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

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

@ -12,9 +12,9 @@
(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

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

@ -2,15 +2,12 @@
(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"
@ -392,7 +389,7 @@
(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)
@ -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)])

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

@ -32,10 +32,7 @@ A test case:
(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")
@ -52,6 +49,11 @@ A test case:
(export hyper^) (export hyper^)
(init-depend mred^) (init-depend mred^)
(define (last-pair l)
(if (null? (cdr l))
l
(last-pair (cdr l))))
(define-struct (exn:file-saved-instead exn) (pathname)) (define-struct (exn:file-saved-instead exn) (pathname))
(define-struct (exn:cancelled exn) ()) (define-struct (exn:cancelled exn) ())
(define-struct (exn:tcp-problem exn) ()) (define-struct (exn:tcp-problem exn) ())
@ -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]
@ -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<%>))
@ -1137,14 +1139,14 @@ A test case:
(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%)))

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

16
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")
@ -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,8 +387,7 @@
(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)
@ -530,12 +528,12 @@
[(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))))
@ -684,11 +682,11 @@
(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

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))

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

@ -1,4 +1,3 @@
#lang scheme/unit #lang scheme/unit
(require "base64-sig.ss") (require "base64-sig.ss")

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^)

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

@ -4,7 +4,7 @@
;; 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^)

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)

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

@ -1,6 +1,6 @@
#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^)
@ -72,7 +72,7 @@
;; 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))))

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

@ -1,6 +1,6 @@
#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^)
@ -13,7 +13,7 @@
;; 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) ())
@ -86,7 +86,7 @@
;; 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))))

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

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

@ -1,5 +1,6 @@
#lang scheme/unit #lang scheme/unit
(require (lib "list.ss") (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(require scheme/tcp "base64.ss" "smtp-sig.ss")
(import) (import)
(export smtp^) (export smtp^)
@ -36,7 +37,7 @@
(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)))
@ -148,15 +149,13 @@
(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

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

@ -4,9 +4,7 @@
#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")
@ -26,7 +24,7 @@
;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Back boxes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct secure-box (value)) (define-struct secure-box (value) #:mutable)
(define init-value-list '()) (define init-value-list '())
@ -110,7 +108,7 @@
(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
@ -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,7 +504,7 @@
[_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)
@ -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))))))]))
@ -640,24 +630,24 @@
(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))
@ -665,7 +655,7 @@
(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))
@ -674,59 +664,59 @@
(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))
@ -734,7 +724,8 @@
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)
#:mutable)
(define (create-module-form z name rt-requires et-requires tt-requires (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
@ -749,23 +740,23 @@
(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))