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

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

@ -1,6 +1,6 @@
#lang scheme/unit #lang scheme/unit
(require "sig.ss") (require "sig.ss")
;; Implements a red-black tree with relative indexing along right ;; Implements a red-black tree with relative indexing along right
;; splines. This allows the usual O(log(n)) operations, plus a ;; splines. This allows the usual O(log(n)) operations, plus a
@ -8,25 +8,25 @@
;; (This is the same data structure as used for lines by MrEd's text% ;; (This is the same data structure as used for lines by MrEd's text%
;; class, but that one is implemented in C++.) ;; class, but that one is implemented in C++.)
(import) (import)
(export (rename relative-btree^ (export (rename relative-btree^
(create-btree make-btree))) (create-btree make-btree)))
(define-struct btree (root)) (define-struct btree (root) #:mutable)
(define-struct node (pos data parent left right color)) (define-struct node (pos data parent left right color) #:mutable)
(define (adjust-offsets n new-child) (define (adjust-offsets n new-child)
(when new-child (when new-child
(set-node-pos! new-child (- (node-pos new-child) (set-node-pos! new-child (- (node-pos new-child)
(node-pos n))))) (node-pos n)))))
(define (deadjust-offsets n old-child) (define (deadjust-offsets n old-child)
(when old-child (when old-child
(set-node-pos! old-child (+ (node-pos old-child) (set-node-pos! old-child (+ (node-pos old-child)
(node-pos n))))) (node-pos n)))))
(define (rotate-left n btree) (define (rotate-left n btree)
(let ([old-right (node-right n)]) (let ([old-right (node-right n)])
(deadjust-offsets n old-right) (deadjust-offsets n old-right)
@ -45,7 +45,7 @@
(set-node-left! old-right n) (set-node-left! old-right n)
(set-node-parent! n old-right))) (set-node-parent! n old-right)))
(define (rotate-right n btree) (define (rotate-right n btree)
(let ([old-left (node-left n)]) (let ([old-left (node-left n)])
(adjust-offsets old-left n) (adjust-offsets old-left n)
@ -65,7 +65,7 @@
(set-node-parent! n old-left))) (set-node-parent! n old-left)))
(define (insert before? n btree pos data) (define (insert before? n btree pos data)
(let ([new (make-node pos data #f #f #f 'black)]) (let ([new (make-node pos data #f #f #f 'black)])
(if (not (btree-root btree)) (if (not (btree-root btree))
(set-btree-root! btree new) (set-btree-root! btree new)
@ -147,7 +147,7 @@
(set-node-color! (btree-root btree) 'black))))) (set-node-color! (btree-root btree) 'black)))))
(define (find-following-node btree pos) (define (find-following-node btree pos)
(let ([root (btree-root btree)]) (let ([root (btree-root btree)])
(let loop ([n root] (let loop ([n root]
[so-far root] [so-far root]
@ -165,23 +165,23 @@
[else [else
(loop (node-right n) so-far so-far-pos npos)])))))) (loop (node-right n) so-far so-far-pos npos)]))))))
(define (create-btree) (define (create-btree)
(make-btree #f)) (make-btree #f))
(define (btree-get btree pos) (define (btree-get btree pos)
(let-values ([(n npos) (find-following-node btree pos)]) (let-values ([(n npos) (find-following-node btree pos)])
(and n (and n
(= npos pos) (= npos pos)
(node-data n)))) (node-data n))))
(define (btree-put! btree pos data) (define (btree-put! btree pos data)
(let-values ([(n npos) (find-following-node btree pos)]) (let-values ([(n npos) (find-following-node btree pos)])
(if (and n (= npos pos)) (if (and n (= npos pos))
(set-node-data! n data) (set-node-data! n data)
(insert (and n (< pos npos)) (insert (and n (< pos npos))
n btree pos data)))) n btree pos data))))
(define (btree-shift! btree start delta) (define (btree-shift! btree start delta)
(let loop ([n (btree-root btree)] (let loop ([n (btree-root btree)]
[v 0]) [v 0])
(when n (when n
@ -193,7 +193,7 @@
[else [else
(loop (node-right n) (+ v npos))]))))) (loop (node-right n) (+ v npos))])))))
(define (btree-for-each btree f) (define (btree-for-each btree f)
(when (btree-root btree) (when (btree-root btree)
(let loop ([n (btree-root btree)] (let loop ([n (btree-root btree)]
[v 0]) [v 0])
@ -204,7 +204,7 @@
(loop (node-right n) (loop (node-right n)
(+ v (node-pos n))))))) (+ v (node-pos n)))))))
(define (btree-map btree f) (define (btree-map btree f)
(reverse (reverse
(let loop ([n (btree-root btree)] (let loop ([n (btree-root btree)]
[v 0] [v 0]

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

@ -1,33 +1,30 @@
#lang scheme/unit #lang scheme/unit
(require "sig.ss" (require "sig.ss"
(lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")
(lib "file.ss") scheme/file
(lib "etc.ss")
(lib "list.ss")
(lib "string.ss")
(lib "port.ss") (lib "port.ss")
(lib "url-sig.ss" "net") (lib "url-sig.ss" "net")
(only (lib "html.ss" "html") (only-in (lib "html.ss" "html")
read-html-as-xml read-html-comments use-html-spec) read-html-as-xml read-html-comments use-html-spec)
(all-except (lib "xml.ss" "xml") read-comments) (except-in (lib "xml.ss" "xml") read-comments)
(lib "class.ss") (lib "class.ss")
"bullet.ss" "bullet.ss"
"option-snip.ss" "option-snip.ss"
"entity-names.ss") "entity-names.ss")
(import mred^ url^) (import mred^ url^)
(export html^) (export html^)
(init-depend mred^) (init-depend mred^)
;; CACHE ;; CACHE
(define NUM-CACHED 10) (define NUM-CACHED 10)
(define cached (make-vector 10 'no-image)) (define cached (make-vector 10 'no-image))
(define cached-name (make-vector 10 #f)) ; string or #f (define cached-name (make-vector 10 #f)) ; string or #f
(define cached-use (make-vector 10 0)) (define cached-use (make-vector 10 0))
(define html-status-handler (define html-status-handler
(make-parameter (make-parameter
void void
(lambda (f) (lambda (f)
@ -38,13 +35,13 @@
f)) f))
f))) f)))
(define (status . args) (define (status . args)
((html-status-handler) (apply format args))) ((html-status-handler) (apply format args)))
(define status-stack (make-parameter null)) (define status-stack (make-parameter null))
;; load-status : boolean string (union #f url) -> void ;; load-status : boolean string (union #f url) -> void
(define (load-status push? what url) (define (load-status push? what url)
(let ([s (format "Loading ~a ~a..." (let ([s (format "Loading ~a ~a..."
what what
(if url (if url
@ -53,24 +50,24 @@
(status-stack (cons s (if push? (status-stack) null))) (status-stack (cons s (if push? (status-stack) null)))
(status "~a" s))) (status "~a" s)))
(define (pop-status) (define (pop-status)
(status-stack (cdr (status-stack))) (status-stack (cdr (status-stack)))
(status "~a" (car (status-stack)))) (status "~a" (car (status-stack))))
(define (trim len s) (define (trim len s)
(if ((string-length s) . <= . len) (if ((string-length s) . <= . len)
s s
(string-append (substring s 0 (- len 4)) " ..."))) (string-append (substring s 0 (- len 4)) " ...")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Imap maps ;; Imap maps
;; ;;
(define-struct image-map-rect (href left top right bottom)) (define-struct image-map-rect (href left top right bottom))
(define finger-cursor (make-object cursor% 'arrow)) (define finger-cursor (make-object cursor% 'arrow))
(define image-map-snip% (define image-map-snip%
(class image-snip% (class image-snip%
(init-field html-text) (init-field html-text)
@ -143,31 +140,31 @@
(set-flags (cons 'handles-events (get-flags))))) (set-flags (cons 'handles-events (get-flags)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Hardwired Scheme colorization; should come from a .css file ;; Hardwired Scheme colorization; should come from a .css file
;; ;;
(define (make-scheme-color-delta col) (define (make-scheme-color-delta col)
(let ([d (make-object style-delta%)]) (let ([d (make-object style-delta%)])
(send d set-delta-foreground col) (send d set-delta-foreground col)
d)) d))
(define scheme-code-delta (make-scheme-color-delta "brown")) (define scheme-code-delta (make-scheme-color-delta "brown"))
(define scheme-code-delta/keyword (define scheme-code-delta/keyword
(let ([d (make-scheme-color-delta (make-object color% #x99 0 0))]) (let ([d (make-scheme-color-delta (make-object color% #x99 0 0))])
(send d set-weight-on 'bold) (send d set-weight-on 'bold)
d)) d))
(define scheme-code-delta/variable (make-scheme-color-delta "navy")) (define scheme-code-delta/variable (make-scheme-color-delta "navy"))
(define scheme-code-delta/global (make-scheme-color-delta "purple")) (define scheme-code-delta/global (make-scheme-color-delta "purple"))
(define scheme-code-delta/selfeval (make-scheme-color-delta "forest green")) (define scheme-code-delta/selfeval (make-scheme-color-delta "forest green"))
(define scheme-code-delta/comment (make-scheme-color-delta "cornflower blue")) (define scheme-code-delta/comment (make-scheme-color-delta "cornflower blue"))
(define navigation-delta (let ([d (make-scheme-color-delta "red")]) (define navigation-delta (let ([d (make-scheme-color-delta "red")])
(send d set-style-on 'italic) (send d set-style-on 'italic)
d)) d))
(define current-style-class (make-parameter null)) (define current-style-class (make-parameter null))
(define (lookup-class-delta class) (define (lookup-class-delta class)
(let ([class-path (cons class (current-style-class))]) (let ([class-path (cons class (current-style-class))])
(cond (cond
[(sub-path? class-path '("scheme")) scheme-code-delta] [(sub-path? class-path '("scheme")) scheme-code-delta]
@ -180,25 +177,25 @@
[(sub-path? class-path '("navigation")) navigation-delta] [(sub-path? class-path '("navigation")) navigation-delta]
[else #f]))) [else #f])))
(define (sub-path? a b) (define (sub-path? a b)
(cond (cond
[(null? b) #t] [(null? b) #t]
[(null? a) #f] [(null? a) #f]
[else (and (equal? (car a) (car b)) [else (and (equal? (car a) (car b))
(sub-path? (cdr a) (cdr b)))])) (sub-path? (cdr a) (cdr b)))]))
(define (with-style-class class thunk) (define (with-style-class class thunk)
(if class (if class
(parameterize ([current-style-class (cons class (current-style-class))]) (parameterize ([current-style-class (cons class (current-style-class))])
(thunk)) (thunk))
(thunk))) (thunk)))
(define (lookup-span-class-delta class) (lookup-class-delta class)) (define (lookup-span-class-delta class) (lookup-class-delta class))
(define re:hexcolor (define re:hexcolor
(regexp "^#([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])$")) (regexp "^#([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])$"))
(define color-string->color (define color-string->color
(lambda (str) (lambda (str)
(let ([m (regexp-match re:hexcolor str)]) (let ([m (regexp-match re:hexcolor str)])
(if m (if m
@ -208,10 +205,10 @@
(string->number (cadddr m) 16)) (string->number (cadddr m) 16))
(send the-color-database find-color str))))) (send the-color-database find-color str)))))
(define html-eval-ok (make-parameter #t)) (define html-eval-ok (make-parameter #t))
(define html-img-ok (make-parameter #t)) (define html-img-ok (make-parameter #t))
(define (get-bitmap-from-url url) (define (get-bitmap-from-url url)
(if (html-img-ok) (if (html-img-ok)
(let ([tmp-filename (make-temporary-file "mredimg~a")]) (let ([tmp-filename (make-temporary-file "mredimg~a")])
(load-status #t "image" url) (load-status #t "image" url)
@ -244,8 +241,8 @@
#f))) #f)))
#f)) #f))
;; cache-bitmap : string -> (is-a?/c bitmap%) ;; cache-bitmap : string -> (is-a?/c bitmap%)
(define (cache-bitmap url) (define (cache-bitmap url)
(let ([url-string (url->string url)]) (let ([url-string (url->string url)])
(let loop ([n 0]) (let loop ([n 0])
(cond (cond
@ -275,7 +272,7 @@
[else [else
(loop (add1 n))])))) (loop (add1 n))]))))
(define (update-image-maps image-map-snips image-maps) (define (update-image-maps image-map-snips image-maps)
(for-each (for-each
(lambda (image-map-snip) (lambda (image-map-snip)
(let ([image-map-key (send image-map-snip get-key)]) (let ([image-map-key (send image-map-snip get-key)])
@ -292,7 +289,7 @@
(loop (cdr image-maps))))])))) (loop (cdr image-maps))))]))))
image-map-snips)) image-map-snips))
(define (find/add-areas image-map-snip image-map) (define (find/add-areas image-map-snip image-map)
(let loop ([sexp image-map]) (let loop ([sexp image-map])
(cond (cond
[(and (pair? sexp) [(and (pair? sexp)
@ -305,11 +302,11 @@
(loop (cdr sexp))] (loop (cdr sexp))]
[else (void)]))) [else (void)])))
;; add-area : snip (listof (list sym string))[assoc] -> void ;; add-area : snip (listof (list sym string))[assoc] -> void
;; the second arg type is actually `any', but if it ;; the second arg type is actually `any', but if it
;; matches the above, it is interprted propoerly; ;; matches the above, it is interprted propoerly;
;; otherwise silently nothing happens. ;; otherwise silently nothing happens.
(define (add-area image-map-snip sexp) (define (add-area image-map-snip sexp)
(let ([shape #f] (let ([shape #f]
[coords #f] [coords #f]
[href #f]) [href #f])
@ -333,10 +330,10 @@
(when p-coords (when p-coords
(send image-map-snip add-area shape p-coords href)))))) (send image-map-snip add-area shape p-coords href))))))
;; parse-coords : string -> (listof number) ;; parse-coords : string -> (listof number)
;; separates out a bunch of comma separated numbers in a string ;; separates out a bunch of comma separated numbers in a string
;; into a list of scheme numbers ;; into a list of scheme numbers
(define (parse-coords str) (define (parse-coords str)
(let loop ([str str]) (let loop ([str str])
(cond (cond
[(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*,(.*)$" str) [(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*,(.*)$" str)
@ -352,7 +349,7 @@
(list (string->number (cadr m))))] (list (string->number (cadr m))))]
[else null]))) [else null])))
(define (make-get-field str) (define (make-get-field str)
(let ([s (apply (let ([s (apply
string-append string-append
(map (map
@ -369,31 +366,31 @@
(regexp-match re:plain args))]) (regexp-match re:plain args))])
(and m (caddr m))))))) (and m (caddr m)))))))
(define (get-field e name) (define (get-field e name)
(let ([a (assq name (cadr e))]) (let ([a (assq name (cadr e))])
(and a (cadr a)))) (and a (cadr a))))
(define get-mzscheme-arg (define get-mzscheme-arg
(let ([get-mz (make-get-field "mzscheme")]) (let ([get-mz (make-get-field "mzscheme")])
(lambda (str) (lambda (str)
(let ([v (get-mz str)]) (let ([v (get-mz str)])
(and v (filter-mzscheme v)))))) (and v (filter-mzscheme v))))))
(define filter-mzscheme (define filter-mzscheme
(lambda (v) (lambda (v)
(regexp-replace* "[|]" v "\""))) (regexp-replace* "[|]" v "\"")))
(define face-list #f) (define face-list #f)
(define default-font (make-object font% 12 'default)) (define default-font (make-object font% 12 'default))
(define re:quot (regexp "[&][qQ][uU][oO][tT][;]")) (define re:quot (regexp "[&][qQ][uU][oO][tT][;]"))
(define re:amp (regexp "[&][aA][mM][pP][;]")) (define re:amp (regexp "[&][aA][mM][pP][;]"))
(define re:empty (regexp (format "^[ ~c]*$" (integer->char 160)))) (define re:empty (regexp (format "^[ ~c]*$" (integer->char 160))))
(define-struct form (action target method parts active-select)) (define-struct form (action target method [parts #:mutable] [active-select #:mutable]))
(define (protect-chars s) (define (protect-chars s)
(apply string-append (apply string-append
(map (lambda (c) (map (lambda (c)
(if (or (char-alphabetic? c) (if (or (char-alphabetic? c)
@ -404,30 +401,30 @@
(substring s (- (string-length s) 2) (string-length s)))))) (substring s (- (string-length s) 2) (string-length s))))))
(string->list s)))) (string->list s))))
(define re:true (regexp-quote "true" #f)) (define re:true (regexp-quote "true" #f))
(define (true? s) (regexp-match re:true s)) (define (true? s) (regexp-match re:true s))
(define verbatim-tags '(listing xmp plaintext)) (define verbatim-tags '(listing xmp plaintext))
(define preformatted-tags '(pre)) (define preformatted-tags '(pre))
(define exact-whitespace-tags (append verbatim-tags (define exact-whitespace-tags (append verbatim-tags
preformatted-tags)) preformatted-tags))
(define comment-tags '(script)) (define comment-tags '(script))
(define atomic-tags '(p br hr li dd dt img html meta link input)) (define atomic-tags '(p br hr li dd dt img html meta link input))
(define enum-tags '(ul dl ol menu)) (define enum-tags '(ul dl ol menu))
(define space-eating-tags '(title p div center br h1 h2 h3 h4 (define space-eating-tags '(title p div center br h1 h2 h3 h4
li dt dd li dt dd
ul ol dl menu ul ol dl menu
samp kbd pre blockquote samp kbd pre blockquote
table tr td)) table tr td))
(define whitespace-string "[ \t\n\r\v\f]+") (define whitespace-string "[ \t\n\r\v\f]+")
(define re:whitespace (regexp whitespace-string)) (define re:whitespace (regexp whitespace-string))
(define re:starting-whitespace (regexp (format "^~a" whitespace-string))) (define re:starting-whitespace (regexp (format "^~a" whitespace-string)))
(define re:ending-whitespace (regexp (format "~a$" whitespace-string))) (define re:ending-whitespace (regexp (format "~a$" whitespace-string)))
(define re:leading-newline (regexp "^(\r|\n|(\r\n))")) (define re:leading-newline (regexp "^(\r|\n|(\r\n))"))
(define (remove-leading-newline c) (define (remove-leading-newline c)
(cond (cond
[(string? c) [(string? c)
(let ([s (regexp-match-positions re:leading-newline c)]) (let ([s (regexp-match-positions re:leading-newline c)])
@ -450,7 +447,7 @@
(loop (cdr b) (cons d accum))))))] (loop (cdr b) (cons d accum))))))]
[else (values c #f)])) [else (values c #f)]))
(define (fixup-whitespace c leading-ok?) (define (fixup-whitespace c leading-ok?)
(cond (cond
[(string? c) [(string? c)
(let ([s (regexp-match-positions re:starting-whitespace c)] (let ([s (regexp-match-positions re:starting-whitespace c)]
@ -520,19 +517,19 @@
(and leading-ok? (and leading-ok?
(not (memq tag space-eating-tags)))))))])) (not (memq tag space-eating-tags)))))))]))
(define (read-html a-port) (define (read-html a-port)
(let* ([xml (parameterize ([read-html-comments #t] (let* ([xml (parameterize ([read-html-comments #t]
[use-html-spec #f]) [use-html-spec #f])
(read-html-as-xml a-port))] (read-html-as-xml a-port))]
[xexpr `(html () ,@(map xml->xexpr xml))]) [xexpr `(html () ,@(map xml->xexpr xml))])
xexpr)) xexpr))
(define (parse-html a-port) (define (parse-html a-port)
(let ([raw (read-html a-port)]) (let ([raw (read-html a-port)])
(let-values ([(v ?) (fixup-whitespace raw #f)]) (let-values ([(v ?) (fixup-whitespace raw #f)])
v))) v)))
(define html-convert (define html-convert
(lambda (a-port a-text) (lambda (a-port a-text)
(let ([content (parse-html a-port)]) (let ([content (parse-html a-port)])
(with-method ([a-text-insert (a-text insert)] (with-method ([a-text-insert (a-text insert)]
@ -751,7 +748,7 @@
(r)) (r))
rfl)))] rfl)))]
[styler (opt-lambda (delta rest [drop-empty? #f]) [styler (lambda (delta rest [drop-empty? #f])
(let*-values ([(start-pos) (current-pos)] (let*-values ([(start-pos) (current-pos)]
[(r rfl) (rest)] [(r rfl) (rest)]
[(end-pos) (current-pos)]) [(end-pos) (current-pos)])

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

@ -30,12 +30,9 @@ A test case:
#lang scheme/unit #lang scheme/unit
(require (lib "class.ss") (require (lib "class.ss")
"sig.ss" "sig.ss"
(lib "file.ss") scheme/file
(lib "list.ss")
(lib "string.ss")
(lib "etc.ss")
(lib "url-sig.ss" "net") (lib "url-sig.ss" "net")
(lib "url-structs.ss" "net") (lib "url-structs.ss" "net")
(lib "head.ss" "net") (lib "head.ss" "net")
@ -45,24 +42,29 @@ A test case:
(lib "plt-installer-sig.ss" "setup")) (lib "plt-installer-sig.ss" "setup"))
(import html^ (import html^
mred^ mred^
setup:plt-installer^ setup:plt-installer^
url^) url^)
(export hyper^) (export hyper^)
(init-depend mred^) (init-depend mred^)
(define-struct (exn:file-saved-instead exn) (pathname)) (define (last-pair l)
(define-struct (exn:cancelled exn) ()) (if (null? (cdr l))
(define-struct (exn:tcp-problem exn) ()) l
(last-pair (cdr l))))
(define history-limit 20) (define-struct (exn:file-saved-instead exn) (pathname))
(define-struct (exn:cancelled exn) ())
(define-struct (exn:tcp-problem exn) ())
(define-struct hyperlink (anchor-start anchor-end url-string)) (define history-limit 20)
(define-struct hypertag (name position)) (define-struct hyperlink (anchor-start anchor-end url-string))
(define (same-page-url? a b) (define-struct hypertag (name position))
(define (same-page-url? a b)
(or (eq? a b) (or (eq? a b)
(and (url? a) (url? b) (and (url? a) (url? b)
;; fragment can be different ;; fragment can be different
@ -77,14 +79,14 @@ A test case:
(equal? (url-query a) (url-query b))))) (equal? (url-query a) (url-query b)))))
(define hyper-text<%> (define hyper-text<%>
(interface () (interface ()
init-browser-status-line init-browser-status-line
update-browser-status-line update-browser-status-line
close-browser-status-line close-browser-status-line
url-allows-evaling?)) url-allows-evaling?))
(define hyper-text-mixin (define hyper-text-mixin
(mixin ((class->interface text%) editor:keymap<%>) (hyper-text<%>) (mixin ((class->interface text%) editor:keymap<%>) (hyper-text<%>)
(inherit begin-edit-sequence end-edit-sequence lock erase clear-undos (inherit begin-edit-sequence end-edit-sequence lock erase clear-undos
change-style change-style
@ -142,7 +144,7 @@ A test case:
(define/public (get-url) (and (url? url) url)) (define/public (get-url) (and (url? url) url))
(define/public post-url (define/public post-url
(opt-lambda (url-string [post-data #f]) (lambda (url-string [post-data #f])
(on-url-click (on-url-click
(lambda (url-string post-data) (lambda (url-string post-data)
(send (get-canvas) goto-url url-string (get-url) void post-data)) (send (get-canvas) goto-url url-string (get-url) void post-data))
@ -213,7 +215,7 @@ A test case:
begin-busy-cursor begin-busy-cursor
(lambda () (lambda ()
(with-handlers ([exn:fail? (build-html-error-message s)]) (with-handlers ([exn:fail? (build-html-error-message s)])
(eval-string s))) (eval (read (open-input-string s)))))
end-busy-cursor)]) end-busy-cursor)])
(when (string? v) (when (string? v)
(send (get-canvas) goto-url (send (get-canvas) goto-url
@ -230,7 +232,7 @@ A test case:
(define/public reload (define/public reload
;; The reload function is called in a non-main thread, ;; The reload function is called in a non-main thread,
;; since this class is instantiated in a non-main thread. ;; since this class is instantiated in a non-main thread.
(opt-lambda ([progress void]) (lambda ([progress void])
(when url (when url
(let ([s (make-semaphore)] (let ([s (make-semaphore)]
[closer-t #f] [closer-t #f]
@ -573,8 +575,8 @@ A test case:
;(printf "url: ~a\n" (if (url? url) (url->string url) url)) ;; handy for debugging help desk ;(printf "url: ~a\n" (if (url? url) (url->string url) url)) ;; handy for debugging help desk
(reload progress)))) (reload progress))))
;; build-html-error-message : exn -> string[html] ;; build-html-error-message : exn -> string[html]
(define ((build-html-error-message str) exn) (define ((build-html-error-message str) exn)
(string-append (string-append
"<html><head><title>Error Evaluating Scheme</title></head>" "<html><head><title>Error Evaluating Scheme</title></head>"
"<body>" "<body>"
@ -585,53 +587,53 @@ A test case:
(regexp-replace* #rx"<" (regexp-replace* #rx">" (exn-message exn) "&lt;") "&gt;")) (regexp-replace* #rx"<" (regexp-replace* #rx">" (exn-message exn) "&lt;") "&gt;"))
"</body></html>")) "</body></html>"))
(define hyper-text% (hyper-text-mixin text:keymap%)) (define hyper-text% (hyper-text-mixin text:keymap%))
(define space-page-keymap (make-object keymap%)) (define space-page-keymap (make-object keymap%))
(add-text-keymap-functions space-page-keymap) (add-text-keymap-functions space-page-keymap)
(send space-page-keymap map-function "space" "next-page") (send space-page-keymap map-function "space" "next-page")
(send space-page-keymap map-function "s:space" "previous-page") (send space-page-keymap map-function "s:space" "previous-page")
(define hyper-keymap (make-object keymap%)) (define hyper-keymap (make-object keymap%))
(send hyper-keymap add-function "rewind" (send hyper-keymap add-function "rewind"
(lambda (txt evt) (lambda (txt evt)
(call-with-hyper-panel (call-with-hyper-panel
txt txt
(lambda (panel) (lambda (panel)
(send panel rewind))))) (send panel rewind)))))
(send hyper-keymap add-function "forward" (send hyper-keymap add-function "forward"
(lambda (txt evt) (lambda (txt evt)
(call-with-hyper-panel (call-with-hyper-panel
txt txt
(lambda (panel) (lambda (panel)
(send panel forward))))) (send panel forward)))))
(send hyper-keymap add-function "do-wheel" (send hyper-keymap add-function "do-wheel"
(lambda (txt evt) (lambda (txt evt)
;; Redirect the event to the canvas, which should ;; Redirect the event to the canvas, which should
;; handle the event ;; handle the event
(send (send txt get-canvas) on-char evt))) (send (send txt get-canvas) on-char evt)))
(add-text-keymap-functions hyper-keymap) (add-text-keymap-functions hyper-keymap)
(send hyper-keymap map-function "d:[" "rewind") (send hyper-keymap map-function "d:[" "rewind")
(send hyper-keymap map-function "a:[" "rewind") (send hyper-keymap map-function "a:[" "rewind")
(send hyper-keymap map-function "c:[" "rewind") (send hyper-keymap map-function "c:[" "rewind")
(send hyper-keymap map-function "d:left" "rewind") (send hyper-keymap map-function "d:left" "rewind")
(send hyper-keymap map-function "a:left" "rewind") (send hyper-keymap map-function "a:left" "rewind")
(send hyper-keymap map-function "c:left" "rewind") (send hyper-keymap map-function "c:left" "rewind")
(send hyper-keymap map-function "m:left" "rewind") (send hyper-keymap map-function "m:left" "rewind")
(send hyper-keymap map-function "d:]" "forward") (send hyper-keymap map-function "d:]" "forward")
(send hyper-keymap map-function "a:]" "forward") (send hyper-keymap map-function "a:]" "forward")
(send hyper-keymap map-function "c:]" "forward") (send hyper-keymap map-function "c:]" "forward")
(send hyper-keymap map-function "d:right" "forward") (send hyper-keymap map-function "d:right" "forward")
(send hyper-keymap map-function "a:right" "forward") (send hyper-keymap map-function "a:right" "forward")
(send hyper-keymap map-function "c:right" "forward") (send hyper-keymap map-function "c:right" "forward")
(send hyper-keymap map-function "m:right" "forward") (send hyper-keymap map-function "m:right" "forward")
(send hyper-keymap map-function "wheelup" "do-wheel") (send hyper-keymap map-function "wheelup" "do-wheel")
(send hyper-keymap map-function "pageup" "previous-page") (send hyper-keymap map-function "pageup" "previous-page")
(send hyper-keymap map-function "wheeldown" "do-wheel") (send hyper-keymap map-function "wheeldown" "do-wheel")
(send hyper-keymap map-function "pagedown" "next-page") (send hyper-keymap map-function "pagedown" "next-page")
;; call-with-hyper-panel : object ((is-a?/c hyper-panel<%>) -> void) -> void ;; call-with-hyper-panel : object ((is-a?/c hyper-panel<%>) -> void) -> void
(define (call-with-hyper-panel text f) (define (call-with-hyper-panel text f)
(when (is-a? text hyper-text<%>) (when (is-a? text hyper-text<%>)
(let ([canvas (send text get-canvas)]) (let ([canvas (send text get-canvas)])
(when canvas (when canvas
@ -639,9 +641,9 @@ A test case:
(when (is-a? tlw hyper-frame<%>) (when (is-a? tlw hyper-frame<%>)
(f (send tlw get-hyper-panel)))))))) (f (send tlw get-hyper-panel))))))))
;; path-below? : string[normalized-path] string[normalized-path] -> boolean ;; path-below? : string[normalized-path] string[normalized-path] -> boolean
;; returns #t if subpath points to a place below top ;; returns #t if subpath points to a place below top
(define (path-below? top longer) (define (path-below? top longer)
(let loop ([top (explode-path top)] (let loop ([top (explode-path top)]
[longer (explode-path longer)]) [longer (explode-path longer)])
(cond (cond
@ -651,7 +653,7 @@ A test case:
(loop (cdr top) (cdr longer))] (loop (cdr top) (cdr longer))]
[else #f]))) [else #f])))
(keymap:add-to-right-button-menu/before (keymap:add-to-right-button-menu/before
(let ([old (keymap:add-to-right-button-menu/before)]) (let ([old (keymap:add-to-right-button-menu/before)])
(lambda (menu editor event) (lambda (menu editor event)
(when (is-a? editor hyper-text<%>) (when (is-a? editor hyper-text<%>)
@ -680,7 +682,7 @@ A test case:
(parent menu)))) (parent menu))))
(old menu editor event)))) (old menu editor event))))
(define hyper-canvas-mixin (define hyper-canvas-mixin
(mixin ((class->interface editor-canvas%)) () (mixin ((class->interface editor-canvas%)) ()
(inherit get-editor set-editor refresh get-parent get-top-level-window) (inherit get-editor set-editor refresh get-parent get-top-level-window)
@ -696,7 +698,7 @@ A test case:
(define/public (on-url-click k url post-data) (define/public (on-url-click k url post-data)
(send (get-parent) on-url-click k url post-data)) (send (get-parent) on-url-click k url post-data))
(define/public goto-url (define/public goto-url
(opt-lambda (in-url relative [progress void] [post-data #f]) (lambda (in-url relative [progress void] [post-data #f])
(let ([tlw (get-top-level-window)]) (let ([tlw (get-top-level-window)])
(when (and tlw (when (and tlw
(is-a? tlw hyper-frame<%>)) (is-a? tlw hyper-frame<%>))
@ -778,11 +780,11 @@ A test case:
(refresh)))) (refresh))))
(super-new))) (super-new)))
;; make-editor/setup-kill : custodian editor-class frame%-instance ;; make-editor/setup-kill : custodian editor-class frame%-instance
;; url (boolean??? -> void) ??? (url -> (union port #f url)) ;; url (boolean??? -> void) ??? (url -> (union port #f url))
;; -> (union (cons editor (union #f url)) exn #f) ;; -> (union (cons editor (union #f url)) exn #f)
;; if cust is shutdown, the url will stop being loaded and a dummy editor is returned. ;; if cust is shutdown, the url will stop being loaded and a dummy editor is returned.
(define (make-editor/setup-kill cust html-editor% tlw init-url progress post-data remap-url) (define (make-editor/setup-kill cust html-editor% tlw init-url progress post-data remap-url)
(let* ([c (make-channel)] (let* ([c (make-channel)]
[progs (make-channel)] [progs (make-channel)]
[sent-prog? #f] [sent-prog? #f]
@ -821,13 +823,13 @@ A test case:
(progress #f)) (progress #f))
ans)) ans))
;; make-editor/follow-redirections : editor-class frame%-instance ;; make-editor/follow-redirections : editor-class frame%-instance
;; url (boolean??? -> void) ??? (url -> (union port #f url)) ;; url (boolean??? -> void) ??? (url -> (union port #f url))
;; -> (cons (union #f editor) (union #f url)) ;; -> (cons (union #f editor) (union #f url))
;; builds an html editor using make-editor and follows any redictions, ;; builds an html editor using make-editor and follows any redictions,
;; but stops after 10 redirections (just in case there are too many ;; but stops after 10 redirections (just in case there are too many
;; of these things, give the user a chance to stop) ;; of these things, give the user a chance to stop)
(define (make-editor/follow-redirections html-editor% tlw init-url progress post-data remap-url) (define (make-editor/follow-redirections html-editor% tlw init-url progress post-data remap-url)
(with-handlers ([(lambda (x) (with-handlers ([(lambda (x)
(or (exn:file-saved-instead? x) (or (exn:file-saved-instead? x)
(exn:cancelled? x) (exn:cancelled? x)
@ -861,9 +863,9 @@ A test case:
(cons html-editor url)])) (cons html-editor url)]))
#f))))) #f)))))
(define hyper-canvas% (hyper-canvas-mixin canvas:basic%)) (define hyper-canvas% (hyper-canvas-mixin canvas:basic%))
(define info-canvas% (define info-canvas%
(class canvas% (class canvas%
(inherit min-client-height get-dc stretchable-height (inherit min-client-height get-dc stretchable-height
get-parent enable refresh show) get-parent enable refresh show)
@ -899,7 +901,7 @@ A test case:
(let-values ([(w h d a) (send dc get-text-extent "X" font)]) (let-values ([(w h d a) (send dc get-text-extent "X" font)])
(min-client-height (+ 4 (inexact->exact (ceiling h)))))))) (min-client-height (+ 4 (inexact->exact (ceiling h))))))))
(define hyper-panel<%> (define hyper-panel<%>
(interface () (interface ()
current-page current-page
rewind rewind
@ -924,7 +926,7 @@ A test case:
enable-browsing)) enable-browsing))
(define hyper-panel-mixin (define hyper-panel-mixin
(mixin (area-container<%>) (hyper-panel<%>) (mixin (area-container<%>) (hyper-panel<%>)
(init info-line?) (init info-line?)
(inherit reflow-container) (inherit reflow-container)
@ -1120,14 +1122,14 @@ A test case:
(send hp stretchable-height #f)) (send hp stretchable-height #f))
(update-buttons/set-page #f))) (update-buttons/set-page #f)))
(define hyper-panel% (hyper-panel-mixin vertical-panel%)) (define hyper-panel% (hyper-panel-mixin vertical-panel%))
(define hyper-frame<%> (define hyper-frame<%>
(interface () (interface ()
get-hyper-panel get-hyper-panel
get-hyper-panel%)) get-hyper-panel%))
(define hyper-no-show-frame-mixin (define hyper-no-show-frame-mixin
(mixin (frame:status-line<%>) (hyper-frame<%>) (mixin (frame:status-line<%>) (hyper-frame<%>)
(field [p #f]) (field [p #f])
(define/public get-hyper-panel% (lambda () hyper-panel%)) (define/public get-hyper-panel% (lambda () hyper-panel%))
@ -1136,25 +1138,25 @@ A test case:
(super-instantiate ()) (super-instantiate ())
(set! p (make-object (get-hyper-panel%) #f (get-area-container))))) (set! p (make-object (get-hyper-panel%) #f (get-area-container)))))
(define hyper-frame-mixin (define hyper-frame-mixin
(compose (let ([m (mixin (hyper-frame<%> top-level-window<%>) ()
(mixin (hyper-frame<%> top-level-window<%>) ()
(init start-url) (init start-url)
(inherit show get-hyper-panel) (inherit show get-hyper-panel)
(super-instantiate ()) (super-instantiate ())
(show #t) (show #t)
(send (send (get-hyper-panel) get-canvas) goto-url start-url #f)) (send (send (get-hyper-panel) get-canvas) goto-url start-url #f))])
hyper-no-show-frame-mixin)) (lambda (%)
(hyper-no-show-frame-mixin (m %)))))
(define hyper-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%))) (define hyper-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%)))
(define hyper-no-show-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%))) (define hyper-no-show-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%)))
(define (editor->page e) (list e 0 0)) (define (editor->page e) (list e 0 0))
(define (page->editor e) (car e)) (define (page->editor e) (car e))
(define (same-page? a b) (define (same-page? a b)
(eq? (car a) (car b))) (eq? (car a) (car b)))
(define (open-url file) (define (open-url file)
(make-object hyper-frame% file (string-constant browser) #f 500 450)) (make-object hyper-frame% file (string-constant browser) #f 500 450))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,34 +1,34 @@
#lang scheme/unit #lang scheme/unit
(require (lib "mred-sig.ss" "mred") (require (lib "mred-sig.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "class100.ss") (lib "class100.ss")
(lib "list.ss") (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
"turtle-sig.ss") "turtle-sig.ss")
(import [prefix mred: mred^]) (import [prefix mred: mred^])
(export turtle^) (export turtle^)
(init-depend mred^) (init-depend mred^)
(define turtles:window #f) (define turtles:window #f)
(define turtles:shown? #f) (define turtles:shown? #f)
(define pi 3.141592653589793) (define pi 3.141592653589793)
(define pi/2 (/ pi 2)) (define pi/2 (/ pi 2))
(define icon-pen (send mred:the-pen-list find-or-create-pen "SALMON" 1 'xor)) (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 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 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 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 b-pen (send mred:the-pen-list find-or-create-pen "black" 1 'solid))
(define show-turtle-icons? #t) (define show-turtle-icons? #t)
;; turtle-style : (union 'triangle 'line 'empty) ;; turtle-style : (union 'triangle 'line 'empty)
(define turtle-style 'triangle) (define turtle-style 'triangle)
(define plot-window% (define plot-window%
(class100 mred:frame% (name width height) (class100 mred:frame% (name width height)
(private-field (private-field
@ -148,7 +148,7 @@
(send canvas min-height height) (send canvas min-height height)
(send this clear)))) (send this clear))))
(define turtle-window-size (define turtle-window-size
(let-values ([(w h) (mred:get-display-size)] (let-values ([(w h) (mred:get-display-size)]
[(user/client-offset) 65] [(user/client-offset) 65]
[(default-size) 800]) [(default-size) 800])
@ -156,52 +156,52 @@
(- w user/client-offset) (- w user/client-offset)
(- h user/client-offset)))) (- h user/client-offset))))
(define-struct turtle (x y angle)) (define-struct turtle (x y angle))
; x : int ; x : int
; y: int ; y: int
; angle : int ; angle : int
(define-struct cached (turtles cache)) (define-struct cached (turtles cache))
; turtles : (list-of turtle) ; turtles : (list-of turtle)
; cache : turtle -> turtle ; cache : turtle -> turtle
(define-struct tree (children)) (define-struct tree (children))
; children : (list-of cached) ; children : (list-of cached)
(define clear-turtle (make-turtle (/ turtle-window-size 2) (define clear-turtle (make-turtle (/ turtle-window-size 2)
(/ turtle-window-size 2) 0)) (/ turtle-window-size 2) 0))
;; turtles-state is either a ;; turtles-state is either a
;; - (list-of turtle) or ;; - (list-of turtle) or
;; - tree ;; - tree
(define turtles-state (list clear-turtle)) (define turtles-state (list clear-turtle))
;; the cache contains a turtle-offset, which is represented ;; the cache contains a turtle-offset, which is represented
;; by a turtle -- but it is a delta not an absolute. ;; by a turtle -- but it is a delta not an absolute.
(define empty-cache (make-turtle 0 0 0)) (define empty-cache (make-turtle 0 0 0))
(define turtles-cache empty-cache) (define turtles-cache empty-cache)
(define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles)."))) (define init-error (lambda _ (error 'turtles "Turtles not initialized. Evaluate (turtles).")))
(define inner-line init-error) (define inner-line init-error)
(define inner-wipe-line init-error) (define inner-wipe-line init-error)
(define inner-clear-window init-error) (define inner-clear-window init-error)
(define inner-flip-icons init-error) (define inner-flip-icons init-error)
(define inner-save-turtle-bitmap init-error) (define inner-save-turtle-bitmap init-error)
(define line (define line
(lambda (a b c d) (lambda (a b c d)
(set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing)) (set! lines-in-drawing (cons (make-draw-line a b c d) lines-in-drawing))
(inner-line a b c d))) (inner-line a b c d)))
(define do-wipe-line (define do-wipe-line
(lambda (a b c d) (lambda (a b c d)
(set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing)) (set! lines-in-drawing (cons (make-wipe-line a b c d) lines-in-drawing))
(inner-wipe-line a b c d))) (inner-wipe-line a b c d)))
(define (flip-icons) (inner-flip-icons)) (define (flip-icons) (inner-flip-icons))
(define clear-window (lambda () (inner-clear-window))) (define clear-window (lambda () (inner-clear-window)))
(define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y))) (define save-turtle-bitmap (lambda (x y) (inner-save-turtle-bitmap x y)))
(define turtles (define turtles
(case-lambda (case-lambda
[() (turtles #t)] [() (turtles #t)]
[(x) [(x)
@ -220,23 +220,23 @@
(send turtles:window show x) (send turtles:window show x)
(send turtles:window get-canvas)])) (send turtles:window get-canvas)]))
(define clear (define clear
(lambda () (lambda ()
(set! turtles-cache empty-cache) (set! turtles-cache empty-cache)
(set! turtles-state (list clear-turtle)) (set! turtles-state (list clear-turtle))
(set! lines-in-drawing null) (set! lines-in-drawing null)
(clear-window))) (clear-window)))
;; cache elements: ;; cache elements:
(define-struct c-forward (distance)) (define-struct c-forward (distance))
(define-struct c-turn (angle)) (define-struct c-turn (angle))
(define-struct c-draw (distance)) (define-struct c-draw (distance))
(define-struct c-offset (x y)) (define-struct c-offset (x y))
;; combines a cache-element and a turtle-offset. ;; combines a cache-element and a turtle-offset.
;; turtle-offsets are represented as turtles, ;; turtle-offsets are represented as turtles,
;; however they are deltas, not absolutes. ;; however they are deltas, not absolutes.
(define combine (define combine
(lambda (entry cache) (lambda (entry cache)
(cond (cond
[(c-forward? entry) [(c-forward? entry)
@ -262,10 +262,10 @@
[else [else
(error 'turtles-cache "illegal entry in cache: ~a" entry)]))) (error 'turtles-cache "illegal entry in cache: ~a" entry)])))
;; this applies an offset to a turtle. ;; this applies an offset to a turtle.
;; an offset is a turtle, representing what would happen ;; an offset is a turtle, representing what would happen
;; if the turtle had started at zero. ;; if the turtle had started at zero.
(define apply-cache (define apply-cache
(lambda (offset) (lambda (offset)
(let ([x (turtle-x offset)] (let ([x (turtle-x offset)]
[y (turtle-y offset)] [y (turtle-y offset)]
@ -280,7 +280,7 @@
(+ ry (turtle-y turtle)) (+ ry (turtle-y turtle))
(+ offset-angle angle)))))))) (+ offset-angle angle))))))))
(define flatten (define flatten
(lambda (at-end) (lambda (at-end)
(letrec ([walk-turtles (letrec ([walk-turtles
(lambda (turtles cache list) (lambda (turtles cache list)
@ -300,7 +300,7 @@
(set! turtles-state (walk-turtles turtles-state turtles-cache null)) (set! turtles-state (walk-turtles turtles-state turtles-cache null))
(set! turtles-cache empty-cache)))) (set! turtles-cache empty-cache))))
(define draw/erase (define draw/erase
(lambda (doit) (lambda (doit)
(lambda (n) (lambda (n)
(flip-icons) (flip-icons)
@ -322,32 +322,32 @@
(make-turtle newx newy angle)))) (make-turtle newx newy angle))))
(flip-icons)))) (flip-icons))))
(define draw (draw/erase (lambda (a b c d) (line a b c d)))) (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 erase (draw/erase (lambda (a b c d) (do-wipe-line a b c d))))
(define move (define move
(lambda (n) (lambda (n)
(flip-icons) (flip-icons)
(set! turtles-cache (combine (make-c-forward n) turtles-cache)) (set! turtles-cache (combine (make-c-forward n) turtles-cache))
(flip-icons))) (flip-icons)))
(define turn/radians (define turn/radians
(lambda (d) (lambda (d)
(flip-icons) (flip-icons)
(set! turtles-cache (combine (make-c-turn d) turtles-cache)) (set! turtles-cache (combine (make-c-turn d) turtles-cache))
(flip-icons))) (flip-icons)))
(define turn (define turn
(lambda (c) (lambda (c)
(turn/radians (* (/ c 360) 2 pi)))) (turn/radians (* (/ c 360) 2 pi))))
(define move-offset (define move-offset
(lambda (x y) (lambda (x y)
(flip-icons) (flip-icons)
(set! turtles-cache (combine (make-c-offset x y) turtles-cache)) (set! turtles-cache (combine (make-c-offset x y) turtles-cache))
(flip-icons))) (flip-icons)))
(define erase/draw-offset (define erase/draw-offset
(lambda (doit) (lambda (doit)
(lambda (x y) (lambda (x y)
(flip-icons) (flip-icons)
@ -361,10 +361,10 @@
(make-turtle newx newy (turtle-angle turtle))))) (make-turtle newx newy (turtle-angle turtle)))))
(flip-icons)))) (flip-icons))))
(define erase-offset (erase/draw-offset (lambda (a b c d) (do-wipe-line a b c d)))) (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 draw-offset (erase/draw-offset (lambda (a b c d) (line a b c d))))
(define splitfn (define splitfn
(lambda (e) (lambda (e)
(let ([t turtles-state] (let ([t turtles-state]
[c turtles-cache]) [c turtles-cache])
@ -376,7 +376,7 @@
(set! turtles-cache empty-cache) (set! turtles-cache empty-cache)
(flip-icons)))) (flip-icons))))
(define split*fn (define split*fn
(lambda (es) (lambda (es)
(let ([t turtles-state] (let ([t turtles-state]
[c turtles-cache] [c turtles-cache]
@ -395,7 +395,7 @@
(flip-icons)))) (flip-icons))))
(define tpromptfn (define tpromptfn
(lambda (thunk) (lambda (thunk)
(let ([save-turtles-cache #f] (let ([save-turtles-cache #f]
[save-turtles-state #f]) [save-turtles-state #f])
@ -412,12 +412,12 @@
(flip-icons)))))) (flip-icons))))))
(define-struct drawing-line (x1 y1 x2 y2)) (define-struct drawing-line (x1 y1 x2 y2))
(define-struct (wipe-line drawing-line) ()) (define-struct (wipe-line drawing-line) ())
(define-struct (draw-line drawing-line) ()) (define-struct (draw-line drawing-line) ())
(define lines-in-drawing null) (define lines-in-drawing null)
(define (draw-lines-into-dc dc) (define (draw-lines-into-dc dc)
(for-each (lambda (line) (for-each (lambda (line)
(cond (cond
[(wipe-line? line) (send dc set-pen w-pen)] [(wipe-line? line) (send dc set-pen w-pen)]
@ -429,8 +429,8 @@
(drawing-line-y2 line))) (drawing-line-y2 line)))
lines-in-drawing)) lines-in-drawing))
;; used to test printing ;; used to test printing
(define (display-lines-in-drawing) (define (display-lines-in-drawing)
(let* ([lines-in-drawing-canvas% (let* ([lines-in-drawing-canvas%
(class100 mred:canvas% (frame) (class100 mred:canvas% (frame)
(inherit get-dc) (inherit get-dc)
@ -445,7 +445,7 @@
(send frame show #t))) (send frame show #t)))
(define (print) (define (print)
(case (system-type) (case (system-type)
[(macos macosx windows) [(macos macosx windows)
(let ([dc (make-object mred:printer-dc%)]) (let ([dc (make-object mred:printer-dc%)])

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

@ -1,9 +1,7 @@
#lang scheme/unit #lang scheme/unit
(require (lib "file.ss") (require scheme/file
(lib "string.ss")
(lib "etc.ss")
(lib "compile-sig.ss" "dynext") (lib "compile-sig.ss" "dynext")
(lib "link-sig.ss" "dynext") (lib "link-sig.ss" "dynext")
@ -15,11 +13,11 @@
(lib "winutf16.ss" "compiler" "private")) (lib "winutf16.ss" "compiler" "private"))
(import (prefix c: dynext:compile^) (import (prefix c: dynext:compile^)
(prefix l: dynext:link^)) (prefix l: dynext:link^))
(export launcher^) (export launcher^)
(define current-launcher-variant (define current-launcher-variant
(make-parameter (system-type 'gc) (make-parameter (system-type 'gc)
(lambda (v) (lambda (v)
(unless (memq v '(3m script-3m cgc script-cgc)) (unless (memq v '(3m script-3m cgc script-cgc))
@ -29,7 +27,7 @@
v)) v))
v))) v)))
(define (variant-available? kind cased-kind-name variant) (define (variant-available? kind cased-kind-name variant)
(cond (cond
[(or (eq? 'unix (system-type)) [(or (eq? 'unix (system-type))
(and (eq? 'macosx (system-type)) (and (eq? 'macosx (system-type))
@ -54,7 +52,7 @@
(variant-suffix variant #t))))] (variant-suffix variant #t))))]
[else (error "unknown system type")])) [else (error "unknown system type")]))
(define (available-variants kind) (define (available-variants kind)
(let* ([cased-kind-name (if (eq? kind 'mzscheme) (let* ([cased-kind-name (if (eq? kind 'mzscheme)
"MzScheme" "MzScheme"
"MrEd")] "MrEd")]
@ -83,13 +81,13 @@
null)]) null)])
(append normal alt script script-alt))) (append normal alt script script-alt)))
(define (available-mred-variants) (define (available-mred-variants)
(available-variants 'mred)) (available-variants 'mred))
(define (available-mzscheme-variants) (define (available-mzscheme-variants)
(available-variants 'mzscheme)) (available-variants 'mzscheme))
(define (install-template dest kind mz mr) (define (install-template dest kind mz mr)
(define src (build-path (collection-path "launcher") (define src (build-path (collection-path "launcher")
(if (eq? kind 'mzscheme) mz mr))) (if (eq? kind 'mzscheme) mz mr)))
(when (or (file-exists? dest) (when (or (file-exists? dest)
@ -98,10 +96,10 @@
(delete-directory/files dest)) (delete-directory/files dest))
(copy-file src dest)) (copy-file src dest))
(define (script-variant? v) (define (script-variant? v)
(memq v '(script-3m script-cgc))) (memq v '(script-3m script-cgc)))
(define (add-file-suffix path variant mred?) (define (add-file-suffix path variant mred?)
(let ([s (variant-suffix variant (case (system-type) (let ([s (variant-suffix variant (case (system-type)
[(unix) #f] [(unix) #f]
[(windows) #t] [(windows) #t]
@ -115,7 +113,7 @@
(format "~a.exe" s))) (format "~a.exe" s)))
(path-replace-suffix path (string->bytes/utf-8 s)))))) (path-replace-suffix path (string->bytes/utf-8 s))))))
(define (string-append/spaces f flags) (define (string-append/spaces f flags)
(if (null? flags) (if (null? flags)
"" ""
(string-append (string-append
@ -123,7 +121,7 @@
" " " "
(string-append/spaces f (cdr flags))))) (string-append/spaces f (cdr flags)))))
(define (str-list->sh-str flags) (define (str-list->sh-str flags)
(letrec ([trans (letrec ([trans
(lambda (s) (lambda (s)
(cond (cond
@ -135,7 +133,7 @@
[else (format "'~a'" s)]))]) [else (format "'~a'" s)]))])
(string-append/spaces trans flags))) (string-append/spaces trans flags)))
(define (str-list->dos-str flags) (define (str-list->dos-str flags)
(letrec ([trans (letrec ([trans
(lambda (s) (lambda (s)
(if (or (regexp-match (string #\[ #\space #\newline #\tab #\return #\vtab #\]) s) (if (or (regexp-match (string #\[ #\space #\newline #\tab #\return #\vtab #\]) s)
@ -161,7 +159,7 @@
s))]) s))])
(string-append/spaces trans flags))) (string-append/spaces trans flags)))
(define one-arg-x-flags '((xa "-display") (define one-arg-x-flags '((xa "-display")
(xb "-geometry") (xb "-geometry")
(xc "-bg" "-background") (xc "-bg" "-background")
(xd "-fg" "-foregound") (xd "-fg" "-foregound")
@ -171,13 +169,13 @@
(xh "-title") (xh "-title")
(xi "-xnllanguage") (xi "-xnllanguage")
(xj "-xrm"))) (xj "-xrm")))
(define no-arg-x-flags '((xk "-iconic") (define no-arg-x-flags '((xk "-iconic")
(xl "-rv" "-reverse") (xl "-rv" "-reverse")
(xm "+rv") (xm "+rv")
(xn "-synchronous") (xn "-synchronous")
(xo "-singleInstance"))) (xo "-singleInstance")))
(define (skip-x-flags flags) (define (skip-x-flags flags)
(let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))]) (let ([xfmem (lambda (flag) (lambda (xf) (member flag (cdr xf))))])
(let loop ([f flags]) (let loop ([f flags])
(if (null? f) (if (null? f)
@ -190,7 +188,7 @@
(loop (cdr f)) (loop (cdr f))
f)))))) f))))))
(define (output-x-arg-getter exec args) (define (output-x-arg-getter exec args)
(let ([or-flags (let ([or-flags
(lambda (l) (lambda (l)
(if (null? (cdr l)) (if (null? (cdr l))
@ -244,14 +242,14 @@
no-arg-x-flags))) no-arg-x-flags)))
args)))))) args))))))
(define (protect-shell-string s) (define (protect-shell-string s)
(regexp-replace* (regexp-replace*
#rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&")) #rx"[\"`'$\\]" (if (path? s) (path->string s) s) "\\\\&"))
(define (normalize+explode-path p) (define (normalize+explode-path p)
(explode-path (normal-case-path (normalize-path p)))) (explode-path (normal-case-path (normalize-path p))))
(define (relativize bindir-explode dest-explode) (define (relativize bindir-explode dest-explode)
(let loop ([b bindir-explode] [d dest-explode]) (let loop ([b bindir-explode] [d dest-explode])
(if (and (pair? b) (equal? (car b) (car d))) (if (and (pair? b) (equal? (car b) (car d)))
(loop (cdr b) (cdr d)) (loop (cdr b) (cdr d))
@ -260,7 +258,7 @@
#f #f
(apply build-path p)))))) (apply build-path p))))))
(define (make-relative-path-header dest bindir) (define (make-relative-path-header dest bindir)
;; rely only on binaries in /usr/bin:/bin ;; rely only on binaries in /usr/bin:/bin
(define (has-exe? exe) (define (has-exe? exe)
(or (file-exists? (build-path "/usr/bin" exe)) (or (file-exists? (build-path "/usr/bin" exe))
@ -322,10 +320,10 @@
;; fallback to absolute path header ;; fallback to absolute path header
(make-absolute-path-header bindir)))) (make-absolute-path-header bindir))))
(define (make-absolute-path-header bindir) (define (make-absolute-path-header bindir)
(string-append "bindir=\""(protect-shell-string bindir)"\"\n")) (string-append "bindir=\""(protect-shell-string bindir)"\"\n"))
(define (make-unix-launcher kind variant flags dest aux) (define (make-unix-launcher kind variant flags dest aux)
(install-template dest kind "sh" "sh") ; just for something that's executable (install-template dest kind "sh" "sh") ; just for something that's executable
(let* ([alt-exe (let ([m (and (eq? kind 'mred) (let* ([alt-exe (let ([m (and (eq? kind 'mred)
(script-variant? variant) (script-variant? variant)
@ -379,6 +377,7 @@
(unless (find-console-bin-dir) (unless (find-console-bin-dir)
(error 'make-unix-launcher "unable to locate bin directory")) (error 'make-unix-launcher "unable to locate bin directory"))
(with-output-to-file dest (with-output-to-file dest
#:exists 'truncate
(lambda () (lambda ()
(display header) (display header)
(newline) (newline)
@ -388,15 +387,14 @@
(display dir-finder) (display dir-finder)
(display "# }}} bindir\n") (display "# }}} bindir\n")
(newline) (newline)
(display (assemble-exec exec args))) (display (assemble-exec exec args))))))
'truncate)))
(define (utf-16-regexp b) (define (utf-16-regexp b)
(byte-regexp (bytes-append (bytes->utf-16-bytes b) (byte-regexp (bytes-append (bytes->utf-16-bytes b)
#"[^>]*" #"[^>]*"
(bytes->utf-16-bytes #">")))) (bytes->utf-16-bytes #">"))))
(define (make-windows-launcher kind variant flags dest aux) (define (make-windows-launcher kind variant flags dest aux)
(if (not (and (let ([m (assq 'independent? aux)]) (if (not (and (let ([m (assq 'independent? aux)])
(and m (cdr m))))) (and m (cdr m)))))
;; Normal launcher: ;; Normal launcher:
@ -481,10 +479,10 @@
(write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes))) (write-magic p suffix-bytes pos-variant (bytes-length suffix-bytes)))
(close-output-port p))))))) (close-output-port p)))))))
;; OS X launcher code: ;; OS X launcher code:
; make-macosx-launcher : symbol (listof str) pathname -> ; make-macosx-launcher : symbol (listof str) pathname ->
(define (make-macosx-launcher kind variant flags dest aux) (define (make-macosx-launcher kind variant flags dest aux)
(if (or (eq? kind 'mzscheme) (if (or (eq? kind 'mzscheme)
(script-variant? variant)) (script-variant? variant))
;; MzScheme or script launcher is the same as for Unix ;; MzScheme or script launcher is the same as for Unix
@ -497,7 +495,7 @@
#t #t
variant))) variant)))
(define (make-macos-launcher kind variant flags dest aux) (define (make-macos-launcher kind variant flags dest aux)
(install-template dest kind "GoMr" "GoMr") (install-template dest kind "GoMr" "GoMr")
(let ([p (open-input-file dest)]) (let ([p (open-input-file dest)])
(let ([m (regexp-match-positions #rx#"<Insert offset here>" p)]) (let ([m (regexp-match-positions #rx#"<Insert offset here>" p)])
@ -522,27 +520,27 @@
(display str p) (display str p)
(close-output-port p)))))) (close-output-port p))))))
(define (get-maker) (define (get-maker)
(case (system-type) (case (system-type)
[(unix) make-unix-launcher] [(unix) make-unix-launcher]
[(windows) make-windows-launcher] [(windows) make-windows-launcher]
[(macos) make-macos-launcher] [(macos) make-macos-launcher]
[(macosx) make-macosx-launcher])) [(macosx) make-macosx-launcher]))
(define make-mred-launcher (define make-mred-launcher
(opt-lambda (flags dest [aux null]) (lambda (flags dest [aux null])
(let ([variant (current-launcher-variant)]) (let ([variant (current-launcher-variant)])
((get-maker) 'mred variant flags dest aux)))) ((get-maker) 'mred variant flags dest aux))))
(define make-mzscheme-launcher (define make-mzscheme-launcher
(opt-lambda (flags dest [aux null]) (lambda (flags dest [aux null])
(let ([variant (current-launcher-variant)]) (let ([variant (current-launcher-variant)])
((get-maker) 'mzscheme variant flags dest aux)))) ((get-maker) 'mzscheme variant flags dest aux))))
(define (strip-suffix s) (define (strip-suffix s)
(path-replace-suffix s #"")) (path-replace-suffix s #""))
(define (build-aux-from-path aux-root) (define (build-aux-from-path aux-root)
(let ([aux-root (if (string? aux-root) (let ([aux-root (if (string? aux-root)
(string->path aux-root) (string->path aux-root)
aux-root)]) aux-root)])
@ -588,21 +586,21 @@
(cons 'file-types d) (cons 'file-types d)
(cons 'resource-files icon-files)))))))))))))) (cons 'resource-files icon-files))))))))))))))
(define (make-mred-program-launcher file collection dest) (define (make-mred-program-launcher file collection dest)
(make-mred-launcher (list "-mqvL" file collection "--") (make-mred-launcher (list "-mqvL" file collection "--")
dest dest
(build-aux-from-path (build-aux-from-path
(build-path (collection-path collection) (build-path (collection-path collection)
(strip-suffix file))))) (strip-suffix file)))))
(define (make-mzscheme-program-launcher file collection dest) (define (make-mzscheme-program-launcher file collection dest)
(make-mzscheme-launcher (list "-mqvL" file collection "--") (make-mzscheme-launcher (list "-mqvL" file collection "--")
dest dest
(build-aux-from-path (build-aux-from-path
(build-path (collection-path collection) (build-path (collection-path collection)
(strip-suffix file))))) (strip-suffix file)))))
(define (unix-sfx file mred?) (define (unix-sfx file mred?)
(list->string (list->string
(map (map
(lambda (c) (lambda (c)
@ -611,14 +609,14 @@
(char-downcase c))) (char-downcase c)))
(string->list file)))) (string->list file))))
(define (sfx file mred?) (define (sfx file mred?)
(case (system-type) (case (system-type)
[(unix) (unix-sfx file mred?)] [(unix) (unix-sfx file mred?)]
[(windows) (string-append (if mred? file (unix-sfx file mred?)) [(windows) (string-append (if mred? file (unix-sfx file mred?))
".exe")] ".exe")]
[else file])) [else file]))
(define (program-launcher-path name mred?) (define (program-launcher-path name mred?)
(let* ([variant (current-launcher-variant)] (let* ([variant (current-launcher-variant)]
[mac-script? (and (eq? (system-type) 'macosx) [mac-script? (and (eq? (system-type) 'macosx)
(script-variant? variant))]) (script-variant? variant))])
@ -635,10 +633,10 @@
(path-replace-suffix p #".app") (path-replace-suffix p #".app")
p)))) p))))
(define (mred-program-launcher-path name) (define (mred-program-launcher-path name)
(program-launcher-path name #t)) (program-launcher-path name #t))
(define (mzscheme-program-launcher-path name) (define (mzscheme-program-launcher-path name)
(case (system-type) (case (system-type)
[(macosx) (add-file-suffix [(macosx) (add-file-suffix
(build-path (find-console-bin-dir) (unix-sfx name #f)) (build-path (find-console-bin-dir) (unix-sfx name #f))
@ -646,49 +644,49 @@
#f)] #f)]
[else (program-launcher-path name #f)])) [else (program-launcher-path name #f)]))
(define (mred-launcher-is-directory?) (define (mred-launcher-is-directory?)
#f) #f)
(define (mzscheme-launcher-is-directory?) (define (mzscheme-launcher-is-directory?)
#f) #f)
(define (mred-launcher-is-actually-directory?) (define (mred-launcher-is-actually-directory?)
(and (eq? 'macosx (system-type)) (and (eq? 'macosx (system-type))
(not (script-variant? (current-launcher-variant))))) (not (script-variant? (current-launcher-variant)))))
(define (mzscheme-launcher-is-actually-directory?) (define (mzscheme-launcher-is-actually-directory?)
#f) #f)
;; Helper: ;; Helper:
(define (put-file-extension+style+filters type) (define (put-file-extension+style+filters type)
(case type (case type
[(windows) (values "exe" null '(("Executable" "*.exe")))] [(windows) (values "exe" null '(("Executable" "*.exe")))]
[(macosx) (values "app" '(packages) '(("App" "*.app")))] [(macosx) (values "app" '(packages) '(("App" "*.app")))]
[else (values #f null null)])) [else (values #f null null)]))
(define (mred-launcher-add-suffix path) (define (mred-launcher-add-suffix path)
(embedding-executable-add-suffix path #t)) (embedding-executable-add-suffix path #t))
(define (mzscheme-launcher-add-suffix path) (define (mzscheme-launcher-add-suffix path)
(embedding-executable-add-suffix path #f)) (embedding-executable-add-suffix path #f))
(define (mred-launcher-put-file-extension+style+filters) (define (mred-launcher-put-file-extension+style+filters)
(put-file-extension+style+filters (put-file-extension+style+filters
(if (and (eq? 'macosx (system-type)) (if (and (eq? 'macosx (system-type))
(script-variant? (current-launcher-variant))) (script-variant? (current-launcher-variant)))
'unix 'unix
(system-type)))) (system-type))))
(define (mzscheme-launcher-put-file-extension+style+filters) (define (mzscheme-launcher-put-file-extension+style+filters)
(put-file-extension+style+filters (put-file-extension+style+filters
(if (eq? 'macosx (system-type)) (if (eq? 'macosx (system-type))
'unix 'unix
(system-type)))) (system-type))))
(define mred-launcher-up-to-date? (define mred-launcher-up-to-date?
(opt-lambda (dest [aux null]) (lambda (dest [aux null])
(mzscheme-launcher-up-to-date? dest aux))) (mzscheme-launcher-up-to-date? dest aux)))
(define mzscheme-launcher-up-to-date? (define mzscheme-launcher-up-to-date?
(opt-lambda (dest [aux null]) (lambda (dest [aux null])
(cond (cond
;; When running Setup PLT under Windows, the ;; When running Setup PLT under Windows, the
;; launcher process stays running until MzScheme ;; launcher process stays running until MzScheme
@ -705,8 +703,8 @@
;; launchers. ;; launchers.
[else #f]))) [else #f])))
(define (install-mred-program-launcher file collection name) (define (install-mred-program-launcher file collection name)
(make-mred-program-launcher file collection (mred-program-launcher-path name))) (make-mred-program-launcher file collection (mred-program-launcher-path name)))
(define (install-mzscheme-program-launcher file collection name) (define (install-mzscheme-program-launcher file collection name)
(make-mzscheme-program-launcher file collection (mzscheme-program-launcher-path name))) (make-mzscheme-program-launcher file collection (mzscheme-program-launcher-path name)))

15
collects/mzlib/cm.ss
View File

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

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

@ -1,13 +1,12 @@
#lang scheme/unit #lang scheme/unit
(require "base64-sig.ss") (require "base64-sig.ss")
(import) (import)
(export base64^) (export base64^)
(define base64-digit (make-vector 256)) (define base64-digit (make-vector 256))
(let loop ([n 0]) (let loop ([n 0])
(unless (= n 256) (unless (= n 256)
(cond [(<= (char->integer #\A) n (char->integer #\Z)) (cond [(<= (char->integer #\A) n (char->integer #\Z))
(vector-set! base64-digit n (- n (char->integer #\A)))] (vector-set! base64-digit n (- n (char->integer #\A)))]
@ -23,25 +22,25 @@
(vector-set! base64-digit n #f)]) (vector-set! base64-digit n #f)])
(loop (add1 n)))) (loop (add1 n))))
(define digit-base64 (make-vector 64)) (define digit-base64 (make-vector 64))
(define (each-char s e pos) (define (each-char s e pos)
(let loop ([i (char->integer s)][pos pos]) (let loop ([i (char->integer s)][pos pos])
(unless (> i (char->integer e)) (unless (> i (char->integer e))
(vector-set! digit-base64 pos i) (vector-set! digit-base64 pos i)
(loop (add1 i) (add1 pos))))) (loop (add1 i) (add1 pos)))))
(each-char #\A #\Z 0) (each-char #\A #\Z 0)
(each-char #\a #\z 26) (each-char #\a #\z 26)
(each-char #\0 #\9 52) (each-char #\0 #\9 52)
(each-char #\+ #\+ 62) (each-char #\+ #\+ 62)
(each-char #\/ #\/ 63) (each-char #\/ #\/ 63)
(define (base64-filename-safe) (define (base64-filename-safe)
(vector-set! base64-digit (char->integer #\-) 62) (vector-set! base64-digit (char->integer #\-) 62)
(vector-set! base64-digit (char->integer #\_) 63) (vector-set! base64-digit (char->integer #\_) 63)
(each-char #\- #\- 62) (each-char #\- #\- 62)
(each-char #\_ #\_ 63)) (each-char #\_ #\_ 63))
(define (base64-decode-stream in out) (define (base64-decode-stream in out)
(let loop ([waiting 0][waiting-bits 0]) (let loop ([waiting 0][waiting-bits 0])
(if (>= waiting-bits 8) (if (>= waiting-bits 8)
(begin (begin
@ -57,7 +56,7 @@
[(eq? c (char->integer #\=)) (void)] ; done [(eq? c (char->integer #\=)) (void)] ; done
[else (loop waiting waiting-bits)]))))) [else (loop waiting waiting-bits)])))))
(define base64-encode-stream (define base64-encode-stream
(case-lambda (case-lambda
[(in out) (base64-encode-stream in out #"\n")] [(in out) (base64-encode-stream in out #"\n")]
[(in out linesep) [(in out linesep)
@ -124,12 +123,12 @@
(outc (bitwise-and #x3f c)) (outc (bitwise-and #x3f c))
(loop (+ pos 4))))))))])))))])) (loop (+ pos 4))))))))])))))]))
(define (base64-decode src) (define (base64-decode src)
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(base64-decode-stream (open-input-bytes src) s) (base64-decode-stream (open-input-bytes src) s)
(get-output-bytes s))) (get-output-bytes s)))
(define (base64-encode src) (define (base64-encode src)
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(base64-encode-stream (open-input-bytes src) s (bytes 13 10)) (base64-encode-stream (open-input-bytes src) s (bytes 13 10))
(get-output-bytes s))) (get-output-bytes s)))

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,57 +1,57 @@
#lang scheme/unit #lang scheme/unit
(require (lib "etc.ss") "nntp-sig.ss") (require scheme/tcp "nntp-sig.ss")
(import) (import)
(export nntp^) (export nntp^)
;; sender : oport ;; sender : oport
;; receiver : iport ;; receiver : iport
;; server : string ;; server : string
;; port : number ;; port : number
(define-struct communicator (sender receiver server port)) (define-struct communicator (sender receiver server port))
;; code : number ;; code : number
;; text : string ;; text : string
;; line : string ;; line : string
;; communicator : communicator ;; communicator : communicator
;; group : string ;; group : string
;; article : number ;; article : number
(define-struct (nntp exn) ()) (define-struct (nntp exn) ())
(define-struct (unexpected-response nntp) (code text)) (define-struct (unexpected-response nntp) (code text))
(define-struct (bad-status-line nntp) (line)) (define-struct (bad-status-line nntp) (line))
(define-struct (premature-close nntp) (communicator)) (define-struct (premature-close nntp) (communicator))
(define-struct (bad-newsgroup-line nntp) (line)) (define-struct (bad-newsgroup-line nntp) (line))
(define-struct (non-existent-group nntp) (group)) (define-struct (non-existent-group nntp) (group))
(define-struct (article-not-in-group nntp) (article)) (define-struct (article-not-in-group nntp) (article))
(define-struct (no-group-selected nntp) ()) (define-struct (no-group-selected nntp) ())
(define-struct (article-not-found nntp) (article)) (define-struct (article-not-found nntp) (article))
(define-struct (authentication-rejected nntp) ()) (define-struct (authentication-rejected nntp) ())
;; signal-error : ;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... -> ;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> () ;; exn-args -> ()
;; - throws an exception ;; - throws an exception
(define (signal-error constructor format-string . args) (define (signal-error constructor format-string . args)
(lambda exn-args (lambda exn-args
(raise (apply constructor (raise (apply constructor
(apply format format-string args) (apply format format-string args)
(current-continuation-marks) (current-continuation-marks)
exn-args)))) exn-args))))
;; default-nntpd-port-number : ;; default-nntpd-port-number :
;; number ;; number
(define default-nntpd-port-number 119) (define default-nntpd-port-number 119)
;; connect-to-server*: ;; connect-to-server*:
;; input-port output-port -> communicator ;; input-port output-port -> communicator
(define connect-to-server* (define connect-to-server*
(case-lambda (case-lambda
[(receiver sender) [(receiver sender)
(connect-to-server* receiver sender "unspecified" "unspecified")] (connect-to-server* receiver sender "unspecified" "unspecified")]
@ -68,26 +68,26 @@
code response) code response)
code response)])))])) code response)])))]))
;; connect-to-server : ;; connect-to-server :
;; string [x number] -> commnicator ;; string [x number] -> commnicator
(define connect-to-server (define connect-to-server
(opt-lambda (server-name (port-number default-nntpd-port-number)) (lambda (server-name (port-number default-nntpd-port-number))
(let-values ([(receiver sender) (let-values ([(receiver sender)
(tcp-connect server-name port-number)]) (tcp-connect server-name port-number)])
(connect-to-server* receiver sender server-name port-number)))) (connect-to-server* receiver sender server-name port-number))))
;; close-communicator : ;; close-communicator :
;; communicator -> () ;; communicator -> ()
(define (close-communicator communicator) (define (close-communicator communicator)
(close-input-port (communicator-receiver communicator)) (close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))) (close-output-port (communicator-sender communicator)))
;; disconnect-from-server : ;; disconnect-from-server :
;; communicator -> () ;; communicator -> ()
(define (disconnect-from-server communicator) (define (disconnect-from-server communicator)
(send-to-server communicator "QUIT") (send-to-server communicator "QUIT")
(let-values ([(code response) (let-values ([(code response)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
@ -100,11 +100,11 @@
code response) code response)
code response)]))) code response)])))
;; authenticate-user : ;; authenticate-user :
;; communicator x user-name x password -> () ;; communicator x user-name x password -> ()
;; the password is not used if the server does not ask for it. ;; the password is not used if the server does not ask for it.
(define (authenticate-user communicator user password) (define (authenticate-user communicator user password)
(define (reject code response) (define (reject code response)
((signal-error make-authentication-rejected ((signal-error make-authentication-rejected
"authentication rejected (~s ~s)" "authentication rejected (~s ~s)"
@ -130,20 +130,20 @@
[else (reject code response) [else (reject code response)
(unexpected code response)]))) (unexpected code response)])))
;; send-to-server : ;; send-to-server :
;; communicator x format-string x list (values) -> () ;; communicator x format-string x list (values) -> ()
(define (send-to-server communicator message-template . rest) (define (send-to-server communicator message-template . rest)
(let ([sender (communicator-sender communicator)]) (let ([sender (communicator-sender communicator)])
(apply fprintf sender (apply fprintf sender
(string-append message-template "\r\n") (string-append message-template "\r\n")
rest) rest)
(flush-output sender))) (flush-output sender)))
;; parse-status-line : ;; parse-status-line :
;; string -> number x string ;; string -> number x string
(define (parse-status-line line) (define (parse-status-line line)
(if (eof-object? line) (if (eof-object? line)
((signal-error make-bad-status-line "eof instead of a status line") ((signal-error make-bad-status-line "eof instead of a status line")
line) line)
@ -154,24 +154,24 @@
(values (string->number (car match)) (values (string->number (car match))
(cadr match))))) (cadr match)))))
;; get-one-line-from-server : ;; get-one-line-from-server :
;; iport -> string ;; iport -> string
(define (get-one-line-from-server server->client-port) (define (get-one-line-from-server server->client-port)
(read-line server->client-port 'return-linefeed)) (read-line server->client-port 'return-linefeed))
;; get-single-line-response : ;; get-single-line-response :
;; communicator -> number x string ;; communicator -> number x string
(define (get-single-line-response communicator) (define (get-single-line-response communicator)
(let* ([receiver (communicator-receiver communicator)] (let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]) [status-line (get-one-line-from-server receiver)])
(parse-status-line status-line))) (parse-status-line status-line)))
;; get-rest-of-multi-line-response : ;; get-rest-of-multi-line-response :
;; communicator -> list (string) ;; communicator -> list (string)
(define (get-rest-of-multi-line-response communicator) (define (get-rest-of-multi-line-response communicator)
(let ([receiver (communicator-receiver communicator)]) (let ([receiver (communicator-receiver communicator)])
(let loop () (let loop ()
(let ([l (get-one-line-from-server receiver)]) (let ([l (get-one-line-from-server receiver)])
@ -187,26 +187,26 @@
[else [else
(cons l (loop))]))))) (cons l (loop))])))))
;; get-multi-line-response : ;; get-multi-line-response :
;; communicator -> number x string x list (string) ;; communicator -> number x string x list (string)
;; -- The returned values are the status code, the rest of the status ;; -- The returned values are the status code, the rest of the status
;; response line, and the remaining lines. ;; response line, and the remaining lines.
(define (get-multi-line-response communicator) (define (get-multi-line-response communicator)
(let* ([receiver (communicator-receiver communicator)] (let* ([receiver (communicator-receiver communicator)]
[status-line (get-one-line-from-server receiver)]) [status-line (get-one-line-from-server receiver)])
(let-values ([(code rest-of-line) (let-values ([(code rest-of-line)
(parse-status-line status-line)]) (parse-status-line status-line)])
(values code rest-of-line (get-rest-of-multi-line-response))))) (values code rest-of-line (get-rest-of-multi-line-response)))))
;; open-news-group : ;; open-news-group :
;; communicator x string -> number x number x number ;; communicator x string -> number x number x number
;; -- The returned values are the number of articles, the first ;; -- The returned values are the number of articles, the first
;; article number, and the last article number for that group. ;; article number, and the last article number for that group.
(define (open-news-group communicator group-name) (define (open-news-group communicator group-name)
(send-to-server communicator "GROUP ~a" group-name) (send-to-server communicator "GROUP ~a" group-name)
(let-values ([(code rest-of-line) (let-values ([(code rest-of-line)
(get-single-line-response communicator)]) (get-single-line-response communicator)])
@ -235,10 +235,10 @@
"unexpected group opening response: ~s" code) "unexpected group opening response: ~s" code)
code rest-of-line)]))) code rest-of-line)])))
;; generic-message-command : ;; generic-message-command :
;; string x number -> communicator x (number U string) -> list (string) ;; string x number -> communicator x (number U string) -> list (string)
(define (generic-message-command command ok-code) (define (generic-message-command command ok-code)
(lambda (communicator message-index) (lambda (communicator message-index)
(send-to-server communicator (string-append command " ~a") (send-to-server communicator (string-append command " ~a")
(if (number? message-index) (if (number? message-index)
@ -265,28 +265,28 @@
"unexpected message access response: ~s" code) "unexpected message access response: ~s" code)
code response)]))))) code response)])))))
;; head-of-message : ;; head-of-message :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define head-of-message (define head-of-message
(generic-message-command "HEAD" 221)) (generic-message-command "HEAD" 221))
;; body-of-message : ;; body-of-message :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define body-of-message (define body-of-message
(generic-message-command "BODY" 222)) (generic-message-command "BODY" 222))
;; newnews-since : ;; newnews-since :
;; communicator x (number U string) -> list (string) ;; communicator x (number U string) -> list (string)
(define newnews-since (define newnews-since
(generic-message-command "NEWNEWS" 230)) (generic-message-command "NEWNEWS" 230))
;; make-desired-header : ;; make-desired-header :
;; string -> desired ;; string -> desired
(define (make-desired-header raw-header) (define (make-desired-header raw-header)
(regexp (regexp
(string-append (string-append
"^" "^"
@ -303,10 +303,10 @@
(string->list raw-header)))) (string->list raw-header))))
":"))) ":")))
;; extract-desired-headers : ;; extract-desired-headers :
;; list (string) x list (desired) -> list (string) ;; list (string) x list (desired) -> list (string)
(define (extract-desired-headers headers desireds) (define (extract-desired-headers headers desireds)
(let loop ([headers headers]) (let loop ([headers headers])
(if (null? headers) null (if (null? headers) null
(let ([first (car headers)] (let ([first (car headers)]

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

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

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

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

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

@ -1,22 +1,23 @@
#lang scheme/unit #lang scheme/unit
(require (lib "list.ss") (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(import) (require scheme/tcp "base64.ss" "smtp-sig.ss")
(export smtp^)
(define smtp-sending-server (make-parameter "localhost")) (import)
(export smtp^)
(define debug-via-stdio? #f) (define smtp-sending-server (make-parameter "localhost"))
(define (log . args) (define debug-via-stdio? #f)
(define (log . args)
;; (apply printf args) ;; (apply printf args)
(void)) (void))
(define (starts-with? l n) (define (starts-with? l n)
(and (>= (string-length l) (string-length n)) (and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n))))) (string=? n (substring l 0 (string-length n)))))
(define (check-reply/accum r v w a) (define (check-reply/accum r v w a)
(flush-output w) (flush-output w)
(let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))])
(log "server: ~a\n" l) (log "server: ~a\n" l)
@ -33,19 +34,19 @@
(when a (when a
(reverse (cons (substring l 4) a))))))))) (reverse (cons (substring l 4) a)))))))))
(define (check-reply/commands r v w . commands) (define (check-reply/commands r v w . commands)
;; drop the first response, which is just the flavor text -- we expect the rest to ;; drop the first response, which is just the flavor text -- we expect the rest to
;; be a list of supported ESMTP commands. ;; be a list of supported ESMTP commands.
(let ([cmdlist (rest (check-reply/accum r v w '()))]) (let ([cmdlist (cdr (check-reply/accum r v w '()))])
(for-each (lambda (c1) (for-each (lambda (c1)
(unless (findf (lambda (c2) (string=? c1 c2)) cmdlist) (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist)
(error "expected advertisement of ESMTP command ~a" c1))) (error "expected advertisement of ESMTP command ~a" c1)))
commands))) commands)))
(define (check-reply r v w) (define (check-reply r v w)
(check-reply/accum r v w #f)) (check-reply/accum r v w #f))
(define (protect-line l) (define (protect-line l)
;; If begins with a dot, add one more ;; If begins with a dot, add one more
(if (or (equal? l #"") (if (or (equal? l #"")
(equal? l "") (equal? l "")
@ -58,7 +59,7 @@
(bytes-append #"." l) (bytes-append #"." l)
(string-append "." l)))) (string-append "." l))))
(define smtp-sending-end-of-message (define smtp-sending-end-of-message
(make-parameter void (make-parameter void
(lambda (f) (lambda (f)
(unless (and (procedure? f) (unless (and (procedure? f)
@ -66,7 +67,7 @@
(raise-type-error 'smtp-sending-end-of-message "thunk" f)) (raise-type-error 'smtp-sending-end-of-message "thunk" f))
f))) f)))
(define (smtp-send-message* r w sender recipients header message-lines (define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd tls-encode) auth-user auth-passwd tls-encode)
(with-handlers ([void (lambda (x) (with-handlers ([void (lambda (x)
(close-input-port r) (close-input-port r)
@ -147,16 +148,14 @@
(close-output-port w) (close-output-port w)
(close-input-port r))) (close-input-port r)))
(define smtp-send-message (define smtp-send-message
(lambda/kw (server sender recipients header message-lines (lambda (server sender recipients header message-lines
#:key #:port-no [port-no 25]
[port-no 25] #:auth-user [auth-user #f]
[auth-user #f] #:auth-passwd [auth-passwd #f]
[auth-passwd #f] #:tcp-connect [tcp-connect tcp-connect]
[tcp-connect tcp-connect] #:tls-encode [tls-encode #f]
[tls-encode #f] [opt-port-no port-no])
#:body
(#:optional [opt-port-no port-no]))
(when (null? recipients) (when (null? recipients)
(error 'send-smtp-message "no receivers")) (error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio? (let-values ([(r w) (if debug-via-stdio?

8
collects/scheme/list.ss
View File

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

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

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

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

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

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

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

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

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

104
collects/scheme/unit.ss
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

14
collects/sirmail/sendr.ss
View File

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

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

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

20
collects/syntax/struct.ss
View File

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

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

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

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

@ -4,39 +4,37 @@
#lang scheme/unit #lang scheme/unit
(require (lib "unit.ss") (require "kerncase.ss"
(lib "list.ss")
"kerncase.ss"
"zodiac-sig.ss" "zodiac-sig.ss"
"stx.ss") "stx.ss")
(import) (import)
(export zodiac^) (export zodiac^)
(define (stx-bound-assq ssym l) (define (stx-bound-assq ssym l)
(ormap (lambda (p) (ormap (lambda (p)
(and (bound-identifier=? ssym (car p)) (and (bound-identifier=? ssym (car p))
p)) p))
l)) l))
(define global-prepare-id (gensym)) (define global-prepare-id (gensym))
(define global-lookup-id (gensym)) (define global-lookup-id (gensym))
(define global-assign-id (gensym)) (define global-assign-id (gensym))
(define safe-vector-ref-id (gensym)) (define safe-vector-ref-id (gensym))
;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct secure-box (value)) (define-struct secure-box (value) #:mutable)
(define init-value-list '()) (define init-value-list '())
(define register-initial-value (define register-initial-value
(lambda (index value-thunk) (lambda (index value-thunk)
(set! init-value-list (set! init-value-list
(append init-value-list (append init-value-list
(list value-thunk))))) (list value-thunk)))))
(define make-initial-value-vector (define make-initial-value-vector
(lambda () (lambda ()
(let ((v (make-vector current-vector-size uninitialized-flag))) (let ((v (make-vector current-vector-size uninitialized-flag)))
(let loop ((index 0) (inits init-value-list)) (let loop ((index 0) (inits init-value-list))
@ -45,13 +43,13 @@
(loop (add1 index) (cdr inits)))) (loop (add1 index) (cdr inits))))
v))) v)))
(define make-empty-back-box (define make-empty-back-box
(lambda () (lambda ()
(make-secure-box (make-initial-value-vector)))) (make-secure-box (make-initial-value-vector))))
(define current-vector-size 2) (define current-vector-size 2)
(define next-client-count (define next-client-count
(let ((count -1)) (let ((count -1))
(lambda () (lambda ()
(set! count (add1 count)) (set! count (add1 count))
@ -59,10 +57,10 @@
(set! current-vector-size (* 2 current-vector-size))) (set! current-vector-size (* 2 current-vector-size)))
count))) count)))
(define-struct uninitialized-back ()) (define-struct uninitialized-back ())
(define uninitialized-flag (make-uninitialized-back)) (define uninitialized-flag (make-uninitialized-back))
(define getters-setters (define getters-setters
(lambda (index) (lambda (index)
(values (values
(lambda (back) ; getter (lambda (back) ; getter
@ -86,13 +84,13 @@
(vector-set! (extend-back-vector back) index value)))) (vector-set! (extend-back-vector back) index value))))
(vector-set! v index value))))))) (vector-set! v index value)))))))
(define register-client (define register-client
(lambda (client-name default-initial-value-thunk) (lambda (client-name default-initial-value-thunk)
(let ((index (next-client-count))) (let ((index (next-client-count)))
(register-initial-value index default-initial-value-thunk) (register-initial-value index default-initial-value-thunk)
(getters-setters index)))) (getters-setters index))))
(define extend-back-vector (define extend-back-vector
(lambda (back-box) (lambda (back-box)
(let ((v (secure-box-value back-box))) (let ((v (secure-box-value back-box)))
(let ((new-v (make-initial-value-vector))) (let ((new-v (make-initial-value-vector)))
@ -105,12 +103,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (mk-back) (make-empty-back-box)) (define (mk-back) (make-empty-back-box))
(define (get-slot stx table) (define (get-slot stx table)
(let ([l (hash-table-get table (syntax-e stx) (lambda () null))]) (let ([l (hash-table-get table (syntax-e stx) (lambda () null))])
(let ([s (ormap (lambda (b) (let ([s (ormap (lambda (b)
(and (module-identifier=? stx (car b)) (and (free-identifier=? stx (car b))
(cdr b))) (cdr b)))
l)]) l)])
(if s (if s
@ -119,7 +117,7 @@
(hash-table-put! table (syntax-e stx) (cons (cons stx s) l)) (hash-table-put! table (syntax-e stx) (cons (cons stx s) l))
s))))) s)))))
(define (let-s->z mk-let rec? stx env loop) (define (let-s->z mk-let rec? stx env loop)
(syntax-case stx () (syntax-case stx ()
[(_ ([vars rhs] ...) . body) [(_ ([vars rhs] ...) . body)
(let* ([varses (syntax->list (syntax (vars ...)))] (let* ([varses (syntax->list (syntax (vars ...)))]
@ -155,7 +153,7 @@
rhses) rhses)
(loop (syntax (begin . body)) body-env)))])) (loop (syntax (begin . body)) body-env)))]))
(define (args-s->z env args) (define (args-s->z env args)
(let-values ([(maker ids) (let-values ([(maker ids)
(syntax-case args () (syntax-case args ()
[id [id
@ -182,7 +180,7 @@
(append (map cons ids bindings) env) (append (map cons ids bindings) env)
(maker bindings))))) (maker bindings)))))
(define (syntax->zodiac stx) (define (syntax->zodiac stx)
(define slot-table (make-hash-table)) (define slot-table (make-hash-table))
(define trans-slot-table (make-hash-table)) (define trans-slot-table (make-hash-table))
(define syntax-slot-table (make-hash-table)) (define syntax-slot-table (make-hash-table))
@ -264,9 +262,9 @@
(loop (syntax rhs) null #f))] (loop (syntax rhs) null #f))]
[(-define names rhs) [(-define names rhs)
(or (module-identifier=? #'-define #'define-syntaxes) (or (free-identifier=? #'-define #'define-syntaxes)
(module-identifier=? #'-define #'define-values-for-syntax)) (free-identifier=? #'-define #'define-values-for-syntax))
(let ([for-stx? (module-identifier=? #'-define #'define-values-for-syntax)]) (let ([for-stx? (free-identifier=? #'-define #'define-values-for-syntax)])
((if for-stx? ((if for-stx?
make-define-for-syntax-form make-define-for-syntax-form
make-define-syntaxes-form) make-define-syntaxes-form)
@ -298,7 +296,7 @@
(cond (cond
[(null? body) null] [(null? body) null]
[(and (require/provide-form? (car body)) [(and (require/provide-form? (car body))
(module-identifier=? req (stx-car (zodiac-stx (car body))))) (free-identifier=? req (stx-car (zodiac-stx (car body)))))
(append (append
(map (lambda (r) (map (lambda (r)
(syntax-case* r (prefix all-except rename) (syntax-case* r (prefix all-except rename)
@ -435,14 +433,6 @@
(loop x env trans?)) (loop x env trans?))
(syntax->list (syntax exprs))))] (syntax->list (syntax exprs))))]
[(if test then)
(make-if-form
stx
(mk-back)
(loop (syntax test) env trans?)
(loop (syntax then) env trans?)
(loop (syntax (#%plain-app void)) env trans?))]
[(if test then else) [(if test then else)
(make-if-form (make-if-form
stx stx
@ -514,10 +504,10 @@
[_else [_else
(error 'syntax->zodiac (error 'syntax->zodiac
"unrecognized expression form: ~e" "unrecognized expression form: ~e"
(syntax-object->datum stx))])))) (syntax->datum stx))]))))
(define (zodiac->syntax x) (define (zodiac->syntax x)
(let loop ([x x]) (let loop ([x x])
(cond (cond
[(zread? x) [(zread? x)
@ -527,7 +517,7 @@
(zodiac-stx x)] (zodiac-stx x)]
[(bound-varref? x) [(bound-varref? x)
;; An stx object is getting gensymmed here! ;; An stx object is getting gensymmed here!
(datum->syntax-object #f (binding-var (bound-varref-binding x)) #f)] (datum->syntax #f (binding-var (bound-varref-binding x)) #f)]
[(app? x) [(app? x)
(with-syntax ([fun (loop (app-fun x))] (with-syntax ([fun (loop (app-fun x))]
@ -588,14 +578,14 @@
(map (lambda (args) (map (lambda (args)
(cond (cond
[(sym-arglist? args) [(sym-arglist? args)
(datum->syntax-object #f (binding-var (car (arglist-vars args))) #f)] (datum->syntax #f (binding-var (car (arglist-vars args))) #f)]
[(list-arglist? args) [(list-arglist? args)
(map (lambda (var) (map (lambda (var)
(datum->syntax-object #f (binding-var var) #f)) (datum->syntax #f (binding-var var) #f))
(arglist-vars args))] (arglist-vars args))]
[(ilist-arglist? args) [(ilist-arglist? args)
(let loop ([vars (arglist-vars args)]) (let loop ([vars (arglist-vars args)])
(let ([id (datum->syntax-object #f (binding-var (car vars)) #f)]) (let ([id (datum->syntax #f (binding-var (car vars)) #f)])
(if (null? (cdr vars)) (if (null? (cdr vars))
id id
(cons id (loop (cdr vars))))))])) (cons id (loop (cdr vars))))))]))
@ -614,128 +604,129 @@
"unknown zodiac record type: ~e" "unknown zodiac record type: ~e"
x)]))) x)])))
(define (zodiac-origin z) z) (define (zodiac-origin z) z)
(define (origin-who z) (define (origin-who z)
(if (syntax-original? (zodiac-stx z)) (if (syntax-original? (zodiac-stx z))
'source 'source
'macro)) 'macro))
(define (origin-how z) (define (origin-how z)
(syntax-property (zodiac-stx z) 'origin)) (syntax-property (zodiac-stx z) 'origin))
(define (zodiac-start z) z) (define (zodiac-start z) z)
(define (zodiac-finish z) z) (define (zodiac-finish z) z)
(define (location-line z) (define (location-line z)
(and (zodiac-stx z) (syntax-line (zodiac-stx z)))) (and (zodiac-stx z) (syntax-line (zodiac-stx z))))
(define (location-column z) (define (location-column z)
(and (zodiac-stx z) (syntax-column (zodiac-stx z)))) (and (zodiac-stx z) (syntax-column (zodiac-stx z))))
(define (location-file z) (define (location-file z)
(and (zodiac-stx z) (syntax-source (zodiac-stx z)))) (and (zodiac-stx z) (syntax-source (zodiac-stx z))))
(define (zread-object z) (define (zread-object z)
(syntax-e (zodiac-stx z))) (syntax-e (zodiac-stx z)))
(define (structurize-syntax sexp) (define (structurize-syntax sexp)
(make-zread (datum->syntax-object #f sexp #f))) (make-zread (datum->syntax #f sexp #f)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define eof? eof-object?) (define eof? eof-object?)
(define-struct zodiac (stx)) (define-struct zodiac (stx) #:mutable)
(define-struct (zread zodiac) ()) (define-struct (zread zodiac) () #:mutable)
(define-struct (parsed zodiac) (back)) (define-struct (parsed zodiac) (back) #:mutable)
(define-struct (varref parsed) (var)) (define-struct (varref parsed) (var) #:mutable)
(define-struct (top-level-varref varref) (module slot exptime? expdef? position)) (define-struct (top-level-varref varref) (module slot exptime? expdef? position) #:mutable)
(define (create-top-level-varref z var module slot exptime? expdef? position) (define (create-top-level-varref z var module slot exptime? expdef? position)
(make-top-level-varref (zodiac-stx z) (mk-back) var module slot exptime? expdef? position)) (make-top-level-varref (zodiac-stx z) (mk-back) var module slot exptime? expdef? position))
(define-struct (bound-varref varref) (binding)) (define-struct (bound-varref varref) (binding) #:mutable)
(define (create-bound-varref z var binding) (define (create-bound-varref z var binding)
(make-bound-varref (zodiac-stx z) (mk-back) var binding)) (make-bound-varref (zodiac-stx z) (mk-back) var binding))
(define lexical-varref? bound-varref?) (define lexical-varref? bound-varref?)
(define make-lexical-varref make-bound-varref) (define make-lexical-varref make-bound-varref)
(define create-lexical-varref create-bound-varref) (define create-lexical-varref create-bound-varref)
(define-struct (binding parsed) (var orig-name)) (define-struct (binding parsed) (var orig-name) #:mutable)
(define (create-binding z var orig-name) (define (create-binding z var orig-name)
(make-binding (zodiac-stx z) (mk-back) var orig-name)) (make-binding (zodiac-stx z) (mk-back) var orig-name))
(define lexical-binding? binding?) (define lexical-binding? binding?)
(define make-lexical-binding make-binding) (define make-lexical-binding make-binding)
(define create-lexical-binding create-binding) (define create-lexical-binding create-binding)
(define-struct (app parsed) (fun args)) (define-struct (app parsed) (fun args) #:mutable)
(define (create-app z fun args) (define (create-app z fun args)
(make-app (zodiac-stx z) (mk-back) fun args)) (make-app (zodiac-stx z) (mk-back) fun args))
(define-struct (if-form parsed) (test then else)) (define-struct (if-form parsed) (test then else) #:mutable)
(define (create-if-form z test then else) (define (create-if-form z test then else)
(make-if-form (zodiac-stx z) (mk-back) test then else)) (make-if-form (zodiac-stx z) (mk-back) test then else))
(define-struct (quote-form parsed) (expr)) (define-struct (quote-form parsed) (expr) #:mutable)
(define (create-quote-form z expr) (define (create-quote-form z expr)
(make-quote-form (zodiac-stx z) (mk-back) expr)) (make-quote-form (zodiac-stx z) (mk-back) expr))
(define-struct (begin-form parsed) (bodies)) (define-struct (begin-form parsed) (bodies) #:mutable)
(define (create-begin-form z bodies) (define (create-begin-form z bodies)
(make-begin-form (zodiac-stx z) (mk-back) bodies)) (make-begin-form (zodiac-stx z) (mk-back) bodies))
(define-struct (begin0-form parsed) (bodies)) (define-struct (begin0-form parsed) (bodies) #:mutable)
(define (create-begin0-form z bodies) (define (create-begin0-form z bodies)
(make-begin0-form (zodiac-stx z) (mk-back) bodies)) (make-begin0-form (zodiac-stx z) (mk-back) bodies))
(define-struct (let-values-form parsed) (vars vals body)) (define-struct (let-values-form parsed) (vars vals body) #:mutable)
(define (create-let-values-form z vars vals body) (define (create-let-values-form z vars vals body)
(make-let-values-form (zodiac-stx z) (mk-back) vars vals body)) (make-let-values-form (zodiac-stx z) (mk-back) vars vals body))
(define-struct (letrec-values-form parsed) (vars vals body)) (define-struct (letrec-values-form parsed) (vars vals body) #:mutable)
(define (create-letrec-values-form z vars vals body) (define (create-letrec-values-form z vars vals body)
(make-letrec-values-form (zodiac-stx z) (mk-back) vars vals body)) (make-letrec-values-form (zodiac-stx z) (mk-back) vars vals body))
(define-struct (define-values-form parsed) (vars val)) (define-struct (define-values-form parsed) (vars val) #:mutable)
(define (create-define-values-form z vars val) (define (create-define-values-form z vars val)
(make-define-values-form (zodiac-stx z) (mk-back) vars val)) (make-define-values-form (zodiac-stx z) (mk-back) vars val))
(define-struct (set!-form parsed) (var val)) (define-struct (set!-form parsed) (var val) #:mutable)
(define (create-set!-form z var val) (define (create-set!-form z var val)
(make-set!-form (zodiac-stx z) (mk-back) var val)) (make-set!-form (zodiac-stx z) (mk-back) var val))
(define-struct (case-lambda-form parsed) (args bodies)) (define-struct (case-lambda-form parsed) (args bodies) #:mutable)
(define (create-case-lambda-form z args bodies) (define (create-case-lambda-form z args bodies)
(make-case-lambda-form (zodiac-stx z) (mk-back) args bodies)) (make-case-lambda-form (zodiac-stx z) (mk-back) args bodies))
(define-struct (with-continuation-mark-form parsed) (key val body)) (define-struct (with-continuation-mark-form parsed) (key val body) #:mutable)
(define (create-with-continuation-mark-form z key val body) (define (create-with-continuation-mark-form z key val body)
(make-with-continuation-mark-form (zodiac-stx z) (mk-back) key val body)) (make-with-continuation-mark-form (zodiac-stx z) (mk-back) key val body))
(define-struct (quote-syntax-form parsed) (expr)) (define-struct (quote-syntax-form parsed) (expr) #:mutable)
(define (create-quote-syntax-form z expr) (define (create-quote-syntax-form z expr)
(make-quote-syntax-form (zodiac-stx z) (mk-back) expr)) (make-quote-syntax-form (zodiac-stx z) (mk-back) expr))
(define-struct (define-syntaxes-form parsed) (names expr)) (define-struct (define-syntaxes-form parsed) (names expr) #:mutable)
(define (create-define-syntaxes-form z names expr) (define (create-define-syntaxes-form z names expr)
(make-define-syntaxes-form (zodiac-stx z) (mk-back) names expr)) (make-define-syntaxes-form (zodiac-stx z) (mk-back) names expr))
(define-struct (define-for-syntax-form parsed) (names expr)) (define-struct (define-for-syntax-form parsed) (names expr) #:mutable)
(define (create-define-for-syntax-form z names expr) (define (create-define-for-syntax-form z names expr)
(make-define-for-syntax-form (zodiac-stx z) (mk-back) names expr)) (make-define-for-syntax-form (zodiac-stx z) (mk-back) names expr))
(define-struct (module-form parsed) (name requires for-syntax-requires for-template-requires (define-struct (module-form parsed) (name requires for-syntax-requires for-template-requires
body syntax-body body syntax-body
provides syntax-provides indirect-provides provides syntax-provides indirect-provides
kernel-reprovide-hint kernel-reprovide-hint
self-path-index)) self-path-index)
(define (create-module-form z name rt-requires et-requires tt-requires #:mutable)
(define (create-module-form z name rt-requires et-requires tt-requires
rt-body et-body rt-body et-body
var-provides syntax-provides indirect-provides var-provides syntax-provides indirect-provides
kernel-hint self) kernel-hint self)
@ -745,27 +736,27 @@
var-provides syntax-provides indirect-provides var-provides syntax-provides indirect-provides
kernel-hint self)) kernel-hint self))
(define-struct (require/provide-form parsed) ()) (define-struct (require/provide-form parsed) ())
(define (create-require/provide-form z) (define (create-require/provide-form z)
(make-require/provide-form (zodiac-stx z) (mk-back))) (make-require/provide-form (zodiac-stx z) (mk-back)))
(define-struct (global-prepare parsed) (vec pos)) (define-struct (global-prepare parsed) (vec pos) #:mutable)
(define (create-global-prepare z vec pos) (define (create-global-prepare z vec pos)
(make-global-prepare (zodiac-stx z) (mk-back) vec pos)) (make-global-prepare (zodiac-stx z) (mk-back) vec pos))
(define-struct (global-lookup parsed) (vec pos)) (define-struct (global-lookup parsed) (vec pos) #:mutable)
(define (create-global-lookup z vec pos) (define (create-global-lookup z vec pos)
(make-global-lookup (zodiac-stx z) (mk-back) vec pos)) (make-global-lookup (zodiac-stx z) (mk-back) vec pos))
(define-struct (global-assign parsed) (vec pos expr)) (define-struct (global-assign parsed) (vec pos expr) #:mutable)
(define (create-global-assign z vec pos expr) (define (create-global-assign z vec pos expr)
(make-global-assign (zodiac-stx z) (mk-back) vec pos expr)) (make-global-assign (zodiac-stx z) (mk-back) vec pos expr))
(define-struct (safe-vector-ref parsed) (vec pos)) (define-struct (safe-vector-ref parsed) (vec pos) #:mutable)
(define (create-safe-vector-ref z vec pos) (define (create-safe-vector-ref z vec pos)
(make-safe-vector-ref (zodiac-stx z) (mk-back) vec pos)) (make-safe-vector-ref (zodiac-stx z) (mk-back) vec pos))
(define-struct arglist (vars)) (define-struct arglist (vars) #:mutable)
(define-struct (sym-arglist arglist) ()) (define-struct (sym-arglist arglist) () #:mutable)
(define-struct (list-arglist arglist) ()) (define-struct (list-arglist arglist) () #:mutable)
(define-struct (ilist-arglist arglist) ()) (define-struct (ilist-arglist arglist) () #:mutable)

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

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

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

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