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

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

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

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

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

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

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

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

@ -11,7 +11,7 @@
(lib "etc.ss")
(lib "struct.ss")
(lib "class.ss")
(lib "file.ss")
scheme/file
(lib "list.ss")
(lib "embed.ss" "compiler")
(lib "launcher.ss" "launcher")
@ -1131,7 +1131,7 @@
(let ([s (reader (object-name port) port)])
(if (syntax? 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)))
s))))

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

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

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

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

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

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

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

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

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

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

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

@ -8,7 +8,7 @@
"bday.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
(lib "file.ss")
scheme/file
(lib "etc.ss"))
(import mred^
@ -310,7 +310,7 @@
(define-struct status-line (id count))
;; 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
(mixin (basic<%>) (status-line<%>)

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

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

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

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

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

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

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

@ -511,7 +511,7 @@
(λ (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(if (= sel-start sel-end)
(when (= sel-start sel-end)
(send* edit
(insert #\newline)
(set-position sel-start)))))]
@ -729,7 +729,7 @@
(get-text-from-user
(string-constant goto-position)
(string-constant goto-position))))])
(if (string? num-str)
(when (string? num-str)
(let ([pos (string->number num-str)])
(when 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))
;; type percentage : (make-percentage number)
(define-struct percentage (%))
(define-struct percentage (%) #:mutable)
(define dragable<%>
(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")
(lib "class.ss")
(lib "file.ss")
scheme/file
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
@ -117,7 +117,7 @@ the state transitions / contracts are:
;; (make-ppanel-interior string (union #f panel) (listof panel-tree)))
(define-struct ppanel (name panel))
(define-struct (ppanel-leaf ppanel) (maker))
(define-struct (ppanel-interior ppanel) (children))
(define-struct (ppanel-interior ppanel) (children) #:mutable)
;; ppanels : (listof ppanel-tree)
(define ppanels null)

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

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

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

@ -1,7 +1,7 @@
(module sig mzscheme
(require (lib "unit.ss"))
(module sig scheme/base
(require scheme/unit)
(provide (prefix-all-defined-except framework: framework^)
(provide (prefix-out framework: (except-out (all-defined-out) framework^))
framework^)
(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 "dirs.ss" "setup")
(lib "string.ss")
(prefix srfi1: (lib "1.ss" "srfi")))
(prefix-in srfi1: (lib "1.ss" "srfi")))
(import mred^
[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-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 msec-timeout 500)
@ -1989,7 +1989,7 @@ WARNING: printf is rebound in the body of the unit to always
;;
;; queues
;;
(define-struct queue (front back count))
(define-struct queue (front back count) #:mutable)
(define (empty-queue) (make-queue '() '() 0))
(define (enqueue e q) (make-queue
(cons e (queue-front q))

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

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

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

@ -1,466 +1,466 @@
#lang scheme/unit
(require (lib "mred-sig.ss" "mred")
(lib "class.ss")
(lib "class100.ss")
(lib "list.ss")
(lib "etc.ss")
"turtle-sig.ss")
(import [prefix mred: mred^])
(export turtle^)
(init-depend mred^)
(require (lib "mred-sig.ss" "mred")
(lib "class.ss")
(lib "class100.ss")
(lib "list.ss")
(lib "etc.ss")
"turtle-sig.ss")
(import [prefix mred: mred^])
(export turtle^)
(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)
(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)
(private-field
[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))))])
(private-field
[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)
(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))]
(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)
(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
(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
(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)
(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)
(flatten
(lambda (turtle)
(let* ([x (turtle-x turtle)]
[y (turtle-y turtle)]
[angle (turtle-angle turtle)]
[d (if (zero? n) 0 (sub1 (abs n)))]
[res (if (< n 0) (- d) d)]
[c (cos angle)]
[s (sin angle)]
[drawx (+ x (* res c))]
[drawy (+ y (* res s))]
[newx (+ x (* n c))]
[newy (+ y (* n s))])
(unless (zero? n)
(doit x y drawx drawy))
(make-turtle newx newy angle))))
(flip-icons))))
(define draw (draw/erase (lambda (a b c d) (line a b c d))))
(define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d))))
(define move
(lambda (n)
(flip-icons)
(set! turtles-cache (combine (make-c-forward n) turtles-cache))
(flip-icons)))
(define turn/radians
(lambda (d)
(flip-icons)
(set! turtles-cache (combine (make-c-turn d) turtles-cache))
(flip-icons)))
(define turn
(lambda (c)
(turn/radians (* (/ c 360) 2 pi))))
(define move-offset
(lambda (x y)
(flip-icons)
(set! turtles-cache (combine (make-c-offset x y) turtles-cache))
(flip-icons)))
(define erase/draw-offset
(lambda (doit)
(lambda (x y)
(flip-icons)
(flatten
(lambda (turtle)
(let* ([tx (turtle-x turtle)]
[ty (turtle-y turtle)]
[newx (+ tx x)]
[newy (+ ty y)])
(doit tx ty newx newy)
(make-turtle newx newy (turtle-angle turtle)))))
(flip-icons))))
(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)
(flatten
(lambda (turtle)
(let* ([x (turtle-x turtle)]
[y (turtle-y turtle)]
[angle (turtle-angle turtle)]
[d (if (zero? n) 0 (sub1 (abs n)))]
[res (if (< n 0) (- d) d)]
[c (cos angle)]
[s (sin angle)]
[drawx (+ x (* res c))]
[drawy (+ y (* res s))]
[newx (+ x (* n c))]
[newy (+ y (* n s))])
(unless (zero? n)
(doit x y drawx drawy))
(make-turtle newx newy angle))))
(flip-icons))))
(define draw (draw/erase (lambda (a b c d) (line a b c d))))
(define erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d))))
(define move
(lambda (n)
(flip-icons)
(set! turtles-cache (combine (make-c-forward n) turtles-cache))
(flip-icons)))
(define turn/radians
(lambda (d)
(flip-icons)
(set! turtles-cache (combine (make-c-turn d) turtles-cache))
(flip-icons)))
(define turn
(lambda (c)
(turn/radians (* (/ c 360) 2 pi))))
(define move-offset
(lambda (x y)
(flip-icons)
(set! turtles-cache (combine (make-c-offset x y) turtles-cache))
(flip-icons)))
(define erase/draw-offset
(lambda (doit)
(lambda (x y)
(flip-icons)
(flatten
(lambda (turtle)
(let* ([tx (turtle-x turtle)]
[ty (turtle-y turtle)]
[newx (+ tx x)]
[newy (+ ty y)])
(doit tx ty newx newy)
(make-turtle newx newy (turtle-angle turtle)))))
(flip-icons))))
(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")]))
(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)
(set! external-deps
(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))]
[code-dir (get-code-dir mode path)])
(if (not (directory-exists? code-dir))

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

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

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

@ -59,7 +59,7 @@
(import)
(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) ())
;; error* : string args ... -> raises a cookie-error exception

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

@ -1,6 +1,7 @@
#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)
(export dns^)

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

@ -1,82 +1,82 @@
#lang scheme/unit
;; Version 0.2
;; Version 0.1a
;; Micah Flatt
;; 06-06-2002
(require (lib "date.ss") (lib "file.ss") (lib "port.ss") "ftp-sig.ss")
(import)
(export ftp^)
;; Version 0.2
;; Version 0.1a
;; Micah Flatt
;; 06-06-2002
(require scheme/date scheme/file scheme/port scheme/tcp "ftp-sig.ss")
(import)
(export ftp^)
;; opqaue record to represent an FTP connection:
(define-struct tcp-connection (in out))
;; opqaue record to represent an FTP connection:
(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:response-end #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 (check-expected-result line expected)
(when expected
(unless (ormap (lambda (expected)
(bytes=? expected (subbytes line 0 3)))
(if (bytes? expected)
(define (check-expected-result line expected)
(when expected
(unless (ormap (lambda (expected)
(bytes=? expected (subbytes line 0 3)))
(if (bytes? expected)
(list 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
;;
;; Checks a standard-format response, checking for the given
;; expected 3-digit result code if expected is not #f.
;;
;; While checking, the function sends reponse lines to
;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and
;; `(void)' to ignore the response info.
;;
;; If an unexpected result is found, an exception is raised, and the
;; stream is left in an undefined state.
(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
(flush-output tcpout)
(let ([line (read-bytes-line tcpin 'any)])
(cond
[(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:multi-response-start line)
(check-expected-result line expected)
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)])
(cond [(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:done line)
(diagnostic-accum line accum)]
[else
(loop (diagnostic-accum line accum))]))))]
[(regexp-match re:response-end line)
(check-expected-result line expected)
(diagnostic-accum line accum-start)]
[else
(error 'ftp "unexpected result: ~e" line)])))
;; 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
;; expected 3-digit result code if expected is not #f.
;;
;; While checking, the function sends reponse lines to
;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and
;; `(void)' to ignore the response info.
;;
;; If an unexpected result is found, an exception is raised, and the
;; stream is left in an undefined state.
(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start)
(flush-output tcpout)
(let ([line (read-bytes-line tcpin 'any)])
(cond
[(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:multi-response-start line)
(check-expected-result line expected)
(let ([re:done (regexp (format "^~a " (subbytes line 0 3)))])
(let loop ([accum (diagnostic-accum line accum-start)])
(let ([line (read-bytes-line tcpin 'any)])
(cond [(eof-object? line)
(error 'ftp "unexpected EOF")]
[(regexp-match re:done line)
(diagnostic-accum line accum)]
[else
(loop (diagnostic-accum line accum))]))))]
[(regexp-match re:response-end line)
(check-expected-result line expected)
(diagnostic-accum line accum-start)]
[else
(error 'ftp "unexpected result: ~e" line)])))
(define (get-month month-bytes)
(cond [(assoc month-bytes
'((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
(#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
(#"Nov" 11) (#"Dec" 12)))
=> cadr]
[else (error 'get-month "bad month: ~s" month-bytes)]))
(define (get-month month-bytes)
(cond [(assoc month-bytes
'((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5)
(#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10)
(#"Nov" 11) (#"Dec" 12)))
=> cadr]
[else (error 'get-month "bad month: ~s" month-bytes)]))
(define (bytes->number bytes)
(string->number (bytes->string/latin-1 bytes)))
(define (bytes->number 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)
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
(if (not (list-ref date-list 4))
(define (ftp-make-file-seconds ftp-date-str)
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
(if (not (list-ref date-list 4))
(find-seconds 0
0
2
@ -91,128 +91,128 @@
2002)
tzoffset))))
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
(define (establish-data-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV\n")
(let ([response (ftp-check-response
(tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"227"
(lambda (s ignore) s) ; should be the only response
(void))])
(let* ([reg-list (regexp-match re:passive response)]
[pn1 (and reg-list
(bytes->number (list-ref reg-list 5)))]
[pn2 (bytes->number (list-ref reg-list 6))])
(unless (and reg-list pn1 pn2)
(error 'ftp "can't understand PASV response: ~e" response))
(let-values ([(tcp-data tcp-data-out)
(tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 1)
(list-ref reg-list 2)
(list-ref reg-list 3)
(list-ref reg-list 4))
(+ (* 256 pn1) pn2))])
(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)
(define (establish-data-connection tcp-ports)
(fprintf (tcp-connection-out tcp-ports) "PASV\n")
(let ([response (ftp-check-response
(tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"227"
(lambda (s ignore) s) ; should be the only response
(void))])
(let* ([reg-list (regexp-match re:passive response)]
[pn1 (and reg-list
(bytes->number (list-ref reg-list 5)))]
[pn2 (bytes->number (list-ref reg-list 6))])
(unless (and reg-list pn1 pn2)
(error 'ftp "can't understand PASV response: ~e" response))
(let-values ([(tcp-data tcp-data-out)
(tcp-connect (format "~a.~a.~a.~a"
(list-ref reg-list 1)
(list-ref reg-list 2)
(list-ref reg-list 3)
(list-ref reg-list 4))
(+ (* 256 pn1) pn2))])
(fprintf (tcp-connection-out tcp-ports) "TYPE I\n")
(ftp-check-response (tcp-connection-in tcp-ports)
(tcp-connection-out tcp-ports)
#"226" print-msg (void))
(map (lambda (l) (map bytes->string/locale l)) dir-list))))
#"200" void (void))
(close-output-port tcp-data-out)
tcp-data))))
(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)
;; 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)
(tcp-connection-out tcp-ports)
#"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
(require (lib "list.ss") "imap-sig.ss" "private/rbtree.ss")
(require scheme/tcp
"imap-sig.ss"
"private/rbtree.ss")
(import)
(export imap^)
@ -252,7 +254,8 @@
(info-handler i)))
(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-port-number

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

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

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

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

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

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

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

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

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

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

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

@ -1,26 +1,27 @@
#lang scheme/unit
(require (lib "list.ss") (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(import)
(export smtp^)
(require scheme/tcp "base64.ss" "smtp-sig.ss")
(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)
;; (apply printf args)
(void))
(define debug-via-stdio? #f)
(define (starts-with? l n)
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(define (log . args)
;; (apply printf args)
(void))
(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)
(define (starts-with? l n)
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(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")
(let ([n (number->string v)])
(unless (starts-with? l n)
@ -32,135 +33,133 @@
;; We're finished, so add the last and reverse the result
(when 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)
;; 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)))))
(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 (cdr (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)
;; 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
(if (bytes? l)
(bytes-append #"." l)
(string-append "." l))))
(bytes-append #"." l)
(string-append "." l))))
(define smtp-sending-end-of-message
(make-parameter void
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" f))
f)))
(define smtp-sending-end-of-message
(make-parameter void
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" f))
f)))
(define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode)
(with-handlers ([void (lambda (x)
(close-input-port r)
(close-output-port w)
(raise x))])
(define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode)
(with-handlers ([void (lambda (x)
(close-input-port r)
(close-output-port w)
(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)
(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)
(let-values ([(ssl-r ssl-w)
(tls-encode r w
#:mode 'connect
#:encrypt 'tls
#: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)
(let-values ([(ssl-r ssl-w)
(tls-encode r w
#:mode 'connect
#:encrypt 'tls
#: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
(log "auth\n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
(string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(when auth-user
(log "auth\n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
(string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(log "from\n")
(fprintf w "MAIL FROM:<~a>\r\n" sender)
(check-reply r 250 w)
(log "from\n")
(fprintf w "MAIL FROM:<~a>\r\n" sender)
(check-reply r 250 w)
(log "to\n")
(for-each
(lambda (dest)
(fprintf w "RCPT TO:<~a>\r\n" dest)
(check-reply r 250 w))
recipients)
(log "to\n")
(for-each
(lambda (dest)
(fprintf w "RCPT TO:<~a>\r\n" dest)
(check-reply r 250 w))
recipients)
(log "header\n")
(fprintf w "DATA\r\n")
(check-reply r 354 w)
(fprintf w "~a" header)
(for-each
(lambda (l)
(log "body: ~a\n" l)
(fprintf w "~a\r\n" (protect-line l)))
message-lines)
(log "header\n")
(fprintf w "DATA\r\n")
(check-reply r 354 w)
(fprintf w "~a" header)
(for-each
(lambda (l)
(log "body: ~a\n" l)
(fprintf w "~a\r\n" (protect-line l)))
message-lines)
;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message))
;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message))
(log "dot\n")
(fprintf w ".\r\n")
(flush-output w)
(check-reply r 250 w)
(log "dot\n")
(fprintf w ".\r\n")
(flush-output w)
(check-reply r 250 w)
;; 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
;; hands. This function should thus indicate success at this point
;; no matter what else happens.
;;
;; 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
;; email failed, we'll just log them.
(with-handlers ([void (lambda (x)
(log "error after send: ~a\n" (exn-message x)))])
(log "quit\n")
(fprintf w "QUIT\r\n")
(check-reply r 221 w))
;; 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
;; hands. This function should thus indicate success at this point
;; no matter what else happens.
;;
;; 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
;; email failed, we'll just log them.
(with-handlers ([void (lambda (x)
(log "error after send: ~a\n" (exn-message x)))])
(log "quit\n")
(fprintf w "QUIT\r\n")
(check-reply r 221 w))
(close-output-port w)
(close-input-port r)))
(close-output-port w)
(close-input-port r)))
(define smtp-send-message
(lambda/kw (server sender recipients header message-lines
#:key
[port-no 25]
[auth-user #f]
[auth-passwd #f]
[tcp-connect tcp-connect]
[tls-encode #f]
#:body
(#:optional [opt-port-no port-no]))
(when (null? recipients)
(error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode))))
(define smtp-send-message
(lambda (server sender recipients header message-lines
#:port-no [port-no 25]
#:auth-user [auth-user #f]
#:auth-passwd [auth-passwd #f]
#:tcp-connect [tcp-connect tcp-connect]
#:tls-encode [tls-encode #f]
[opt-port-no port-no])
(when (null? recipients)
(error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))])
(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))
(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 empty? (lambda (x) (null? x)))
(define empty '()))

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

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

104
collects/scheme/unit.ss
View File

@ -1,4 +1,104 @@
(module unit scheme/base
(require mzlib/unit)
(provide (all-from-out mzlib/unit)))
(require 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
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["units.scrbl"]
@include-section["contracts.scrbl"]
@include-section["match.scrbl"]
@include-section["control.scrbl"]
@include-section["concurrency.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.)}
@defform/subs[
#:literals (-type -selectors -setters -constructor)
(struct id (field-id ...) omit-decl ...)
(struct id (field ...) option ...)
([omit-decl
-type
-selectors
-setters
-constructor])]{
([field id
[id #:mutable]]
[option #:mutable
#:omit-constructor
#:omit-define-syntaxes
#:omit-define-values])]{
For use with @scheme[define-signature]. The expansion of a
@scheme[struct] signature form includes all of the identifiers that
would be bound by @scheme[(define-struct id (field-id ...))], except
that a @scheme[omit-decl] can cause some of the bindings to be
omitted. Specifically @scheme[-type] causes
@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).}
would be bound by @scheme[(define-struct id (field ...) option ...)],
where the extra option @scheme[#:omit-constructor] omits the
@schemeidfont{make-}@scheme[id] identifier.}
@; ------------------------------------------------------------------------

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
@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'
;; function creates a compose-window instance.
(module sendr mzscheme
(require (lib "unit.ss")
(lib "class.ss")
(module sendr scheme/base
(require scheme/tcp
scheme/unit
scheme/class
(lib "mred-sig.ss" "mred")
(lib "framework.ss" "framework"))
(require (lib "list.ss")
(lib "file.ss")
(lib "string.ss")
(require scheme/file
(lib "process.ss")
(lib "mzssl.ss" "openssl"))
@ -126,7 +125,8 @@
(define-struct enclosure (name ; identifies enclosure in the GUI
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.
;; `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")
(provide resolve-path-spec)
@ -19,7 +20,7 @@
(string->path s))]
[(-build-path elem ...)
(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)
(raise-syntax-error
#f
@ -28,7 +29,7 @@
fn))
(apply build-path l))]
[(lib filename ...)
(let ([l (syntax-object->datum (syntax (filename ...)))])
(let ([l (syntax->datum (syntax (filename ...)))])
(unless (or (andmap string? l)
(pair? l))
(raise-syntax-error

20
collects/syntax/struct.ss
View File

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

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

@ -30,7 +30,7 @@ eof?
;; zodiac struct:
;; zodiac (stx) ; used to be (origin start finish)
(struct zodiac (stx))
(struct zodiac (stx) #:mutable)
zodiac-origin ; = identity
zodiac-start ; = identity
zodiac-finish ; = zodiac-start
@ -40,70 +40,70 @@ zodiac-finish ; = zodiac-start
;; zread ; used to have (object)
;; The sub-tree has been cut off; inspect
;; the stx object, instead.
(struct zread ())
(struct zread () #:mutable)
;; elaborator structs:
(struct parsed (back))
(struct parsed (back) #:mutable)
(struct varref (var))
(struct top-level-varref (module slot exptime? expdef? position)) ; added module, exptime?, position
(struct varref (var) #:mutable)
(struct top-level-varref (module slot exptime? expdef? position) #:mutable) ; added module, exptime?, position
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
lexical-varref? create-lexical-varref ; alias for bound-varref
make-lexical-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 quote-form (expr)) create-quote-form
(struct begin-form (bodies)) create-begin-form
(struct begin0-form (bodies)) create-begin0-form
(struct let-values-form (vars vals body)) create-let-values-form
(struct letrec-values-form (vars vals body)) create-letrec-values-form
(struct define-values-form (vars val)) create-define-values-form
(struct set!-form (var val)) create-set!-form
(struct case-lambda-form (args bodies)) create-case-lambda-form
(struct with-continuation-mark-form (key val body)) create-with-continuation-mark-form
(struct if-form (test then else) #:mutable) create-if-form
(struct quote-form (expr) #:mutable) create-quote-form
(struct begin-form (bodies) #:mutable) create-begin-form
(struct begin0-form (bodies) #:mutable) create-begin0-form
(struct let-values-form (vars vals body) #:mutable) create-let-values-form
(struct letrec-values-form (vars vals body) #:mutable) create-letrec-values-form
(struct define-values-form (vars val) #:mutable) create-define-values-form
(struct set!-form (var val) #:mutable) create-set!-form
(struct case-lambda-form (args bodies) #:mutable) create-case-lambda-form
(struct with-continuation-mark-form (key val body) #:mutable) create-with-continuation-mark-form
;; Thess are new:
(struct quote-syntax-form (expr)) create-quote-syntax-form
(struct define-syntaxes-form (names expr)) create-define-syntaxes-form
(struct define-for-syntax-form (names expr)) create-define-for-syntax-form
(struct quote-syntax-form (expr) #:mutable) create-quote-syntax-form
(struct define-syntaxes-form (names expr) #:mutable) create-define-syntaxes-form
(struct define-for-syntax-form (names expr) #:mutable) create-define-for-syntax-form
(struct module-form (name requires ; lstof stx for module paths
for-syntax-requires ; lstof stx for module paths
for-template-requires ; lstof stx for module paths
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
indirect-provides ; lstof sym
kernel-reprovide-hint ; #f | #t | exclude-sym
self-path-index)) ; module path index
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
;; as applications of the corresponding quoted symbols to the
;; right kinds of arguments.
(struct global-prepare (vec pos)) create-global-prepare
(struct global-lookup (vec pos)) create-global-lookup
(struct global-assign (vec pos expr)) create-global-assign
(struct safe-vector-ref (vec pos)) create-safe-vector-ref
(struct global-prepare (vec pos) #:mutable) create-global-prepare
(struct global-lookup (vec pos) #:mutable) create-global-lookup
(struct global-assign (vec pos expr) #:mutable) create-global-assign
(struct safe-vector-ref (vec pos) #:mutable) create-safe-vector-ref
global-prepare-id
global-lookup-id
global-assign-id
safe-vector-ref-id
;; args:
(struct arglist (vars))
(struct sym-arglist ())
(struct list-arglist ())
(struct ilist-arglist ())
(struct arglist (vars) #:mutable)
(struct sym-arglist () #:mutable)
(struct list-arglist () #:mutable)
(struct ilist-arglist () #:mutable)
make-empty-back-box
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
(require (lib "unit.ss"))
(module common-sig scheme/base
(require scheme/unit)
(provide 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
descent ; portion of height below bottom baseline
children ; list of child records
panbox)) ; panorama box
panbox) ; panorama box
#:mutable)
(define-struct child (pict dx dy sx sy))
(define-struct bbox (x1 y1 x2 y2 ay dy))