suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

change scheme/unit and scheme/signature #langs to build on scheme/base

Browse Source 
svn: r7792
This commit is contained in:
Matthew Flatt 2007-11-20 23:44:31 +00:00
parent 53926bee23
commit 5b0a0be3d6
57 changed files with 5760 additions and 5544 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

416
collects/browser/private/btree.ss
View File

@ -1,220 +1,220 @@
#lang scheme/unit #lang scheme/unit
(require "sig.ss") (require "sig.ss")
;; Implements a red-black tree with relative indexing along right ;; Implements a red-black tree with relative indexing along right
;; splines. This allows the usual O(log(n)) operations, plus a ;; splines. This allows the usual O(log(n)) operations, plus a
;; O(log(n)) shift operation. ;; O(log(n)) shift operation.
;; (This is the same data structure as used for lines by MrEd's text% ;; (This is the same data structure as used for lines by MrEd's text%
;; class, but that one is implemented in C++.) ;; class, but that one is implemented in C++.)
(import) (import)
(export (rename relative-btree^ (export (rename relative-btree^
(create-btree make-btree))) (create-btree make-btree)))
(define-struct btree (root)) (define-struct btree (root) #:mutable)
(define-struct node (pos data parent left right color)) (define-struct node (pos data parent left right color) #:mutable)
(define (adjust-offsets n new-child) (define (adjust-offsets n new-child)
(when new-child (when new-child
(set-node-pos! new-child (- (node-pos new-child) (set-node-pos! new-child (- (node-pos new-child)
(node-pos n))))) (node-pos n)))))
(define (deadjust-offsets n old-child) (define (deadjust-offsets n old-child)
(when old-child (when old-child
(set-node-pos! old-child (+ (node-pos old-child) (set-node-pos! old-child (+ (node-pos old-child)
(node-pos n))))) (node-pos n)))))
(define (rotate-left n btree) (define (rotate-left n btree)
(let ([old-right (node-right n)]) (let ([old-right (node-right n)])
(deadjust-offsets n old-right) (deadjust-offsets n old-right)
(let ([r (node-left old-right)])
(set-node-right! n r)
(when r
(set-node-parent! r n)))
(let ([p (node-parent n)])
(set-node-parent! old-right p)
(cond
[(not p) (set-btree-root! btree old-right)]
[(eq? n (node-left p)) (set-node-left! p old-right)]
[else (set-node-right! p old-right)]))
(set-node-left! old-right n)
(set-node-parent! n old-right)))
(define (rotate-right n btree)
(let ([old-left (node-left n)])
(adjust-offsets old-left n)
(let ([l (node-right old-left)])
(set-node-left! n l)
(when l
(set-node-parent! l n)))
(let ([p (node-parent n)])
(set-node-parent! old-left p)
(cond
[(not p) (set-btree-root! btree old-left)]
[(eq? n (node-left p)) (set-node-left! p old-left)]
[else (set-node-right! p old-left)]))
(set-node-right! old-left n)
(set-node-parent! n old-left)))
(define (insert before? n btree pos data)
(let ([new (make-node pos data #f #f #f 'black)])
(if (not (btree-root btree))
(set-btree-root! btree new)
(begin
(let ([r (node-left old-right)]) (set-node-color! new 'red)
(set-node-right! n r)
(when r
(set-node-parent! r n)))
(let ([p (node-parent n)]) ; Insert into tree
(set-node-parent! old-right p) (if before?
(cond
[(not p) (set-btree-root! btree old-right)]
[(eq? n (node-left p)) (set-node-left! p old-right)]
[else (set-node-right! p old-right)]))
(set-node-left! old-right n)
(set-node-parent! n old-right)))
(define (rotate-right n btree)
(let ([old-left (node-left n)])
(adjust-offsets old-left n)
(let ([l (node-right old-left)])
(set-node-left! n l)
(when l
(set-node-parent! l n)))
(let ([p (node-parent n)])
(set-node-parent! old-left p)
(cond
[(not p) (set-btree-root! btree old-left)]
[(eq? n (node-left p)) (set-node-left! p old-left)]
[else (set-node-right! p old-left)]))
(set-node-right! old-left n)
(set-node-parent! n old-left)))
(define (insert before? n btree pos data)
(let ([new (make-node pos data #f #f #f 'black)])
(if (not (btree-root btree))
(set-btree-root! btree new)
(begin (if (not (node-left n))
(begin
(set-node-color! new 'red) (set-node-left! n new)
(set-node-parent! new n))
; Insert into tree
(if before? (let loop ([node (node-left n)])
(if (node-right node)
(if (not (node-left n)) (loop (node-right node))
(begin (begin
(set-node-left! n new) (set-node-right! node new)
(set-node-parent! new n)) (set-node-parent! new node)))))
(let loop ([node (node-left n)]) (if (not (node-right n))
(if (node-right node) (begin
(loop (node-right node)) (set-node-right! n new)
(begin (set-node-parent! new n))
(set-node-right! node new)
(set-node-parent! new node))))) (let loop ([node (node-right n)])
(if (node-left node)
(if (not (node-right n)) (loop (node-left node))
(begin (begin
(set-node-right! n new) (set-node-left! node new)
(set-node-parent! new n)) (set-node-parent! new node))))))
(let loop ([node (node-right n)]) ; Make value in new node relative to right-hand parents
(if (node-left node) (let loop ([node new])
(loop (node-left node)) (let ([p (node-parent node)])
(begin (when p
(set-node-left! node new) (when (eq? node (node-right p))
(set-node-parent! new node)))))) (adjust-offsets p new))
(loop p))))
; Make value in new node relative to right-hand parents
(let loop ([node new]) ; Balance tree
(let ([p (node-parent node)]) (let loop ([node new])
(when p (let ([p (node-parent node)])
(when (eq? node (node-right p)) (when (and (not (eq? node (btree-root btree)))
(adjust-offsets p new)) (eq? 'red (node-color p)))
(loop p)))) (let* ([recolor-k
(lambda (y)
; Balance tree (set-node-color! p 'black)
(let loop ([node new]) (set-node-color! y 'black)
(let ([p (node-parent node)]) (let ([pp (node-parent p)])
(when (and (not (eq? node (btree-root btree))) (set-node-color! pp 'red)
(eq? 'red (node-color p))) (loop pp)))]
(let* ([recolor-k [rotate-k
(lambda (y) (lambda (rotate node)
(set-node-color! p 'black) (let ([p (node-parent node)])
(set-node-color! y 'black) (set-node-color! p 'black)
(let ([pp (node-parent p)]) (let ([pp (node-parent p)])
(set-node-color! pp 'red) (set-node-color! pp 'red)
(loop pp)))] (rotate pp btree)
[rotate-k (loop pp))))]
(lambda (rotate node) [k
(let ([p (node-parent node)]) (lambda (node-y long-rotate always-rotate)
(set-node-color! p 'black) (let ([y (node-y (node-parent p))])
(let ([pp (node-parent p)]) (if (and y (eq? 'red (node-color y)))
(set-node-color! pp 'red) (recolor-k y)
(rotate pp btree) (let ([k (lambda (node)
(loop pp))))] (rotate-k always-rotate node))])
[k (if (eq? node (node-y p))
(lambda (node-y long-rotate always-rotate) (begin
(let ([y (node-y (node-parent p))]) (long-rotate p btree)
(if (and y (eq? 'red (node-color y))) (k p))
(recolor-k y) (k node))))))])
(let ([k (lambda (node) (if (eq? p (node-left (node-parent p)))
(rotate-k always-rotate node))]) (k node-right rotate-left rotate-right)
(if (eq? node (node-y p)) (k node-left rotate-right rotate-left))))))
(begin
(long-rotate p btree) (set-node-color! (btree-root btree) 'black)))))
(k p))
(k node))))))]) (define (find-following-node btree pos)
(if (eq? p (node-left (node-parent p))) (let ([root (btree-root btree)])
(k node-right rotate-left rotate-right) (let loop ([n root]
(k node-left rotate-right rotate-left)))))) [so-far root]
[so-far-pos (and root (node-pos root))]
(set-node-color! (btree-root btree) 'black))))) [v 0])
(if (not n)
(define (find-following-node btree pos) (values so-far so-far-pos)
(let ([root (btree-root btree)]) (let ([npos (+ (node-pos n) v)])
(let loop ([n root] (cond
[so-far root] [(<= pos npos)
[so-far-pos (and root (node-pos root))] (loop (node-left n) n npos v)]
[v 0]) [(or (not so-far-pos)
(if (not n) (> npos so-far-pos))
(values so-far so-far-pos) (loop (node-right n) n npos npos)]
(let ([npos (+ (node-pos n) v)]) [else
(cond (loop (node-right n) so-far so-far-pos npos)]))))))
[(<= pos npos)
(loop (node-left n) n npos v)] (define (create-btree)
[(or (not so-far-pos) (make-btree #f))
(> npos so-far-pos))
(loop (node-right n) n npos npos)] (define (btree-get btree pos)
[else (let-values ([(n npos) (find-following-node btree pos)])
(loop (node-right n) so-far so-far-pos npos)])))))) (and n
(= npos pos)
(define (create-btree) (node-data n))))
(make-btree #f))
(define (btree-put! btree pos data)
(define (btree-get btree pos) (let-values ([(n npos) (find-following-node btree pos)])
(let-values ([(n npos) (find-following-node btree pos)]) (if (and n (= npos pos))
(and n (set-node-data! n data)
(= npos pos) (insert (and n (< pos npos))
(node-data n)))) n btree pos data))))
(define (btree-put! btree pos data) (define (btree-shift! btree start delta)
(let-values ([(n npos) (find-following-node btree pos)]) (let loop ([n (btree-root btree)]
(if (and n (= npos pos)) [v 0])
(set-node-data! n data) (when n
(insert (and n (< pos npos)) (let ([npos (node-pos n)])
n btree pos data)))) (cond
[(< start (+ v npos))
(define (btree-shift! btree start delta) (set-node-pos! n (+ npos delta))
(let loop ([n (btree-root btree)] (loop (node-left n) v)]
[v 0]) [else
(when n (loop (node-right n) (+ v npos))])))))
(let ([npos (node-pos n)])
(cond (define (btree-for-each btree f)
[(< start (+ v npos)) (when (btree-root btree)
(set-node-pos! n (+ npos delta)) (let loop ([n (btree-root btree)]
(loop (node-left n) v)] [v 0])
[else (when (node-left n)
(loop (node-right n) (+ v npos))]))))) (loop (node-left n) v))
(f (+ v (node-pos n)) (node-data n))
(define (btree-for-each btree f) (when (node-right n)
(when (btree-root btree) (loop (node-right n)
(let loop ([n (btree-root btree)] (+ v (node-pos n)))))))
[v 0])
(when (node-left n) (define (btree-map btree f)
(loop (node-left n) v)) (reverse
(f (+ v (node-pos n)) (node-data n)) (let loop ([n (btree-root btree)]
(when (node-right n) [v 0]
(loop (node-right n) [a null])
(+ v (node-pos n))))))) (if (not n)
a
(define (btree-map btree f) (let* ([pre (loop (node-left n) v a)]
(reverse [here (cons (f (+ v (node-pos n))
(let loop ([n (btree-root btree)] (node-data n))
[v 0] pre)])
[a null]) (loop (node-right n)
(if (not n) (+ v (node-pos n))
a here))))))
(let* ([pre (loop (node-left n) v a)]
[here (cons (f (+ v (node-pos n))
(node-data n))
pre)])
(loop (node-right n)
(+ v (node-pos n))
here))))))

2481
collects/browser/private/html.ss
View File

File diff suppressed because it is too large Load Diff

2242
collects/browser/private/hyper.ss
View File

File diff suppressed because it is too large Load Diff

4
collects/browser/private/sig.ss
View File

@ -1,5 +1,5 @@
(module sig mzscheme (module sig scheme/base
(require (lib "unit.ss")) (require scheme/unit)
(provide relative-btree^ (provide relative-btree^
bullet-export^ bullet-export^

2
collects/drscheme/private/app.ss
View File

@ -2,7 +2,7 @@
#lang scheme/unit #lang scheme/unit
(require (lib "class.ss") (require (lib "class.ss")
(lib "list.ss") (lib "list.ss")
(lib "file.ss") scheme/file
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")

16
collects/drscheme/private/drsig.ss
View File

@ -1,6 +1,6 @@
(module drsig mzscheme (module drsig scheme/base
(require (lib "unit.ss")) (require scheme/unit)
(provide drscheme:eval^ (provide drscheme:eval^
drscheme:debug^ drscheme:debug^
@ -33,8 +33,7 @@
get-modes get-modes
add-initial-modes add-initial-modes
(struct mode (name surrogate repl-submit matches-language) (struct mode (name surrogate repl-submit matches-language)
-setters #:omit-constructor)))
-constructor)))
(define-signature drscheme:font^ (define-signature drscheme:font^
(setup-preferences)) (setup-preferences))
@ -93,7 +92,7 @@
(define-signature drscheme:language-configuration^ (define-signature drscheme:language-configuration^
(add-language (add-language
get-languages get-languages
(struct language-settings (language settings) -setters) (struct language-settings (language settings))
get-settings-preferences-symbol get-settings-preferences-symbol
language-dialog language-dialog
fill-language-dialog)) fill-language-dialog))
@ -216,16 +215,15 @@
create-executable-gui create-executable-gui
put-executable put-executable
;(struct loc (source position line column span) -setters) ;(struct loc (source position line column span))
(struct text/pos (text start end) -setters) (struct text/pos (text start end))
(struct simple-settings (case-sensitive (struct simple-settings (case-sensitive
printing-style printing-style
fraction-style fraction-style
show-sharing show-sharing
insert-newlines insert-newlines
annotations) annotations))
-setters)
simple-settings->vector simple-settings->vector
simple-module-based-language-config-panel simple-module-based-language-config-panel

10
collects/drscheme/private/frame.ss
View File

@ -2,7 +2,6 @@
#lang scheme/unit #lang scheme/unit
(require (lib "name-message.ss" "mrlib") (require (lib "name-message.ss" "mrlib")
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
(lib "unit.ss")
(lib "match.ss") (lib "match.ss")
(lib "class.ss") (lib "class.ss")
(lib "string.ss") (lib "string.ss")
@ -14,8 +13,7 @@
(lib "head.ss" "net") (lib "head.ss" "net")
(lib "plt-installer.ss" "setup") (lib "plt-installer.ss" "setup")
(lib "bug-report.ss" "help") (lib "bug-report.ss" "help")
(prefix mzlib:file: (lib "file.ss")) (lib "file.ss") scheme/file)
(prefix mzlib:list: (lib "list.ss")))
(import [prefix drscheme:unit: drscheme:unit^] (import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:app: drscheme:app^] [prefix drscheme:app: drscheme:app^]
@ -123,7 +121,7 @@
(filter (λ (binding) (not (bound-by-menu? binding menu-names))) (filter (λ (binding) (not (bound-by-menu? binding menu-names)))
bindings))] bindings))]
[structured-list [structured-list
(mzlib:list:sort (sort
w/menus w/menus
(λ (x y) (string-ci<=? (cadr x) (cadr y))))]) (λ (x y) (string-ci<=? (cadr x) (cadr y))))])
(show-keybindings-to-user structured-list this)) (show-keybindings-to-user structured-list this))
@ -500,8 +498,8 @@
(λ (a b) (string-ci<=? (cadr a) (cadr b)))]) (λ (a b) (string-ci<=? (cadr a) (cadr b)))])
(send lb set (send lb set
(if by-key? (if by-key?
(map format-binding/key (mzlib:list:sort bindings predicate/key)) (map format-binding/key (sort bindings predicate/key))
(map format-binding/name (mzlib:list:sort bindings predicate/name))))))]) (map format-binding/name (sort bindings predicate/name))))))])
(send bp stretchable-height #f) (send bp stretchable-height #f)
(send bp set-alignment 'center 'center) (send bp set-alignment 'center 'center)
(send bp2 stretchable-height #f) (send bp2 stretchable-height #f)

4
collects/drscheme/private/language.ss
View File

@ -11,7 +11,7 @@
(lib "etc.ss") (lib "etc.ss")
(lib "struct.ss") (lib "struct.ss")
(lib "class.ss") (lib "class.ss")
(lib "file.ss") scheme/file
(lib "list.ss") (lib "list.ss")
(lib "embed.ss" "compiler") (lib "embed.ss" "compiler")
(lib "launcher.ss" "launcher") (lib "launcher.ss" "launcher")
@ -1131,7 +1131,7 @@
(let ([s (reader (object-name port) port)]) (let ([s (reader (object-name port) port)])
(if (syntax? s) (if (syntax? s)
(with-syntax ([s s] (with-syntax ([s s]
[t (namespace-syntax-introduce (datum->syntax-object #f '#%top-interaction))]) [t (namespace-syntax-introduce (datum->syntax #f '#%top-interaction))])
(syntax (t . s))) (syntax (t . s)))
s)))) s))))

6
collects/drscheme/private/main.ss
View File

@ -7,11 +7,11 @@
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "class.ss") (lib "class.ss")
(prefix pretty-print: (lib "pretty.ss")) (prefix-in pretty-print: (lib "pretty.ss"))
(prefix print-convert: (lib "pconvert.ss")) (prefix-in print-convert: (lib "pconvert.ss"))
(lib "include.ss") (lib "include.ss")
(lib "list.ss") (lib "list.ss")
(lib "file.ss") scheme/file
(lib "external.ss" "browser") (lib "external.ss" "browser")
(lib "plt-installer.ss" "setup")) (lib "plt-installer.ss" "setup"))

2
collects/drscheme/private/multi-file-search.ss
View File

@ -3,7 +3,7 @@
(require (lib "framework.ss" "framework") (require (lib "framework.ss" "framework")
(lib "class.ss") (lib "class.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "file.ss") scheme/file
(lib "thread.ss") (lib "thread.ss")
(lib "async-channel.ss") (lib "async-channel.ss")
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")

2
collects/framework/private/autosave.ss
View File

@ -2,7 +2,7 @@
#lang scheme/unit #lang scheme/unit
(require (lib "class.ss") (require (lib "class.ss")
(lib "file.ss") scheme/file
"sig.ss" "sig.ss"
"../gui-utils.ss" "../gui-utils.ss"
"../preferences.ss" "../preferences.ss"

2
collects/framework/private/editor.ss
View File

@ -7,7 +7,7 @@
"../gui-utils.ss" "../gui-utils.ss"
(lib "etc.ss") (lib "etc.ss")
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "file.ss")) scheme/file)
(import mred^ (import mred^
[prefix autosave: framework:autosave^] [prefix autosave: framework:autosave^]

2
collects/framework/private/finder.ss
View File

@ -5,7 +5,7 @@
"../preferences.ss" "../preferences.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "string.ss") (lib "string.ss")
(lib "file.ss") scheme/file
(lib "etc.ss")) (lib "etc.ss"))

4
collects/framework/private/frame.ss
View File

@ -8,7 +8,7 @@
"bday.ss" "bday.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "list.ss") (lib "list.ss")
(lib "file.ss") scheme/file
(lib "etc.ss")) (lib "etc.ss"))
(import mred^ (import mred^
@ -310,7 +310,7 @@
(define-struct status-line (id count)) (define-struct status-line (id count))
;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f)) ;; status-line-msg : (make-status-line-msg (is-a?/c message%) (union symbol #f))
(define-struct status-line-msg (message id)) (define-struct status-line-msg (message [id #:mutable]))
(define status-line-mixin (define status-line-mixin
(mixin (basic<%>) (status-line<%>) (mixin (basic<%>) (status-line<%>)

2
collects/framework/private/group.ss
View File

@ -7,7 +7,7 @@
"../gui-utils.ss" "../gui-utils.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "list.ss") (lib "list.ss")
(lib "file.ss")) scheme/file)
(import mred^ (import mred^
[prefix application: framework:application^] [prefix application: framework:application^]

2
collects/framework/private/handler.ss
View File

@ -7,7 +7,7 @@
"../preferences.ss" "../preferences.ss"
"../gui-utils.ss" "../gui-utils.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "file.ss") scheme/file
(lib "string-constant.ss" "string-constants")) (lib "string-constant.ss" "string-constants"))

3
collects/framework/private/icon.ss
View File

@ -1,5 +1,6 @@
#lang scheme/unit #lang scheme/unit
(require (lib "class.ss") (require (for-syntax scheme/base)
(lib "class.ss")
(lib "include-bitmap.ss" "mrlib") (lib "include-bitmap.ss" "mrlib")
"bday.ss" "bday.ss"
"sig.ss" "sig.ss"

4
collects/framework/private/keymap.ss
View File

@ -511,7 +511,7 @@
(λ (edit event) (λ (edit event)
(let ([sel-start (send edit get-start-position)] (let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)]) [sel-end (send edit get-end-position)])
(if (= sel-start sel-end) (when (= sel-start sel-end)
(send* edit (send* edit
(insert #\newline) (insert #\newline)
(set-position sel-start)))))] (set-position sel-start)))))]
@ -729,7 +729,7 @@
(get-text-from-user (get-text-from-user
(string-constant goto-position) (string-constant goto-position)
(string-constant goto-position))))]) (string-constant goto-position))))])
(if (string? num-str) (when (string? num-str)
(let ([pos (string->number num-str)]) (let ([pos (string->number num-str)])
(when pos (when pos
(send edit set-position (sub1 pos)))))) (send edit set-position (sub1 pos))))))

2
collects/framework/private/panel.ss
View File

@ -164,7 +164,7 @@
(define-struct gap (before before-dim before-percentage after after-dim after-percentage)) (define-struct gap (before before-dim before-percentage after after-dim after-percentage))
;; type percentage : (make-percentage number) ;; type percentage : (make-percentage number)
(define-struct percentage (%)) (define-struct percentage (%) #:mutable)
(define dragable<%> (define dragable<%>
(interface (window<%> area-container<%>) (interface (window<%> area-container<%>)

4
collects/framework/private/preferences.ss
View File

@ -30,7 +30,7 @@ the state transitions / contracts are:
(require (lib "string-constant.ss" "string-constants") (require (lib "string-constant.ss" "string-constants")
(lib "class.ss") (lib "class.ss")
(lib "file.ss") scheme/file
"sig.ss" "sig.ss"
"../gui-utils.ss" "../gui-utils.ss"
"../preferences.ss" "../preferences.ss"
@ -117,7 +117,7 @@ the state transitions / contracts are:
;; (make-ppanel-interior string (union #f panel) (listof panel-tree))) ;; (make-ppanel-interior string (union #f panel) (listof panel-tree)))
(define-struct ppanel (name panel)) (define-struct ppanel (name panel))
(define-struct (ppanel-leaf ppanel) (maker)) (define-struct (ppanel-leaf ppanel) (maker))
(define-struct (ppanel-interior ppanel) (children)) (define-struct (ppanel-interior ppanel) (children) #:mutable)
;; ppanels : (listof ppanel-tree) ;; ppanels : (listof ppanel-tree)
(define ppanels null) (define ppanels null)

16
collects/framework/private/scheme.ss
View File

@ -75,7 +75,7 @@
(send text last-position) (send text last-position)
(send text last-position))) (send text last-position)))
saved-snips) saved-snips)
(datum->syntax-object (datum->syntax
#f #f
(read (open-input-text-editor text)) (read (open-input-text-editor text))
(list file line col pos 1)))) (list file line col pos 1))))
@ -551,10 +551,10 @@
[get-proc [get-proc
(λ () (λ ()
(let ([id-end (get-forward-sexp contains)]) (let ([id-end (get-forward-sexp contains)])
(if (and id-end (> id-end contains)) (and (and id-end (> id-end contains))
(let* ([text (get-text contains id-end)]) (let* ([text (get-text contains id-end)])
(or (get-keyword-type text tabify-prefs) (or (get-keyword-type text tabify-prefs)
'other)))))] 'other)))))]
[procedure-indent [procedure-indent
(λ () (λ ()
(case (get-proc) (case (get-proc)
@ -715,7 +715,7 @@
(let* ([first-para (position-paragraph start-pos)] (let* ([first-para (position-paragraph start-pos)]
[last-para (calc-last-para end-pos)]) [last-para (calc-last-para end-pos)])
(let para-loop ([curr-para first-para]) (let para-loop ([curr-para first-para])
(if (<= curr-para last-para) (when (<= curr-para last-para)
(let ([first-on-para (paragraph-start-position curr-para)]) (let ([first-on-para (paragraph-start-position curr-para)])
(insert #\; first-on-para) (insert #\; first-on-para)
(para-loop (add1 curr-para)))))) (para-loop (add1 curr-para))))))
@ -964,8 +964,8 @@
[first-char (get-character pos)] [first-char (get-character pos)]
[paren? (or (char=? first-char #\( ) [paren? (or (char=? first-char #\( )
(char=? first-char #\[ ))] (char=? first-char #\[ ))]
[closer (if paren? [closer (and paren?
(get-forward-sexp pos))]) (get-forward-sexp pos))])
(if (and paren? closer) (if (and paren? closer)
(begin (begin-edit-sequence) (begin (begin-edit-sequence)
(delete pos (add1 pos)) (delete pos (add1 pos))

6
collects/framework/private/sig.ss
View File

@ -1,7 +1,7 @@
(module sig mzscheme (module sig scheme/base
(require (lib "unit.ss")) (require scheme/unit)
(provide (prefix-all-defined-except framework: framework^) (provide (prefix-out framework: (except-out (all-defined-out) framework^))
framework^) framework^)
(define-signature number-snip-class^ (define-signature number-snip-class^

6
collects/framework/private/text.ss
View File

@ -18,7 +18,7 @@ WARNING: printf is rebound in the body of the unit to always
(lib "etc.ss") (lib "etc.ss")
(lib "dirs.ss" "setup") (lib "dirs.ss" "setup")
(lib "string.ss") (lib "string.ss")
(prefix srfi1: (lib "1.ss" "srfi"))) (prefix-in srfi1: (lib "1.ss" "srfi")))
(import mred^ (import mred^
[prefix icon: framework:icon^] [prefix icon: framework:icon^]
@ -954,7 +954,7 @@ WARNING: printf is rebound in the body of the unit to always
get-box-input-editor-snip% get-box-input-editor-snip%
get-box-input-text%)) get-box-input-text%))
(define-struct peeker (bytes skip-count pe resp-chan nack polling?) (make-inspector)) (define-struct peeker (bytes skip-count pe resp-chan nack polling?) #:inspector (make-inspector))
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define msec-timeout 500) (define msec-timeout 500)
@ -1989,7 +1989,7 @@ WARNING: printf is rebound in the body of the unit to always
;; ;;
;; queues ;; queues
;; ;;
(define-struct queue (front back count)) (define-struct queue (front back count) #:mutable)
(define (empty-queue) (make-queue '() '() 0)) (define (empty-queue) (make-queue '() '() 0))
(define (enqueue e q) (make-queue (define (enqueue e q) (make-queue
(cons e (queue-front q)) (cons e (queue-front q))

2
collects/frtime/graphics-posn-less-unit.ss
View File

@ -122,7 +122,7 @@
|# |#
[on-char [on-char
(lambda (key-event) (lambda (key-event)
(if key-listener (when key-listener
(send-event (send-event
key-listener key-listener
(make-sixkey (make-sixkey

920
collects/graphics/turtle-unit.ss
View File

@ -1,466 +1,466 @@
#lang scheme/unit #lang scheme/unit
(require (lib "mred-sig.ss" "mred") (require (lib "mred-sig.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
(lib "list.ss") (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
"turtle-sig.ss") "turtle-sig.ss")
(import [prefix mred: mred^]) (import [prefix mred: mred^])
(export turtle^) (export turtle^)
(init-depend mred^) (init-depend mred^)
(define turtles:window #f)
(define turtles:shown? #f)
(define pi 3.141592653589793)
(define pi/2 (/ pi 2))
(define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor))
(define icon-brush (send mred:the-brush-list find-or-create-brush "SALMON" 'xor))
(define blank-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
(define w-pen (send mred:the-pen-list find-or-create-pen "white" 1 'solid))
(define b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid))
(define show-turtle-icons? #t)
;; turtle-style : (union 'triangle 'line 'empty)
(define turtle-style 'triangle)
(define plot-window%
(class100 mred:frame% (name width height)
(define turtles:window #f) (private-field
(define turtles:shown? #f) [bitmap (make-object mred:bitmap% width height #t)])
(define pi 3.141592653589793) (inherit show)
(define pi/2 (/ pi 2)) (private-field
[memory-dc (make-object mred:bitmap-dc%)]
(define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor)) [pl (make-object mred:point% 0 0)]
(define icon-brush (send mred:the-brush-list find-or-create-brush "SALMON" 'xor)) [pr (make-object mred:point% 0 0)]
(define blank-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent)) [ph (make-object mred:point% 0 0)]
(define w-pen (send mred:the-pen-list find-or-create-pen "white" 1 'solid)) [points (list pl pr ph)])
(define b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid)) (public
[get-canvas
(define show-turtle-icons? #t) (lambda ()
canvas)]
;; turtle-style : (union 'triangle 'line 'empty) [flip-icons
(define turtle-style 'triangle) (lambda ()
(case turtle-style
(define plot-window% [(triangle line)
(class100 mred:frame% (name width height) (flatten (lambda (x) x))
(let* ([dc (send canvas get-dc)]
(private-field [proc
[bitmap (make-object mred:bitmap% width height #t)])
(inherit show)
(private-field
[memory-dc (make-object mred:bitmap-dc%)]
[pl (make-object mred:point% 0 0)]
[pr (make-object mred:point% 0 0)]
[ph (make-object mred:point% 0 0)]
[points (list pl pr ph)])
(public
[get-canvas
(lambda ()
canvas)]
[flip-icons
(lambda ()
(case turtle-style
[(triangle line)
(flatten (lambda (x) x))
(let* ([dc (send canvas get-dc)]
[proc
(if (eq? turtle-style 'line)
(lambda (turtle)
(let ([x (turtle-x turtle)]
[y (turtle-y turtle)]
[theta (turtle-angle turtle)]
[size 2])
(send dc draw-line
x y
(+ x (* size (cos theta)))
(+ y (* size (sin theta))))))
(lambda (turtle)
(let* ([x (turtle-x turtle)]
[y (turtle-y turtle)]
[theta (turtle-angle turtle)]
[long-size 20]
[short-size 7]
[l-theta (+ theta pi/2)]
[r-theta (- theta pi/2)])
(send ph set-x (+ x (* long-size (cos theta))))
(send ph set-y (+ y (* long-size (sin theta))))
(send pl set-x (+ x (* short-size (cos l-theta))))
(send pl set-y (+ y (* short-size (sin l-theta))))
(send pr set-x (+ x (* short-size (cos r-theta))))
(send pr set-y (+ y (* short-size (sin r-theta))))
(send dc draw-polygon points))))])
(if (eq? turtle-style 'line) (if (eq? turtle-style 'line)
(send dc set-pen icon-pen) (lambda (turtle)
(begin (let ([x (turtle-x turtle)]
(send dc set-pen blank-pen) [y (turtle-y turtle)]
(send dc set-brush icon-brush))) [theta (turtle-angle turtle)]
(for-each proc turtles-state) [size 2])
(send dc set-pen b-pen))] (send dc draw-line
x y
(+ x (* size (cos theta)))
(+ y (* size (sin theta))))))
(lambda (turtle)
(let* ([x (turtle-x turtle)]
[y (turtle-y turtle)]
[theta (turtle-angle turtle)]
[long-size 20]
[short-size 7]
[l-theta (+ theta pi/2)]
[r-theta (- theta pi/2)])
(send ph set-x (+ x (* long-size (cos theta))))
(send ph set-y (+ y (* long-size (sin theta))))
(send pl set-x (+ x (* short-size (cos l-theta))))
(send pl set-y (+ y (* short-size (sin l-theta))))
(send pr set-x (+ x (* short-size (cos r-theta))))
(send pr set-y (+ y (* short-size (sin r-theta))))
(send dc draw-polygon points))))])
(if (eq? turtle-style 'line)
(send dc set-pen icon-pen)
(begin
(send dc set-pen blank-pen)
(send dc set-brush icon-brush)))
(for-each proc turtles-state)
(send dc set-pen b-pen))]
[else
(void)]))]
[clear
(lambda ()
(send memory-dc clear)
(send canvas on-paint))])
(sequence
(send memory-dc set-bitmap bitmap)
(send memory-dc clear)
(super-init name #f width height))
(public
[on-menu-command (lambda (op) (turtles #f))])
(private-field
[menu-bar (make-object mred:menu-bar% this)]
[file-menu (make-object mred:menu% "File" menu-bar)])
(sequence
(make-object mred:menu-item%
"Print"
file-menu
(lambda (_1 _2)
(print)))
(make-object mred:menu-item%
"Close"
file-menu
(lambda (_1 _2)
(turtles #f))))
(public
[save-turtle-bitmap
(lambda (fn type)
(send bitmap save-file fn type))])
(private-field
[canvas%
(class100 mred:canvas% args
(inherit get-dc)
(override
[on-paint
(lambda ()
(let ([dc (get-dc)])
(send dc clear)
(send dc draw-bitmap (send memory-dc get-bitmap) 0 0)
(flip-icons)))])
(sequence (apply super-init args)))]
[canvas (make-object canvas% this)]
[dc (send canvas get-dc)])
(public
[wipe-line (lambda (a b c d)
(send memory-dc set-pen w-pen)
(send dc set-pen w-pen)
(send memory-dc draw-line a b c d)
(send dc draw-line a b c d)
(send memory-dc set-pen b-pen)
(send dc set-pen b-pen))]
[draw-line (lambda (a b c d)
(send memory-dc draw-line a b c d)
(send dc draw-line a b c d))])
(sequence
(send canvas min-width width)
(send canvas min-height height)
(send this clear))))
(define turtle-window-size
(let-values ([(w h) (mred:get-display-size)]
[(user/client-offset) 65]
[(default-size) 800])
(min default-size
(- w user/client-offset)
(- h user/client-offset))))
(define-struct turtle (x y angle))
; x : int
; y: int
; angle : int
(define-struct cached (turtles cache))
; turtles : (list-of turtle)
; cache : turtle -> turtle
(define-struct tree (children))
; children : (list-of cached)
(define clear-turtle (make-turtle (/ turtle-window-size 2)
(/ turtle-window-size 2) 0))
;; turtles-state is either a
;; - (list-of turtle) or
;; - tree
(define turtles-state (list clear-turtle))
;; the cache contains a turtle-offset, which is represented
;; by a turtle -- but it is a delta not an absolute.
(define empty-cache (make-turtle 0 0 0))
(define turtles-cache empty-cache)
(define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles).")))
(define inner-line init-error)
(define inner-wipe-line init-error)
(define inner-clear-window init-error)
(define inner-flip-icons init-error)
(define inner-save-turtle-bitmap init-error)
(define line
(lambda (a b c d)
(set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing))
(inner-line a b c d)))
(define do-wipe-line
(lambda (a b c d)
(set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing))
(inner-wipe-line a b c d)))
(define (flip-icons) (inner-flip-icons))
(define clear-window (lambda () (inner-clear-window)))
(define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y)))
(define turtles
(case-lambda
[() (turtles #t)]
[(x)
(set! turtles:shown? x)
(unless turtles:window
(set! turtles:window
(make-object plot-window%
"Turtles"
turtle-window-size
turtle-window-size))
(set! inner-line (lambda x (send turtles:window draw-line . x)))
(set! inner-wipe-line (lambda x (send turtles:window wipe-line . x)))
(set! inner-clear-window (lambda x (send turtles:window clear . x)))
(set! inner-save-turtle-bitmap (lambda x (send turtles:window save-turtle-bitmap . x)))
(set! flip-icons (lambda x (send turtles:window flip-icons . x))))
(send turtles:window show x)
(send turtles:window get-canvas)]))
(define clear
(lambda ()
(set! turtles-cache empty-cache)
(set! turtles-state (list clear-turtle))
(set! lines-in-drawing null)
(clear-window)))
;; cache elements:
(define-struct c-forward (distance))
(define-struct c-turn (angle))
(define-struct c-draw (distance))
(define-struct c-offset (x y))
;; combines a cache-element and a turtle-offset.
;; turtle-offsets are represented as turtles,
;; however they are deltas, not absolutes.
(define combine
(lambda (entry cache)
(cond
[(c-forward? entry)
(let* ([n (c-forward-distance entry)]
[angle (turtle-angle cache)]
[x (turtle-x cache)]
[y (turtle-y cache)]
[newx (+ x (* n (cos angle)))]
[newy (+ y (* n (sin angle)))])
(make-turtle newx newy angle))]
[(c-offset? entry)
(let* ([tx (turtle-x cache)]
[ty (turtle-y cache)]
[newx (+ tx (c-offset-x entry))]
[newy (+ ty (c-offset-y entry))])
(make-turtle newx newy
(turtle-angle cache)))]
[(c-turn? entry)
(make-turtle (turtle-x cache)
(turtle-y cache)
(- (turtle-angle cache)
(c-turn-angle entry)))]
[else
(error 'turtles-cache "illegal entry in cache: ~a" entry)])))
;; this applies an offset to a turtle.
;; an offset is a turtle, representing what would happen
;; if the turtle had started at zero.
(define apply-cache
(lambda (offset)
(let ([x (turtle-x offset)]
[y (turtle-y offset)]
[offset-angle (turtle-angle offset)])
(lambda (turtle)
(let* ([angle (turtle-angle turtle)])
(let* ([c (cos angle)]
[s (sin angle)]
[rx (- (* x c) (* y s))]
[ry (+ (* y c) (* x s))])
(make-turtle (+ rx (turtle-x turtle))
(+ ry (turtle-y turtle))
(+ offset-angle angle))))))))
(define flatten
(lambda (at-end)
(letrec ([walk-turtles
(lambda (turtles cache list)
(cond
[(tree? turtles)
(let ([children (tree-children turtles)]
[ac (apply-cache cache)])
(foldl (lambda (child list)
(walk-turtles (cached-turtles child)
(ac (cached-cache child))
list))
list
children))]
[else [else
(void)]))] (let ([f (compose at-end (apply-cache cache))])
[clear (foldl (lambda (t l) (cons (f t) l)) list turtles))]))])
(lambda () (set! turtles-state (walk-turtles turtles-state turtles-cache null))
(send memory-dc clear) (set! turtles-cache empty-cache))))
(send canvas on-paint))])
(sequence (define draw/erase
(send memory-dc set-bitmap bitmap) (lambda (doit)
(send memory-dc clear) (lambda (n)
(super-init name #f width height)) (flip-icons)
(flatten
(public (lambda (turtle)
[on-menu-command (lambda (op) (turtles #f))]) (let* ([x (turtle-x turtle)]
(private-field [y (turtle-y turtle)]
[menu-bar (make-object mred:menu-bar% this)] [angle (turtle-angle turtle)]
[file-menu (make-object mred:menu% "File" menu-bar)]) [d (if (zero? n) 0 (sub1 (abs n)))]
(sequence [res (if (< n 0) (- d) d)]
(make-object mred:menu-item% [c (cos angle)]
"Print" [s (sin angle)]
file-menu [drawx (+ x (* res c))]
(lambda (_1 _2) [drawy (+ y (* res s))]
(print))) [newx (+ x (* n c))]
(make-object mred:menu-item% [newy (+ y (* n s))])
"Close" (unless (zero? n)
file-menu (doit x y drawx drawy))
(lambda (_1 _2) (make-turtle newx newy angle))))
(turtles #f)))) (flip-icons))))
(public (define draw (draw/erase (lambda (a b c d) (line a b c d))))
[save-turtle-bitmap (define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d))))
(lambda (fn type)
(send bitmap save-file fn type))]) (define move
(lambda (n)
(private-field (flip-icons)
[canvas% (set! turtles-cache (combine (make-c-forward n) turtles-cache))
(class100 mred:canvas% args (flip-icons)))
(inherit get-dc)
(override (define turn/radians
[on-paint (lambda (d)
(lambda () (flip-icons)
(let ([dc (get-dc)]) (set! turtles-cache (combine (make-c-turn d) turtles-cache))
(send dc clear) (flip-icons)))
(send dc draw-bitmap (send memory-dc get-bitmap) 0 0)
(flip-icons)))]) (define turn
(sequence (apply super-init args)))] (lambda (c)
[canvas (make-object canvas% this)] (turn/radians (* (/ c 360) 2 pi))))
[dc (send canvas get-dc)])
(define move-offset
(public (lambda (x y)
[wipe-line (lambda (a b c d) (flip-icons)
(send memory-dc set-pen w-pen) (set! turtles-cache (combine (make-c-offset x y) turtles-cache))
(send dc set-pen w-pen) (flip-icons)))
(send memory-dc draw-line a b c d)
(send dc draw-line a b c d) (define erase/draw-offset
(send memory-dc set-pen b-pen) (lambda (doit)
(send dc set-pen b-pen))] (lambda (x y)
[draw-line (lambda (a b c d) (flip-icons)
(send memory-dc draw-line a b c d) (flatten
(send dc draw-line a b c d))]) (lambda (turtle)
(sequence (let* ([tx (turtle-x turtle)]
(send canvas min-width width) [ty (turtle-y turtle)]
(send canvas min-height height) [newx (+ tx x)]
(send this clear)))) [newy (+ ty y)])
(doit tx ty newx newy)
(define turtle-window-size (make-turtle newx newy (turtle-angle turtle)))))
(let-values ([(w h) (mred:get-display-size)] (flip-icons))))
[(user/client-offset) 65]
[(default-size) 800]) (define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d))))
(min default-size (define draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d))))
(- w user/client-offset)
(- h user/client-offset)))) (define splitfn
(lambda (e)
(define-struct turtle (x y angle)) (let ([t turtles-state]
; x : int [c turtles-cache])
; y: int (e)
; angle : int (flip-icons)
(set! turtles-state
(define-struct cached (turtles cache)) (make-tree (list (make-cached turtles-state turtles-cache)
; turtles : (list-of turtle) (make-cached t c))))
; cache : turtle -> turtle (set! turtles-cache empty-cache)
(flip-icons))))
(define-struct tree (children))
; children : (list-of cached) (define split*fn
(lambda (es)
(define clear-turtle (make-turtle (/ turtle-window-size 2) (let ([t turtles-state]
(/ turtle-window-size 2) 0)) [c turtles-cache]
[l '()])
;; turtles-state is either a (for-each (lambda (x)
;; - (list-of turtle) or (x)
;; - tree (set! l (cons (make-cached turtles-state turtles-cache) l))
(define turtles-state (list clear-turtle)) (flip-icons)
(set! turtles-state t)
;; the cache contains a turtle-offset, which is represented (set! turtles-cache c)
;; by a turtle -- but it is a delta not an absolute. (flip-icons))
(define empty-cache (make-turtle 0 0 0)) es)
(define turtles-cache empty-cache) (flip-icons)
(set! turtles-cache empty-cache)
(define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles)."))) (set! turtles-state (make-tree l))
(define inner-line init-error) (flip-icons))))
(define inner-wipe-line init-error)
(define inner-clear-window init-error)
(define inner-flip-icons init-error) (define tpromptfn
(define inner-save-turtle-bitmap init-error) (lambda (thunk)
(let ([save-turtles-cache #f]
(define line [save-turtles-state #f])
(lambda (a b c d) (dynamic-wind
(set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing)) (lambda ()
(inner-line a b c d))) (set! save-turtles-cache turtles-cache)
(define do-wipe-line (set! save-turtles-state turtles-state))
(lambda (a b c d) (lambda ()
(set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing)) (thunk))
(inner-wipe-line a b c d))) (lambda ()
(define (flip-icons) (inner-flip-icons))
(define clear-window (lambda () (inner-clear-window)))
(define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y)))
(define turtles
(case-lambda
[() (turtles #t)]
[(x)
(set! turtles:shown? x)
(unless turtles:window
(set! turtles:window
(make-object plot-window%
"Turtles"
turtle-window-size
turtle-window-size))
(set! inner-line (lambda x (send turtles:window draw-line . x)))
(set! inner-wipe-line (lambda x (send turtles:window wipe-line . x)))
(set! inner-clear-window (lambda x (send turtles:window clear . x)))
(set! inner-save-turtle-bitmap (lambda x (send turtles:window save-turtle-bitmap . x)))
(set! flip-icons (lambda x (send turtles:window flip-icons . x))))
(send turtles:window show x)
(send turtles:window get-canvas)]))
(define clear
(lambda ()
(set! turtles-cache empty-cache)
(set! turtles-state (list clear-turtle))
(set! lines-in-drawing null)
(clear-window)))
;; cache elements:
(define-struct c-forward (distance))
(define-struct c-turn (angle))
(define-struct c-draw (distance))
(define-struct c-offset (x y))
;; combines a cache-element and a turtle-offset.
;; turtle-offsets are represented as turtles,
;; however they are deltas, not absolutes.
(define combine
(lambda (entry cache)
(cond
[(c-forward? entry)
(let* ([n (c-forward-distance entry)]
[angle (turtle-angle cache)]
[x (turtle-x cache)]
[y (turtle-y cache)]
[newx (+ x (* n (cos angle)))]
[newy (+ y (* n (sin angle)))])
(make-turtle newx newy angle))]
[(c-offset? entry)
(let* ([tx (turtle-x cache)]
[ty (turtle-y cache)]
[newx (+ tx (c-offset-x entry))]
[newy (+ ty (c-offset-y entry))])
(make-turtle newx newy
(turtle-angle cache)))]
[(c-turn? entry)
(make-turtle (turtle-x cache)
(turtle-y cache)
(- (turtle-angle cache)
(c-turn-angle entry)))]
[else
(error 'turtles-cache "illegal entry in cache: ~a" entry)])))
;; this applies an offset to a turtle.
;; an offset is a turtle, representing what would happen
;; if the turtle had started at zero.
(define apply-cache
(lambda (offset)
(let ([x (turtle-x offset)]
[y (turtle-y offset)]
[offset-angle (turtle-angle offset)])
(lambda (turtle)
(let* ([angle (turtle-angle turtle)])
(let* ([c (cos angle)]
[s (sin angle)]
[rx (- (* x c) (* y s))]
[ry (+ (* y c) (* x s))])
(make-turtle (+ rx (turtle-x turtle))
(+ ry (turtle-y turtle))
(+ offset-angle angle))))))))
(define flatten
(lambda (at-end)
(letrec ([walk-turtles
(lambda (turtles cache list)
(cond
[(tree? turtles)
(let ([children (tree-children turtles)]
[ac (apply-cache cache)])
(foldl (lambda (child list)
(walk-turtles (cached-turtles child)
(ac (cached-cache child))
list))
list
children))]
[else
(let ([f (compose at-end (apply-cache cache))])
(foldl (lambda (t l) (cons (f t) l)) list turtles))]))])
(set! turtles-state (walk-turtles turtles-state turtles-cache null))
(set! turtles-cache empty-cache))))
(define draw/erase
(lambda (doit)
(lambda (n)
(flip-icons) (flip-icons)
(flatten (set! turtles-cache save-turtles-cache)
(lambda (turtle) (set! turtles-state save-turtles-state)
(let* ([x (turtle-x turtle)] (flip-icons))))))
[y (turtle-y turtle)]
[angle (turtle-angle turtle)]
[d (if (zero? n) 0 (sub1 (abs n)))] (define-struct drawing-line (x1 y1 x2 y2))
[res (if (< n 0) (- d) d)] (define-struct (wipe-line drawing-line) ())
[c (cos angle)] (define-struct (draw-line drawing-line) ())
[s (sin angle)] (define lines-in-drawing null)
[drawx (+ x (* res c))]
[drawy (+ y (* res s))] (define (draw-lines-into-dc dc)
[newx (+ x (* n c))] (for-each (lambda (line)
[newy (+ y (* n s))]) (cond
(unless (zero? n) [(wipe-line? line) (send dc set-pen w-pen)]
(doit x y drawx drawy)) [(draw-line? line) (send dc set-pen b-pen)])
(make-turtle newx newy angle)))) (send dc draw-line
(flip-icons)))) (drawing-line-x1 line)
(drawing-line-y1 line)
(define draw (draw/erase (lambda (a b c d) (line a b c d)))) (drawing-line-x2 line)
(define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d)))) (drawing-line-y2 line)))
lines-in-drawing))
(define move
(lambda (n) ;; used to test printing
(flip-icons) (define (display-lines-in-drawing)
(set! turtles-cache (combine (make-c-forward n) turtles-cache)) (let* ([lines-in-drawing-canvas%
(flip-icons))) (class100 mred:canvas% (frame)
(inherit get-dc)
(define turn/radians (override
(lambda (d) [on-paint
(flip-icons) (lambda ()
(set! turtles-cache (combine (make-c-turn d) turtles-cache)) (draw-lines-into-dc (get-dc)))])
(flip-icons))) (sequence
(super-init frame)))]
(define turn [frame (make-object mred:frame% "Lines in Drawing")]
(lambda (c) [canvas (make-object lines-in-drawing-canvas% frame)])
(turn/radians (* (/ c 360) 2 pi)))) (send frame show #t)))
(define move-offset
(lambda (x y) (define (print)
(flip-icons) (case (system-type)
(set! turtles-cache (combine (make-c-offset x y) turtles-cache)) [(macos macosx windows)
(flip-icons))) (let ([dc (make-object mred:printer-dc%)])
(send dc start-doc "Turtles")
(define erase/draw-offset (send dc start-page)
(lambda (doit) (draw-lines-into-dc dc)
(lambda (x y) (send dc end-page)
(flip-icons) (send dc end-doc))]
(flatten [(unix)
(lambda (turtle) (let ([dc (make-object mred:post-script-dc%)])
(let* ([tx (turtle-x turtle)] (send dc start-doc "Turtles")
[ty (turtle-y turtle)] (send dc start-page)
[newx (+ tx x)] (draw-lines-into-dc dc)
[newy (+ ty y)]) (send dc end-page)
(doit tx ty newx newy) (send dc end-doc))]
(make-turtle newx newy (turtle-angle turtle))))) [else
(flip-icons)))) (mred:message-box "Turtles"
"Printing is not supported on this platform")]))
(define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d))))
(define draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d))))
(define splitfn
(lambda (e)
(let ([t turtles-state]
[c turtles-cache])
(e)
(flip-icons)
(set! turtles-state
(make-tree (list (make-cached turtles-state turtles-cache)
(make-cached t c))))
(set! turtles-cache empty-cache)
(flip-icons))))
(define split*fn
(lambda (es)
(let ([t turtles-state]
[c turtles-cache]
[l '()])
(for-each (lambda (x)
(x)
(set! l (cons (make-cached turtles-state turtles-cache) l))
(flip-icons)
(set! turtles-state t)
(set! turtles-cache c)
(flip-icons))
es)
(flip-icons)
(set! turtles-cache empty-cache)
(set! turtles-state (make-tree l))
(flip-icons))))
(define tpromptfn
(lambda (thunk)
(let ([save-turtles-cache #f]
[save-turtles-state #f])
(dynamic-wind
(lambda ()
(set! save-turtles-cache turtles-cache)
(set! save-turtles-state turtles-state))
(lambda ()
(thunk))
(lambda ()
(flip-icons)
(set! turtles-cache save-turtles-cache)
(set! turtles-state save-turtles-state)
(flip-icons))))))
(define-struct drawing-line (x1 y1 x2 y2))
(define-struct (wipe-line drawing-line) ())
(define-struct (draw-line drawing-line) ())
(define lines-in-drawing null)
(define (draw-lines-into-dc dc)
(for-each (lambda (line)
(cond
[(wipe-line? line) (send dc set-pen w-pen)]
[(draw-line? line) (send dc set-pen b-pen)])
(send dc draw-line
(drawing-line-x1 line)
(drawing-line-y1 line)
(drawing-line-x2 line)
(drawing-line-y2 line)))
lines-in-drawing))
;; used to test printing
(define (display-lines-in-drawing)
(let* ([lines-in-drawing-canvas%
(class100 mred:canvas% (frame)
(inherit get-dc)
(override
[on-paint
(lambda ()
(draw-lines-into-dc (get-dc)))])
(sequence
(super-init frame)))]
[frame (make-object mred:frame% "Lines in Drawing")]
[canvas (make-object lines-in-drawing-canvas% frame)])
(send frame show #t)))
(define (print)
(case (system-type)
[(macos macosx windows)
(let ([dc (make-object mred:printer-dc%)])
(send dc start-doc "Turtles")
(send dc start-page)
(draw-lines-into-dc dc)
(send dc end-page)
(send dc end-doc))]
[(unix)
(let ([dc (make-object mred:post-script-dc%)])
(send dc start-doc "Turtles")
(send dc start-page)
(draw-lines-into-dc dc)
(send dc end-page)
(send dc end-doc))]
[else
(mred:message-box "Turtles"
"Printing is not supported on this platform")]))

1328
collects/launcher/launcher-unit.ss
View File

File diff suppressed because it is too large Load Diff

15
collects/mzlib/cm.ss
View File

@ -131,7 +131,20 @@
[code (parameterize ([param (lambda (ext-file) [code (parameterize ([param (lambda (ext-file)
(set! external-deps (set! external-deps
(cons (path->bytes ext-file) (cons (path->bytes ext-file)
external-deps)))]) external-deps)))]
[current-reader-guard
(let ([rg (current-reader-guard)])
(lambda (d)
(let ([d (rg d)])
(when (module-path? d)
(let ([p (resolved-module-path-name
(module-path-index-resolve
(module-path-index-join d #f)))])
(when (path? p)
(set! external-deps
(cons (path->bytes p)
external-deps)))))
d)))])
(get-module-code path mode))] (get-module-code path mode))]
[code-dir (get-code-dir mode path)]) [code-dir (get-code-dir mode path)])
(if (not (directory-exists? code-dir)) (if (not (directory-exists? code-dir))

203
collects/net/base64-unit.ss
View File

@ -1,49 +1,48 @@
#lang scheme/unit #lang scheme/unit
(require "base64-sig.ss") (require "base64-sig.ss")
(import) (import)
(export base64^) (export base64^)
(define base64-digit (make-vector 256)) (define base64-digit (make-vector 256))
(let loop ([n 0]) (let loop ([n 0])
(unless (= n 256) (unless (= n 256)
(cond [(<= (char->integer #\A) n (char->integer #\Z)) (cond [(<= (char->integer #\A) n (char->integer #\Z))
(vector-set! base64-digit n (- n (char->integer #\A)))] (vector-set! base64-digit n (- n (char->integer #\A)))]
[(<= (char->integer #\a) n (char->integer #\z)) [(<= (char->integer #\a) n (char->integer #\z))
(vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))] (vector-set! base64-digit n (+ 26 (- n (char->integer #\a))))]
[(<= (char->integer #\0) n (char->integer #\9)) [(<= (char->integer #\0) n (char->integer #\9))
(vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))] (vector-set! base64-digit n (+ 52 (- n (char->integer #\0))))]
[(= (char->integer #\+) n) [(= (char->integer #\+) n)
(vector-set! base64-digit n 62)] (vector-set! base64-digit n 62)]
[(= (char->integer #\/) n) [(= (char->integer #\/) n)
(vector-set! base64-digit n 63)] (vector-set! base64-digit n 63)]
[else [else
(vector-set! base64-digit n #f)]) (vector-set! base64-digit n #f)])
(loop (add1 n)))) (loop (add1 n))))
(define digit-base64 (make-vector 64)) (define digit-base64 (make-vector 64))
(define (each-char s e pos) (define (each-char s e pos)
(let loop ([i (char->integer s)][pos pos]) (let loop ([i (char->integer s)][pos pos])
(unless (> i (char->integer e)) (unless (> i (char->integer e))
(vector-set! digit-base64 pos i) (vector-set! digit-base64 pos i)
(loop (add1 i) (add1 pos))))) (loop (add1 i) (add1 pos)))))
(each-char #\A #\Z 0) (each-char #\A #\Z 0)
(each-char #\a #\z 26) (each-char #\a #\z 26)
(each-char #\0 #\9 52) (each-char #\0 #\9 52)
(each-char #\+ #\+ 62) (each-char #\+ #\+ 62)
(each-char #\/ #\/ 63) (each-char #\/ #\/ 63)
(define (base64-filename-safe) (define (base64-filename-safe)
(vector-set! base64-digit (char->integer #\-) 62) (vector-set! base64-digit (char->integer #\-) 62)
(vector-set! base64-digit (char->integer #\_) 63) (vector-set! base64-digit (char->integer #\_) 63)
(each-char #\- #\- 62) (each-char #\- #\- 62)
(each-char #\_ #\_ 63)) (each-char #\_ #\_ 63))
(define (base64-decode-stream in out) (define (base64-decode-stream in out)
(let loop ([waiting 0][waiting-bits 0]) (let loop ([waiting 0][waiting-bits 0])
(if (>= waiting-bits 8) (if (>= waiting-bits 8)
(begin (begin
(write-byte (arithmetic-shift waiting (- 8 waiting-bits)) out) (write-byte (arithmetic-shift waiting (- 8 waiting-bits)) out)
(let ([waiting-bits (- waiting-bits 8)]) (let ([waiting-bits (- waiting-bits 8)])
@ -57,79 +56,79 @@
[(eq? c (char->integer #\=)) (void)] ; done [(eq? c (char->integer #\=)) (void)] ; done
[else (loop waiting waiting-bits)]))))) [else (loop waiting waiting-bits)])))))
(define base64-encode-stream (define base64-encode-stream
(case-lambda (case-lambda
[(in out) (base64-encode-stream in out #"\n")] [(in out) (base64-encode-stream in out #"\n")]
[(in out linesep) [(in out linesep)
;; Process input 3 characters at a time, because 18 bits ;; Process input 3 characters at a time, because 18 bits
;; is divisible by both 6 and 8, and 72 (the line length) ;; is divisible by both 6 and 8, and 72 (the line length)
;; is divisible by 3. ;; is divisible by 3.
(let ([three (make-bytes 3)] (let ([three (make-bytes 3)]
[outc (lambda (n) [outc (lambda (n)
(write-byte (vector-ref digit-base64 n) out))] (write-byte (vector-ref digit-base64 n) out))]
[done (lambda (fill) [done (lambda (fill)
(let loop ([fill fill]) (let loop ([fill fill])
(unless (zero? fill) (unless (zero? fill)
(write-byte (char->integer #\=) out) (write-byte (char->integer #\=) out)
(loop (sub1 fill)))) (loop (sub1 fill))))
(display linesep out))]) (display linesep out))])
(let loop ([pos 0]) (let loop ([pos 0])
(if (= pos 72) (if (= pos 72)
;; Insert newline ;; Insert newline
(begin (begin
(display linesep out) (display linesep out)
(loop 0)) (loop 0))
;; Next group of 3 ;; Next group of 3
(let ([n (read-bytes-avail! three in)]) (let ([n (read-bytes-avail! three in)])
(cond (cond
[(eof-object? n) [(eof-object? n)
(unless (= pos 0) (done 0))] (unless (= pos 0) (done 0))]
[(= n 3) [(= n 3)
;; Easy case: ;; Easy case:
(let ([a (bytes-ref three 0)] (let ([a (bytes-ref three 0)]
[b (bytes-ref three 1)] [b (bytes-ref three 1)]
[c (bytes-ref three 2)]) [c (bytes-ref three 2)])
(outc (arithmetic-shift a -2)) (outc (arithmetic-shift a -2))
(outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) (outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
(arithmetic-shift b -4))) (arithmetic-shift b -4)))
(outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) (outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
(arithmetic-shift c -6))) (arithmetic-shift c -6)))
(outc (bitwise-and #x3f c)) (outc (bitwise-and #x3f c))
(loop (+ pos 4)))] (loop (+ pos 4)))]
[else [else
;; Hard case: n is 1 or 2 ;; Hard case: n is 1 or 2
(let ([a (bytes-ref three 0)]) (let ([a (bytes-ref three 0)])
(outc (arithmetic-shift a -2)) (outc (arithmetic-shift a -2))
(let* ([next (if (= n 2) (let* ([next (if (= n 2)
(bytes-ref three 1) (bytes-ref three 1)
(read-byte in))] (read-byte in))]
[b (if (eof-object? next) [b (if (eof-object? next)
0 0
next)]) next)])
(outc (+ (bitwise-and #x3f (arithmetic-shift a 4)) (outc (+ (bitwise-and #x3f (arithmetic-shift a 4))
(arithmetic-shift b -4))) (arithmetic-shift b -4)))
(if (eof-object? next) (if (eof-object? next)
(done 2) (done 2)
;; More to go ;; More to go
(let* ([next (read-byte in)] (let* ([next (read-byte in)]
[c (if (eof-object? next) [c (if (eof-object? next)
0 0
next)]) next)])
(outc (+ (bitwise-and #x3f (arithmetic-shift b 2)) (outc (+ (bitwise-and #x3f (arithmetic-shift b 2))
(arithmetic-shift c -6))) (arithmetic-shift c -6)))
(if (eof-object? next) (if (eof-object? next)
(done 1) (done 1)
;; Finish c, loop ;; Finish c, loop
(begin (begin
(outc (bitwise-and #x3f c)) (outc (bitwise-and #x3f c))
(loop (+ pos 4))))))))])))))])) (loop (+ pos 4))))))))])))))]))
(define (base64-decode src) (define (base64-decode src)
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(base64-decode-stream (open-input-bytes src) s) (base64-decode-stream (open-input-bytes src) s)
(get-output-bytes s))) (get-output-bytes s)))
(define (base64-encode src) (define (base64-encode src)
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(base64-encode-stream (open-input-bytes src) s (bytes 13 10)) (base64-encode-stream (open-input-bytes src) s (bytes 13 10))
(get-output-bytes s))) (get-output-bytes s)))

2
collects/net/cookie-unit.ss
View File

@ -59,7 +59,7 @@
(import) (import)
(export cookie^) (export cookie^)
(define-struct cookie (name value comment domain max-age path secure version)) (define-struct cookie (name value comment domain max-age path secure version) #:mutable)
(define-struct (cookie-error exn:fail) ()) (define-struct (cookie-error exn:fail) ())
;; error* : string args ... -> raises a cookie-error exception ;; error* : string args ... -> raises a cookie-error exception

3
collects/net/dns-unit.ss
View File

@ -1,6 +1,7 @@
#lang scheme/unit #lang scheme/unit
(require (lib "list.ss") (lib "process.ss") "dns-sig.ss") (require (lib "list.ss") (lib "process.ss") "dns-sig.ss"
scheme/udp)
(import) (import)
(export dns^) (export dns^)

362
collects/net/ftp-unit.ss
View File

@ -1,82 +1,82 @@
#lang scheme/unit #lang scheme/unit
;; Version 0.2 ;; Version 0.2
;; Version 0.1a ;; Version 0.1a
;; Micah Flatt ;; Micah Flatt
;; 06-06-2002 ;; 06-06-2002
(require (lib "date.ss") (lib "file.ss") (lib "port.ss") "ftp-sig.ss") (require scheme/date scheme/file scheme/port scheme/tcp "ftp-sig.ss")
(import) (import)
(export ftp^) (export ftp^)
;; opqaue record to represent an FTP connection: ;; opqaue record to represent an FTP connection:
(define-struct tcp-connection (in out)) (define-struct tcp-connection (in out))
(define tzoffset (date-time-zone-offset (seconds->date (current-seconds)))) (define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") (define re:multi-response-start #rx#"^[0-9][0-9][0-9]-")
(define re:response-end #rx#"^[0-9][0-9][0-9] ") (define re:response-end #rx#"^[0-9][0-9][0-9] ")
(define (check-expected-result line expected) (define (check-expected-result line expected)
(when expected (when expected
(unless (ormap (lambda (expected) (unless (ormap (lambda (expected)
(bytes=? expected (subbytes line 0 3))) (bytes=? expected (subbytes line 0 3)))
(if (bytes? expected) (if (bytes? expected)
(list expected) (list expected)
expected)) expected))
(error 'ftp "exected result code ~a, got ~a" expected line)))) (error 'ftp "exected result code ~a, got ~a" expected line))))
;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any
;; ;;
;; Checks a standard-format response, checking for the given ;; Checks a standard-format response, checking for the given
;; expected 3-digit result code if expected is not #f. ;; expected 3-digit result code if expected is not #f.
;; ;;
;; While checking, the function sends reponse lines to ;; While checking, the function sends reponse lines to
;; diagnostic-accum. This function -accum functions can return a ;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and ;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and ;; accum-start is used as the initial value. Use `void' and
;; `(void)' to ignore the response info. ;; `(void)' to ignore the response info.
;; ;;
;; If an unexpected result is found, an exception is raised, and the ;; If an unexpected result is found, an exception is raised, and the
;; stream is left in an undefined state. ;; stream is left in an undefined state.
(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
(flush-output tcpout) (flush-output tcpout)
(let ([line (read-bytes-line tcpin 'any)]) (let ([line (read-bytes-line tcpin 'any)])
(cond (cond
[(eof-object? line) [(eof-object? line)
(error 'ftp "unexpected EOF")] (error 'ftp "unexpected EOF")]
[(regexp-match re:multi-response-start line) [(regexp-match re:multi-response-start line)
(check-expected-result line expected) (check-expected-result line expected)
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)]) (let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)]) (let ([line (read-bytes-line tcpin 'any)])
(cond [(eof-object? line) (cond [(eof-object? line)
(error 'ftp "unexpected EOF")] (error 'ftp "unexpected EOF")]
[(regexp-match re:done line) [(regexp-match re:done line)
(diagnostic-accum line accum)] (diagnostic-accum line accum)]
[else [else
(loop (diagnostic-accum line accum))]))))] (loop (diagnostic-accum line accum))]))))]
[(regexp-match re:response-end line) [(regexp-match re:response-end line)
(check-expected-result line expected) (check-expected-result line expected)
(diagnostic-accum line accum-start)] (diagnostic-accum line accum-start)]
[else [else
(error 'ftp "unexpected result: ~e" line)]))) (error 'ftp "unexpected result: ~e" line)])))
(define (get-month month-bytes) (define (get-month month-bytes)
(cond [(assoc month-bytes (cond [(assoc month-bytes
'((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
(#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
(#"Nov" 11) (#"Dec" 12))) (#"Nov" 11) (#"Dec" 12)))
=> cadr] => cadr]
[else (error 'get-month "bad month: ~s" month-bytes)])) [else (error 'get-month "bad month: ~s" month-bytes)]))
(define (bytes->number bytes) (define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes))) (string->number (bytes->string/latin-1 bytes)))
(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") (define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)")
(define (ftp-make-file-seconds ftp-date-str) (define (ftp-make-file-seconds ftp-date-str)
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))]) (let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
(if (not (list-ref date-list 4)) (if (not (list-ref date-list 4))
(find-seconds 0 (find-seconds 0
0 0
2 2
@ -91,128 +91,128 @@
2002) 2002)
tzoffset)))) tzoffset))))
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") (define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(define (establish-data-connection tcp-ports) (define (establish-data-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV\n") (fprintf (tcp-connection-out tcp-ports) "PASV\n")
(let ([response (ftp-check-response (let ([response (ftp-check-response
(tcp-connection-in tcp-ports) (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports) (tcp-connection-out tcp-ports)
#"227" #"227"
(lambda (s ignore) s) ; should be the only response (lambda (s ignore) s) ; should be the only response
(void))]) (void))])
(let* ([reg-list (regexp-match re:passive response)] (let* ([reg-list (regexp-match re:passive response)]
[pn1 (and reg-list [pn1 (and reg-list
(bytes->number (list-ref reg-list 5)))] (bytes->number (list-ref reg-list 5)))]
[pn2 (bytes->number (list-ref reg-list 6))]) [pn2 (bytes->number (list-ref reg-list 6))])
(unless (and reg-list pn1 pn2) (unless (and reg-list pn1 pn2)
(error 'ftp "can't understand PASV response: ~e" response)) (error 'ftp "can't understand PASV response: ~e" response))
(let-values ([(tcp-data tcp-data-out) (let-values ([(tcp-data tcp-data-out)
(tcp-connect (format "~a.~a.~a.~a" (tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 1) (list-ref reg-list 1)
(list-ref reg-list 2) (list-ref reg-list 2)
(list-ref reg-list 3) (list-ref reg-list 3)
(list-ref reg-list 4)) (list-ref reg-list 4))
(+ (* 256 pn1) pn2))]) (+ (* 256 pn1) pn2))])
(fprintf (tcp-connection-out tcp-ports) "TYPE I\n") (fprintf (tcp-connection-out tcp-ports) "TYPE I\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"200" void (void))
(close-output-port tcp-data-out)
tcp-data))))
;; Used where version 0.1a printed responses:
(define (print-msg s ignore)
;; (printf "~a\n" s)
(void))
(define (ftp-establish-connection* in out username password)
(ftp-check-response in out #"220" print-msg (void))
(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(let ([no-password? (ftp-check-response
in out (list #"331" #"230")
(lambda (line 230?)
(or 230? (regexp-match #rx#"^230" line)))
#f)])
(unless no-password?
(display (bytes-append #"PASS " (string->bytes/locale password) #"\n")
out)
(ftp-check-response in out #"230" void (void))))
(make-tcp-connection in out))
(define (ftp-establish-connection server-address server-port username password)
(let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
(ftp-establish-connection* tcpin tcpout username password)))
(define (ftp-close-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "QUIT\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"221" void (void))
(close-input-port (tcp-connection-in tcp-ports))
(close-output-port (tcp-connection-out tcp-ports)))
(define (filter-tcp-data tcp-data-port regular-exp)
(let loop ()
(let ([theline (read-bytes-line tcp-data-port 'any)])
(cond [(or (eof-object? theline) (< (bytes-length theline) 3))
null]
[(regexp-match regular-exp theline)
=> (lambda (m) (cons (cdr m) (loop)))]
[else
;; ignore unrecognized lines?
(loop)]))))
(define (ftp-cd ftp-ports new-dir)
(display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n")
(tcp-connection-out ftp-ports))
(ftp-check-response (tcp-connection-in ftp-ports)
(tcp-connection-out ftp-ports)
#"250" void (void)))
(define re:dir-line
#rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
(define (ftp-directory-list tcp-ports)
(let ([tcp-data (establish-data-connection tcp-ports)])
(fprintf (tcp-connection-out tcp-ports) "LIST\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"150" void (void))
(let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports) (ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports) (tcp-connection-out tcp-ports)
#"226" print-msg (void)) #"200" void (void))
(map (lambda (l) (map bytes->string/locale l)) dir-list)))) (close-output-port tcp-data-out)
tcp-data))))
(define (ftp-download-file tcp-ports folder filename) ;; Used where version 0.1a printed responses:
;; Save the file under the name tmp.file, rename it once download is (define (print-msg s ignore)
;; complete this assures we don't over write any existing file without ;; (printf "~a\n" s)
;; having a good file down (void))
(let* ([tmpfile (make-temporary-file
(string-append (define (ftp-establish-connection* in out username password)
(regexp-replace (ftp-check-response in out #"220" print-msg (void))
#rx"~" (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
(path->string (build-path folder "ftptmp")) (let ([no-password? (ftp-check-response
"~~") in out (list #"331" #"230")
"~a"))] (lambda (line 230?)
[new-file (open-output-file tmpfile 'replace)] (or 230? (regexp-match #rx#"^230" line)))
[tcpstring (bytes-append #"RETR " #f)])
(string->bytes/locale filename) (unless no-password?
#"\n")] (display (bytes-append #"PASS " (string->bytes/locale password) #"\n")
[tcp-data (establish-data-connection tcp-ports)]) out)
(display tcpstring (tcp-connection-out tcp-ports)) (ftp-check-response in out #"230" void (void))))
(ftp-check-response (tcp-connection-in tcp-ports) (make-tcp-connection in out))
(tcp-connection-out tcp-ports)
#"150" print-msg (void)) (define (ftp-establish-connection server-address server-port username password)
(copy-port tcp-data new-file) (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)])
(close-output-port new-file) (ftp-establish-connection* tcpin tcpout username password)))
(define (ftp-close-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "QUIT\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"221" void (void))
(close-input-port (tcp-connection-in tcp-ports))
(close-output-port (tcp-connection-out tcp-ports)))
(define (filter-tcp-data tcp-data-port regular-exp)
(let loop ()
(let ([theline (read-bytes-line tcp-data-port 'any)])
(cond [(or (eof-object? theline) (< (bytes-length theline) 3))
null]
[(regexp-match regular-exp theline)
=> (lambda (m) (cons (cdr m) (loop)))]
[else
;; ignore unrecognized lines?
(loop)]))))
(define (ftp-cd ftp-ports new-dir)
(display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n")
(tcp-connection-out ftp-ports))
(ftp-check-response (tcp-connection-in ftp-ports)
(tcp-connection-out ftp-ports)
#"250" void (void)))
(define re:dir-line
#rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$")
(define (ftp-directory-list tcp-ports)
(let ([tcp-data (establish-data-connection tcp-ports)])
(fprintf (tcp-connection-out tcp-ports) "LIST\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"150" void (void))
(let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
(close-input-port tcp-data) (close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports) (ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports) (tcp-connection-out tcp-ports)
#"226" print-msg (void)) #"226" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t))) (map (lambda (l) (map bytes->string/locale l)) dir-list))))
;; (printf "FTP Client Installed...\n") (define (ftp-download-file tcp-ports folder filename)
;; Save the file under the name tmp.file, rename it once download is
;; complete this assures we don't over write any existing file without
;; having a good file down
(let* ([tmpfile (make-temporary-file
(string-append
(regexp-replace
#rx"~"
(path->string (build-path folder "ftptmp"))
"~~")
"~a"))]
[new-file (open-output-file tmpfile 'replace)]
[tcpstring (bytes-append #"RETR "
(string->bytes/locale filename)
#"\n")]
[tcp-data (establish-data-connection tcp-ports)])
(display tcpstring (tcp-connection-out tcp-ports))
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"150" print-msg (void))
(copy-port tcp-data new-file)
(close-output-port new-file)
(close-input-port tcp-data)
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"226" print-msg (void))
(rename-file-or-directory tmpfile (build-path folder filename) #t)))
;; (printf "FTP Client Installed...\n")

7
collects/net/imap-unit.ss
View File

@ -1,6 +1,8 @@
#lang scheme/unit #lang scheme/unit
(require (lib "list.ss") "imap-sig.ss" "private/rbtree.ss") (require scheme/tcp
"imap-sig.ss"
"private/rbtree.ss")
(import) (import)
(export imap^) (export imap^)
@ -252,7 +254,8 @@
(info-handler i))) (info-handler i)))
(define-struct imap (r w exists recent unseen uidnext uidvalidity (define-struct imap (r w exists recent unseen uidnext uidvalidity
expunges fetches new?)) expunges fetches new?)
#:mutable)
(define (imap-connection? v) (imap? v)) (define (imap-connection? v) (imap? v))
(define imap-port-number (define imap-port-number

16
collects/net/mime-sig.ss
View File

@ -1,14 +1,14 @@
#lang scheme/signature #lang scheme/signature
;; -- exceptions raised -- ;; -- exceptions raised --
(struct mime-error () -setters -constructor) (struct mime-error () #:omit-constructor)
(struct unexpected-termination (msg) -setters -constructor) (struct unexpected-termination (msg) #:omit-constructor)
(struct missing-multipart-boundary-parameter () -setters -constructor) (struct missing-multipart-boundary-parameter () #:omit-constructor)
(struct malformed-multipart-entity (msg) -setters -constructor) (struct malformed-multipart-entity (msg) #:omit-constructor)
(struct empty-mechanism () -setters -constructor) (struct empty-mechanism () #:omit-constructor)
(struct empty-type () -setters -constructor) (struct empty-type () #:omit-constructor)
(struct empty-subtype () -setters -constructor) (struct empty-subtype () #:omit-constructor)
(struct empty-disposition-type () -setters -constructor) (struct empty-disposition-type () #:omit-constructor)
;; -- basic mime structures -- ;; -- basic mime structures --
(struct message (version entity fields)) (struct message (version entity fields))

11
collects/net/mime-unit.ss
View File

@ -121,12 +121,15 @@
("quicktime" . quicktime))) ("quicktime" . quicktime)))
;; Basic structures ;; Basic structures
(define-struct message (version entity fields)) (define-struct message (version entity fields)
#:mutable)
(define-struct entity (define-struct entity
(type subtype charset encoding disposition params id description other (type subtype charset encoding disposition params id description other
fields parts body)) fields parts body)
#:mutable)
(define-struct disposition (define-struct disposition
(type filename creation modification read size params)) (type filename creation modification read size params)
#:mutable)
;; Exceptions ;; Exceptions
(define-struct mime-error ()) (define-struct mime-error ())
@ -227,7 +230,7 @@
[(message multipart) [(message multipart)
(let ([boundary (entity-boundary entity)]) (let ([boundary (entity-boundary entity)])
(when (not boundary) (when (not boundary)
(if (eq? 'multipart (entity-type entity)) (when (eq? 'multipart (entity-type entity))
(raise (make-missing-multipart-boundary-parameter)))) (raise (make-missing-multipart-boundary-parameter))))
(set-entity-parts! entity (set-entity-parts! entity
(map (lambda (part) (map (lambda (part)

482
collects/net/nntp-unit.ss
View File

@ -1,150 +1,150 @@
#lang scheme/unit #lang scheme/unit
(require (lib "etc.ss") "nntp-sig.ss") (require scheme/tcp "nntp-sig.ss")
(import) (import)
(export nntp^) (export nntp^)
;; sender : oport ;; sender : oport
;; receiver : iport ;; receiver : iport
;; server : string ;; server : string
;; port : number ;; port : number
(define-struct communicator (sender receiver server port)) (define-struct communicator (sender receiver server port))
;; code : number ;; code : number
;; text : string ;; text : string
;; line : string ;; line : string
;; communicator : communicator ;; communicator : communicator
;; group : string ;; group : string
;; article : number ;; article : number
(define-struct (nntp exn) ()) (define-struct (nntp exn) ())
(define-struct (unexpected-response nntp) (code text)) (define-struct (unexpected-response nntp) (code text))
(define-struct (bad-status-line nntp) (line)) (define-struct (bad-status-line nntp) (line))
(define-struct (premature-close nntp) (communicator)) (define-struct (premature-close nntp) (communicator))
(define-struct (bad-newsgroup-line nntp) (line)) (define-struct (bad-newsgroup-line nntp) (line))
(define-struct (non-existent-group nntp) (group)) (define-struct (non-existent-group nntp) (group))
(define-struct (article-not-in-group nntp) (article)) (define-struct (article-not-in-group nntp) (article))
(define-struct (no-group-selected nntp) ()) (define-struct (no-group-selected nntp) ())
(define-struct (article-not-found nntp) (article)) (define-struct (article-not-found nntp) (article))
(define-struct (authentication-rejected nntp) ()) (define-struct (authentication-rejected nntp) ())
;; signal-error : ;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... -> ;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> () ;; exn-args -> ()
;; - throws an exception ;; - throws an exception
(define (signal-error constructor format-string . args) (define (signal-error constructor format-string . args)
(lambda exn-args (lambda exn-args
(raise (apply constructor (raise (apply constructor
(apply format format-string args) (apply format format-string args)
(current-continuation-marks) (current-continuation-marks)
exn-args)))) exn-args))))
;; default-nntpd-port-number : ;; default-nntpd-port-number :
;; number ;; number
(define default-nntpd-port-number 119) (define default-nntpd-port-number 119)
;; connect-to-server*: ;; connect-to-server*:
;; input-port output-port -> communicator ;; input-port output-port -> communicator
(define connect-to-server* (define connect-to-server*
(case-lambda (case-lambda
[(receiver sender) [(receiver sender)
(connect-to-server* receiver sender "unspecified" "unspecified")] (connect-to-server* receiver sender "unspecified" "unspecified")]
[(receiver sender server-name port-number) [(receiver sender server-name port-number)
(file-stream-buffer-mode sender 'line) (file-stream-buffer-mode sender 'line)
(let ([communicator (make-communicator sender receiver server-name (let ([communicator (make-communicator sender receiver server-name
port-number)]) port-number)])
(let-values ([(code response) (let-values ([(code response)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
(case code (case code
[(200 201) communicator] [(200 201) communicator]
[else ((signal-error make-unexpected-response [else ((signal-error make-unexpected-response
"unexpected connection response: ~s ~s" "unexpected connection response: ~s ~s"
code response) code response)
code response)])))])) code response)])))]))
;; connect-to-server : ;; connect-to-server :
;; string [x number] -> commnicator ;; string [x number] -> commnicator
(define connect-to-server (define connect-to-server
(opt-lambda (server-name (port-number default-nntpd-port-number)) (lambda (server-name (port-number default-nntpd-port-number))
(let-values ([(receiver sender) (let-values ([(receiver sender)
(tcp-connect server-name port-number)]) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number)))) (connect-to-server* receiver sender server-name port-number))))
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define (close-communicator communicator) (define (close-communicator communicator)
(close-input-port (communicator-receiver communicator)) (close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))) (close-output-port (communicator-sender communicator)))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define (disconnect-from-server communicator) (define (disconnect-from-server communicator)
(send-to-server communicator "QUIT") (send-to-server communicator "QUIT")
(let-values ([(code response) (let-values ([(code response)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
(case code (case code
[(205) [(205)
(close-communicator communicator)] (close-communicator communicator)]
[else [else
((signal-error make-unexpected-response ((signal-error make-unexpected-response
"unexpected dis-connect response: ~s ~s" "unexpected dis-connect response: ~s ~s"
code response) code response)
code response)]))) code response)])))
;; authenticate-user : ;; authenticate-user :
;; communicator x user-name x password -> () ;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it. ;; the password is not used if the server does not ask for it.
(define (authenticate-user communicator user password) (define (authenticate-user communicator user password)
(define (reject code response) (define (reject code response)
((signal-error make-authentication-rejected ((signal-error make-authentication-rejected
"authentication rejected (~s ~s)" "authentication rejected (~s ~s)"
code response))) code response)))
(define (unexpected code response) (define (unexpected code response)
((signal-error make-unexpected-response ((signal-error make-unexpected-response
"unexpected response for authentication: ~s ~s" "unexpected response for authentication: ~s ~s"
code response) code response)
code response)) code response))
(send-to-server communicator "AUTHINFO USER ~a" user) (send-to-server communicator "AUTHINFO USER ~a" user)
(let-values ([(code response) (get-single-line-response communicator)]) (let-values ([(code response) (get-single-line-response communicator)])
(case code (case code
[(281) (void)] ; server doesn't ask for a password [(281) (void)] ; server doesn't ask for a password
[(381) [(381)
(send-to-server communicator "AUTHINFO PASS ~a" password) (send-to-server communicator "AUTHINFO PASS ~a" password)
(let-values ([(code response) (let-values ([(code response)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
(case code (case code
[(281) (void)] ; done [(281) (void)] ; done
[(502) (reject code response)] [(502) (reject code response)]
[else (unexpected code response)]))] [else (unexpected code response)]))]
[(502) (reject code response)] [(502) (reject code response)]
[else (reject code response) [else (reject code response)
(unexpected code response)]))) (unexpected code response)])))
;; send-to-server : ;; send-to-server :
;; communicator x format-string x list (values) -> () ;; communicator x format-string x list (values) -> ()
(define (send-to-server communicator message-template . rest) (define (send-to-server communicator message-template . rest)
(let ([sender (communicator-sender communicator)]) (let ([sender (communicator-sender communicator)])
(apply fprintf sender (apply fprintf sender
(string-append message-template "\r\n") (string-append message-template "\r\n")
rest) rest)
(flush-output sender))) (flush-output sender)))
;; parse-status-line : ;; parse-status-line :
;; string -> number x string ;; string -> number x string
(define (parse-status-line line) (define (parse-status-line line)
(if (eof-object? line) (if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line") ((signal-error make-bad-status-line "eof instead of a status line")
line) line)
(let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line)
@ -154,99 +154,99 @@
(values (string->number (car match)) (values (string->number (car match))
(cadr match))))) (cadr match)))))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define (get-one-line-from-server server->client-port) (define (get-one-line-from-server server->client-port)
(read-line server->client-port 'return-linefeed)) (read-line server->client-port 'return-linefeed))
;; get-single-line-response : ;; get-single-line-response :
;; communicator -> number x string ;; communicator -> number x string
(define (get-single-line-response communicator) (define (get-single-line-response communicator)
(let* ([receiver (communicator-receiver communicator)] (let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]) [status-line (get-one-line-from-server receiver)])
(parse-status-line status-line))) (parse-status-line status-line)))
;; get-rest-of-multi-line-response : ;; get-rest-of-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(define (get-rest-of-multi-line-response communicator) (define (get-rest-of-multi-line-response communicator)
(let ([receiver (communicator-receiver communicator)]) (let ([receiver (communicator-receiver communicator)])
(let loop () (let loop ()
(let ([l (get-one-line-from-server receiver)]) (let ([l (get-one-line-from-server receiver)])
(cond (cond
[(eof-object? l) [(eof-object? l)
((signal-error make-premature-close ((signal-error make-premature-close
"port prematurely closed during multi-line response") "port prematurely closed during multi-line response")
communicator)] communicator)]
[(string=? l ".") [(string=? l ".")
'()] '()]
[(string=? l "..") [(string=? l "..")
(cons "." (loop))] (cons "." (loop))]
[else [else
(cons l (loop))]))))) (cons l (loop))])))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> number x string x list (string) ;; communicator -> number x string x list (string)
;; -- The returned values are the status code, the rest of the status ;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines. ;; response line, and the remaining lines.
(define (get-multi-line-response communicator) (define (get-multi-line-response communicator)
(let* ([receiver (communicator-receiver communicator)] (let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]) [status-line (get-one-line-from-server receiver)])
(let-values ([(code rest-of-line)
(parse-status-line status-line)])
(values code rest-of-line (get-rest-of-multi-line-response)))))
;; open-news-group :
;; communicator x string -> number x number x number
;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group.
(define (open-news-group communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values ([(code rest-of-line) (let-values ([(code rest-of-line)
(get-single-line-response communicator)]) (parse-status-line status-line)])
(case code (values code rest-of-line (get-rest-of-multi-line-response)))))
[(211)
(let ([match (map string->number
(cdr
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))])
(let ([number-of-articles (car match)]
[first-article-number (cadr match)]
[last-article-number (caddr match)])
(values number-of-articles
first-article-number
last-article-number)))]
[(411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name)]
[else
((signal-error make-unexpected-response
"unexpected group opening response: ~s" code)
code rest-of-line)])))
;; generic-message-command : ;; open-news-group :
;; string x number -> communicator x (number U string) -> list (string) ;; communicator x string -> number x number x number
(define (generic-message-command command ok-code) ;; -- The returned values are the number of articles, the first
(lambda (communicator message-index) ;; article number, and the last article number for that group.
(send-to-server communicator (string-append command " ~a")
(if (number? message-index) (define (open-news-group communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values ([(code rest-of-line)
(get-single-line-response communicator)])
(case code
[(211)
(let ([match (map string->number
(cdr
(or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))])
(let ([number-of-articles (car match)]
[first-article-number (cadr match)]
[last-article-number (caddr match)])
(values number-of-articles
first-article-number
last-article-number)))]
[(411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name)]
[else
((signal-error make-unexpected-response
"unexpected group opening response: ~s" code)
code rest-of-line)])))
;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string)
(define (generic-message-command command ok-code)
(lambda (communicator message-index)
(send-to-server communicator (string-append command " ~a")
(if (number? message-index)
(number->string message-index) (number->string message-index)
message-index)) message-index))
(let-values ([(code response) (let-values ([(code response)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
(if (= code ok-code) (if (= code ok-code)
(get-rest-of-multi-line-response communicator) (get-rest-of-multi-line-response communicator)
(case code (case code
[(423) [(423)
@ -265,54 +265,54 @@
"unexpected message access response: ~s" code) "unexpected message access response: ~s" code)
code response)]))))) code response)])))))
;; head-of-message : ;; head-of-message :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define head-of-message (define head-of-message
(generic-message-command "HEAD" 221)) (generic-message-command "HEAD" 221))
;; body-of-message : ;; body-of-message :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define body-of-message (define body-of-message
(generic-message-command "BODY" 222)) (generic-message-command "BODY" 222))
;; newnews-since : ;; newnews-since :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define newnews-since (define newnews-since
(generic-message-command "NEWNEWS" 230)) (generic-message-command "NEWNEWS" 230))
;; make-desired-header : ;; make-desired-header :
;; string -> desired ;; string -> desired
(define (make-desired-header raw-header) (define (make-desired-header raw-header)
(regexp (regexp
(string-append (string-append
"^" "^"
(list->string (list->string
(apply append (apply append
(map (lambda (c) (map (lambda (c)
(cond (cond
[(char-lower-case? c) [(char-lower-case? c)
(list #\[ (char-upcase c) c #\])] (list #\[ (char-upcase c) c #\])]
[(char-upper-case? c) [(char-upper-case? c)
(list #\[ c (char-downcase c) #\])] (list #\[ c (char-downcase c) #\])]
[else [else
(list c)])) (list c)]))
(string->list raw-header)))) (string->list raw-header))))
":"))) ":")))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define (extract-desired-headers headers desireds) (define (extract-desired-headers headers desireds)
(let loop ([headers headers]) (let loop ([headers headers])
(if (null? headers) null (if (null? headers) null
(let ([first (car headers)] (let ([first (car headers)]
[rest (cdr headers)]) [rest (cdr headers)])
(if (ormap (lambda (matcher) (if (ormap (lambda (matcher)
(regexp-match matcher first)) (regexp-match matcher first))
desireds) desireds)
(cons first (loop rest)) (cons first (loop rest))
(loop rest)))))) (loop rest))))))

622
collects/net/pop3-unit.ss
View File

@ -1,390 +1,390 @@
#lang scheme/unit #lang scheme/unit
(require (lib "etc.ss") "pop3-sig.ss") (require scheme/tcp "pop3-sig.ss")
(import) (import)
(export pop3^) (export pop3^)
;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose ;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
;; sender : oport ;; sender : oport
;; receiver : iport ;; receiver : iport
;; server : string ;; server : string
;; port : number ;; port : number
;; state : symbol = (disconnected, authorization, transaction) ;; state : symbol = (disconnected, authorization, transaction)
(define-struct communicator (sender receiver server port state)) (define-struct communicator (sender receiver server port [state #:mutable]))
(define-struct (pop3 exn) ()) (define-struct (pop3 exn) ())
(define-struct (cannot-connect pop3) ()) (define-struct (cannot-connect pop3) ())
(define-struct (username-rejected pop3) ()) (define-struct (username-rejected pop3) ())
(define-struct (password-rejected pop3) ()) (define-struct (password-rejected pop3) ())
(define-struct (not-ready-for-transaction pop3) (communicator)) (define-struct (not-ready-for-transaction pop3) (communicator))
(define-struct (not-given-headers pop3) (communicator message)) (define-struct (not-given-headers pop3) (communicator message))
(define-struct (illegal-message-number pop3) (communicator message)) (define-struct (illegal-message-number pop3) (communicator message))
(define-struct (cannot-delete-message exn) (communicator message)) (define-struct (cannot-delete-message exn) (communicator message))
(define-struct (disconnect-not-quiet pop3) (communicator)) (define-struct (disconnect-not-quiet pop3) (communicator))
(define-struct (malformed-server-response pop3) (communicator)) (define-struct (malformed-server-response pop3) (communicator))
;; signal-error : ;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... -> ;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> () ;; exn-args -> ()
(define (signal-error constructor format-string . args) (define (signal-error constructor format-string . args)
(lambda exn-args (lambda exn-args
(raise (apply constructor (raise (apply constructor
(apply format format-string args) (apply format format-string args)
(current-continuation-marks) (current-continuation-marks)
exn-args)))) exn-args))))
;; signal-malformed-response-error : ;; signal-malformed-response-error :
;; exn-args -> () ;; exn-args -> ()
;; -- in practice, it takes only one argument: a communicator. ;; -- in practice, it takes only one argument: a communicator.
(define signal-malformed-response-error (define signal-malformed-response-error
(signal-error make-malformed-server-response (signal-error make-malformed-server-response
"malformed response from server")) "malformed response from server"))
;; confirm-transaction-mode : ;; confirm-transaction-mode :
;; communicator x string -> () ;; communicator x string -> ()
;; -- signals an error otherwise. ;; -- signals an error otherwise.
(define (confirm-transaction-mode communicator error-message) (define (confirm-transaction-mode communicator error-message)
(unless (eq? (communicator-state communicator) 'transaction) (unless (eq? (communicator-state communicator) 'transaction)
((signal-error make-not-ready-for-transaction error-message) ((signal-error make-not-ready-for-transaction error-message)
communicator))) communicator)))
;; default-pop-port-number : ;; default-pop-port-number :
;; number ;; number
(define default-pop-port-number 110) (define default-pop-port-number 110)
(define-struct server-responses ()) (define-struct server-responses ())
(define-struct (+ok server-responses) ()) (define-struct (+ok server-responses) ())
(define-struct (-err server-responses) ()) (define-struct (-err server-responses) ())
;; connect-to-server*: ;; connect-to-server*:
;; input-port output-port -> communicator ;; input-port output-port -> communicator
(define connect-to-server* (define connect-to-server*
(case-lambda (case-lambda
[(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")] [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")]
[(receiver sender server-name port-number) [(receiver sender server-name port-number)
(let ([communicator (make-communicator sender receiver server-name port-number (let ([communicator (make-communicator sender receiver server-name port-number
'authorization)]) 'authorization)])
(let ([response (get-status-response/basic communicator)]) (let ([response (get-status-response/basic communicator)])
(cond
[(+ok? response) communicator]
[(-err? response)
((signal-error make-cannot-connect
"cannot connect to ~a on port ~a"
server-name port-number))])))]))
;; connect-to-server :
;; string [x number] -> communicator
(define connect-to-server
(opt-lambda (server-name (port-number default-pop-port-number))
(let-values ([(receiver sender) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
;; authenticate/plain-text :
;; string x string x communicator -> ()
;; -- if authentication succeeds, sets the communicator's state to
;; transaction.
(define (authenticate/plain-text username password communicator)
(let ([sender (communicator-sender communicator)])
(send-to-server communicator "USER ~a" username)
(let ([status (get-status-response/basic communicator)])
(cond (cond
[(+ok? status) [(+ok? response) communicator]
(send-to-server communicator "PASS ~a" password) [(-err? response)
(let ([status (get-status-response/basic communicator)]) ((signal-error make-cannot-connect
(cond "cannot connect to ~a on port ~a"
[(+ok? status) server-name port-number))])))]))
(set-communicator-state! communicator 'transaction)]
[(-err? status)
((signal-error make-password-rejected
"password was rejected"))]))]
[(-err? status)
((signal-error make-username-rejected
"username was rejected"))]))))
;; get-mailbox-status : ;; connect-to-server :
;; communicator -> number x number ;; string [x number] -> communicator
;; -- returns number of messages and number of octets. (define connect-to-server
(lambda (server-name (port-number default-pop-port-number))
(let-values ([(receiver sender) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number))))
(define (get-mailbox-status communicator) ;; authenticate/plain-text :
(confirm-transaction-mode ;; string x string x communicator -> ()
communicator
"cannot get mailbox status unless in transaction mode")
(send-to-server communicator "STAT")
(apply values
(map string->number
(let-values ([(status result)
(get-status-response/match
communicator
#rx"([0-9]+) ([0-9]+)"
#f)])
result))))
;; get-message/complete : ;; -- if authentication succeeds, sets the communicator's state to
;; communicator x number -> list (string) x list (string) ;; transaction.
(define (get-message/complete communicator message) (define (authenticate/plain-text username password communicator)
(confirm-transaction-mode (let ([sender (communicator-sender communicator)])
communicator (send-to-server communicator "USER ~a" username)
"cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
(cond (cond
[(+ok? status) [(+ok? status)
(split-header/body (get-multi-line-response communicator))] (send-to-server communicator "PASS ~a" password)
[(-err? status) (let ([status (get-status-response/basic communicator)])
((signal-error make-illegal-message-number (cond
"not given message ~a" message) [(+ok? status)
communicator message)]))) (set-communicator-state! communicator 'transaction)]
[(-err? status)
((signal-error make-password-rejected
"password was rejected"))]))]
[(-err? status)
((signal-error make-username-rejected
"username was rejected"))]))))
;; get-message/headers : ;; get-mailbox-status :
;; communicator x number -> list (string) ;; communicator -> number x number
(define (get-message/headers communicator message) ;; -- returns number of messages and number of octets.
(confirm-transaction-mode
communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(let-values ([(headers body)
(split-header/body
(get-multi-line-response communicator))])
headers)]
[(-err? status)
((signal-error make-not-given-headers
"not given headers to message ~a" message)
communicator message)])))
;; get-message/body : (define (get-mailbox-status communicator)
;; communicator x number -> list (string) (confirm-transaction-mode
communicator
"cannot get mailbox status unless in transaction mode")
(send-to-server communicator "STAT")
(apply values
(map string->number
(let-values ([(status result)
(get-status-response/match
communicator
#rx"([0-9]+) ([0-9]+)"
#f)])
result))))
(define (get-message/body communicator message) ;; get-message/complete :
(let-values ([(headers body) (get-message/complete communicator message)]) ;; communicator x number -> list (string) x list (string)
body))
;; split-header/body : (define (get-message/complete communicator message)
;; list (string) -> list (string) x list (string) (confirm-transaction-mode
communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(split-header/body (get-multi-line-response communicator))]
[(-err? status)
((signal-error make-illegal-message-number
"not given message ~a" message)
communicator message)])))
;; -- returns list of headers and list of body lines. ;; get-message/headers :
;; communicator x number -> list (string)
(define (split-header/body lines) (define (get-message/headers communicator message)
(let loop ([lines lines] [header null]) (confirm-transaction-mode
(if (null? lines) communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message)
(let ([status (get-status-response/basic communicator)])
(cond
[(+ok? status)
(let-values ([(headers body)
(split-header/body
(get-multi-line-response communicator))])
headers)]
[(-err? status)
((signal-error make-not-given-headers
"not given headers to message ~a" message)
communicator message)])))
;; get-message/body :
;; communicator x number -> list (string)
(define (get-message/body communicator message)
(let-values ([(headers body) (get-message/complete communicator message)])
body))
;; split-header/body :
;; list (string) -> list (string) x list (string)
;; -- returns list of headers and list of body lines.
(define (split-header/body lines)
(let loop ([lines lines] [header null])
(if (null? lines)
(values (reverse header) null) (values (reverse header) null)
(let ([first (car lines)] (let ([first (car lines)]
[rest (cdr lines)]) [rest (cdr lines)])
(if (string=? first "") (if (string=? first "")
(values (reverse header) rest) (values (reverse header) rest)
(loop rest (cons first header))))))) (loop rest (cons first header)))))))
;; delete-message : ;; delete-message :
;; communicator x number -> () ;; communicator x number -> ()
(define (delete-message communicator message) (define (delete-message communicator message)
(confirm-transaction-mode (confirm-transaction-mode
communicator communicator
"cannot delete message unless in transaction state") "cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message) (send-to-server communicator "DELE ~a" message)
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
(cond (cond
[(-err? status) [(-err? status)
((signal-error make-cannot-delete-message ((signal-error make-cannot-delete-message
"no message numbered ~a available to be deleted" message) "no message numbered ~a available to be deleted" message)
communicator message)] communicator message)]
[(+ok? status) [(+ok? status)
'deleted]))) 'deleted])))
;; regexp for UIDL responses ;; regexp for UIDL responses
(define uidl-regexp #rx"([0-9]+) (.*)") (define uidl-regexp #rx"([0-9]+) (.*)")
;; get-unique-id/single : ;; get-unique-id/single :
;; communicator x number -> string ;; communicator x number -> string
(define (get-unique-id/single communicator message) (define (get-unique-id/single communicator message)
(confirm-transaction-mode (confirm-transaction-mode
communicator communicator
"cannot get unique message id unless in transaction state") "cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message) (send-to-server communicator "UIDL ~a" message)
(let-values ([(status result) (let-values ([(status result)
(get-status-response/match communicator uidl-regexp ".*")]) (get-status-response/match communicator uidl-regexp ".*")])
;; The server response is of the form ;; The server response is of the form
;; +OK 2 QhdPYR:00WBw1Ph7x7 ;; +OK 2 QhdPYR:00WBw1Ph7x7
(cond (cond
[(-err? status) [(-err? status)
((signal-error make-illegal-message-number ((signal-error make-illegal-message-number
"no message numbered ~a available for unique id" message) "no message numbered ~a available for unique id" message)
communicator message)] communicator message)]
[(+ok? status) [(+ok? status)
(cadr result)]))) (cadr result)])))
;; get-unique-id/all : ;; get-unique-id/all :
;; communicator -> list(number x string) ;; communicator -> list(number x string)
(define (get-unique-id/all communicator) (define (get-unique-id/all communicator)
(confirm-transaction-mode communicator (confirm-transaction-mode communicator
"cannot get unique message ids unless in transaction state") "cannot get unique message ids unless in transaction state")
(send-to-server communicator "UIDL") (send-to-server communicator "UIDL")
(let ([status (get-status-response/basic communicator)]) (let ([status (get-status-response/basic communicator)])
;; The server response is of the form ;; The server response is of the form
;; +OK ;; +OK
;; 1 whqtswO00WBw418f9t5JxYwZ ;; 1 whqtswO00WBw418f9t5JxYwZ
;; 2 QhdPYR:00WBw1Ph7x7 ;; 2 QhdPYR:00WBw1Ph7x7
;; . ;; .
(map (lambda (l) (map (lambda (l)
(let ([m (regexp-match uidl-regexp l)]) (let ([m (regexp-match uidl-regexp l)])
(cons (string->number (cadr m)) (caddr m)))) (cons (string->number (cadr m)) (caddr m))))
(get-multi-line-response communicator)))) (get-multi-line-response communicator))))
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define (close-communicator communicator) (define (close-communicator communicator)
(close-input-port (communicator-receiver communicator)) (close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))) (close-output-port (communicator-sender communicator)))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define (disconnect-from-server communicator) (define (disconnect-from-server communicator)
(send-to-server communicator "QUIT") (send-to-server communicator "QUIT")
(set-communicator-state! communicator 'disconnected) (set-communicator-state! communicator 'disconnected)
(let ([response (get-status-response/basic communicator)]) (let ([response (get-status-response/basic communicator)])
(close-communicator communicator) (close-communicator communicator)
(cond (cond
[(+ok? response) (void)] [(+ok? response) (void)]
[(-err? response) [(-err? response)
((signal-error make-disconnect-not-quiet ((signal-error make-disconnect-not-quiet
"got error status upon disconnect") "got error status upon disconnect")
communicator)]))) communicator)])))
;; send-to-server : ;; send-to-server :
;; communicator x format-string x list (values) -> () ;; communicator x format-string x list (values) -> ()
(define (send-to-server communicator message-template . rest) (define (send-to-server communicator message-template . rest)
(apply fprintf (communicator-sender communicator) (apply fprintf (communicator-sender communicator)
(string-append message-template "\r\n") (string-append message-template "\r\n")
rest) rest)
(flush-output (communicator-sender communicator))) (flush-output (communicator-sender communicator)))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define (get-one-line-from-server server->client-port) (define (get-one-line-from-server server->client-port)
(read-line server->client-port 'return-linefeed)) (read-line server->client-port 'return-linefeed))
;; get-server-status-response : ;; get-server-status-response :
;; communicator -> server-responses x string ;; communicator -> server-responses x string
;; -- provides the low-level functionality of checking for +OK ;; -- provides the low-level functionality of checking for +OK
;; and -ERR, returning an appropriate structure, and returning the ;; and -ERR, returning an appropriate structure, and returning the
;; rest of the status response as a string to be used for further ;; rest of the status response as a string to be used for further
;; parsing, if necessary. ;; parsing, if necessary.
(define (get-server-status-response communicator) (define (get-server-status-response communicator)
(let* ([receiver (communicator-receiver communicator)] (let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)] [status-line (get-one-line-from-server receiver)]
[r (regexp-match #rx"^\\+OK(.*)" status-line)]) [r (regexp-match #rx"^\\+OK(.*)" status-line)])
(if r (if r
(values (make-+ok) (cadr r)) (values (make-+ok) (cadr r))
(let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)])
(if r (if r
(values (make--err) (cadr r)) (values (make--err) (cadr r))
(signal-malformed-response-error communicator)))))) (signal-malformed-response-error communicator))))))
;; get-status-response/basic : ;; get-status-response/basic :
;; communicator -> server-responses ;; communicator -> server-responses
;; -- when the only thing to determine is whether the response ;; -- when the only thing to determine is whether the response
;; was +OK or -ERR. ;; was +OK or -ERR.
(define (get-status-response/basic communicator) (define (get-status-response/basic communicator)
(let-values ([(response rest) (let-values ([(response rest)
(get-server-status-response communicator)]) (get-server-status-response communicator)])
response)) response))
;; get-status-response/match : ;; get-status-response/match :
;; communicator x regexp x regexp -> (status x list (string)) ;; communicator x regexp x regexp -> (status x list (string))
;; -- when further parsing of the status response is necessary. ;; -- when further parsing of the status response is necessary.
;; Strips off the car of response from regexp-match. ;; Strips off the car of response from regexp-match.
(define (get-status-response/match communicator +regexp -regexp) (define (get-status-response/match communicator +regexp -regexp)
(let-values ([(response rest) (let-values ([(response rest)
(get-server-status-response communicator)]) (get-server-status-response communicator)])
(if (and +regexp (+ok? response)) (if (and +regexp (+ok? response))
(let ([r (regexp-match +regexp rest)]) (let ([r (regexp-match +regexp rest)])
(if r (values response (cdr r)) (if r (values response (cdr r))
(signal-malformed-response-error communicator))) (signal-malformed-response-error communicator)))
(if (and -regexp (-err? response)) (if (and -regexp (-err? response))
(let ([r (regexp-match -regexp rest)]) (let ([r (regexp-match -regexp rest)])
(if r (values response (cdr r)) (if r (values response (cdr r))
(signal-malformed-response-error communicator))) (signal-malformed-response-error communicator)))
(signal-malformed-response-error communicator))))) (signal-malformed-response-error communicator)))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(define (get-multi-line-response communicator) (define (get-multi-line-response communicator)
(let ([receiver (communicator-receiver communicator)]) (let ([receiver (communicator-receiver communicator)])
(let loop () (let loop ()
(let ([l (get-one-line-from-server receiver)]) (let ([l (get-one-line-from-server receiver)])
(cond (cond
[(eof-object? l) [(eof-object? l)
(signal-malformed-response-error communicator)] (signal-malformed-response-error communicator)]
[(string=? l ".") [(string=? l ".")
'()] '()]
[(and (> (string-length l) 1) [(and (> (string-length l) 1)
(char=? (string-ref l 0) #\.)) (char=? (string-ref l 0) #\.))
(cons (substring l 1 (string-length l)) (loop))] (cons (substring l 1 (string-length l)) (loop))]
[else [else
(cons l (loop))]))))) (cons l (loop))])))))
;; make-desired-header : ;; make-desired-header :
;; string -> desired ;; string -> desired
(define (make-desired-header raw-header) (define (make-desired-header raw-header)
(regexp (regexp
(string-append (string-append
"^" "^"
(list->string (list->string
(apply append (apply append
(map (lambda (c) (map (lambda (c)
(cond (cond
[(char-lower-case? c) [(char-lower-case? c)
(list #\[ (char-upcase c) c #\])] (list #\[ (char-upcase c) c #\])]
[(char-upper-case? c) [(char-upper-case? c)
(list #\[ c (char-downcase c) #\])] (list #\[ c (char-downcase c) #\])]
[else [else
(list c)])) (list c)]))
(string->list raw-header)))) (string->list raw-header))))
":"))) ":")))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define (extract-desired-headers headers desireds) (define (extract-desired-headers headers desireds)
(let loop ([headers headers]) (let loop ([headers headers])
(if (null? headers) null (if (null? headers) null
(let ([first (car headers)] (let ([first (car headers)]
[rest (cdr headers)]) [rest (cdr headers)])
(if (ormap (lambda (matcher) (if (ormap (lambda (matcher)
(regexp-match matcher first)) (regexp-match matcher first))
desireds) desireds)
(cons first (loop rest)) (cons first (loop rest))
(loop rest)))))) (loop rest))))))

6
collects/net/qp-sig.ss
View File

@ -1,9 +1,9 @@
#lang scheme/signature #lang scheme/signature
;; -- exceptions raised -- ;; -- exceptions raised --
(struct qp-error () -setters -constructor) (struct qp-error () #:omit-constructor)
(struct qp-wrong-input () -setters -constructor) (struct qp-wrong-input () #:omit-constructor)
(struct qp-wrong-line-size (size) -setters -constructor) (struct qp-wrong-line-size (size) #:omit-constructor)
;; -- qp methods -- ;; -- qp methods --
qp-encode qp-encode

265
collects/net/smtp-unit.ss
View File

@ -1,26 +1,27 @@
#lang scheme/unit #lang scheme/unit
(require (lib "list.ss") (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(import) (require scheme/tcp "base64.ss" "smtp-sig.ss")
(export smtp^)
(define smtp-sending-server (make-parameter "localhost")) (import)
(export smtp^)
(define debug-via-stdio? #f) (define smtp-sending-server (make-parameter "localhost"))
(define (log . args) (define debug-via-stdio? #f)
;; (apply printf args)
(void))
(define (starts-with? l n) (define (log . args)
(and (>= (string-length l) (string-length n)) ;; (apply printf args)
(string=? n (substring l 0 (string-length n))))) (void))
(define (check-reply/accum r v w a) (define (starts-with? l n)
(flush-output w) (and (>= (string-length l) (string-length n))
(let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) (string=? n (substring l 0 (string-length n)))))
(log "server: ~a\n" l)
(if (eof-object? l) (define (check-reply/accum r v w a)
(flush-output w)
(let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))])
(log "server: ~a\n" l)
(if (eof-object? l)
(error 'check-reply "got EOF") (error 'check-reply "got EOF")
(let ([n (number->string v)]) (let ([n (number->string v)])
(unless (starts-with? l n) (unless (starts-with? l n)
@ -32,135 +33,133 @@
;; We're finished, so add the last and reverse the result ;; We're finished, so add the last and reverse the result
(when a (when a
(reverse (cons (substring l 4) a))))))))) (reverse (cons (substring l 4) a)))))))))
(define (check-reply/commands r v w . commands)
;; drop the first response, which is just the flavor text -- we expect the rest to
;; be a list of supported ESMTP commands.
(let ([cmdlist (rest (check-reply/accum r v w '()))])
(for-each (lambda (c1)
(unless (findf (lambda (c2) (string=? c1 c2)) cmdlist)
(error "expected advertisement of ESMTP command ~a" c1)))
commands)))
(define (check-reply r v w)
(check-reply/accum r v w #f))
(define (protect-line l) (define (check-reply/commands r v w . commands)
;; If begins with a dot, add one more ;; drop the first response, which is just the flavor text -- we expect the rest to
(if (or (equal? l #"") ;; be a list of supported ESMTP commands.
(equal? l "") (let ([cmdlist (cdr (check-reply/accum r v w '()))])
(and (string? l) (for-each (lambda (c1)
(not (char=? #\. (string-ref l 0)))) (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist)
(and (bytes? l) (error "expected advertisement of ESMTP command ~a" c1)))
(not (= (char->integer #\.) (bytes-ref l 0))))) commands)))
(define (check-reply r v w)
(check-reply/accum r v w #f))
(define (protect-line l)
;; If begins with a dot, add one more
(if (or (equal? l #"")
(equal? l "")
(and (string? l)
(not (char=? #\. (string-ref l 0))))
(and (bytes? l)
(not (= (char->integer #\.) (bytes-ref l 0)))))
l l
(if (bytes? l) (if (bytes? l)
(bytes-append #"." l) (bytes-append #"." l)
(string-append "." l)))) (string-append "." l))))
(define smtp-sending-end-of-message (define smtp-sending-end-of-message
(make-parameter void (make-parameter void
(lambda (f) (lambda (f)
(unless (and (procedure? f) (unless (and (procedure? f)
(procedure-arity-includes? f 0)) (procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" f)) (raise-type-error 'smtp-sending-end-of-message "thunk" f))
f))) f)))
(define (smtp-send-message* r w sender recipients header message-lines (define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode) auth-user auth-passwd tls-encode)
(with-handlers ([void (lambda (x) (with-handlers ([void (lambda (x)
(close-input-port r) (close-input-port r)
(close-output-port w) (close-output-port w)
(raise x))]) (raise x))])
(check-reply r 220 w)
(log "hello\n")
(fprintf w "EHLO ~a\r\n" (smtp-sending-server))
(when tls-encode
(check-reply/commands r 250 w "STARTTLS")
(log "starttls\n")
(fprintf w "STARTTLS\r\n")
(check-reply r 220 w) (check-reply r 220 w)
(log "hello\n") (let-values ([(ssl-r ssl-w)
(fprintf w "EHLO ~a\r\n" (smtp-sending-server)) (tls-encode r w
(when tls-encode #:mode 'connect
(check-reply/commands r 250 w "STARTTLS") #:encrypt 'tls
(log "starttls\n") #:close-original? #t)])
(fprintf w "STARTTLS\r\n") (set! r ssl-r)
(check-reply r 220 w) (set! w ssl-w))
(let-values ([(ssl-r ssl-w) ;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO.
(tls-encode r w (log "tls hello\n")
#:mode 'connect (fprintf w "EHLO ~a\r\n" (smtp-sending-server)))
#:encrypt 'tls (check-reply r 250 w)
#:close-original? #t)])
(set! r ssl-r)
(set! w ssl-w))
;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO.
(log "tls hello\n")
(fprintf w "EHLO ~a\r\n" (smtp-sending-server)))
(check-reply r 250 w)
(when auth-user (when auth-user
(log "auth\n") (log "auth\n")
(fprintf w "AUTH PLAIN ~a" (fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF ;; Encoding adds CRLF
(base64-encode (base64-encode
(string->bytes/latin-1 (string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd)))) (format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w)) (check-reply r 235 w))
(log "from\n") (log "from\n")
(fprintf w "MAIL FROM:<~a>\r\n" sender) (fprintf w "MAIL FROM:<~a>\r\n" sender)
(check-reply r 250 w) (check-reply r 250 w)
(log "to\n") (log "to\n")
(for-each (for-each
(lambda (dest) (lambda (dest)
(fprintf w "RCPT TO:<~a>\r\n" dest) (fprintf w "RCPT TO:<~a>\r\n" dest)
(check-reply r 250 w)) (check-reply r 250 w))
recipients) recipients)
(log "header\n") (log "header\n")
(fprintf w "DATA\r\n") (fprintf w "DATA\r\n")
(check-reply r 354 w) (check-reply r 354 w)
(fprintf w "~a" header) (fprintf w "~a" header)
(for-each (for-each
(lambda (l) (lambda (l)
(log "body: ~a\n" l) (log "body: ~a\n" l)
(fprintf w "~a\r\n" (protect-line l))) (fprintf w "~a\r\n" (protect-line l)))
message-lines) message-lines)
;; After we send the ".", then only break in an emergency ;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message)) ((smtp-sending-end-of-message))
(log "dot\n") (log "dot\n")
(fprintf w ".\r\n") (fprintf w ".\r\n")
(flush-output w) (flush-output w)
(check-reply r 250 w) (check-reply r 250 w)
;; Once a 250 has been received in response to the . at the end of ;; Once a 250 has been received in response to the . at the end of
;; the DATA block, the email has been sent successfully and out of our ;; the DATA block, the email has been sent successfully and out of our
;; hands. This function should thus indicate success at this point ;; hands. This function should thus indicate success at this point
;; no matter what else happens. ;; no matter what else happens.
;; ;;
;; Some servers (like smtp.gmail.com) will just close the connection ;; Some servers (like smtp.gmail.com) will just close the connection
;; on a QUIT, so instead of causing any QUIT errors to look like the ;; on a QUIT, so instead of causing any QUIT errors to look like the
;; email failed, we'll just log them. ;; email failed, we'll just log them.
(with-handlers ([void (lambda (x) (with-handlers ([void (lambda (x)
(log "error after send: ~a\n" (exn-message x)))]) (log "error after send: ~a\n" (exn-message x)))])
(log "quit\n") (log "quit\n")
(fprintf w "QUIT\r\n") (fprintf w "QUIT\r\n")
(check-reply r 221 w)) (check-reply r 221 w))
(close-output-port w) (close-output-port w)
(close-input-port r))) (close-input-port r)))
(define smtp-send-message (define smtp-send-message
(lambda/kw (server sender recipients header message-lines (lambda (server sender recipients header message-lines
#:key #:port-no [port-no 25]
[port-no 25] #:auth-user [auth-user #f]
[auth-user #f] #:auth-passwd [auth-passwd #f]
[auth-passwd #f] #:tcp-connect [tcp-connect tcp-connect]
[tcp-connect tcp-connect] #:tls-encode [tls-encode #f]
[tls-encode #f] [opt-port-no port-no])
#:body (when (null? recipients)
(#:optional [opt-port-no port-no])) (error 'send-smtp-message "no receivers"))
(when (null? recipients) (let-values ([(r w) (if debug-via-stdio?
(error 'send-smtp-message "no receivers")) (values (current-input-port) (current-output-port))
(let-values ([(r w) (if debug-via-stdio? (tcp-connect server opt-port-no))])
(values (current-input-port) (current-output-port)) (smtp-send-message* r w sender recipients header message-lines
(tcp-connect server opt-port-no))]) auth-user auth-passwd tls-encode))))
(smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode))))

8
collects/scheme/list.ss
View File

@ -46,14 +46,6 @@
(raise-type-error 'rest "non-empty list" x)) (raise-type-error 'rest "non-empty list" x))
(cdr x)) (cdr x))
(define (last-pair l)
(if (pair? l)
(let loop ([l l] [x (cdr l)])
(if (pair? x)
(loop x (cdr x))
l))
(raise-type-error 'last-pair "pair" l)))
(define cons? (lambda (x) (pair? x))) (define cons? (lambda (x) (pair? x)))
(define empty? (lambda (x) (null? x))) (define empty? (lambda (x) (null? x)))
(define empty '())) (define empty '()))

18
collects/scheme/private/reqprov.ss
View File

@ -164,7 +164,7 @@
[else (error "huh?" mode)]))] [else (error "huh?" mode)]))]
[simple-path? (lambda (p) [simple-path? (lambda (p)
(syntax-case p (lib) (syntax-case p (lib)
[(lib s) [(lib . _)
(check-lib-form p)] (check-lib-form p)]
[_ [_
(or (identifier? p) (or (identifier? p)
@ -211,14 +211,14 @@
(and (simple-path? #'path) (and (simple-path? #'path)
;; check that it's well-formed... ;; check that it's well-formed...
(call-with-values (lambda () (expand-import in)) (call-with-values (lambda () (expand-import in))
(lambda (a b) #t)) (lambda (a b) #t)))
(list (mode-wrap (list (mode-wrap
base-mode base-mode
(datum->syntax (datum->syntax
#'path #'path
(syntax-e (syntax-e
(quasisyntax/loc in (quasisyntax/loc in
(all-except path id ...)))))))] (all-except path id ...))))))]
;; General case: ;; General case:
[_ (let-values ([(imports sources) (expand-import in)]) [_ (let-values ([(imports sources) (expand-import in)])
;; TODO: collapse back to simple cases when possible ;; TODO: collapse back to simple cases when possible

2
collects/scheme/signature/info.ss Normal file
View File

@ -0,0 +1,2 @@
(module info setup/infotab
(define name "Scheme signature language"))

31
collects/scheme/signature/lang.ss Normal file
View File

@ -0,0 +1,31 @@
#lang scheme/base
(require scheme/unit
(for-syntax scheme/base
mzlib/private/unit-compiletime
mzlib/private/unit-syntax))
(provide (rename-out [module-begin #%module-begin])
(except-out (all-from-out scheme/base) #%module-begin)
(all-from-out scheme/unit)
(for-syntax (all-from-out scheme/base)))
(define-for-syntax (make-name s)
(string->symbol
(string-append (regexp-replace "-sig$" (symbol->string s) "")
"^")))
(define-syntax (module-begin stx)
(parameterize ((error-syntax stx))
(with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name))))
(syntax-case stx ()
((_ . x)
(with-syntax ((((reqs ...) . (body ...))
(split-requires (checked-syntax->list #'x))))
(datum->syntax
stx
(syntax-e #'(#%module-begin
reqs ...
(provide name)
(define-signature name (body ...))))
stx)))))))

2
collects/scheme/signature/lang/reader.ss
View File

@ -1,3 +1,3 @@
(module reader syntax/module-reader (module reader syntax/module-reader
mzlib/a-signature) scheme/signature/lang)

104
collects/scheme/unit.ss
View File

@ -1,4 +1,104 @@
(module unit scheme/base (module unit scheme/base
(require mzlib/unit) (require mzlib/unit
(provide (all-from-out mzlib/unit))) (for-syntax scheme/base
syntax/struct))
(provide (except-out (all-from-out mzlib/unit)
struct)
(rename-out [struct* struct]))
;; Replacement `struct' signature form:
(define-signature-form (struct* stx)
(syntax-case stx ()
((_ name (field ...) opt ...)
(let ([omit-selectors #f]
[omit-setters #f]
[omit-constructor #f]
[omit-type #f])
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))])
(cons
#`(define-syntaxes (name)
#,(build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?))
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?))])
(if no-ctr?
(cons (car names) (cddr names))
names))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx)))))

2
collects/scheme/unit/info.ss Normal file
View File

@ -0,0 +1,2 @@
(module info setup/infotab
(define name "Scheme unit language"))

84
collects/scheme/unit/lang.ss Normal file
View File

@ -0,0 +1,84 @@
#lang scheme/base
(require scheme/unit
(for-syntax scheme/base
syntax/kerncase))
(provide (rename-out [module-begin #%module-begin])
(except-out (all-from-out scheme/base) #%module-begin)
(all-from-out scheme/unit))
(define-for-syntax (make-name s)
(string->symbol
(string-append (regexp-replace "-unit$" (symbol->string s) "")
"@")))
;; Look for `import' and `export', and start processing the body:
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ elem ...)
(with-syntax ([((elem ...) . (literal ...))
(let loop ([elems (syntax->list #'(elem ...))]
[accum null])
(syntax-case elems (import export)
[((import . _1) (export . _2) . _3)
(cons (reverse accum) elems)]
[((import . _1) . _2)
(raise-syntax-error
#f
"expected an `export' clause after `import'"
stx)]
[()
(raise-syntax-error
#f
"missing an `import' clause"
stx)]
[_else
(loop (cdr elems) (cons (car elems) accum))]))])
(with-syntax ((name (datum->syntax
stx
(make-name (syntax-property stx 'enclosing-module-name))
stx))
(orig-stx stx))
(datum->syntax
stx
(syntax-e
#'(#%module-begin (a-unit-module orig-stx finish-a-unit (import export)
"original import form"
name (elem ...) (literal ...))))
stx
stx)))]))
;; Process one `require' form (and make sure it's a require form):
(define-syntax (a-unit-module stx)
(syntax-case stx ()
[(_ orig-stx finish stops separator name (elem1 elem ...) (literal ...))
(let ([e (local-expand #'elem1
'module
(append
(syntax->list #'stops)
(list #'#%require)
(kernel-form-identifier-list)))])
(syntax-case e (begin #%require)
[(#%require r ...)
#'(begin
(#%require r ...)
(a-unit-module orig-stx finish stops separator name (elem ...) (literal ...)))]
[(begin b ...)
#'(a-unit-module orig-stx finish stops separator name (b ... elem ...) (literal ...))]
[_
(raise-syntax-error
#f
(format "non-require form before ~a" (syntax-e #'separator))
#'orig-stx
e)]))]
[(_ orig-stx finish stops separator name () (literal ...))
#'(finish orig-stx name literal ...)]))
;; All requires are done, so finish handling the unit:
(define-syntax (finish-a-unit stx)
(syntax-case stx (import export)
[(_ orig-stx name imports exports elem ...)
#'(begin
(provide name)
(define-unit name imports exports elem ...))]))

3
collects/scheme/unit/lang/reader.ss
View File

@ -1,3 +1,2 @@
(module reader syntax/module-reader (module reader syntax/module-reader
mzlib/a-unit) scheme/unit/lang)

1
collects/scribblings/reference/reference.scrbl
View File

@ -24,6 +24,7 @@ language.
@include-section["class.scrbl"] @include-section["class.scrbl"]
@include-section["units.scrbl"] @include-section["units.scrbl"]
@include-section["contracts.scrbl"] @include-section["contracts.scrbl"]
@include-section["match.scrbl"]
@include-section["control.scrbl"] @include-section["control.scrbl"]
@include-section["concurrency.scrbl"] @include-section["concurrency.scrbl"]
@include-section["macros.scrbl"] @include-section["macros.scrbl"]

28
collects/scribblings/reference/units.scrbl
View File

@ -593,28 +593,20 @@ declarations; @scheme[define-signature] has no splicing @scheme[begin]
form.)} form.)}
@defform/subs[ @defform/subs[
#:literals (-type -selectors -setters -constructor) (struct id (field ...) option ...)
(struct id (field-id ...) omit-decl ...)
([omit-decl ([field id
-type [id #:mutable]]
-selectors [option #:mutable
-setters #:omit-constructor
-constructor])]{ #:omit-define-syntaxes
#:omit-define-values])]{
For use with @scheme[define-signature]. The expansion of a For use with @scheme[define-signature]. The expansion of a
@scheme[struct] signature form includes all of the identifiers that @scheme[struct] signature form includes all of the identifiers that
would be bound by @scheme[(define-struct id (field-id ...))], except would be bound by @scheme[(define-struct id (field ...) option ...)],
that a @scheme[omit-decl] can cause some of the bindings to be where the extra option @scheme[#:omit-constructor] omits the
omitted. Specifically @scheme[-type] causes @schemeidfont{make-}@scheme[id] identifier.}
@schemeidfont{struct:}@scheme[id] to be omitted, @scheme[-selectors]
causes all @scheme[id]@schemeidfont{-}@scheme[_field-id]s to be
omitted, @scheme[-setters] causes all
@schemeidfont{set-}@scheme[id]@schemeidfont{-}@scheme[field-id]@schemeidfont{!}s
to be omitted, and @scheme[-construct] causes
@schemeidfont{make-}@scheme[id] to be omitted. These omissions are
reflected in the static information bound to @scheme[id] (which is
used by, for example, pattern matchers).}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------

2
collects/scribblings/slideshow/guide.scrbl
View File

@ -181,7 +181,7 @@ slideshow
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Display Size and Fonts} @section[#:tag "display-size"]{Display Size and Fonts}
Slideshow is configured for generating slides in @math{1024} by Slideshow is configured for generating slides in @math{1024} by
@math{768} pixel format. When the current display has a different @math{768} pixel format. When the current display has a different

14
collects/sirmail/sendr.ss
View File

@ -2,15 +2,14 @@
;; This module implements the mail-composing window. The `new-mailer' ;; This module implements the mail-composing window. The `new-mailer'
;; function creates a compose-window instance. ;; function creates a compose-window instance.
(module sendr mzscheme (module sendr scheme/base
(require (lib "unit.ss") (require scheme/tcp
(lib "class.ss") scheme/unit
scheme/class
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "framework.ss" "framework")) (lib "framework.ss" "framework"))
(require (lib "list.ss") (require scheme/file
(lib "file.ss")
(lib "string.ss")
(lib "process.ss") (lib "process.ss")
(lib "mzssl.ss" "openssl")) (lib "mzssl.ss" "openssl"))
@ -126,7 +125,8 @@
(define-struct enclosure (name ; identifies enclosure in the GUI (define-struct enclosure (name ; identifies enclosure in the GUI
subheader ; header for enclosure subheader ; header for enclosure
data-thunk)) ; gets enclosure data as bytes (already encoded) data-thunk) ; gets enclosure data as bytes (already encoded)
#:mutable)
;; Create a message with enclosures. ;; Create a message with enclosures.
;; `header' is a message header created with the head.ss library ;; `header' is a message header created with the head.ss library

7
collects/syntax/path-spec.ss
View File

@ -1,4 +1,5 @@
(module path-spec mzscheme (module path-spec scheme/base
(require (for-template scheme/base))
(require "stx.ss") (require "stx.ss")
(provide resolve-path-spec) (provide resolve-path-spec)
@ -19,7 +20,7 @@
(string->path s))] (string->path s))]
[(-build-path elem ...) [(-build-path elem ...)
(module-or-top-identifier=? #'-build-path build-path-stx) (module-or-top-identifier=? #'-build-path build-path-stx)
(let ([l (syntax-object->datum (syntax (elem ...)))]) (let ([l (syntax->datum (syntax (elem ...)))])
(when (null? l) (when (null? l)
(raise-syntax-error (raise-syntax-error
#f #f
@ -28,7 +29,7 @@
fn)) fn))
(apply build-path l))] (apply build-path l))]
[(lib filename ...) [(lib filename ...)
(let ([l (syntax-object->datum (syntax (filename ...)))]) (let ([l (syntax->datum (syntax (filename ...)))])
(unless (or (andmap string? l) (unless (or (andmap string? l)
(pair? l)) (pair? l))
(raise-syntax-error (raise-syntax-error

20
collects/syntax/struct.ss
View File

@ -1,14 +1,16 @@
(module struct mzscheme (module struct scheme/base
(require (lib "etc.ss") (require (for-syntax scheme/base)
(lib "etc.ss")
(lib "contract.ss") (lib "contract.ss")
"stx.ss" "stx.ss"
(lib "struct-info.ss" "scheme")) (lib "struct-info.ss" "scheme"))
(require-for-template mzscheme) (require (for-template mzscheme))
(provide parse-define-struct (provide parse-define-struct
build-struct-generation build-struct-generation
build-struct-generation*
build-struct-expand-info build-struct-expand-info
struct-declaration-info? struct-declaration-info?
extract-struct-info extract-struct-info
@ -96,7 +98,7 @@
[fields (map symbol->string (map syntax-e fields))] [fields (map symbol->string (map syntax-e fields))]
[+ string-append]) [+ string-append])
(map (lambda (s) (map (lambda (s)
(datum->syntax-object name-stx (string->symbol s) srcloc-stx)) (datum->syntax name-stx (string->symbol s) srcloc-stx))
(append (append
(list (list
(+ "struct:" name) (+ "struct:" name)
@ -155,8 +157,14 @@
,@acc/mut-makers))))) ,@acc/mut-makers)))))
(define build-struct-expand-info (define build-struct-expand-info
(lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters) (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters
(let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)]) #:omit-constructor? [no-ctr? #f])
(let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)]
[names (if no-ctr?
(list* (car names)
#f
(cddr names))
names)])
(build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters)))) (build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters))))
(define build-struct-expand-info* (define build-struct-expand-info*

62
collects/syntax/zodiac-sig.ss
View File

@ -30,7 +30,7 @@ eof?
;; zodiac struct: ;; zodiac struct:
;; zodiac (stx) ; used to be (origin start finish) ;; zodiac (stx) ; used to be (origin start finish)
(struct zodiac (stx)) (struct zodiac (stx) #:mutable)
zodiac-origin ; = identity zodiac-origin ; = identity
zodiac-start ; = identity zodiac-start ; = identity
zodiac-finish ; = zodiac-start zodiac-finish ; = zodiac-start
@ -40,70 +40,70 @@ zodiac-finish ; = zodiac-start
;; zread ; used to have (object) ;; zread ; used to have (object)
;; The sub-tree has been cut off; inspect ;; The sub-tree has been cut off; inspect
;; the stx object, instead. ;; the stx object, instead.
(struct zread ()) (struct zread () #:mutable)
;; elaborator structs: ;; elaborator structs:
(struct parsed (back)) (struct parsed (back) #:mutable)
(struct varref (var)) (struct varref (var) #:mutable)
(struct top-level-varref (module slot exptime? expdef? position)) ; added module, exptime?, position (struct top-level-varref (module slot exptime? expdef? position) #:mutable) ; added module, exptime?, position
create-top-level-varref create-top-level-varref
(struct bound-varref (binding)) create-bound-varref (struct bound-varref (binding) #:mutable) create-bound-varref
(struct binding (var orig-name)) create-binding (struct binding (var orig-name) #:mutable) create-binding
make-lexical-varref make-lexical-varref
lexical-varref? create-lexical-varref ; alias for bound-varref lexical-varref? create-lexical-varref ; alias for bound-varref
make-lexical-binding make-lexical-binding
lexical-binding? create-lexical-binding ; alias for binding lexical-binding? create-lexical-binding ; alias for binding
(struct app (fun args)) create-app (struct app (fun args) #:mutable) create-app
(struct if-form (test then else)) create-if-form (struct if-form (test then else) #:mutable) create-if-form
(struct quote-form (expr)) create-quote-form (struct quote-form (expr) #:mutable) create-quote-form
(struct begin-form (bodies)) create-begin-form (struct begin-form (bodies) #:mutable) create-begin-form
(struct begin0-form (bodies)) create-begin0-form (struct begin0-form (bodies) #:mutable) create-begin0-form
(struct let-values-form (vars vals body)) create-let-values-form (struct let-values-form (vars vals body) #:mutable) create-let-values-form
(struct letrec-values-form (vars vals body)) create-letrec-values-form (struct letrec-values-form (vars vals body) #:mutable) create-letrec-values-form
(struct define-values-form (vars val)) create-define-values-form (struct define-values-form (vars val) #:mutable) create-define-values-form
(struct set!-form (var val)) create-set!-form (struct set!-form (var val) #:mutable) create-set!-form
(struct case-lambda-form (args bodies)) create-case-lambda-form (struct case-lambda-form (args bodies) #:mutable) create-case-lambda-form
(struct with-continuation-mark-form (key val body)) create-with-continuation-mark-form (struct with-continuation-mark-form (key val body) #:mutable) create-with-continuation-mark-form
;; Thess are new: ;; Thess are new:
(struct quote-syntax-form (expr)) create-quote-syntax-form (struct quote-syntax-form (expr) #:mutable) create-quote-syntax-form
(struct define-syntaxes-form (names expr)) create-define-syntaxes-form (struct define-syntaxes-form (names expr) #:mutable) create-define-syntaxes-form
(struct define-for-syntax-form (names expr)) create-define-for-syntax-form (struct define-for-syntax-form (names expr) #:mutable) create-define-for-syntax-form
(struct module-form (name requires ; lstof stx for module paths (struct module-form (name requires ; lstof stx for module paths
for-syntax-requires ; lstof stx for module paths for-syntax-requires ; lstof stx for module paths
for-template-requires ; lstof stx for module paths for-template-requires ; lstof stx for module paths
body ; begin form body ; begin form
syntax-body ; begin form syntax-body ; begin form
provides ; lstof (sym | (def-sym . prvd-sym) | (mod-path def-sym . prvd-sym)) provides ; lstof (sym | (def-sym . prvd-sym) #:mutable | (mod-path def-sym . prvd-sym))
syntax-provides ; ditto syntax-provides ; ditto
indirect-provides ; lstof sym indirect-provides ; lstof sym
kernel-reprovide-hint ; #f | #t | exclude-sym kernel-reprovide-hint ; #f | #t | exclude-sym
self-path-index)) ; module path index self-path-index)) ; module path index
create-module-form create-module-form
(struct require/provide-form ()) create-require/provide-form (struct require/provide-form () #:mutable) create-require/provide-form
;; These forms are highly mzc-specific. They are recongized ;; These forms are highly mzc-specific. They are recongized
;; as applications of the corresponding quoted symbols to the ;; as applications of the corresponding quoted symbols to the
;; right kinds of arguments. ;; right kinds of arguments.
(struct global-prepare (vec pos)) create-global-prepare (struct global-prepare (vec pos) #:mutable) create-global-prepare
(struct global-lookup (vec pos)) create-global-lookup (struct global-lookup (vec pos) #:mutable) create-global-lookup
(struct global-assign (vec pos expr)) create-global-assign (struct global-assign (vec pos expr) #:mutable) create-global-assign
(struct safe-vector-ref (vec pos)) create-safe-vector-ref (struct safe-vector-ref (vec pos) #:mutable) create-safe-vector-ref
global-prepare-id global-prepare-id
global-lookup-id global-lookup-id
global-assign-id global-assign-id
safe-vector-ref-id safe-vector-ref-id
;; args: ;; args:
(struct arglist (vars)) (struct arglist (vars) #:mutable)
(struct sym-arglist ()) (struct sym-arglist () #:mutable)
(struct list-arglist ()) (struct list-arglist () #:mutable)
(struct ilist-arglist ()) (struct ilist-arglist () #:mutable)
make-empty-back-box make-empty-back-box
register-client register-client

1427
collects/syntax/zodiac-unit.ss
View File

File diff suppressed because it is too large Load Diff

4
collects/texpict/private/common-sig.ss
View File

@ -1,5 +1,5 @@
(module common-sig mzscheme (module common-sig scheme/base
(require (lib "unit.ss")) (require scheme/unit)
(provide texpict-common^) (provide texpict-common^)
(define-signature texpict-common^ (define-signature texpict-common^

3
collects/texpict/private/common-unit.ss
View File

@ -17,7 +17,8 @@
ascent ; portion of height above top baseline ascent ; portion of height above top baseline
descent ; portion of height below bottom baseline descent ; portion of height below bottom baseline
children ; list of child records children ; list of child records
panbox)) ; panorama box panbox) ; panorama box
#:mutable)
(define-struct child (pict dx dy sx sy)) (define-struct child (pict dx dy sx sy))
(define-struct bbox (x1 y1 x2 y2 ay dy)) (define-struct bbox (x1 y1 x2 y2 ay dy))