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

3.99.0.9: binding links in docs use nominal import sources

Browse Source 
svn: r8196
This commit is contained in:
Matthew Flatt 2008-01-03 19:07:02 +00:00
parent 3cf6ed4673
commit 7fc41024c0
80 changed files with 2174 additions and 1090 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drscheme/syncheck.ss
View File

@ -2380,9 +2380,7 @@ If the namespace does not, they are colored the unbound color.
(syntax-span stx)) (syntax-span stx))
(let* ([start (- (syntax-position stx) 1)] (let* ([start (- (syntax-position stx) 1)]
[fin (+ start (syntax-span stx))] [fin (+ start (syntax-span stx))]
[source-mod (list-ref binding-info 0)] [definition-tag (xref-binding->definition-tag (get-xref) binding-info #f)])
[source-id (list-ref binding-info 1)]
[definition-tag (xref-binding->definition-tag (get-xref) source-mod source-id)])
(when definition-tag (when definition-tag
(let-values ([(path tag) (xref-tag->path+anchor (get-xref) definition-tag)]) (let-values ([(path tag) (xref-tag->path+anchor (get-xref) definition-tag)])
(when path (when path

8
collects/games/cards/doc.scrbl
View File

@ -1,12 +1,12 @@
#lang scribble/doc #lang scribble/doc
@require[scribble/manual @require[scribble/manual
(for-label "cards.ss" (for-label "main.ss"
mred)] scheme/gui/base)]
@title{Virtual Playing Cards Library} @title{Virtual Playing Cards Library}
@defmodule[games/cards]{The @scheme[games/cards] module provides a @defmodule[games/cards/main]{The @schememodname[games/cards/main]
toolbox for creating cards games.} module provides a toolbox for creating cards games.}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@section{Creating Tables and Cards} @section{Creating Tables and Cards}

2
collects/lang/htdp-intermediate-lambda.ss
View File

@ -45,4 +45,4 @@
;; procedures: ;; procedures:
(provide-and-document (provide-and-document
procedures procedures
(all-from beginner: lang/htdp-intermediate procedures))) (all-from intermediate: lang/htdp-intermediate procedures)))

8
collects/lang/private/advanced-funs.ss
View File

@ -8,14 +8,8 @@
"../posn.ss" "../posn.ss"
(for-syntax scheme/base)) (for-syntax scheme/base))
(define-syntax (freshen-export stx) (provide-and-document
(syntax-case stx ()
[(_ new-name orig-name)
#'(define-syntax new-name (make-rename-transformer #'orig-name))]))
(provide-and-document/wrap
procedures procedures
freshen-export
("Reading and Printing" ("Reading and Printing"
(print (any -> void) (print (any -> void)

8
collects/lang/private/intermediate-funs.ss
View File

@ -5,14 +5,8 @@
syntax/docprovide syntax/docprovide
(for-syntax scheme/base)) (for-syntax scheme/base))
(define-syntax (freshen-export stx) (provide-and-document
(syntax-case stx ()
[(_ new-name orig-name)
#'(define-syntax new-name (make-rename-transformer #'orig-name))]))
(provide-and-document/wrap
procedures procedures
freshen-export
(all-from beginner: lang/private/beginner-funs procedures) (all-from beginner: lang/private/beginner-funs procedures)
("Higher-Order Functions" ("Higher-Order Functions"

2
collects/lang/private/teach.ss
View File

@ -1889,7 +1889,7 @@
;; new syntax object that is an `intermediate-define' form; ;; new syntax object that is an `intermediate-define' form;
;; that's important for syntax errors, so that they ;; that's important for syntax errors, so that they
;; report `advanced-define' as the source. ;; report `advanced-define' as the source.
(define/proc #f #t stx)] (define/proc #f #t stx #'beginner-lambda)]
[_else [_else
(bad-use-error 'define stx)])) (bad-use-error 'define stx)]))

11
collects/mzlib/foreign.ss
View File

@ -57,10 +57,10 @@
...))]))))]))))) ...))]))))])))))
(provide* ctype-sizeof ctype-alignof compiler-sizeof (provide* ctype-sizeof ctype-alignof compiler-sizeof
(unsafe malloc) (unsafe free) end-stubborn-change (unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
ptr-offset ptr-add! offset-ptr? set-ptr-offset! ptr-offset ptr-add! offset-ptr? set-ptr-offset!
ctype? make-ctype make-cstruct-type make-sized-byte-string ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string)
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum _fixint _ufixint _fixnum _ufixnum
_float _double _double* _float _double _double*
@ -138,7 +138,7 @@
(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1))) (define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1)))
(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$"))) (define lib-suffix-re (regexp (string-append "\\." lib-suffix "$")))
(provide (rename-out [get-ffi-lib ffi-lib]) (provide* (unsafe (rename-out [get-ffi-lib ffi-lib]))
ffi-lib? ffi-lib-name) ffi-lib? ffi-lib-name)
(define get-ffi-lib (define get-ffi-lib
(case-lambda (case-lambda
@ -204,7 +204,7 @@
(ptr-set! ffi-obj type new))) (ptr-set! ffi-obj type new)))
;; This is better handled with `make-c-parameter' ;; This is better handled with `make-c-parameter'
(provide* ffi-obj-ref) (provide* (unsafe ffi-obj-ref))
(define ffi-obj-ref (define ffi-obj-ref
(case-lambda (case-lambda
[(name lib) (ffi-obj-ref name lib #f)] [(name lib) (ffi-obj-ref name lib #f)]
@ -1559,7 +1559,8 @@
(define killer-executor (make-will-executor)) (define killer-executor (make-will-executor))
(define killer-thread #f) (define killer-thread #f)
(define* (register-finalizer obj finalizer) (provide* (unsafe register-finalizer))
(define (register-finalizer obj finalizer)
(unless killer-thread (unless killer-thread
(set! killer-thread (thread (lambda () (let loop () (will-execute killer-executor) (loop)))))) (set! killer-thread (thread (lambda () (let loop () (will-execute killer-executor) (loop))))))
(will-register killer-executor obj finalizer)) (will-register killer-executor obj finalizer))

2
collects/net/doc/smtp.scrbl
View File

@ -106,7 +106,7 @@ probably will not).}
@section{SMTP Unit} @section{SMTP Unit}
@defmodule[net/SMTP-unit] @defmodule[net/smtp-unit]
@defthing[smtp@ unit?]{ @defthing[smtp@ unit?]{

8
collects/net/doc/url.scrbl
View File

@ -27,10 +27,10 @@ library.
@section{URL Structure} @section{URL Structure}
@declare-exporting[net/url-struct net/url] @declare-exporting[net/url-structs net/url]
@defmodule*/no-declare[(net/url-struct)]{The URL structure types are @defmodule*/no-declare[(net/url-structs)]{The URL structure types are
provided by the @schememodname[net/url-struct] library, and provided by the @schememodname[net/url-structs] library, and
re-exported by @schememodname[net/url].} re-exported by @schememodname[net/url].}
@; ---------------------------------------- @; ----------------------------------------
@ -43,7 +43,7 @@ re-exported by @schememodname[net/url].}
[path-absolute? boolean?] [path-absolute? boolean?]
[path (listof path/param?)] [path (listof path/param?)]
[query (listof (cons/c symbol? (or/c false/c string?)))] [query (listof (cons/c symbol? (or/c false/c string?)))]
[fragment (union false/c string?)])]{ [fragment (or/c false/c string?)])]{
The basic structure for all URLs, hich is explained in RFC 3986 The basic structure for all URLs, hich is explained in RFC 3986
@cite["RFC3986"]. The following diagram illustrates the parts: @cite["RFC3986"]. The following diagram illustrates the parts:

4
collects/scheme/gui.ss
View File

@ -1,4 +1,4 @@
(module gui scheme (module gui scheme
(require mred) (require scheme/gui/base)
(provide (all-from-out scheme) (provide (all-from-out scheme)
(all-from-out mred))) (all-from-out scheme/gui/base)))

12
collects/scheme/help.ss
View File

@ -65,22 +65,22 @@
lib)))) lib))))
(define (find-help id) (define (find-help id)
(let ([b (or (identifier-label-binding id) (let* ([lb (identifier-label-binding id)]
(identifier-binding id))] [b (and (not lb) (identifier-binding id))]
[xref (load-collections-xref [xref (load-collections-xref
(lambda () (lambda ()
(printf "Loading help index...\n")))]) (printf "Loading help index...\n")))])
(if b (if (or lb b)
(let ([tag (xref-binding->definition-tag (let ([tag (xref-binding->definition-tag
xref xref
(car b) (or lb b)
(cadr b))]) (if lb 'for-label #f))])
(if tag (if tag
(go-to-tag xref tag) (go-to-tag xref tag)
(error 'help (error 'help
"no documentation found for: ~e provided by: ~a" "no documentation found for: ~e provided by: ~a"
(syntax-e id) (syntax-e id)
(module-path-index-resolve (car b))))) (module-path-index-resolve (caddr b)))))
(search-for-exports xref (syntax-e id))))) (search-for-exports xref (syntax-e id)))))
(define (search-for-exports xref sym) (define (search-for-exports xref sym)

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

@ -38,7 +38,8 @@
(box? v) (box? v)
(void? v) (void? v)
(date? v) (date? v)
(arity-at-least? v))) (arity-at-least? v)
(module-path-index? v)))
;; If a module is dynamic-required through a path, ;; If a module is dynamic-required through a path,
;; then it can cause simplified module paths to be paths; ;; then it can cause simplified module paths to be paths;
@ -192,6 +193,10 @@
(loop v)))] (loop v)))]
[(arity-at-least? v) [(arity-at-least? v)
(loop (arity-at-least-value v))] (loop (arity-at-least-value v))]
[(module-path-index? v)
(let-values ([(path base) (module-path-index-split v)])
(loop path)
(loop base))]
[else (raise-type-error [else (raise-type-error
'serialize 'serialize
"serializable object" "serializable object"
@ -262,6 +267,11 @@
[(arity-at-least? v) [(arity-at-least? v)
(cons 'arity-at-least (cons 'arity-at-least
((serial #t) (arity-at-least-value v)))] ((serial #t) (arity-at-least-value v)))]
[(module-path-index? v)
(let-values ([(path base) (module-path-index-split v)])
(cons 'mpi
(cons ((serial #t) path)
((serial #t) base))))]
[else (error 'serialize "shouldn't get here")])) [else (error 'serialize "shouldn't get here")]))
((serial check-share?) v)) ((serial check-share?) v))
@ -389,6 +399,8 @@
(apply make-immutable-hash-table al (caddr v))))] (apply make-immutable-hash-table al (caddr v))))]
[(date) (apply make-date (map loop (cdr v)))] [(date) (apply make-date (map loop (cdr v)))]
[(arity-at-least) (make-arity-at-least (loop (cdr v)))] [(arity-at-least) (make-arity-at-least (loop (cdr v)))]
[(mpi) (module-path-index-join (loop (cadr v))
(loop (cddr v)))]
[else (error 'serialize "ill-formed serialization")])]))) [else (error 'serialize "ill-formed serialization")])])))
(define (deserial-shell v mod-map fixup n) (define (deserial-shell v mod-map fixup n)
@ -442,7 +454,9 @@
[(date) [(date)
(error 'deserialize "cannot restore date in cycle")] (error 'deserialize "cannot restore date in cycle")]
[(arity-at-least) [(arity-at-least)
(error 'deserialize "cannot restore arity-at-least in cycle")])])) (error 'deserialize "cannot restore arity-at-least in cycle")]
[(mpi)
(error 'deserialize "cannot restore module-path-index in cycle")])]))
(define (deserialize l) (define (deserialize l)
(let-values ([(vers l) (let-values ([(vers l)

30
collects/scribble/base-render.ss
View File

@ -4,7 +4,8 @@
mzlib/class mzlib/class
mzlib/serialize mzlib/serialize
scheme/file scheme/file
scheme/path) scheme/path
setup/main-collects)
(provide render%) (provide render%)
@ -74,7 +75,9 @@
(make-hash-table 'equal) (make-hash-table 'equal)
(make-hash-table) (make-hash-table)
(make-hash-table) (make-hash-table)
"")]) ""
(make-hash-table)
null)])
(start-collect ds fns ci) (start-collect ds fns ci)
ci)) ci))
@ -92,7 +95,9 @@
(string-append (collect-info-gen-prefix ci) (string-append (collect-info-gen-prefix ci)
(part-tag-prefix d) (part-tag-prefix d)
":") ":")
(collect-info-gen-prefix ci)))]) (collect-info-gen-prefix ci))
(collect-info-relatives ci)
(cons d (collect-info-parents ci)))])
(when (part-title-content d) (when (part-title-content d)
(collect-content (part-title-content d) p-ci)) (collect-content (part-title-content d) p-ci))
(collect-part-tags d p-ci number) (collect-part-tags d p-ci number)
@ -184,6 +189,18 @@
(blockquote-paragraphs i))) (blockquote-paragraphs i)))
(define/public (collect-element i ci) (define/public (collect-element i ci)
(if (part-relative-element? i)
(let ([content
(or (hash-table-get (collect-info-relatives ci)
i
#f)
(let ([v ((part-relative-element-collect i) ci)])
(hash-table-put! (collect-info-relatives ci)
i
v)
v))])
(collect-content content ci))
(begin
(when (target-element? i) (when (target-element? i)
(collect-target-element i ci)) (collect-target-element i ci))
(when (index-element? i) (when (index-element? i)
@ -193,7 +210,7 @@
(when (element? i) (when (element? i)
(for-each (lambda (e) (for-each (lambda (e)
(collect-element e ci)) (collect-element e ci))
(element-content i)))) (element-content i))))))
(define/public (collect-target-element i ci) (define/public (collect-target-element i ci)
(collect-put! ci (collect-put! ci
@ -213,6 +230,7 @@
(define/public (resolve ds fns ci) (define/public (resolve ds fns ci)
(let ([ri (make-resolve-info ci (let ([ri (make-resolve-info ci
(make-hash-table) (make-hash-table)
(make-hash-table 'equal)
(make-hash-table 'equal))]) (make-hash-table 'equal))])
(start-resolve ds fns ri) (start-resolve ds fns ri)
ri)) ri))
@ -269,6 +287,8 @@
(define/public (resolve-element i d ri) (define/public (resolve-element i d ri)
(cond (cond
[(part-relative-element? i)
(resolve-content (part-relative-element-content i ri) d ri)]
[(delayed-element? i) [(delayed-element? i)
(resolve-content (or (hash-table-get (resolve-info-delays ri) (resolve-content (or (hash-table-get (resolve-info-delays ri)
i i
@ -372,6 +392,8 @@
(render-content (element-content i) part ri)] (render-content (element-content i) part ri)]
[(delayed-element? i) [(delayed-element? i)
(render-content (delayed-element-content i ri) part ri)] (render-content (delayed-element-content i ri) part ri)]
[(part-relative-element? i)
(render-content (part-relative-element-content i ri) part ri)]
[else [else
(render-other i part ri)])) (render-other i part ri)]))

8
collects/scribble/basic.ss
View File

@ -47,20 +47,20 @@
style style
content))) content)))
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] . str) (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 1 (make-part-start 1
(prefix->string prefix) (prefix->string prefix)
(convert-tag tag content) (convert-tag tag content)
#f style
content))) content)))
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] . str) (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 2 (make-part-start 2
(prefix->string prefix) (prefix->string prefix)
(convert-tag tag content) (convert-tag tag content)
#f style
content))) content)))
(define (subsubsub*section #:tag [tag #f] . str) (define (subsubsub*section #:tag [tag #f] . str)

3
collects/scribble/decode.ss
View File

@ -27,7 +27,8 @@
[splice ([run list?])] [splice ([run list?])]
[part-index-decl ([plain-seq (listof string?)] [part-index-decl ([plain-seq (listof string?)]
[entry-seq list?])] [entry-seq list?])]
[part-collect-decl ([element element?])] [part-collect-decl ([element (or/c element?
part-relative-element?)])]
[part-tag-decl ([tag tag?])]) [part-tag-decl ([tag tag?])])
(define (decode-string s) (define (decode-string s)

5
collects/scribble/html-render.ss
View File

@ -251,7 +251,10 @@
(append (loop (element-content a)) (append (loop (element-content a))
(loop (cdr c)))] (loop (cdr c)))]
[(delayed-element? a) [(delayed-element? a)
(loop (cons (delayed-element-content a ri) (loop (append (delayed-element-content a ri)
(cdr c)))]
[(part-relative-element? a)
(loop (append (part-relative-element-content a ri)
(cdr c)))] (cdr c)))]
[else [else
(loop (cdr c))]))])))] (loop (cdr c))]))])))]

280
collects/scribble/manual.ss
View File

@ -3,6 +3,7 @@
(require "decode.ss" (require "decode.ss"
"struct.ss" "struct.ss"
"scheme.ss" "scheme.ss"
"search.ss"
"config.ss" "config.ss"
"basic.ss" "basic.ss"
"manual-struct.ss" "manual-struct.ss"
@ -10,6 +11,7 @@
scheme/class scheme/class
scheme/stxparam scheme/stxparam
mzlib/serialize mzlib/serialize
setup/main-collects
(for-syntax scheme/base) (for-syntax scheme/base)
(for-label scheme/base (for-label scheme/base
scheme/class)) scheme/class))
@ -309,34 +311,74 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-struct sig (tagstr)) (define (gen-absolute-tag)
`(abs ,(make-generated-tag)))
(define-struct sig (id))
(define (definition-site name stx-id form?) (define (definition-site name stx-id form?)
(let ([sig (current-signature)]) (let ([sig (current-signature)])
(if sig (if sig
(make-link-element (if form? (*sig-elem (sig-id sig) name)
"schemesyntaxlink"
"schemevaluelink")
(list (schemefont (symbol->string name)))
`(,(if form? 'sig-form 'sig-val)
,(format "~a::~a" (sig-tagstr sig) name)))
(annote-exporting-library (annote-exporting-library
(to-element (make-just-context name stx-id)))))) (to-element (make-just-context name stx-id))))))
(define (id-to-tag id) (define (libs->str libs)
(add-signature-tag id #f)) (and (pair? libs)
(format "~a"
(let ([p (resolved-module-path-name
(module-path-index-resolve
(module-path-index-join (car libs) #f)))])
(if (path? p)
(path->main-collects-relative p)
p)))))
(define (id-to-form-tag id) (define (id-to-target-maker id dep?)
(add-signature-tag id #t)) (*id-to-target-maker 'def id dep?))
(define (add-signature-tag id form?) (define (id-to-form-target-maker id dep?)
(*id-to-target-maker 'form id dep?))
(define (*id-to-target-maker sym id dep?)
(let ([sig (current-signature)]) (let ([sig (current-signature)])
(if sig (lambda (content mk)
`(,(if form? 'sig-form 'sig-val) (make-part-relative-element
,(format "~a::~a" (sig-tagstr sig) (syntax-e id))) (lambda (ci)
(if form? (let ([e (ormap (lambda (p)
(register-scheme-form-definition id) (ormap (lambda (e)
(register-scheme-definition id #t))))) (and (exporting-libraries? e) e))
(part-to-collect p)))
(collect-info-parents ci))])
(unless e
;; Call raise-syntax-error to capture error message:
(with-handlers ([exn:fail:syntax? (lambda (exn)
(fprintf (current-error-port)
"~a\n"
(exn-message exn)))])
(raise-syntax-error 'WARNING
"no declared exporting libraries for definition"
id)))
(if e
(let* ([lib-str (libs->str (exporting-libraries-libs e))]
[tag (list (if sig
(case sym
[(def) 'sig-val]
[(form) 'sig-def])
sym)
(format "~a::~a~a~a"
lib-str
(if sig (syntax-e (sig-id sig)) "")
(if sig "::" "")
(syntax-e id)))])
(if (or sig (not dep?))
(list (mk tag))
(list (make-target-element
#f
(list (mk tag))
`(dep ,(format "~a::~a" lib-str (syntax-e id)))))))
content)))
(lambda () (car content))
(lambda () (car content))))))
(define current-signature (make-parameter #f)) (define current-signature (make-parameter #f))
@ -344,21 +386,25 @@
(*sig-elem (quote-syntax sig) 'elem)) (*sig-elem (quote-syntax sig) 'elem))
(define (*sig-elem sig elem) (define (*sig-elem sig elem)
(let ([s (to-element elem)] (let ([s (to-element/no-color elem)])
[tag (format "~a::~a"
(register-scheme-form-definition sig #t)
elem)])
(make-delayed-element (make-delayed-element
(lambda (renderer sec ri) (lambda (renderer sec ri)
(let* ([vtag `(sig-val ,tag)] (let* ([tag (find-scheme-tag sec ri sig 'for-label)]
[stag `(sig-form ,tag)] [str (and tag (format "~a::~a" (cadr tag) elem))]
[sd (resolve-get/tentative sec ri stag)]) [vtag (and tag `(sig-val ,str))]
[stag (and tag `(sig-form ,str))]
[sd (and stag (resolve-get/tentative sec ri stag))])
(list
(make-element
"schemesymbol"
(list (list
(cond (cond
[sd [sd
(make-link-element "schemesyntaxlink" (list s) stag)] (make-link-element "schemesyntaxlink" (list s) stag)]
[vtag
(make-link-element "schemevaluelink" (list s) vtag)]
[else [else
(make-link-element "schemevaluelink" (list s) vtag)])))) s]))))))
(lambda () s) (lambda () s)
(lambda () s)))) (lambda () s))))
@ -379,15 +425,29 @@
(elem (method a b) " in " (scheme a))])) (elem (method a b) " in " (scheme a))]))
(define (*method sym id) (define (*method sym id)
(**method sym (id-to-tag id))) (**method sym id))
(define (**method sym tag) (define (**method sym id/tag)
(let ([content (list (symbol->string sym))])
((if (identifier? id/tag)
(lambda (c mk)
(make-delayed-element
(lambda (ren p ri)
(let ([tag (find-scheme-tag p ri id/tag 'for-label)])
(if tag
(list (mk tag))
content)))
(lambda () (car content))
(lambda () (car content))))
(lambda (c mk) (mk id/tag)))
content
(lambda (tag)
(make-element (make-element
"schemesymbol" "schemesymbol"
(list (make-link-element (list (make-link-element
"schemevaluelink" "schemevaluelink"
(list (symbol->string sym)) content
(method-tag tag sym))))) (method-tag tag sym))))))))
(define (method-tag vtag sym) (define (method-tag vtag sym)
(list 'meth (list 'meth
@ -458,12 +518,18 @@
(syntax-rules () (syntax-rules ()
[(_ lib ...) (*declare-exporting '(lib ...))])) [(_ lib ...) (*declare-exporting '(lib ...))]))
(define-struct (exporting-libraries element) (libs))
(define (*declare-exporting libs) (define (*declare-exporting libs)
(make-splice
(list
(make-part-collect-decl (make-part-collect-decl
(make-collect-element #f (make-collect-element #f
null null
(lambda (ri) (lambda (ri)
(collect-put! ri '(exporting-libraries #f)libs))))) (collect-put! ri '(exporting-libraries #f) libs))))
(make-part-collect-decl
(make-exporting-libraries #f null libs)))))
(define-syntax (quote-syntax/loc stx) (define-syntax (quote-syntax/loc stx)
(syntax-case stx () (syntax-case stx ()
@ -1016,10 +1082,13 @@
(hspace 1) (hspace 1)
(if first? (if first?
(let* ([mname (extract-id prototype)] (let* ([mname (extract-id prototype)]
[ctag (id-to-tag within-id)] [target-maker (id-to-target-maker within-id #f)]
[tag (method-tag ctag mname)]
[content (list (*method mname within-id))]) [content (list (*method mname within-id))])
(if tag (if target-maker
(target-maker
content
(lambda (ctag)
(let ([tag (method-tag ctag mname)])
(make-toc-target-element (make-toc-target-element
#f #f
(list (make-index-element #f (list (make-index-element #f
@ -1034,14 +1103,17 @@
libs libs
mname mname
ctag))))) ctag)))))
tag) tag))))
(car content))) (car content)))
(*method (extract-id prototype) within-id))))] (*method (extract-id prototype) within-id))))]
[else [else
(if first? (if first?
(let ([tag (id-to-tag stx-id)] (let ([target-maker (id-to-target-maker stx-id #t)]
[content (list (definition-site (extract-id prototype) stx-id #f))]) [content (list (definition-site (extract-id prototype) stx-id #f))])
(if tag (if target-maker
(target-maker
content
(lambda (tag)
(make-toc-target-element (make-toc-target-element
#f #f
(list (make-index-element #f (list (make-index-element #f
@ -1054,7 +1126,7 @@
(make-procedure-index-desc (make-procedure-index-desc
(extract-id prototype) (extract-id prototype)
libs))))) libs)))))
tag) tag)))
(car content))) (car content)))
(annote-exporting-library (annote-exporting-library
(to-element (make-just-context (extract-id prototype) (to-element (make-just-context (extract-id prototype)
@ -1241,12 +1313,16 @@
(let* ([name (let* ([name
(apply string-append (apply string-append
(map symbol->string (cdar wrappers)))] (map symbol->string (cdar wrappers)))]
[tag [target-maker
(id-to-tag (id-to-target-maker
(datum->syntax stx-id (datum->syntax stx-id
(string->symbol (string->symbol
name)))]) name))
(if tag #t)])
(if target-maker
(target-maker
(list content)
(lambda (tag)
(inner-make-target-element (inner-make-target-element
#f #f
(list (list
@ -1261,7 +1337,7 @@
(if (eq? 'info (caar wrappers)) (if (eq? 'info (caar wrappers))
(make-struct-index-desc name libs) (make-struct-index-desc name libs)
(make-procedure-index-desc name libs))))))) (make-procedure-index-desc name libs)))))))
tag) tag)))
content)) content))
(cdr wrappers)))) (cdr wrappers))))
@ -1454,12 +1530,16 @@
(list (make-flow (list (make-flow
(list (list
(make-paragraph (make-paragraph
(list (let ([tag ((if form? id-to-form-tag id-to-tag) stx-id)] (list (let ([target-maker ((if form? id-to-form-target-maker id-to-target-maker) stx-id #t)]
[content (list (definition-site name stx-id form?))]) [content (list (definition-site name stx-id form?))])
(if tag (if target-maker
(target-maker
content
(lambda (tag)
(make-toc-target-element (make-toc-target-element
#f #f
(list (make-index-element #f (list
(make-index-element #f
content content
tag tag
(list (symbol->string name)) (list (symbol->string name))
@ -1467,7 +1547,7 @@
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-thing-index-desc name libs))))) (make-thing-index-desc name libs)))))
tag) tag)))
(car content))) (car content)))
spacer ":" spacer)))) spacer ":" spacer))))
(make-flow (make-flow
@ -1520,17 +1600,16 @@
`(,x . ,(cdr form))))))) `(,x . ,(cdr form)))))))
(and kw-id (and kw-id
(eq? form (car forms)) (eq? form (car forms))
(let ([tag (id-to-tag kw-id)] (let ([target-maker (id-to-form-target-maker kw-id #t)]
[stag (id-to-form-tag kw-id)]
[content (list (definition-site (if (pair? form) [content (list (definition-site (if (pair? form)
(car form) (car form)
form) form)
kw-id kw-id
#t))]) #t))])
(if tag (if target-maker
(make-target-element (target-maker
#f content
(list (lambda (tag)
(make-toc-target-element (make-toc-target-element
#f #f
(if kw-id (if kw-id
@ -1543,8 +1622,7 @@
(lambda (libs) (lambda (libs)
(make-form-index-desc (syntax-e kw-id) libs))))) (make-form-index-desc (syntax-e kw-id) libs)))))
content) content)
stag)) tag)))
tag)
(car content))))))))) (car content)))))))))
forms form-procs) forms form-procs)
(if (null? sub-procs) (if (null? sub-procs)
@ -1680,9 +1758,19 @@
(make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc s)))) (make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc s))))
(define (seclink tag #:underline? [u? #t] #:doc [doc #f] . s) (define (seclink tag #:underline? [u? #t] #:doc [doc #f] . s)
(make-link-element (if u? #f "plainlink") (decode-content s) `(part ,(doc-prefix doc tag)))) (make-link-element (if u? #f "plainlink") (decode-content s) `(part ,(doc-prefix doc tag))))
(define (*schemelink stx-id id . s) (define (*schemelink stx-id id . s)
(make-link-element #f (decode-content s) (or (register-scheme-definition stx-id) (let ([content (decode-content s)])
(format "--UNDEFINED:~a--" (syntax-e stx-id))))) (make-delayed-element
(lambda (r p ri)
(list
(make-link-element #f
content
(or (find-scheme-tag p ri stx-id 'for-label)
(format "--UNDEFINED:~a--" (syntax-e stx-id))))))
(lambda () content)
(lambda () content))))
(define-syntax schemelink (define-syntax schemelink
(syntax-rules () (syntax-rules ()
[(_ id . content) (*schemelink (quote-syntax id) 'id . content)])) [(_ id . content) (*schemelink (quote-syntax id) 'id . content)]))
@ -1841,12 +1929,25 @@
(define-struct spec (def)) (define-struct spec (def))
(define-struct impl (def)) (define-struct impl (def))
(define (id-info id)
(let ([b (identifier-label-binding id)])
(list (let ([p (resolved-module-path-name (module-path-index-resolve (caddr b)))])
(if (path? p)
(path->main-collects-relative p)
p))
(cadddr b)
(list-ref b 5))))
(define-serializable-struct cls/intf (name-element super intfs methods)) (define-serializable-struct cls/intf (name-element super intfs methods))
(define (make-inherited-table r d ri decl) (define (make-inherited-table r d ri decl)
(let* ([start (let ([key (register-scheme-definition (decl-name decl))]) (let* ([start (let ([key (find-scheme-tag d ri (decl-name decl) 'for-label)])
(list (cons key (lookup-cls/intf d ri key))))] (if key
[supers (cdr (list (cons key (lookup-cls/intf d ri key)))
null))]
[supers (if (null? start)
null
(cdr
(let loop ([supers start][accum null]) (let loop ([supers start][accum null])
(cond (cond
[(null? supers) (reverse accum)] [(null? supers) (reverse accum)]
@ -1854,15 +1955,19 @@
(loop (cdr supers) accum)] (loop (cdr supers) accum)]
[else [else
(let ([super (car supers)]) (let ([super (car supers)])
(loop (append (map (lambda (i) (loop (append (filter values
(cons i (lookup-cls/intf d ri i))) (map (lambda (i)
(reverse (cls/intf-intfs (cdr super)))) (let ([key (find-scheme-tag d ri i 'for-label)])
(let ([s (cls/intf-super (cdr super))]) (and key
(cons key (lookup-cls/intf d ri key)))))
(reverse (cls/intf-intfs (cdr super)))))
(let ([s (and (cls/intf-super (cdr super))
(find-scheme-tag d ri (cls/intf-super (cdr super)) 'for-label))])
(if s (if s
(list (cons s (lookup-cls/intf d ri s))) (list (cons s (lookup-cls/intf d ri s)))
null)) null))
(cdr supers)) (cdr supers))
(cons super accum)))])))] (cons super accum)))]))))]
[ht (let ([ht (make-hash-table)]) [ht (let ([ht (make-hash-table)])
(for-each (lambda (i) (for-each (lambda (i)
(when (meth? i) (when (meth? i)
@ -1902,12 +2007,14 @@
(define (make-decl-collect decl) (define (make-decl-collect decl)
(make-part-collect-decl (make-part-collect-decl
((id-to-target-maker (decl-name decl) #f)
(list "ignored")
(lambda (tag)
(make-collect-element (make-collect-element
#f null #f null
(lambda (ci) (lambda (ci)
(let ([tag (register-scheme-definition (decl-name decl))])
(collect-put! ci (collect-put! ci
`(cls/intf ,tag) `(cls/intf ,(cadr tag))
(make-cls/intf (make-cls/intf
(make-element (make-element
"schemesymbol" "schemesymbol"
@ -1918,11 +2025,11 @@
(and (decl-super decl) (and (decl-super decl)
(not (free-label-identifier=? (quote-syntax object%) (not (free-label-identifier=? (quote-syntax object%)
(decl-super decl))) (decl-super decl)))
(register-scheme-definition (decl-super decl))) (id-info (decl-super decl)))
(map register-scheme-definition (decl-intfs decl)) (map id-info (decl-intfs decl))
(map (lambda (m) (map (lambda (m)
(meth-name m)) (meth-name m))
(filter meth? (decl-body decl)))))))))) (filter meth? (decl-body decl)))))))))))
(define (build-body decl body) (define (build-body decl body)
(append (append
@ -1969,14 +2076,18 @@
(list (make-flow (list (make-flow
(list (list
(make-paragraph (make-paragraph
(list (let ([tag (id-to-tag stx-id)] (list (let ([target-maker (id-to-target-maker stx-id #t)]
[content (list (annote-exporting-library (to-element stx-id)))]) [content (list (annote-exporting-library (to-element stx-id)))])
(if tag (if target-maker
(target-maker
content
(lambda (tag)
((if whole-page? ((if whole-page?
make-page-target-element make-page-target-element
make-toc-target-element) make-toc-target-element)
#f #f
(list (make-index-element #f (list
(make-index-element #f
content content
tag tag
(list (symbol->string (syntax-e stx-id))) (list (symbol->string (syntax-e stx-id)))
@ -1984,7 +2095,7 @@
(with-exporting-libraries (with-exporting-libraries
(lambda (libs) (lambda (libs)
(make-index-desc (syntax-e stx-id) libs))))) (make-index-desc (syntax-e stx-id) libs)))))
tag) tag)))
(car content))) (car content)))
spacer ":" spacer spacer ":" spacer
(case kind (case kind
@ -2222,36 +2333,38 @@
(define (*xmethod/super cname name) (define (*xmethod/super cname name)
(let ([get (let ([get
(lambda (d ri key) (lambda (d ri key)
(if key
(let ([v (lookup-cls/intf d ri key)]) (let ([v (lookup-cls/intf d ri key)])
(if v (if v
(cons (cls/intf-super v) (cons (cls/intf-super v)
(cls/intf-intfs v)) (cls/intf-intfs v))
null)))] null))
[ctag (id-to-tag cname)]) null))])
(make-delayed-element (make-delayed-element
(lambda (r d ri) (lambda (r d ri)
(let loop ([search (get d ri ctag)]) (let loop ([search (get d ri (find-scheme-tag d ri cname 'for-label))])
(cond (cond
[(null? search) [(null? search)
(list (make-element #f '("<method not found>")))] (list (make-element #f '("<method not found>")))]
[(not (car search)) [(not (car search))
(loop (cdr search))] (loop (cdr search))]
[else [else
(let ([v (lookup-cls/intf d ri (car search))]) (let* ([a-key (find-scheme-tag d ri (car search) 'for-label)]
[v (and a-key (lookup-cls/intf d ri a-key))])
(if v (if v
(if (member name (cls/intf-methods v)) (if (member name (cls/intf-methods v))
(list (list
(make-element #f (make-element #f
(list (**method name (car search)) (list (**method name a-key)
" in " " in "
(cls/intf-name-element v)))) (cls/intf-name-element v))))
(loop (append (cdr search) (get d ri (car search))))) (loop (append (cdr search) (get d ri (find-scheme-tag d ri (car search) 'for-label)))))
(loop (cdr search))))]))) (loop (cdr search))))])))
(lambda () (format "~a in ~a" (syntax-e cname) name)) (lambda () (format "~a in ~a" (syntax-e cname) name))
(lambda () (format "~a in ~a" (syntax-e cname) name))))) (lambda () (format "~a in ~a" (syntax-e cname) name)))))
(define (lookup-cls/intf d ri name) (define (lookup-cls/intf d ri tag)
(let ([v (resolve-get d ri `(cls/intf ,name))]) (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))])
(or v (or v
(make-cls/intf "unknown" (make-cls/intf "unknown"
#f #f
@ -2294,8 +2407,7 @@
#t #t
(list (make-element #f '("signature"))) (list (make-element #f '("signature")))
(lambda () (lambda ()
(let ([in (parameterize ([current-signature (make-sig (let ([in (parameterize ([current-signature (make-sig stx-id)])
(id-to-form-tag stx-id))])
(body-thunk))]) (body-thunk))])
(if indent? (if indent?
(let-values ([(pre-body post-body) (let-values ([(pre-body post-body)

65
collects/scribble/scheme.ss
View File

@ -1,10 +1,12 @@
(module scheme scheme/base (module scheme scheme/base
(require "struct.ss" (require "struct.ss"
"basic.ss" "basic.ss"
"search.ss"
mzlib/class mzlib/class
mzlib/for mzlib/for
setup/main-collects setup/main-collects
syntax/modresolve syntax/modresolve
syntax/modcode
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide define-code (provide define-code
@ -12,8 +14,6 @@
to-element/no-color to-element/no-color
to-paragraph to-paragraph
to-paragraph/prefix to-paragraph/prefix
register-scheme-definition
register-scheme-form-definition
syntax-ize syntax-ize
syntax-ize-hook syntax-ize-hook
current-keyword-list current-keyword-list
@ -73,28 +73,30 @@
(values (substring s 1) #t #f) (values (substring s 1) #t #f)
(values s #f #f))))]) (values s #f #f))))])
(if (or (element? (syntax-e c)) (if (or (element? (syntax-e c))
(delayed-element? (syntax-e c))) (delayed-element? (syntax-e c))
(part-relative-element? (syntax-e c)))
(out (syntax-e c) #f) (out (syntax-e c) #f)
(out (if (and (identifier? c) (out (if (and (identifier? c)
color? color?
(quote-depth . <= . 0) (quote-depth . <= . 0)
(not (or it? is-var?))) (not (or it? is-var?)))
(let ([tag (register-scheme c)]) (if (pair? (identifier-label-binding c))
(if tag
(make-delayed-element (make-delayed-element
(lambda (renderer sec ri) (lambda (renderer sec ri)
(let* ([vtag `(def ,tag)] (let* ([tag (find-scheme-tag sec ri c 'for-label)])
[stag `(form ,tag)] (if tag
[sd (resolve-get/tentative sec ri stag)])
(list (list
(cond (case (car tag)
[sd [(form)
(make-link-element "schemesyntaxlink" (list s) stag)] (make-link-element "schemesyntaxlink" (list s) tag)]
[else [else
(make-link-element "schemevaluelink" (list s) vtag)])))) (make-link-element "schemevaluelink" (list s) tag)]))
(list
(make-element "badlink"
(list (make-element "schemevaluelink" (list s))))))))
(lambda () s) (lambda () s)
(lambda () s)) (lambda () s))
s)) s)
(literalize-spaces s)) (literalize-spaces s))
(cond (cond
[(positive? quote-depth) value-color] [(positive? quote-depth) value-color]
@ -155,6 +157,8 @@
(element-width v)] (element-width v)]
[(delayed-element? v) [(delayed-element? v)
(element-width v)] (element-width v)]
[(part-relative-element? v)
(element-width v)]
[(spaces? v) [(spaces? v)
(+ (sz-loop (car (element-content v))) (+ (sz-loop (car (element-content v)))
(spaces-cnt v) (spaces-cnt v)
@ -538,41 +542,6 @@
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) [(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
(define (register-scheme stx [warn-if-no-label? #f])
(unless (identifier? stx)
(error 'register-scheme-definition "not an identifier: ~e" (syntax->datum stx)))
(let ([b (identifier-label-binding stx)])
(if (or (not b)
(eq? b 'lexical))
(if warn-if-no-label?
(begin
(fprintf (current-error-port)
"~a\n"
;; Call raise-syntax-error to capture error message:
(with-handlers ([exn:fail:syntax? (lambda (exn)
(exn-message exn))])
(raise-syntax-error 'WARNING
"no for-label binding of identifier"
stx)))
(format ":NOLABEL:~a" (syntax-e stx)))
#f)
(format ":~a:~a"
(let ([p (resolve-module-path-index (car b) #f)])
(if (path? p)
(path->main-collects-relative p)
p))
(cadr b)))))
(define (register-scheme/invent stx warn-if-no-label?)
(or (register-scheme stx warn-if-no-label?)
(format ":UNKNOWN:~a" (syntax-e stx))))
(define (register-scheme-definition stx [warn-if-no-label? #f])
`(def ,(register-scheme/invent stx warn-if-no-label?)))
(define (register-scheme-form-definition stx [warn-if-no-label? #f])
`(form ,(register-scheme/invent stx warn-if-no-label?)))
(define syntax-ize-hook (make-parameter (lambda (v col) #f))) (define syntax-ize-hook (make-parameter (lambda (v col) #f)))
(define (vector->short-list v extract) (define (vector->short-list v extract)

126
collects/scribble/search.ss Normal file
View File

@ -0,0 +1,126 @@
(module search scheme/base
(require "struct.ss"
"basic.ss"
setup/main-collects
syntax/modcode)
(provide find-scheme-tag)
(define module-info-cache (make-hash-table))
(define (module-path-index-rejoin mpi rel-to)
(let-values ([(name base) (module-path-index-split mpi)])
(cond
[(not name) rel-to]
[(not base) mpi]
[else
(module-path-index-join name
(module-path-index-rejoin base rel-to))])))
;; mode is #f, 'for-label, or 'for-run
(define (find-scheme-tag part ri stx/binding mode)
(let ([b (cond
[(identifier? stx/binding)
((case mode
[(for-label) identifier-label-binding]
[(for-syntax) identifier-transformer-binding]
[else identifier-binding])
stx/binding)]
[(and (list? stx/binding)
(= 6 (length stx/binding)))
stx/binding]
[else
(and (not (symbol? (car stx/binding)))
(let ([p (module-path-index-join
(main-collects-relative->path (car stx/binding))
#f)])
(list #f
(cadr stx/binding)
p
(cadr stx/binding)
#f
(if (= 2 (length stx/binding))
mode
(caddr stx/binding)))))])])
(and
(pair? b)
(let ([seen (make-hash-table)]
[search-key #f])
(let loop ([queue (list (list (caddr b) (cadddr b) (eq? mode (list-ref b 5))))]
[rqueue null])
(cond
[(null? queue)
(if (null? rqueue)
;; Not documented
#f
(loop (reverse rqueue) null))]
[else
(let ([mod (caar queue)]
[id (cadar queue)]
[here? (caddar queue)]
[queue (cdr queue)])
(let* ([rmp (module-path-index-resolve mod)]
[eb (and here?
(format "~a::~a"
(let ([p (resolved-module-path-name rmp)])
(if (path? p)
(path->main-collects-relative p)
p))
id))])
(when (and eb
(not search-key))
(set! search-key eb))
(let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
(or (and v
(let ([v (resolve-get/tentative part ri `(form ,eb))])
(or (and v `(form ,eb))
`(def ,eb))))
;; Maybe it's re-exported from this module...
;; Try a shortcut:
(if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
;; Not defined through this path, so keep looking
(loop queue rqueue)
;; Check parents, if we can get the source:
(if (and (path? (resolved-module-path-name rmp))
(not (hash-table-get seen rmp #f)))
(let ([exports
(hash-table-get
module-info-cache
rmp
(lambda ()
(let-values ([(run-vals run-stxes
syntax-vals syntax-stxes
label-vals label-stxes)
(module-compiled-exports
(get-module-code (resolved-module-path-name rmp)))])
(let ([t (list (append run-vals run-stxes)
(append syntax-vals syntax-stxes)
(append label-vals label-stxes))])
(hash-table-put! module-info-cache rmp t)
t))))])
(hash-table-put! seen rmp #t)
(let ([a (assq id (list-ref exports
(if here?
0
(case mode
[(for-syntax) 1]
[(for-label) 2]
[else 0]))))])
(if a
(loop queue
(append (map (lambda (m)
(if (pair? m)
(list (module-path-index-rejoin (car m) mod)
(caddr m)
(or here?
(eq? mode (cadr m))))
(list (module-path-index-rejoin m mod)
id
here?)))
(cadr a))
rqueue))
(error 'find-scheme-tag
"dead end when looking for binding source: ~e"
id))))
;; Can't get the module source, so continue with queue:
(loop queue rqueue)))))))])))))))

64
collects/scribble/struct.ss
View File

@ -6,8 +6,8 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-struct collect-info (ht ext-ht parts tags gen-prefix)) (define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents))
(define-struct resolve-info (ci delays undef)) (define-struct resolve-info (ci delays undef searches))
(define (part-collected-info part ri) (define (part-collected-info part ri)
(hash-table-get (collect-info-parts (resolve-info-ci ri)) (hash-table-get (collect-info-parts (resolve-info-ci ri))
@ -49,6 +49,18 @@
#t)) #t))
v)) v))
(define (resolve-search search-key part ri key)
(let ([s-ht (hash-table-get (resolve-info-searches ri)
search-key
(lambda ()
(let ([s-ht (make-hash-table 'equal)])
(hash-table-put! (resolve-info-searches ri)
search-key
s-ht)
s-ht)))])
(hash-table-put! s-ht key #t))
(resolve-get part ri key))
(define (resolve-get/tentative part ri key) (define (resolve-get/tentative part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)]) (let-values ([(v ext?) (resolve-get/where part ri key)])
v)) v))
@ -69,6 +81,7 @@
part-collected-info part-collected-info
collect-put! collect-put!
resolve-get resolve-get
resolve-search
resolve-get/tentative resolve-get/tentative
resolve-get-keys) resolve-get-keys)
@ -168,7 +181,6 @@
;; Delayed element has special serialization support: ;; Delayed element has special serialization support:
(define-struct delayed-element (resolve sizer plain) (define-struct delayed-element (resolve sizer plain)
#:mutable
#:property #:property
prop:serializable prop:serializable
(make-serialize-info (make-serialize-info
@ -210,6 +222,47 @@
;; ---------------------------------------- ;; ----------------------------------------
;; part-relative element has special serialization support:
(define-struct part-relative-element (collect sizer plain)
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-part-relative-element
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-part-relative-element
"serialization failed (wrong resolve info?); ~a"
(exn-message exn)))])
(vector
(make-element #f (part-relative-element-content d ri))))))
#'deserialize-part-relative-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract
(struct part-relative-element ([collect (collect-info? . -> . list?)]
[sizer (-> any)]
[plain (-> any)])))
(provide deserialize-part-relative-element)
(define deserialize-part-relative-element
(make-deserialize-info values values))
(provide part-relative-element-content)
(define (part-relative-element-content e ci/ri)
(hash-table-get (collect-info-relatives (if (resolve-info? ci/ri)
(resolve-info-ci ci/ri)
ci/ri))
e))
(provide collect-info-parents)
;; ----------------------------------------
;; Delayed index entry also has special serialization support. ;; Delayed index entry also has special serialization support.
;; It uses the same delay -> value table as delayed-element ;; It uses the same delay -> value table as delayed-element
(define-struct delayed-index-desc (resolve) (define-struct delayed-index-desc (resolve)
@ -336,6 +389,7 @@
[(c) [(c)
(cond (cond
[(element? c) (content->string (element-content c))] [(element? c) (content->string (element-content c))]
[(part-relative-element? c) (element->string ((part-relative-element-plain c)))]
[(delayed-element? c) (element->string ((delayed-element-plain c)))] [(delayed-element? c) (element->string ((delayed-element-plain c)))]
[(string? c) c] [(string? c) c]
[else (case c [else (case c
@ -356,6 +410,9 @@
[(delayed-element? c) [(delayed-element? c)
(content->string (delayed-element-content c ri) (content->string (delayed-element-content c ri)
renderer sec ri)] renderer sec ri)]
[(part-relative-element? c)
(content->string (part-relative-element-content c ri)
renderer sec ri)]
[else (element->string c)])])) [else (element->string c)])]))
(define (strip-aux content) (define (strip-aux content)
@ -376,6 +433,7 @@
[(string? s) (string-length s)] [(string? s) (string-length s)]
[(element? s) (apply + (map element-width (element-content s)))] [(element? s) (apply + (map element-width (element-content s)))]
[(delayed-element? s) (element-width ((delayed-element-sizer s)))] [(delayed-element? s) (element-width ((delayed-element-sizer s)))]
[(part-relative-element? s) (element-width ((part-relative-element-sizer s)))]
[else 1])) [else 1]))
(define (paragraph-width s) (define (paragraph-width s)

47
collects/scribble/xref.ss
View File

@ -4,6 +4,7 @@
scribble/manual-struct scribble/manual-struct
scribble/decode-struct scribble/decode-struct
scribble/base-render scribble/base-render
scribble/search
(prefix-in html: scribble/html-render) (prefix-in html: scribble/html-render)
scheme/class scheme/class
mzlib/serialize mzlib/serialize
@ -74,27 +75,28 @@
(void)))) (void))))
;; Returns (values <tag-or-#f> <form?>) ;; Returns (values <tag-or-#f> <form?>)
(define (xref-binding-tag xrefs src id) (define xref-binding-tag
(case-lambda
[(xrefs id/binding mode)
(let ([search (let ([search
(lambda (src) (lambda (id/binding)
(let ([base (format ":~a:~a" (let ([tag (find-scheme-tag #f (xrefs-ri xrefs) id/binding mode)])
(if (path? src) (if tag
(path->main-collects-relative src) (values tag (eq? (car tag) 'form))
src) (values #f #f))))])
id)] (cond
[ht (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))]) [(identifier? id/binding)
(let ([form-tag `(form ,base)] (search id/binding)]
[val-tag `(def ,base)]) [(and (list? id/binding)
(if (hash-table-get ht form-tag #f) (= 6 (length id/binding)))
(values form-tag #t) (search id/binding)]
(if (hash-table-get ht val-tag #f) [(and (list? id/binding)
(values val-tag #f) (= 2 (length id/binding)))
(values #f #f))))))]) (let loop ([src (car id/binding)])
(let loop ([src src])
(cond (cond
[(path? src) [(path? src)
(if (complete-path? src) (if (complete-path? src)
(search src) (search (list src (cadr id/binding)))
(loop (path->complete-path src)))] (loop (path->complete-path src)))]
[(path-string? src) [(path-string? src)
(loop (path->complete-path src))] (loop (path->complete-path src))]
@ -109,11 +111,14 @@
(loop (module-path-index-join src #f))] (loop (module-path-index-join src #f))]
[else [else
(raise-type-error 'xref-binding-definition->tag (raise-type-error 'xref-binding-definition->tag
"module path, resolved module path, module path index, path, or string" "list starting with module path, resolved module path, module path index, path, or string"
src)])))) src)]))]
[else (raise-type-error 'xref-binding-definition->tag
"identifier, 2-element list, or 6-element list"
id/binding)]))]))
(define (xref-binding->definition-tag xrefs src id) (define (xref-binding->definition-tag xrefs id/binding mode)
(let-values ([(tag form?) (xref-binding-tag xrefs src id)]) (let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)])
tag)) tag))
(define (xref-tag->path+anchor xrefs tag #:render% [render% (html:render-mixin render%)]) (define (xref-tag->path+anchor xrefs tag #:render% [render% (html:render-mixin render%)])

71
collects/scribblings/foreign/derived.scrbl
View File

@ -5,30 +5,8 @@
@section[#:tag "foreign:tagged-pointers"]{Tagged C Pointer Types} @section[#:tag "foreign:tagged-pointers"]{Tagged C Pointer Types}
@defproc*[([(cpointer-has-tag? [cptr any/c][tag any/c]) boolean?] The unsafe @scheme[cpointer-has-tag?] and @scheme[cpointer-push-tag!]
[(cpointer-push-tag! [cptr any/c][tag any/c]) void])]{ operations manage tags to distinguish pointer types.
These two functions treat pointer tags as lists of tags. As described
in @secref["foreign:pointer-funcs"], a pointer tag does not have any
role, except for Scheme code that uses it to distinguish pointers;
these functions treat the tag value as a list of tags, which makes it
possible to construct pointer types that can be treated as other
pointer types, mainly for implementing inheritance via upcasts (when a
struct contains a super struct as its first element).
The @scheme[cpointer-hash-tag] function checks whether if the given
@scheme[cptr] has the @scheme[tag]. A pointer has a tag @scheme[tag]
when its tag is either @scheme[eq?] to @scheme[tag] or a list that
contains (@scheme[memq]) @scheme[t].
The @scheme[cpointer-push-tag!] function pushes the given @scheme[tag]
value on @scheme[cptr]'s tags. The main properties of this operation
are: (a) pushing any tag will make later calls to
@scheme[cpointer-has-tag?] succeed with this tag, and (b) the pushed tag
will be used when printing the pointer (until a new value is pushed).
Technically, pushing a tag will simply set it if there is no tag set,
otherwise push it on an existing list or an existing value (treated as
a single-element list).}
@defproc*[([(_cpointer [tag any/c] @defproc*[([(_cpointer [tag any/c]
[ptr-type ctype? _pointer] [ptr-type ctype? _pointer]
@ -82,12 +60,43 @@ type produced by @scheme[_cpointer/null] type. Finally,
@schemevarfont{id}@schemeidfont{-tag} is defined as an accessor to @schemevarfont{id}@schemeidfont{-tag} is defined as an accessor to
obtain a tag. The tag is the string form of @schemevarfont{id}.} obtain a tag. The tag is the string form of @schemevarfont{id}.}
@; ----------------------------------------
@subsection{Unsafe Tagged C Pointer Functions}
@declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc*[([(cpointer-has-tag? [cptr any/c][tag any/c]) boolean?]
[(cpointer-push-tag! [cptr any/c][tag any/c]) void])]{
These two functions treat pointer tags as lists of tags. As described
in @secref["foreign:pointer-funcs"], a pointer tag does not have any
role, except for Scheme code that uses it to distinguish pointers;
these functions treat the tag value as a list of tags, which makes it
possible to construct pointer types that can be treated as other
pointer types, mainly for implementing inheritance via upcasts (when a
struct contains a super struct as its first element).
The @scheme[cpointer-hash-tag] function checks whether if the given
@scheme[cptr] has the @scheme[tag]. A pointer has a tag @scheme[tag]
when its tag is either @scheme[eq?] to @scheme[tag] or a list that
contains (@scheme[memq]) @scheme[t].
The @scheme[cpointer-push-tag!] function pushes the given @scheme[tag]
value on @scheme[cptr]'s tags. The main properties of this operation
are: (a) pushing any tag will make later calls to
@scheme[cpointer-has-tag?] succeed with this tag, and (b) the pushed tag
will be used when printing the pointer (until a new value is pushed).
Technically, pushing a tag will simply set it if there is no tag set,
otherwise push it on an existing list or an existing value (treated as
a single-element list).}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section[#:tag "foreign:cvector"]{Safe C Vectors} @section[#:tag "foreign:cvector"]{Safe C Vectors}
The @scheme[cvector] form can be used as a type C vectors (i.e., a the The @scheme[cvector] form can be used as a type C vectors (i.e., a the
pointer to the memory block) pointer to the memory block).
@defproc[(make-cvector [type ctype?][length exact-nonnegative-integer?]) cvector?]{ @defproc[(make-cvector [type ctype?][length exact-nonnegative-integer?]) cvector?]{
@ -139,6 +148,11 @@ Converts the @scheme[cvec] C vector object to a list of values.}
Converts the list @scheme[lst] to a C vector of the given Converts the list @scheme[lst] to a C vector of the given
@scheme[type].} @scheme[type].}
@; ----------------------------------------
@subsection{Unsafe C Vector Construction}
@declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc[(make-cvector* [cptr any/c][type ctype?][length exact-nonnegative-integer?]) cvector?]{ @defproc[(make-cvector* [cptr any/c][type ctype?][length exact-nonnegative-integer?]) cvector?]{
@ -237,11 +251,10 @@ just aliases for byte-string bindings: @scheme[make-u8vector],
"Like " (scheme _cvector) ", but for vectors of " (scheme elem) " elements."))))]))) "Like " (scheme _cvector) ", but for vectors of " (scheme elem) " elements."))))])))
@defform*[[(_u8vector mode type maybe-len) @srfi-4-vector/desc[u8 _uint8]{
_u8vector]]{
Like @scheme[_cvector], but for vectors of @scheme[_byte] elements.}
Like @scheme[_cvector], but for vectors of @scheme[_byte] elements. These are
aliases for @schemeidfont{byte} operations.}
@srfi-4-vector[s8 _int8] @srfi-4-vector[s8 _int8]
@srfi-4-vector[s16 _int16] @srfi-4-vector[s16 _int16]

5
collects/scribblings/foreign/foreign.scrbl
View File

@ -13,8 +13,9 @@ interface}. Furthermore, since most APIs consist mostly of functions,
the foreign interface is sometimes called a @defterm{foreign function the foreign interface is sometimes called a @defterm{foreign function
interface}, abbreviated @deftech{FFI}. interface}, abbreviated @deftech{FFI}.
@bold{Important:} Most of the bindings documented here are available @bold{Important:} Many of the bindings documented here (the ones in
only after an @scheme[(unsafe!)] declaration in the importing module. sections with titles starting ``Unsafe'') are available only after an
@scheme[(unsafe!)] declaration in the importing module.
@table-of-contents[] @table-of-contents[]

4
collects/scribblings/foreign/intro.scrbl
View File

@ -26,7 +26,9 @@ itself protected; see @secref[#:doc '(lib
"scribblings/reference/reference.scrbl") "modprotect"].) Using this "scribblings/reference/reference.scrbl") "modprotect"].) Using this
macro should be considered as a declaration that your code is itself macro should be considered as a declaration that your code is itself
unsafe, therefore can lead to serious problems in case of bugs: it is unsafe, therefore can lead to serious problems in case of bugs: it is
your responsibility to provide a safe interface. your responsibility to provide a safe interface. Bindings that become
available only via @scheme[unsafe!] are documented in this manual in
sections with titles starting ``Unsafe.''
For examples of common FFI usage patterns, see the defined interfaces For examples of common FFI usage patterns, see the defined interfaces
in the @filepath{ffi} collection. in the @filepath{ffi} collection.

19
collects/scribblings/foreign/libs.scrbl
View File

@ -9,6 +9,19 @@ from @as-index{shared objects} (a.k.a. @defterm{@as-index{shared
libraries}} or @defterm{@as-index{dynamically loaded libraries}}). The libraries}} or @defterm{@as-index{dynamically loaded libraries}}). The
@scheme[ffi-lib] function loads a shared object. @scheme[ffi-lib] function loads a shared object.
@defproc[(ffi-lib? [v any/c]) boolean>]{
Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib],
@scheme[#f] otherwise.}
@; ----------------------------------------------------------------------
@section{Unsafe Library Functions}
@declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc[(ffi-lib [path (or/c path-string? false/c)] @defproc[(ffi-lib [path (or/c path-string? false/c)]
[version (or/c string? (listof string?) false/c) #f]) any]{ [version (or/c string? (listof string?) false/c) #f]) any]{
@ -49,12 +62,6 @@ the file is not found. In such cases try to specify a full or
relative path (containing slashes, e.g., @filepath{./foo.so}).} relative path (containing slashes, e.g., @filepath{./foo.so}).}
@defproc[(ffi-lib? [v any/c]) boolean>]{
Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib],
@scheme[#f] otherwise.}
@defproc[(get-ffi-obj [objname (or/c string? bytes? symbol?)] @defproc[(get-ffi-obj [objname (or/c string? bytes? symbol?)]
[lib (or/c ffi-lib? path-string? false/c)] [lib (or/c ffi-lib? path-string? false/c)]
[type ctype?] [type ctype?]

15
collects/scribblings/foreign/misc.scrbl
View File

@ -46,6 +46,16 @@ using values from @scheme[lst] and the given @scheme[type]. The
according to the given @scheme[type].} according to the given @scheme[type].}
@defproc[(vector->cblock [vector any/c][type type?]) any]{
Like @scheme[list->cblock], but for Scheme vectors.}
@; ----------------------------------------------------------------------
@section{Unsafe Miscellaneous Operations}
@declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc[(cblock->list [cblock any/c][type ctype?][length nonnegative-exact-integer?]) @defproc[(cblock->list [cblock any/c][type ctype?][length nonnegative-exact-integer?])
list?]{ list?]{
@ -55,11 +65,6 @@ Scheme list. The arguments are the same as in the
there is no way to know where the block ends.} there is no way to know where the block ends.}
@defproc[(vector->cblock [vector any/c][type type?]) any]{
Like @scheme[list->cblock], but for Scheme vectors.}
@defproc[(cblock->vector [cblock any/c][type ctype?][length nonnegative-exact-integer?]) @defproc[(cblock->vector [cblock any/c][type ctype?][length nonnegative-exact-integer?])
vector?]{ vector?]{

145
collects/scribblings/foreign/pointers.scrbl
View File

@ -11,6 +11,63 @@ strings (used as memory blocks), some additional internal objects
(@scheme[ffi-obj]s and callbacks, see @secref["foreign:c-only"]). (@scheme[ffi-obj]s and callbacks, see @secref["foreign:c-only"]).
Returns @scheme[#f] for other values.} Returns @scheme[#f] for other values.}
@defproc[(ptr-equal? [cptr1 cpointer?][cptr2 cpointer?]) boolean?]{
Compares the values of the two pointers. Two different Scheme
pointer objects can contain the same pointer.}
@defproc[(ptr-add [cptr cpointer?][offset exact-integer?][type ctype? _byte])
cpointer?]{
Returns a cpointer that is like @scheme[cptr] offset by
@scheme[offset] instances of @scheme[ctype].
The resulting cpointer keeps the base pointer and offset separate. The
two pieces are combined at the last minute before any operation on the
pointer, such as supplying the pointer to a foreign function. In
particular, the pointer and offset are not combined until after all
allocation leading up to a foreign-function call; if the called
function does not itself call anything that can trigger a garbage
collection, it can safely use pointers that are offset into the middle
of a GCable object.}
@defproc[(offset-ptr? [cptr cpointer?]) boolean?]{
A predicate for cpointers that have an offset, such as pointers that
were created using @scheme[ptr-add]. Returns @scheme[#t] even if such
an offset happens to be 0. Returns @scheme[#f] for other cpointers
and non-cpointers.}
@defproc[(ptr-offset [cptr cpointer?]) exact-integer?]{
Returns the offset of a pointer that has an offset. The resulting
offset is always in bytes.}
@; ----------------------------------------------------------------------
@section{Unsafe Pointer Operations}
@declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc[(set-ptr-offset! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte])
void?]{
Sets the offset component of an offset pointer. The arguments are
used in the same way as @scheme[ptr-add]. If @scheme[cptr] has no
offset, the @scheme[exn:fail:contract] exception is raised.}
@defproc[(ptr-add! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte])
void?]{
Like @scheme[ptr-add], but destructively modifies the offset contained
in a pointer. The same operation could be performed using
@scheme[ptr-offset] and @scheme[set-ptr-offset!].}
@defproc*[([(ptr-ref [cptr cpointer?] @defproc*[([(ptr-ref [cptr cpointer?]
[type ctype?] [type ctype?]
[offset exact-nonnegative-integer? 0]) [offset exact-nonnegative-integer? 0])
@ -68,74 +125,6 @@ offsets are beyond an object's memory bounds; out-of-bounds access can
easily lead to a segmentation fault or memory corruption.} easily lead to a segmentation fault or memory corruption.}
@defproc[(ptr-equal? [cptr1 cpointer?][cptr2 cpointer?]) boolean?]{
Compares the values of the two pointers. Two different Scheme
pointer objects can contain the same pointer.}
@defproc[(ptr-add [cptr cpointer?][offset exact-integer?][type ctype? _byte])
cpointer?]{
Returns a cpointer that is like @scheme[cptr] offset by
@scheme[offset] instances of @scheme[ctype].
The resulting cpointer keeps the base pointer and offset separate. The
two pieces are combined at the last minute before any operation on the
pointer, such as supplying the pointer to a foreign function. In
particular, the pointer and offset are not combined until after all
allocation leading up to a foreign-function call; if the called
function does not itself call anything that can trigger a garbage
collection, it can safely use pointers that are offset into the middle
of a GCable object.}
@defproc[(offset-ptr? [cptr cpointer?]) boolean?]{
A predicate for cpointers that have an offset, such as pointers that
were created using @scheme[ptr-add]. Returns @scheme[#t] even if such
an offset happens to be 0. Returns @scheme[#f] for other cpointers
and non-cpointers.}
@defproc[(ptr-offset [cptr cpointer?]) exact-integer?]{
Returns the offset of a pointer that has an offset. The resulting
offset is always in bytes.}
@defproc[(set-ptr-offset! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte])
void?]{
Sets the offset component of an offset pointer. The arguments are
used in the same way as @scheme[ptr-add]. If @scheme[cptr] has no
offset, the @scheme[exn:fail:contract] exception is raised.}
@defproc[(ptr-add! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte])
void?]{
Like @scheme[ptr-add], but destructively modifies the offset contained
in a pointer. The same operation could be performed using
@scheme[ptr-offset] and @scheme[set-ptr-offset!].}
@defproc[(cpointer-tag [cptr cpointer?]) any]{
Returns the Scheme object that is the tag of the given @scheme[cptr]
pointer.}
@defproc[(set-cpointer-tag! [cptr cpointer?][tag any/c]) void?]{
Sets the tag of the given @scheme[cptr]. The @scheme[tag] argument can
be any arbitrary value; other pointer operations ignore it. When a
cpointer value is printed, its tag is shown if it is a symbol, a byte
string, a string. In addition, if the tag is a pair holding one of
these in its @scheme[car], the @scheme[car] is shown (so that the tag
can contain other information).}
@defproc*[([(memmove [cptr cpointer?] @defproc*[([(memmove [cptr cpointer?]
[src-cptr cpointer?] [src-cptr cpointer?]
[count nonnegative-exact-integer?] [count nonnegative-exact-integer?]
@ -200,9 +189,27 @@ Similar to @scheme[memmove], but the destination is uniformly filled
with @scheme[byte] (i.e., an exact integer between 0 and 255 with @scheme[byte] (i.e., an exact integer between 0 and 255
inclusive).} inclusive).}
@defproc[(cpointer-tag [cptr cpointer?]) any]{
Returns the Scheme object that is the tag of the given @scheme[cptr]
pointer.}
@defproc[(set-cpointer-tag! [cptr cpointer?][tag any/c]) void?]{
Sets the tag of the given @scheme[cptr]. The @scheme[tag] argument can
be any arbitrary value; other pointer operations ignore it. When a
cpointer value is printed, its tag is shown if it is a symbol, a byte
string, a string. In addition, if the tag is a pair holding one of
these in its @scheme[car], the @scheme[car] is shown (so that the tag
can contain other information).}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@section{Memory Management} @section{Unsafe Memory Management}
@declare-exporting[scribblings/foreign/unsafe-foreign]
For general information on C-level memory management with PLT Scheme, For general information on C-level memory management with PLT Scheme,
see @|InsideMzScheme|. see @|InsideMzScheme|.

5
collects/scribblings/foreign/unsafe-foreign.ss
View File

@ -1,8 +1,11 @@
#lang scheme/base #lang scheme/base
(require scheme/foreign) (require scheme/foreign)
(error 'unsafe! "only `for-label' use in the documentation")
(unsafe!) (unsafe!)
(provide (all-defined-out) (provide (protect-out (all-defined-out))
(all-from-out scheme/foreign)) (all-from-out scheme/foreign))

2
collects/scribblings/gui/blurbs.ss
View File

@ -4,7 +4,7 @@
scribble/manual scribble/manual
scribble/scheme scribble/scheme
scribble/decode scribble/decode
(for-label mred)) (for-label scheme/gui/base))
(provide (except-out (all-defined-out) p)) (provide (except-out (all-defined-out) p))

20
collects/scribblings/gui/common.ss
View File

@ -2,23 +2,23 @@
(module common scheme/base (module common scheme/base
(require scribble/manual (require scribble/manual
scribble/basic scribble/basic
mzlib/class scheme/class
mzlib/contract scheme/contract
"blurbs.ss" "blurbs.ss"
(only-in "../reference/mz.ss" AllUnix exnraise)) (only-in "../reference/mz.ss" AllUnix exnraise))
(provide (all-from-out scribble/manual) (provide (all-from-out scribble/manual)
(all-from-out scribble/basic) (all-from-out scribble/basic)
(all-from-out mzlib/class) (all-from-out scheme/class)
(all-from-out mzlib/contract) (all-from-out scheme/contract)
(all-from-out "blurbs.ss") (all-from-out "blurbs.ss")
(all-from-out "../reference/mz.ss")) (all-from-out "../reference/mz.ss"))
(require (for-label mred (require (for-label scheme/gui/base
mzlib/class scheme/class
mzlib/contract scheme/contract
scheme/base)) scheme/base))
(provide (for-label (all-from-out mred) (provide (for-label (all-from-out scheme/gui/base)
(all-from-out mzlib/class) (all-from-out scheme/class)
(all-from-out mzlib/contract) (all-from-out scheme/contract)
(all-from-out scheme/base)))) (all-from-out scheme/base))))

2
collects/scribblings/gui/diagrams.ss
View File

@ -2,7 +2,7 @@
(require scribble/struct (require scribble/struct
scribble/scheme scribble/scheme
scribble/manual scribble/manual
(for-label mred)) (for-label scheme/gui/base))
(provide diagram->table (provide diagram->table
short-windowing-diagram short-windowing-diagram

2
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -268,7 +268,7 @@ The result depends on @scheme[what], and a @scheme[#f] result is only
} }
@defproc[(graphical-read-eval-print-loop [eval-eventspace eventspace #f] @defproc[(graphical-read-eval-print-loop [eval-eventspace eventspace #f]
[redirect-ports? any/c @scheme[(not @scheme[eval-eventspace])]]) [redirect-ports? any/c (not eval-eventspace)])
void?]{ void?]{
Similar to MzScheme's @scheme[read-eval-print-loop], except that none of Similar to MzScheme's @scheme[read-eval-print-loop], except that none of

84
collects/scribblings/htdp-langs/advanced.scrbl
View File

@ -4,18 +4,36 @@
"prim-ops.ss" "prim-ops.ss"
(for-label lang/htdp-advanced)) (for-label lang/htdp-advanced))
@(define-syntax-rule (bd intm-define intm-define-struct intm-lambda intm-let) @(define-syntax-rule (bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time)
(begin (begin
(require (for-label lang/htdp-intermediate-lambda)) (require (for-label lang/htdp-intermediate))
(define intm-define (scheme define)) (define intm-define (scheme define))
(define intm-define-struct (scheme define-struct)) (define intm-define-struct (scheme define-struct))
(define intm-lambda (scheme lambda)) (define intm-lambda (scheme lambda))
(define intm-let (scheme let)))) (define intm-local (scheme local))
@(bd intm-define intm-define-struct intm-lambda intm-let) (define intm-letrec (scheme letrec))
(define intm-let (scheme let))
(define intm-let* (scheme let*))
(define intm-time (scheme time))))
@(bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time)
@(define-syntax-rule (bbd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
(begin
(require (for-label lang/htdp-beginner))
(define beg-define (scheme define))
(define beg-define-struct (scheme define-struct))
(define beg-cond (scheme cond))
(define beg-if (scheme if))
(define beg-and (scheme and))
(define beg-or (scheme or))
(define beg-require (scheme require))))
@(bbd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
@title[#:style 'toc]{Advanced Student} @title[#:style 'toc]{Advanced Student}
@declare-exporting[lang/htdp-advanced]
@schemegrammar*+qq[ @schemegrammar*+qq[
#:literals (define define-struct lambda cond else if and or empty true false require lib planet #:literals (define define-struct lambda cond else if and or empty true false require lib planet
local let let* letrec time begin begin0 set! delay shared recur when case unless) local let let* letrec time begin begin0 set! delay shared recur when case unless)
@ -255,9 +273,57 @@ first @scheme[expr] produces @scheme[false] instead of @scheme[true].}
@section[#:tag "advanced-prim-ops"]{Primitive Operations} @section[#:tag "advanced-prim-ops"]{Primitive Operations}
The following primitives extend the set available though @prim-op-defns['(lib "htdp-advanced.ss" "lang") #'here '()]
@seclink["intermediate-prim-op"]{Intermediate}.
@prim-op-defns['(lib "htdp-advanced.ss" "lang") @; ----------------------------------------------------------------------
#'here
'((lib "htdp-beginner.ss" "lang") (lib "htdp-intermediate.ss" "lang"))] @section[#:tag "advanced-unchanged"]{Unchanged Forms}
@deftogether[(
@defform[(local [definition ...] expr)]
@defform[(letrec ([id expr-for-let] ...) expr)]
@defform[(let* ([id expr-for-let] ...) expr)]
)]{
The same as Intermediate's @|intm-local|, @|intm-letrec|, and
@|intm-let*|.}
@deftogether[(
@defform[(cond [expr expr] ... [expr expr])]
@defidform[else]
)]{
The same as Beginner's @|beg-cond|, except that @scheme[else] can be
used with @scheme[case].}
@defform[(if expr expr expr)]{
The same as Beginner's @|beg-if|.}
@deftogether[(
@defform[(and expr expr expr ...)]
@defform[(or expr expr expr ...)]
)]{
The same as Beginner's @|beg-and| and @|beg-or|.}
@defform[(time expr)]{
The same as Intermediate's @|intm-time|.}
@deftogether[(
@defthing[empty empty?]
@defthing[true boolean?]
@defthing[false boolean?]
)]{
Constants for the empty list, true, and false.}
@defform[(require string)]{
The same as Beginner's @|beg-require|.}

73
collects/scribblings/htdp-langs/beginner-abbr.scrbl
View File

@ -4,8 +4,23 @@
"prim-ops.ss" "prim-ops.ss"
(for-label lang/htdp-beginner-abbr)) (for-label lang/htdp-beginner-abbr))
@(define-syntax-rule (bd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
(begin
(require (for-label lang/htdp-beginner))
(define beg-define (scheme define))
(define beg-define-struct (scheme define-struct))
(define beg-cond (scheme cond))
(define beg-if (scheme if))
(define beg-and (scheme and))
(define beg-or (scheme or))
(define beg-require (scheme require))))
@(bd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
@title[#:style 'toc]{Beginner Student with List Abbreviations} @title[#:style 'toc]{Beginner Student with List Abbreviations}
@declare-exporting[lang/htdp-beginner-abbr]
@schemegrammar*+qq[ @schemegrammar*+qq[
#:literals (define define-struct lambda cond else if and or empty true false require lib planet) #:literals (define define-struct lambda cond else if and or empty true false require lib planet)
[program def-or-expr] [program def-or-expr]
@ -102,3 +117,61 @@ that is, it decrements the quasiquote count by one.
Normally, a splicing unquote is written with @litchar{,}, but it can Normally, a splicing unquote is written with @litchar{,}, but it can
also be written with @scheme[unquote-splicing].} also be written with @scheme[unquote-splicing].}
@; ----------------------------------------
@section[#:tag "beginner-abbr-prim-ops"]{Primitive Operations}
@prim-op-defns['(lib "htdp-beginner-abbr.ss" "lang") #'here '()]
@; ----------------------------------------------------------------------
@section{Unchanged Forms}
@deftogether[(
@defform[(define (id id id ...) expr)]
@defform/none[#:literals (define)
(define id expr)]
@defform/none[#:literals (define lambda)
(define id (lambda (id id ...) expr))]
@defidform[lambda]
)]{
The same as Beginner's @|beg-define|.}
@defform[(define-struct structid (fieldid ...))]{
The same as Beginner's @|beg-define-struct|.}
@deftogether[(
@defform[(cond [expr expr] ... [expr expr])]
@defidform[else]
)]{
The same as Beginner's @|beg-cond|.}
@defform[(if expr expr expr)]{
The same as Beginner's @|beg-if|.}
@deftogether[(
@defform[(and expr expr expr ...)]
@defform[(or expr expr expr ...)]
)]{
The same as Beginner's @|beg-and| and @|beg-or|.}
@deftogether[(
@defthing[empty empty?]
@defthing[true boolean?]
@defthing[false boolean?]
)]{
Constants for the empty list, true, and false.}
@defform[(require string)]{
The same as Beginner's @|beg-require|.}

11
collects/scribblings/htdp-langs/beginner.scrbl
View File

@ -4,15 +4,11 @@
"prim-ops.ss" "prim-ops.ss"
(for-label lang/htdp-beginner)) (for-label lang/htdp-beginner))
@(define-syntax-rule (bd intm-case)
(begin
(require (for-label lang/htdp-advanced))
(define intm-case (scheme case))))
@(bd adv-case)
@title[#:style 'toc]{Beginner Student} @title[#:style 'toc]{Beginner Student}
@declare-exporting[lang/htdp-beginner]
@schemegrammar*+library[ @schemegrammar*+library[
#:literals (define define-struct lambda cond else if and or empty true false require lib planet) #:literals (define define-struct lambda cond else if and or empty true false require lib planet)
[program def-or-expr] [program def-or-expr]
@ -175,8 +171,7 @@ end'' of the @scheme[cond] form.}
@defidform[else]{ @defidform[else]{
The @scheme[else] keyword can be used only with @scheme[cond], or in The @scheme[else] keyword can be used only with @scheme[cond].}
Advanced language, with @|adv-case|.}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------

87
collects/scribblings/htdp-langs/intermediate-lambda.scrbl
View File

@ -4,15 +4,35 @@
"prim-ops.ss" "prim-ops.ss"
(for-label lang/htdp-intermediate-lambda)) (for-label lang/htdp-intermediate-lambda))
@(define-syntax-rule (bd intm-define) @(define-syntax-rule (bd intm-define intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time)
(begin (begin
(require (for-label lang/htdp-intermediate)) (require (for-label lang/htdp-intermediate))
(define intm-define (scheme define)))) (define intm-define (scheme define))
@(bd intm-define) (define intm-define-struct (scheme define-struct))
(define intm-local (scheme local))
(define intm-letrec (scheme letrec))
(define intm-let (scheme let))
(define intm-let* (scheme let*))
(define intm-time (scheme time))))
@(bd intm-define intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time)
@(define-syntax-rule (bbd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
(begin
(require (for-label lang/htdp-beginner))
(define beg-define (scheme define))
(define beg-define-struct (scheme define-struct))
(define beg-cond (scheme cond))
(define beg-if (scheme if))
(define beg-and (scheme and))
(define beg-or (scheme or))
(define beg-require (scheme require))))
@(bbd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
@title[#:style 'toc]{Intermediate Student with Lambda} @title[#:style 'toc]{Intermediate Student with Lambda}
@declare-exporting[lang/htdp-intermediate-lambda]
@schemegrammar*+qq[ @schemegrammar*+qq[
#:literals (define define-struct lambda cond else if and or empty true false require lib planet #:literals (define define-struct lambda cond else if and or empty true false require lib planet
local let let* letrec time) local let let* letrec time)
@ -97,3 +117,64 @@ practically never written that way.}
The name of a primitive operation can be used as an expression. It The name of a primitive operation can be used as an expression. It
produces a function version of the operation.} produces a function version of the operation.}
@prim-op-defns['(lib "htdp-intermediate-lambda.ss" "lang") #'here '()]
@; ----------------------------------------------------------------------
@section[#:tag "intermediate-lambda-unchanged"]{Unchanged Forms}
@defform[(define-struct structid (fieldid ...))]{
The same as Intermediate's @|intm-define-struct|.}
@deftogether[(
@defform[(local [definition ...] expr)]
@defform[(letrec ([id expr-for-let] ...) expr)]
@defform[(let ([id expr-for-let] ...) expr)]
@defform[(let* ([id expr-for-let] ...) expr)]
)]{
The same as Intermediate's @|intm-local|, @|intm-letrec|, @|intm-let|,
and @|intm-let*|.}
@deftogether[(
@defform[(cond [expr expr] ... [expr expr])]
@defidform[else]
)]{
The same as Beginner's @|beg-cond|.}
@defform[(if expr expr expr)]{
The same as Beginner's @|beg-if|.}
@deftogether[(
@defform[(and expr expr expr ...)]
@defform[(or expr expr expr ...)]
)]{
The same as Beginner's @|beg-and| and @|beg-or|.}
@defform[(time expr)]{
The same as Intermediate's @|intm-time|.}
@deftogether[(
@defthing[empty empty?]
@defthing[true boolean?]
@defthing[false boolean?]
)]{
Constants for the empty list, true, and false.}
@defform[(require string)]{
The same as Beginner's @|beg-require|.}

53
collects/scribblings/htdp-langs/intermediate.scrbl
View File

@ -4,16 +4,22 @@
"prim-ops.ss" "prim-ops.ss"
(for-label lang/htdp-intermediate)) (for-label lang/htdp-intermediate))
@(define-syntax-rule (bd beg-define beg-define-struct) @(define-syntax-rule (bd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
(begin (begin
(require (for-label lang/htdp-beginner)) (require (for-label lang/htdp-beginner))
(define beg-define (scheme define)) (define beg-define (scheme define))
(define beg-define-struct (scheme define-struct)))) (define beg-define-struct (scheme define-struct))
@(bd beg-define beg-define-struct) (define beg-cond (scheme cond))
(define beg-if (scheme if))
(define beg-and (scheme and))
(define beg-or (scheme or))
(define beg-require (scheme require))))
@(bd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-require)
@title[#:style 'toc]{Intermediate Student} @title[#:style 'toc]{Intermediate Student}
@declare-exporting[lang/htdp-intermediate]
@schemegrammar*+qq[ @schemegrammar*+qq[
#:literals (define define-struct lambda cond else if and or empty true false require lib planet #:literals (define define-struct lambda cond else if and or empty true false require lib planet
local let let* letrec time) local let let* letrec time)
@ -179,6 +185,39 @@ The name of a primitive operation can be used as an expression. If it
is passed to a function, then it can be used in a function call within is passed to a function, then it can be used in a function call within
the function's body.} the function's body.}
@prim-op-defns['(lib "htdp-intermediate.ss" "lang") @prim-op-defns['(lib "htdp-intermediate.ss" "lang") #'here '()]
#'here
'((lib "htdp-beginner.ss" "lang"))] @; ----------------------------------------------------------------------
@section[#:tag "intermediate-unchanged"]{Unchanged Forms}
@deftogether[(
@defform[(cond [expr expr] ... [expr expr])]
@defidform[else]
)]{
The same as Beginner's @|beg-cond|.}
@defform[(if expr expr expr)]{
The same as Beginner's @|beg-if|.}
@deftogether[(
@defform[(and expr expr expr ...)]
@defform[(or expr expr expr ...)]
)]{
The same as Beginner's @|beg-and| and @|beg-or|.}
@deftogether[(
@defthing[empty empty?]
@defthing[true boolean?]
@defthing[false boolean?]
)]{
Constants for the empty list, true, and false.}
@defform[(require string)]{
The same as Beginner's @|beg-require|.}

2
collects/scribblings/quick/quick.scrbl
View File

@ -15,7 +15,7 @@
"mred-doc.ss" "mred-doc.ss"
(for-label scheme/base (for-label scheme/base
mred/mred scheme/gui/base
scheme/class scheme/class
slideshow) slideshow)

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

@ -15,6 +15,7 @@ called.
@include-section["stx-ops.scrbl"] @include-section["stx-ops.scrbl"]
@include-section["stx-comp.scrbl"] @include-section["stx-comp.scrbl"]
@include-section["stx-trans.scrbl"] @include-section["stx-trans.scrbl"]
@include-section["stx-param.scrbl"]
@include-section["stx-props.scrbl"] @include-section["stx-props.scrbl"]
@include-section["stx-certs.scrbl"] @include-section["stx-certs.scrbl"]
@include-section["stx-expand.scrbl"] @include-section["stx-expand.scrbl"]

52
collects/scribblings/reference/module-reflect.scrbl
View File

@ -243,22 +243,56 @@ the module's declared name.}
@defproc[(module-compiled-imports [compiled-module-code compiled-module-expression?]) @defproc[(module-compiled-imports [compiled-module-code compiled-module-expression?])
(values (listof module-path-index?) (values (listof module-path-index?)
(listof module-path-index?)
(listof module-path-index?) (listof module-path-index?)
(listof module-path-index?))]{ (listof module-path-index?))]{
Takes a module declaration in compiled form and returns three values: Takes a module declaration in compiled form and returns four values: a
a list of module references for the module's explicit imports, a list list of module references for the module's explicit imports, a list of
of module references for the module's explicit for-syntax imports, and module references for the module's explicit for-syntax imports, a list
a list of module references for the module's explicit for-template of module references for the module's explicit for-template imports,
and a list of module references for the module's explicit for-label
imports.} imports.}
@defproc[(module-compiled-exports [compiled-module-code compiled-module-expression?]) @defproc[(module-compiled-exports [compiled-module-code compiled-module-expression?])
(values (listof symbol?) (values list? list? list? list? list? list?)]{
(listof symbol?))]{
Takes a module declaration in compiled form and returns two values: a Returns six lists: one for the module's explicit variable exports, one
list of symbols for the module's explicit variable exports, a list for the module's explicit syntax exports, one for the module's
symbols for the module's explicit syntax exports.} explicit @scheme[for-syntax] variable exports, one for the module's
explicit @scheme[for-syntax] syntax exports, one for the module's
explicit @scheme[for-label] variable exports, one for the module's
explicit @scheme[for-label] syntax exports.
Each list more precisely matches the contract
@schemeblock[
(listof (list/c symbol?
(listof
(or/c module-path-index?
(list/c module-path-index?
(one-of/c #f 'for-syntax 'for-label)
symbol?)))))
]
For each element of the list, the leading symbol is the name of the
export.
The second part---the list of @tech{module path index} values,
etc.---describes the origin of the exported identifier. If the origin
list is @scheme[null], then the exported identifier is defined in the
module. If the exported identifier is re-exported, instead, then the
origin list provides information on the import that was re-exported.
The origin list has more than one element if the binding was imported
multiple times from (possibly) different sources.
For each origin, a @tech{module path index} by itself means that the
binding was imported with a plain @scheme[require] (not
@scheme[for-syntax] or @scheme[for-label]), and imported identifier
has the same name as the re-exported name. An origin represented with
a list indicates explicitly the import, the import mode (plain
@scheme[require], @scheme[for-syntax], or @scheme[for-label]) and the
original export name of the re-exported binding.}
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "dynreq"]{Dynamic Module Access} @section[#:tag "dynreq"]{Dynamic Module Access}

2
collects/scribblings/reference/sandbox.scrbl
View File

@ -2,7 +2,7 @@
@(require "mz.ss" @(require "mz.ss"
scheme/sandbox scheme/sandbox
(for-label scheme/sandbox (for-label scheme/sandbox
(only-in mred/mred make-gui-namespace) (only-in scheme/gui make-gui-namespace)
scheme/gui/dynamic)) scheme/gui/dynamic))
@title{Sandboxed Evaluation} @title{Sandboxed Evaluation}

18
collects/scribblings/reference/serialization.scrbl
View File

@ -41,9 +41,11 @@ The following kinds of values are serializable:
@item{booleans, numbers, characters, symbols, strings, byte strings, @item{booleans, numbers, characters, symbols, strings, byte strings,
paths (for a specific convention), @|void-const|, and the empty list;} paths (for a specific convention), @|void-const|, and the empty list;}
@item{pairs, mutable pairs, vectors, boxes, and hash tables; and} @item{pairs, mutable pairs, vectors, boxes, and hash tables;}
@item{@scheme[date] and @scheme[arity-at-least] structures.} @item{@scheme[date] and @scheme[arity-at-least] structures; and}
@item{@tech{module path index} values.}
} }
@ -133,12 +135,17 @@ elements:
@item{@scheme['date] for a @scheme[date] structure, which @item{@scheme['date] for a @scheme[date] structure, which
fails on deserialization (since dates are immutable; fails on deserialization (since dates are immutable;
this case does not appear in output generated by this case does not appear in output generated by
@scheme[serialize]); or} @scheme[serialize]);}
@item{@scheme['arity-at-least] for an @item{@scheme['arity-at-least] for an
@scheme[arity-at-least] structure, which fails on @scheme[arity-at-least] structure, which fails on
deserialization (since dates are immutable; this deserialization (since dates are immutable; this
case does not appear in output generated by case does not appear in output generated by
@scheme[serialize]); or}
@item{@scheme['mpi] for a @tech{module path index}, which
fails on deserialization (since dates are immutable;
this case does not appear in output generated by
@scheme[serialize]).} @scheme[serialize]).}
} }
@ -240,6 +247,11 @@ elements:
and whose @scheme[cdr] is a serial; it represents an and whose @scheme[cdr] is a serial; it represents an
@scheme[arity-at-least] structure.} @scheme[arity-at-least] structure.}
@item{a pair whose @scheme[car] is @scheme['mpi] and whose
@scheme[cdr] is a pair; it represents an
@tech{module path index} that joins the paired
values.}
}} }}
}} }}

116
collects/scribblings/reference/stx-comp.scrbl
View File

@ -1,7 +1,5 @@
#lang scribble/doc #lang scribble/doc
@(require "mz.ss" @(require "mz.ss")
(for-label scheme/stxparam
scheme/stxparam-exptime))
@title[#:tag "stxcmp"]{Syntax Object Bindings} @title[#:tag "stxcmp"]{Syntax Object Bindings}
@ -56,11 +54,12 @@ is @scheme[#f].}
@defproc[(identifier-binding [id-stx syntax?]) @defproc[(identifier-binding [id-stx syntax?])
(or/c (one-of 'lexical #f) (or/c (one-of 'lexical #f)
(listof (or/c module-path-index? symbol?) (listof module-path-index?
symbol? symbol?
(or/c module-path-index? symbol?) module-path-index?
symbol? symbol?
boolean?))]{ boolean?
(one-of/c #f 'for-syntax 'for-template)))]{
Returns one of three kinds of values, depending on the binding of Returns one of three kinds of values, depending on the binding of
@scheme[id-stx] at @tech{phase level} 0: @scheme[id-stx] at @tech{phase level} 0:
@ -70,9 +69,9 @@ Returns one of three kinds of values, depending on the binding of
@item{The result is @indexed-scheme['lexical] if @scheme[id-stx] @item{The result is @indexed-scheme['lexical] if @scheme[id-stx]
has a @tech{local binding}.} has a @tech{local binding}.}
@item{The result is a list of five items when @scheme[id-stx] @item{The result is a list of six items when @scheme[id-stx]
has a @tech{module binding}: @scheme[(list source-mod source-id has a @tech{module binding}: @scheme[(list source-mod source-id
nominal-source-mod nominal-source-id et?)]. nominal-source-mod nominal-source-id et? mode)].
@itemize{ @itemize{
@ -104,6 +103,11 @@ Returns one of three kinds of values, depending on the binding of
@item{@scheme[et?] is @scheme[#t] if the source definition is @item{@scheme[et?] is @scheme[#t] if the source definition is
for-syntax, @scheme[#f] otherwise.} for-syntax, @scheme[#f] otherwise.}
@item{@scheme[mode] is @scheme[#f] if the binding import is a
plain @scheme[require], @scheme['for-syntax] if it is from a
@scheme[for-syntax] import, or @scheme['for-template] if it is
from a @scheme[for-template] import.}
}} }}
@item{The result is @scheme[#f] if @scheme[id-stx] @item{The result is @scheme[#f] if @scheme[id-stx]
@ -113,11 +117,12 @@ Returns one of three kinds of values, depending on the binding of
@defproc[(identifier-transformer-binding [id-stx syntax?]) @defproc[(identifier-transformer-binding [id-stx syntax?])
(or/c (one-of 'lexical #f) (or/c (one-of 'lexical #f)
(listof (or/c module-path-index? symbol?) (listof module-path-index?
symbol? symbol?
(or/c module-path-index? symbol?) module-path-index?
symbol? symbol?
boolean?))]{ boolean?
(one-of/c #f 'for-syntax 'for-template)))]{
Like @scheme[identifier-binding], but that the reported information is Like @scheme[identifier-binding], but that the reported information is
for the identifier's binding in @tech{phase level} 1 (see for the identifier's binding in @tech{phase level} 1 (see
@ -131,11 +136,12 @@ If the result is @scheme['lexical] for either of
@defproc[(identifier-template-binding [id-stx syntax?]) @defproc[(identifier-template-binding [id-stx syntax?])
(or/c (one-of 'lexical #f) (or/c (one-of 'lexical #f)
(listof (or/c module-path-index? symbol?) (listof module-path-index?
symbol? symbol?
(or/c module-path-index? symbol?) module-path-index?
symbol? symbol?
boolean?))]{ boolean?
(one-of/c #f 'for-syntax 'for-template)))]{
Like @scheme[identifier-binding], but that the reported information is Like @scheme[identifier-binding], but that the reported information is
for the identifier's binding in @tech{phase level} -1 (see for the identifier's binding in @tech{phase level} -1 (see
@ -153,7 +159,8 @@ If the result is @scheme['lexical] for either of
symbol? symbol?
(or/c module-path-index? symbol?) (or/c module-path-index? symbol?)
symbol? symbol?
boolean?))]{ boolean?
(one-of/c #f 'for-label)))]{
Like @scheme[identifier-binding], but that the reported information is Like @scheme[identifier-binding], but that the reported information is
for the identifier's binding in the @tech{label phase level} (see for the identifier's binding in the @tech{label phase level} (see
@ -162,82 +169,3 @@ for the identifier's binding in the @tech{label phase level} (see
Unlike @scheme[identifier-binding], the result cannot be Unlike @scheme[identifier-binding], the result cannot be
@scheme['lexical].} @scheme['lexical].}
@; ----------------------------------------------------------------------
@section[#:tag "stxparam"]{Syntax Parameters}
@note-lib-only[scheme/stxparam]
@defform[(define-syntax-parameter id expr)]{
Binds @scheme[id] as syntax to a @deftech{syntax
parameter}. The @scheme[expr] is an expression in the
@tech{transformer environment} that serves as the default value for
the @tech{syntax parameter}. The value is typically obtained by a transformer
using @scheme[syntax-parameter-value].
The @scheme[id] can be used with @scheme[syntax-parameterize]
or @scheme[syntax-parameter-value] (in a transformer). If
@scheme[expr] produces a procedure of one argument or a
@scheme[make-set!-transformer] result, then @scheme[id] can be
used as a macro. If @scheme[expr] produces a
@scheme[rename-transformer] result, then @scheme[id] can be
used as a macro that expands to a use of the target identifier, but
@scheme[syntax-local-value] of @scheme[id] does not produce
the target's value.}
@defform[(syntax-parameterize ((id expr) ...) body-expr ...+)]{
Each @scheme[id] must be bound to a @tech{syntax parameter} using
@scheme[define-syntax-parameter]. Each @scheme[expr] is an expression
in the @tech{transformer environment}. During the expansion of the
@scheme[body-expr]s, the value of each @scheme[expr] is bound to the
corresponding @scheme[id].
If an @scheme[expr] produces a procedure of one argument or a
@scheme[make-set!-transformer] result, then its @scheme[id]
can be used as a macro during the expansion of the
@scheme[body-expr]s. If @scheme[expr] produces a
@scheme[rename-transformer] result, then @scheme[id] can be
used as a macro that expands to a use of the target identifier, but
@scheme[syntax-local-value] of @scheme[id] does not produce
the target's value.}
@defproc[(syntax-parameter-value [id-stx syntax?]) any]{
This procedure is intended for use in a @tech{transformer
environment}, where @scheme[id-stx] is an identifier bound in the
normal environment to a @tech{syntax parameter}. The result is the current
value of the @tech{syntax parameter}, as adjusted by
@scheme[syntax-parameterize] form.
This binding is provided @scheme[for-syntax] by
@schememodname[scheme/stxparam], since it is normally used in a
transformer. It is provided normally by
@scheme[scheme/stxparam-exptime].}
@defproc[(make-parameter-rename-transformer [id-stx syntax?]) any]{
This procedure is intended for use in a transformer, where
@scheme[id-stx] is an identifier bound to a @tech{syntax parameter}. The
result is transformer that behaves as @scheme[id-stx], but that cannot
be used with @scheme[syntax-parameterize] or
@scheme[syntax-parameter-value].
Using @scheme[make-parameter-rename-transformer] is analogous to
defining a procedure that calls a parameter. Such a procedure can be
exported to others to allow access to the parameter value, but not to
change the parameter value. Similarly,
@scheme[make-parameter-rename-transformer] allows a @tech{syntax parameter}
to used as a macro, but not changed.
The result of @scheme[make-parameter-rename-transformer] is not
treated specially by @scheme[syntax-local-value], unlike the result
of @scheme[make-rename-transformer].
This binding is provided @scheme[for-syntax] by
@schememodname[scheme/stxparam], since it is normally used in a
transformer. It is provided normally by
@scheme[scheme/stxparam-exptime].}

89
collects/scribblings/reference/stx-param.scrbl Normal file
View File

@ -0,0 +1,89 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/stxparam
scheme/stxparam-exptime))
@title[#:tag "stxparam"]{Syntax Parameters}
@note-lib-only[scheme/stxparam]
@defform[(define-syntax-parameter id expr)]{
Binds @scheme[id] as syntax to a @deftech{syntax
parameter}. The @scheme[expr] is an expression in the
@tech{transformer environment} that serves as the default value for
the @tech{syntax parameter}. The value is typically obtained by a transformer
using @scheme[syntax-parameter-value].
The @scheme[id] can be used with @scheme[syntax-parameterize]
or @scheme[syntax-parameter-value] (in a transformer). If
@scheme[expr] produces a procedure of one argument or a
@scheme[make-set!-transformer] result, then @scheme[id] can be
used as a macro. If @scheme[expr] produces a
@scheme[rename-transformer] result, then @scheme[id] can be
used as a macro that expands to a use of the target identifier, but
@scheme[syntax-local-value] of @scheme[id] does not produce
the target's value.}
@defform[(syntax-parameterize ((id expr) ...) body-expr ...+)]{
Each @scheme[id] must be bound to a @tech{syntax parameter} using
@scheme[define-syntax-parameter]. Each @scheme[expr] is an expression
in the @tech{transformer environment}. During the expansion of the
@scheme[body-expr]s, the value of each @scheme[expr] is bound to the
corresponding @scheme[id].
If an @scheme[expr] produces a procedure of one argument or a
@scheme[make-set!-transformer] result, then its @scheme[id]
can be used as a macro during the expansion of the
@scheme[body-expr]s. If @scheme[expr] produces a
@scheme[rename-transformer] result, then @scheme[id] can be
used as a macro that expands to a use of the target identifier, but
@scheme[syntax-local-value] of @scheme[id] does not produce
the target's value.}
@; ----------------------------------------------------------------------
@section{Syntax Parameter Inspection}
@defmodule*/no-declare[(scheme/stxparam-exptime)]
@declare-exporting[scheme/stxparam-exptime scheme/stxparam]
@defproc[(syntax-parameter-value [id-stx syntax?]) any]{
This procedure is intended for use in a @tech{transformer
environment}, where @scheme[id-stx] is an identifier bound in the
normal environment to a @tech{syntax parameter}. The result is the current
value of the @tech{syntax parameter}, as adjusted by
@scheme[syntax-parameterize] form.
This binding is provided @scheme[for-syntax] by
@schememodname[scheme/stxparam], since it is normally used in a
transformer. It is provided normally by
@schememodname[scheme/stxparam-exptime].}
@defproc[(make-parameter-rename-transformer [id-stx syntax?]) any]{
This procedure is intended for use in a transformer, where
@scheme[id-stx] is an identifier bound to a @tech{syntax parameter}. The
result is transformer that behaves as @scheme[id-stx], but that cannot
be used with @scheme[syntax-parameterize] or
@scheme[syntax-parameter-value].
Using @scheme[make-parameter-rename-transformer] is analogous to
defining a procedure that calls a parameter. Such a procedure can be
exported to others to allow access to the parameter value, but not to
change the parameter value. Similarly,
@scheme[make-parameter-rename-transformer] allows a @tech{syntax parameter}
to used as a macro, but not changed.
The result of @scheme[make-parameter-rename-transformer] is not
treated specially by @scheme[syntax-local-value], unlike the result
of @scheme[make-rename-transformer].
This binding is provided @scheme[for-syntax] by
@schememodname[scheme/stxparam], since it is normally used in a
transformer. It is provided normally by
@schememodname[scheme/stxparam-exptime].}

111
collects/scribblings/reference/stx-trans.scrbl
View File

@ -445,6 +445,61 @@ mark}. Multiple applications of the same
@scheme[make-syntax-introducer] result procedure use the same mark, @scheme[make-syntax-introducer] result procedure use the same mark,
and different result procedures use distinct marks.} and different result procedures use distinct marks.}
@defproc[(syntax-local-transforming-module-provides?) boolean?]{
Returns @scheme[#t] while a @tech{provide transformer} is running (see
@scheme[make-provide-transformer]) or while a @schemeidfont{expand} sub-form of
@scheme[#%provide] is expanded, @scheme[#f] otherwise.}
@defproc[(syntax-local-module-defined-identifiers)
(values (listof identifier?) (listof identifier?))]{
Can be called only while
@scheme[syntax-local-transforming-module-provides?] returns
@scheme[#t].
It returns two lists of identifiers corresponding to all definitions
within the module being expanded. This information is used for
implementing @scheme[provide] sub-forms like @scheme[all-defined-out].
The first result list corresponds to @tech{phase} 0 (i.e., normal)
definitions, and the second corresponds to @tech{phase} -1 (i.e.,
for-syntax) definitions.}
@defproc[(syntax-local-module-required-identifiers
[mod-path module-path?]
[normal-imports? any/c]
[syntax-imports? any/c]
[label-imports? any/c])
(values (listof identifier?)
(listof identifier?)
(listof identifier?))]{
Can be called only while
@scheme[syntax-local-transforming-module-provides?] returns
@scheme[#t].
It returns three lists of identifiers corresponding to all bindings
imported into the module being expanded using the module path
@scheme[mod-path]. This information is used for implementing
@scheme[provide] sub-forms like @scheme[all-from-out].
The first result list corresponds to @tech{phase level} 0 (i.e.,
normal) bindings, and the second list corresponds to @tech{phase
level} -1 (i.e., for-syntax) bindings, and the last list corresponds
corresponds to @tech{label phase level} (i.e., for-label) bindings.
The @scheme[normal-imports?], @scheme[syntax-imports?], and
@scheme[label-imports?] arguments determine whether each of normal,
@scheme[for-syntax], and @scheme[for-label] @scheme[require]s are
considered in building the result lists. Note that normal
@scheme[require]s can add to all three lists, while
@scheme[for-syntax] and @scheme[for-label] @scheme[require]s
contribute only to one of the latter two lists, respectively.}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@section[#:tag "require-trans"]{@scheme[require] Transformers} @section[#:tag "require-trans"]{@scheme[require] Transformers}
@ -530,6 +585,7 @@ A structure representing a single imported identifier:
}} }}
@defstruct[import-source ([mod-path-stx (and/c syntax? @defstruct[import-source ([mod-path-stx (and/c syntax?
(lambda (x) (lambda (x)
(module-path? (syntax->datum x))))] (module-path? (syntax->datum x))))]
@ -627,58 +683,3 @@ A structure representing a single imported identifier:
exporting module.} exporting module.}
}} }}
@defproc[(syntax-local-transforming-module-provides?) boolean?]{
Returns @scheme[#t] while a provide transformer is running or while a
@schemeidfont{expand} sub-form of @scheme[#%provide] is expanded,
@scheme[#f] otherwise.}
@defproc[(syntax-local-module-defined-identifiers)
(values (listof identifier?) (listof identifier?))]{
Returns two lists of identifiers corresponding to all definitions
within the module being expanded. This information is used for
implementing @scheme[provide] sub-forms like @scheme[all-defined-out].
The first result list corresponds to @tech{phase} 0 (i.e., normal)
definitions, and the second corresponds to @tech{phase} -1 (i.e.,
for-syntax) definitions.
This procedure can be called only while
@scheme[syntax-local-transforming-module-provides?] returns
@scheme[#t].}
@defproc[(syntax-local-module-required-identifiers
[mod-path module-path?]
[normal-imports? any/c]
[syntax-imports? any/c]
[label-imports? any/c])
(values (listof identifier?)
(listof identifier?)
(listof identifier?))]{
Returns three lists of identifiers corresponding to all bindings
imported into the module being expanded using the module path
@scheme[mod-path]. This information is used for implementing
@scheme[provide] sub-forms like @scheme[all-from-out].
The first result list corresponds to @tech{phase level} 0 (i.e.,
normal) bindings, and the second list corresponds to @tech{phase
level} -1 (i.e., for-syntax) bindings, and the last list corresponds
corresponds to @tech{label phase level} (i.e., for-label) bindings.
The @scheme[normal-imports?], @scheme[syntax-imports?], and
@scheme[label-imports?] arguments determine whether each of normal,
@scheme[for-syntax], and @scheme[for-label] @scheme[require]s are
considered in building the result lists. Note that normal
@scheme[require]s can add to all three lists, while
@scheme[for-syntax] and @scheme[for-label] @scheme[require]s
contribute only to one of the latter two lists, respectively.
This procedure can be called only while
@scheme[syntax-local-transforming-module-provides?] returns
@scheme[#t].}

2
collects/scribblings/scribble/bnf.scrbl
View File

@ -3,7 +3,7 @@
"utils.ss" "utils.ss"
(for-label scribble/bnf)) (for-label scribble/bnf))
@title[#:tag "bnf"]{Typesetting Grammars} @title[#:tag "bnf"]{BNF Grammars}
@defmodule[scribble/bnf]{The @scheme[scribble/bnf] library @defmodule[scribble/bnf]{The @scheme[scribble/bnf] library
provides utilities for typesetting grammars.} provides utilities for typesetting grammars.}

2
collects/scribblings/scribble/decode.scrbl
View File

@ -2,7 +2,7 @@
@require[scribble/manual] @require[scribble/manual]
@require["utils.ss"] @require["utils.ss"]
@title[#:tag "decode"]{Text Decoder} @title[#:tag "decode"]{Decoding Text}
@defmodule[scribble/decode]{The @schememodname[scribble/decode] @defmodule[scribble/decode]{The @schememodname[scribble/decode]
library helps you write document content in a natural way---more like library helps you write document content in a natural way---more like

4
collects/scribblings/scribble/doclang.scrbl
View File

@ -2,9 +2,9 @@
@require[scribble/manual] @require[scribble/manual]
@require["utils.ss"] @require["utils.ss"]
@title[#:tag "doclang"]{Document Module Language} @title[#:tag "doclang"]{Document Language}
@defmodule[scribble/doclang]{The @schememodname[scribble/doclang] @defmodulelang[scribble/doclang]{The @schememodname[scribble/doclang]
language provides everything from @scheme[scheme/base], except that it language provides everything from @scheme[scheme/base], except that it
replaces the @scheme[#%module-begin] form.} replaces the @scheme[#%module-begin] form.}

2
collects/scribblings/scribble/docreader.scrbl
View File

@ -5,7 +5,7 @@
@title[#:tag "docreader"]{Document Reader} @title[#:tag "docreader"]{Document Reader}
@defmodule[scribble/doc]{The @schememodname[scribble/doc] language is @defmodulelang[scribble/doc]{The @schememodname[scribble/doc] language is
the same as @schememodname[scribble/doclang], except that the same as @schememodname[scribble/doclang], except that
@scheme[read-inside-syntax] is used to read the body of the module. In @scheme[read-inside-syntax] is used to read the body of the module. In
other words, the module body starts in Scribble ``text'' mode instead other words, the module body starts in Scribble ``text'' mode instead

30
collects/scribblings/scribble/how-to.scrbl
View File

@ -292,7 +292,9 @@ hyperlinks.
To document a @scheme[my-helper] procedure that is exported by To document a @scheme[my-helper] procedure that is exported by
@filepath{helper.ss} in the collection that contains @filepath{helper.ss} in the collection that contains
@filepath{manual.scrbl}, first use @scheme[(require (for-label ....))] @filepath{manual.scrbl}, first use @scheme[(require (for-label ....))]
to import the binding information of @filepath{helper.ss}. Then use to import the binding information of @filepath{helper.ss}. Then add a
@scheme[defmodule] declaration, which connects the @scheme[for-label]
binding with the module path as seen by a reader. Finally, use
@scheme[defproc] to document the procedure: @scheme[defproc] to document the procedure:
@verbatim[#<<EOS @verbatim[#<<EOS
@ -303,6 +305,8 @@ to import the binding information of @filepath{helper.ss}. Then use
@title{My Library} @title{My Library}
@defmodule[my-lib/helper]
@defproc[(my-helper [lst list?]) @defproc[(my-helper [lst list?])
(listof (listof
(not/c (one-of/c 'cow)))]{ (not/c (one-of/c 'cow)))]{
@ -320,30 +324,6 @@ of the result must be given; in this case, @scheme[my-helper]
guarantees a result that is a list where none of the elements are guarantees a result that is a list where none of the elements are
@scheme['cow]. @scheme['cow].
Finally, the documentation should declare the module that is being
defined. Use @scheme[defmodule] to declare the module name before any
other definitions.
@verbatim[#<<EOS
#lang scribble/doc
@(require scribble/manual
(for-label scheme
"helper.ss"))
@title{My Library}
@defmodule[my-lib/helper]{The @schememodname[my-lib/helper]
module---now with extra cows!}
@defproc[(my-helper [lst list?])
(listof
(not/c (one-of/c 'cow)))]{
Replaces each @scheme['cow] in @scheme[lst] with
@scheme['aardvark].}
EOS
]
Some things to notice in this example and the documentation that it Some things to notice in this example and the documentation that it
generates: generates:

47
collects/scribblings/scribble/manual.scrbl
View File

@ -4,7 +4,7 @@
(for-syntax scheme/base) (for-syntax scheme/base)
(for-label scribble/manual-struct)) (for-label scribble/manual-struct))
@title[#:tag "manual"]{PLT Manual Forms} @title[#:tag "manual"]{Manual Forms}
@defmodule[scribble/manual]{The @schememodname[scribble/manual] @defmodule[scribble/manual]{The @schememodname[scribble/manual]
library provides all of @schememodname[scribble/basic], plus library provides all of @schememodname[scribble/basic], plus
@ -39,9 +39,9 @@ because that's the way it is idented the use of @scheme[schemeblock].
Furthermore, @scheme[define] is typeset as a keyword (bold and black) Furthermore, @scheme[define] is typeset as a keyword (bold and black)
and as a hyperlink to @scheme[define]'s definition in the reference and as a hyperlink to @scheme[define]'s definition in the reference
manual, because this document was built using a for-label binding of manual, because this document was built using a for-label binding of
@scheme[define] (in the source) that matches the for-label binding of @scheme[define] (in the source) that matches a definition in the
the definition in the reference manual. Similarly, @scheme[not] is a reference manual. Similarly, @scheme[not] is a hyperlink to the its
hyperlink to the its definition in the reference manual. definition in the reference manual.
Use @scheme[unsyntax] to escape back to an expression that produces an Use @scheme[unsyntax] to escape back to an expression that produces an
@scheme[element]. For example, @scheme[element]. For example,
@ -252,10 +252,14 @@ Produces a sequence of flow elements (encapsulated in a
@scheme[prototype]s corresponds to a curried function, as in @scheme[prototype]s corresponds to a curried function, as in
@scheme[define]. The @scheme[id] is indexed, and it also registered so @scheme[define]. The @scheme[id] is indexed, and it also registered so
that @scheme[scheme]-typeset uses of the identifier (with the same that @scheme[scheme]-typeset uses of the identifier (with the same
for-label binding) are hyperlinked to this documentation. The for-label binding) are hyperlinked to this documentation.
@scheme[id] should have a for-label binding (as introduced by
@scheme[require-for-label]) that determines the module binding being A @scheme[defmodule] or @scheme[declare-exporting] form (or one of the
defined. variants) in an enclosing section determines the @scheme[id] binding
that is being defined. The @scheme[id] should also have a for-label
binding (as introduced by @scheme[(require (for-label ...))]) that
matches the definition binding; otherwise, the defined @scheme[id]
will not typeset correctly within the definition.
Each @scheme[arg-spec] must have one of the following forms: Each @scheme[arg-spec] must have one of the following forms:
@ -317,10 +321,11 @@ Produces a a sequence of flow elements (encaptured in a
@scheme[splice]) to document a syntatic form named by @scheme[id]. The @scheme[splice]) to document a syntatic form named by @scheme[id]. The
@scheme[id] is indexed, and it is also registered so that @scheme[id] is indexed, and it is also registered so that
@scheme[scheme]-typeset uses of the identifier (with the same @scheme[scheme]-typeset uses of the identifier (with the same
for-label binding) are hyperlinked to this documentation. The for-label binding) are hyperlinked to this documentation.
@scheme[id] should have a for-label binding (as introduced by
@scheme[require-for-label]) that determines the module binding being The @scheme[defmodule] or @scheme[declare-exporting] requires, as well
defined. as the binding requirements for @scheme[id], are the same as for
@scheme[defproc].
The @tech{decode}d @scheme[pre-flow] documents the procedure. In this The @tech{decode}d @scheme[pre-flow] documents the procedure. In this
description, a reference to any identifier in @scheme[datum] via description, a reference to any identifier in @scheme[datum] via
@ -504,6 +509,19 @@ Like @scheme[defclass], but for an interfaces. Naturally,
Like @scheme[definterface], but for single-page rendering as in Like @scheme[definterface], but for single-page rendering as in
@scheme[defclass/title].} @scheme[defclass/title].}
@defform[(defmixin id (domain-id ...) (range-id ...) pre-flow ...)]{
Like @scheme[defclass], but for a mixin. Any number of
@scheme[domain-id] classes and interfaces are specified for the
mixin's input requires, and any number of result classes and (more
likely) interfaces are specified for the @scheme[range-id]. The
@scheme[domain-id]s supply inherited methods.}
@defform[(defmixin/title id (domain-id ...) (range-id ...) pre-flow ...)]{
Like @scheme[defmixin], but for single-page rendering as in
@scheme[defclass/title].}
@defform/subs[(defconstructor (arg-spec ...) pre-flow ...) @defform/subs[(defconstructor (arg-spec ...) pre-flow ...)
([arg-spec (arg-id contract-expr-datum) ([arg-spec (arg-id contract-expr-datum)
(arg-id contract-expr-datum default-expr)])]{ (arg-id contract-expr-datum default-expr)])]{
@ -867,6 +885,11 @@ class via @scheme[defclass] and company.}
Indicates that the index entry corresponds to the definition of an Indicates that the index entry corresponds to the definition of an
interface via @scheme[definterface] and company.} interface via @scheme[definterface] and company.}
@defstruct[(mixin-index-desc exported-index-desc) ()]{
Indicates that the index entry corresponds to the definition of a
mixin via @scheme[defmixin] and company.}
@defstruct[(method-index-desc exported-index-desc) ([method-name symbol?] @defstruct[(method-index-desc exported-index-desc) ([method-name symbol?]
[class-tag tag?])]{ [class-tag tag?])]{

2
collects/scribblings/scribble/reader.scrbl
View File

@ -5,7 +5,7 @@
@require["utils.ss"] @require["utils.ss"]
@require[(for-syntax scheme/base)] @require[(for-syntax scheme/base)]
@title[#:tag "reader"]{The Scribble Reader} @title[#:tag "reader"]{@"@"-Reader}
The Scribble @"@"-reader is designed to be a convenient facility for The Scribble @"@"-reader is designed to be a convenient facility for
using free-form text in Scheme code, where ``@"@"'' is chosen as one of using free-form text in Scheme code, where ``@"@"'' is chosen as one of

2
collects/scribblings/scribble/struct.scrbl
View File

@ -3,7 +3,7 @@
"utils.ss" "utils.ss"
(for-label scribble/manual-struct)) (for-label scribble/manual-struct))
@title[#:tag "struct"]{Document Structures And Processing} @title[#:tag "struct"]{Structures And Processing}
@defmodule[scribble/struct] @defmodule[scribble/struct]

64
collects/scribblings/scribble/xref.scrbl
View File

@ -39,17 +39,67 @@ get all cross-reference information for installed documentation.}
@defproc[(xref-binding->definition-tag [xref xref?] @defproc[(xref-binding->definition-tag [xref xref?]
[mod (or/c module-path? [binding (or/c identifier?
(list/c (or/c module-path?
module-path-index? module-path-index?
path? path?
resolved-module-path?)] resolved-module-path?)
[sym symbol?]) symbol?)
(listof module-path-index?
symbol?
module-path-index?
symbol?
boolean?
(one-of/c #f 'for-syntax 'for-label))
(list/c (or/c module-path?
module-path-index?
path?
resolved-module-path?)
symbol?
(one-of/c #f 'for-syntax 'for-label)))]
[mode (one-of/c #f 'for-syntax 'for-label)])
(or/c tag? false/c)]{ (or/c tag? false/c)]{
Locates a tag in @scheme[xref] that documents @scheme[sym] as defined Locates a tag in @scheme[xref] that documents a module export. The
by @scheme[mod]. The @scheme[sym] and @scheme[mod] combination binding is specified in one of several ways, as described below; all
correspond to the first two elements of a @scheme[identifier-binding] possibilities encode an exporting module and a symbolic name. The name
list result. must be exported from the specified module. Documentation is found
either for the specified module or, if the exported name is
re-exported from other other module, for the other module
(transitively).
The @scheme[mode] argument specifies more information about the
binding: whether it refers to a normal binding, a @scheme[for-syntax]
binding, or a @scheme[for-label] binding.
The @scheme[binding] is specified in one of four ways:
@itemize{
@item{If @scheme[binding] is an identifier, then
@scheme[identifier-binding],
@scheme[identifier-transformer-binding], or
@scheme[identifier-label-binding] is used to determine the
binding, depending on the value of @scheme[mode].}
@item{If @scheme[binding] is a two-element list, then the first
element provides the exporting module and the second the
exported name. The @scheme[mode] argument is effectively
ignored.}
@item{If @scheme[binding] is a six-element list, then it corresponds
to a result from @scheme[identifier-binding],
@scheme[identifier-transformer-binding], or
@scheme[identifier-label-binding], depending on the value of
@scheme[mode].}
@item{If @scheme[binding] is a three-element list, then the first
element is as for the 2-element-list case, the second element
is like the fourth element of the six-element case, and the
third element is like the sixth element of the six-element
case.}
}
If a documentation point exists in @scheme[xref], a tag is returned, If a documentation point exists in @scheme[xref], a tag is returned,
which might be used with @scheme[xref-tag->path+anchor] or embedded in which might be used with @scheme[xref-tag->path+anchor] or embedded in

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

@ -1,6 +1,6 @@
#lang scribble/doc #lang scribble/doc
@(require "ss.ss" @(require "ss.ss"
(for-label mred (for-label scheme/gui
slideshow/code slideshow/code
slideshow/flash slideshow/flash
slideshow/face slideshow/face

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

@ -1,6 +1,6 @@
#lang scribble/doc #lang scribble/doc
@require["ss.ss"] @require["ss.ss"]
@require[(for-label mred @require[(for-label scheme/gui
slideshow/step slideshow/step
slideshow/slides-to-picts)] slideshow/slides-to-picts)]

49
collects/setup/scribble.ss
View File

@ -17,7 +17,7 @@
(define verbose (make-parameter #t)) (define verbose (make-parameter #t))
(define-struct doc (src-dir src-file dest-dir flags)) (define-struct doc (src-dir src-file dest-dir flags))
(define-struct info (doc sci provides undef deps (define-struct info (doc sci provides undef searches deps
build? time out-time need-run? build? time out-time need-run?
need-in-write? need-out-write? need-in-write? need-out-write?
vers rendered?) vers rendered?)
@ -71,7 +71,7 @@
null)))) null))))
infos dirs))]) infos dirs))])
(when (ormap (can-build? only-dirs) docs) (when (ormap (can-build? only-dirs) docs)
(let ([infos (map (get-doc-info only-dirs latex-dest) docs)]) (let ([infos (filter values (map (get-doc-info only-dirs latex-dest) docs))])
(let loop ([first? #t][iter 0]) (let loop ([first? #t][iter 0])
(let ([ht (make-hash-table 'equal)]) (let ([ht (make-hash-table 'equal)])
;; Collect definitions ;; Collect definitions
@ -116,13 +116,8 @@
(printf " [Removed Dependency: ~a]\n" (printf " [Removed Dependency: ~a]\n"
(doc-src-file (info-doc info)))))))) (doc-src-file (info-doc info))))))))
(info-deps info)) (info-deps info))
(for-each (lambda (k) (let ([not-found
(let ([i (hash-table-get ht k #f)]) (lambda (k)
(if i
(when (not (hash-table-get deps i #f))
(set! added? #t)
(hash-table-put! deps i #t))
(when first?
(unless one? (unless one?
(fprintf (current-error-port) (fprintf (current-error-port)
"In ~a:\n" "In ~a:\n"
@ -130,8 +125,24 @@
(set! one? #t)) (set! one? #t))
(fprintf (current-error-port) (fprintf (current-error-port)
" undefined tag: ~s\n" " undefined tag: ~s\n"
k))))) k))])
(for-each (lambda (k)
(let ([i (hash-table-get ht k #f)])
(if i
(when (not (hash-table-get deps i #f))
(set! added? #t)
(hash-table-put! deps i #t))
(when first?
(unless (eq? (car k) 'dep)
(not-found k))))))
(info-undef info)) (info-undef info))
(when first?
(hash-table-for-each (info-searches info)
(lambda (s-key s-ht)
(unless (ormap
(lambda (k) (hash-table-get ht k #f))
(hash-table-map s-ht (lambda (k v) k)))
(not-found s-key))))))
(when added? (when added?
(when (verbose) (when (verbose)
(printf " [Added Dependency: ~a]\n" (printf " [Added Dependency: ~a]\n"
@ -265,7 +276,11 @@
(max aux-time (max aux-time
(file-or-directory-modify-seconds src-zo #f (lambda () +inf.0))))))]) (file-or-directory-modify-seconds src-zo #f (lambda () +inf.0))))))])
(printf " [~a ~a]\n" (printf " [~a ~a]\n"
(if up-to-date? "Using" "Running") (if up-to-date?
"Using"
(if can-run?
"Running"
"Skipping"))
(doc-src-file doc)) (doc-src-file doc))
(if up-to-date? (if up-to-date?
;; Load previously calculated info: ;; Load previously calculated info:
@ -285,12 +300,14 @@
(list-ref v-out 1) ; sci (list-ref v-out 1) ; sci
(list-ref v-out 2) ; provides (list-ref v-out 2) ; provides
(list-ref v-in 1) ; undef (list-ref v-in 1) ; undef
(list-ref v-in 3) ; searches
(map string->path (list-ref v-in 2)) ; deps, in case we don't need to build... (map string->path (list-ref v-in 2)) ; deps, in case we don't need to build...
can-run? can-run?
my-time info-out-time #f my-time info-out-time #f
#f #f #f #f
vers vers
#f))) #f)))
(if can-run?
;; Run the doc once: ;; Run the doc once:
(parameterize ([current-directory (doc-src-dir doc)]) (parameterize ([current-directory (doc-src-dir doc)])
(let ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) (let ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc))
@ -305,7 +322,8 @@
(error "old info has wrong version or flags")) (error "old info has wrong version or flags"))
v)))]) v)))])
(let ([sci (send renderer serialize-info ri)] (let ([sci (send renderer serialize-info ri)]
[defs (send renderer get-defined ci)]) [defs (send renderer get-defined ci)]
[searches (resolve-info-searches ri)])
(let ([need-out-write? (let ([need-out-write?
(or (not (equal? (list (list vers (doc-flags doc)) sci defs) (or (not (equal? (list (list vers (doc-flags doc)) sci defs)
out-v)) out-v))
@ -319,6 +337,7 @@
sci sci
defs defs
(send renderer get-undefined ri) (send renderer get-undefined ri)
searches
null ; no deps, yet null ; no deps, yet
can-run? can-run?
-inf.0 -inf.0
@ -328,7 +347,8 @@
#t #t
can-run? need-out-write? can-run? need-out-write?
vers vers
#f)))))))))))) #f)))))))
#f))))))
(define (build-again! latex-dest info) (define (build-again! latex-dest info)
(let* ([doc (info-doc info)] (let* ([doc (info-doc info)]
@ -432,7 +452,8 @@
(info-undef info) (info-undef info)
(map (lambda (i) (map (lambda (i)
(path->string (doc-src-file (info-doc i)))) (path->string (doc-src-file (info-doc i))))
(info-deps info))))))))))) (info-deps info))
(info-searches info))))))))))
(define (write-out info) (define (write-out info)
(make-directory* (doc-dest-dir (info-doc info))) (make-directory* (doc-dest-dir (info-doc info)))

2
collects/teachpack/htdp/Docs/image.scrbl
View File

@ -8,6 +8,8 @@
@title[#:tag "image"]{Manipulating Images: image.ss} @title[#:tag "image"]{Manipulating Images: image.ss}
@declare-exporting[teachpack/htdp/image]
The teachpack provides primitives for constructing and manipulating The teachpack provides primitives for constructing and manipulating
images. Basic images are created as outlines or solid shapes. Additional images. Basic images are created as outlines or solid shapes. Additional
primitives allow for the composition of images. primitives allow for the composition of images.

2
collects/teachpack/htdp/Docs/testing.scrbl
View File

@ -8,6 +8,8 @@
@title[#:tag "testing"]{Testing: testing.ss} @title[#:tag "testing"]{Testing: testing.ss}
@declare-exporting[teachpack/htdp/testing]
The @scheme[testing.ss] teachpack provides forms for formulating test cases The @scheme[testing.ss] teachpack provides forms for formulating test cases
and a primitive for reporting on test cases. and a primitive for reporting on test cases.

2
collects/teachpack/htdp/Docs/world.scrbl
View File

@ -8,6 +8,8 @@
@title[#:tag "world"]{Simulations and Animations: world.ss} @title[#:tag "world"]{Simulations and Animations: world.ss}
@declare-exporting[teachpack/htdp/world]
The teachpack provides two kinds of functions. The first five allow The teachpack provides two kinds of functions. The first five allow
students to simulate a small world of animated drawings and games: students to simulate a small world of animated drawings and games:

16
collects/tests/mzscheme/stx.ss
View File

@ -443,37 +443,37 @@
(cdddr b)) (cdddr b))
b))) b)))
(test '('#%kernel case-lambda scheme/init case-lambda #f) identifier-binding* #'case-lambda) (test '('#%kernel case-lambda scheme/init case-lambda #f #f) identifier-binding* #'case-lambda)
(test '(scheme/promise delay scheme/init delay #f) identifier-binding* #'delay) (test '(scheme/promise delay scheme/init delay #f #f) identifier-binding* #'delay)
(test '('#%kernel #%module-begin scheme/init #%plain-module-begin #f) identifier-binding* #'#%plain-module-begin) (test '('#%kernel #%module-begin scheme/init #%plain-module-begin #f #f) identifier-binding* #'#%plain-module-begin)
(require (only-in scheme/base [#%plain-module-begin #%pmb])) (require (only-in scheme/base [#%plain-module-begin #%pmb]))
(test '('#%kernel #%module-begin scheme/base #%plain-module-begin #f) identifier-binding* #'#%pmb) (test '('#%kernel #%module-begin scheme/base #%plain-module-begin #f #f) identifier-binding* #'#%pmb)
(let ([b (identifier-binding (syntax-case (expand #'(module m scheme/base (let ([b (identifier-binding (syntax-case (expand #'(module m scheme/base
(require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons])) (require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons]))
bcons)) () bcons)) ()
[(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print) void)) [(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print) void))
(let ([s (syntax cons)]) (let ([s (syntax cons)])
(test 'beginner:cons syntax-e s) ; 'was 'bcons (test 'bcons syntax-e s)
s)]))]) s)]))])
(let-values ([(real real-base) (module-path-index-split (car b))] (let-values ([(real real-base) (module-path-index-split (car b))]
[(nominal nominal-base) (module-path-index-split (caddr b))]) [(nominal nominal-base) (module-path-index-split (caddr b))])
(test '"teachprims.ss" values real) (test '"teachprims.ss" values real)
(test 'beginner-cons cadr b) (test 'beginner-cons cadr b)
(test 'lang/private/beginner-funs values nominal) ; was '(lib "lang/htdp-intermediate.ss") (test '(lib "lang/htdp-intermediate.ss") values nominal)
(test 'cons cadddr b))) (test 'cons cadddr b)))
(let ([b (identifier-binding (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss") (let ([b (identifier-binding (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss")
cons)) () cons)) ()
[(mod m beg (#%mod-beg cons)) [(mod m beg (#%mod-beg cons))
(let ([s (syntax cons)]) (let ([s (syntax cons)])
(test 'beginner:cons syntax-e s) ; was 'cons (test 'cons syntax-e s)
s)]))]) s)]))])
(let-values ([(real real-base) (module-path-index-split (car b))] (let-values ([(real real-base) (module-path-index-split (car b))]
[(nominal nominal-base) (module-path-index-split (caddr b))]) [(nominal nominal-base) (module-path-index-split (caddr b))])
(test '"teachprims.ss" values real) (test '"teachprims.ss" values real)
(test 'beginner-cons cadr b) (test 'beginner-cons cadr b)
(test 'lang/private/beginner-funs values nominal) ; was '(lib "lang/htdp-intermediate.ss") (test '(lib "lang/htdp-intermediate.ss") values nominal)
(test 'cons cadddr b))) (test 'cons cadddr b)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

8
collects/web-server/docs/reference/configuration.scrbl
View File

@ -13,6 +13,8 @@ configuring the @web-server .
@section[#:tag "configuration-table-structs.ss"]{Configuration Table Structure} @section[#:tag "configuration-table-structs.ss"]{Configuration Table Structure}
@require[(for-label web-server/configuration/configuration-table-structs)] @require[(for-label web-server/configuration/configuration-table-structs)]
@defmodule[web-server/configuration/configuration-table-structs]
@filepath{configuration/configuration-table-structs.ss} provides the following structures that @filepath{configuration/configuration-table-structs.ss} provides the following structures that
represent a standard configuration (see @secref["web-server-unit.ss"]) of the @web-server . represent a standard configuration (see @secref["web-server-unit.ss"]) of the @web-server .
The contracts on this structure influence the valid types of values in The contracts on this structure influence the valid types of values in
@ -81,6 +83,8 @@ the configuration table S-expression file format described in
@section[#:tag "configuration-table.ss"]{Configuration Table} @section[#:tag "configuration-table.ss"]{Configuration Table}
@require[(for-label web-server/configuration/configuration-table)] @require[(for-label web-server/configuration/configuration-table)]
@defmodule[web-server/configuration/configuration-table]
@filepath{configuration/configuration-table.ss} provides functions for @filepath{configuration/configuration-table.ss} provides functions for
reading, writing, parsing, and printing @scheme[configuration-table] reading, writing, parsing, and printing @scheme[configuration-table]
structures. structures.
@ -152,6 +156,8 @@ This function writes a @scheme[configuration-table] to @scheme[path].
@section[#:tag "namespace.ss"]{Servlet Namespaces} @section[#:tag "namespace.ss"]{Servlet Namespaces}
@require[(for-label web-server/configuration/namespace)] @require[(for-label web-server/configuration/namespace)]
@defmodule[web-server/configuration/namespace]
@filepath{configuration/namespace.ss} provides a function to help create the @filepath{configuration/namespace.ss} provides a function to help create the
@scheme[make-servlet-namespace] procedure needed by the @scheme[make] functions @scheme[make-servlet-namespace] procedure needed by the @scheme[make] functions
of @filepath{dispatchers/dispatch-servlets.ss} and @filepath{dispatchers/dispatch-lang.ss}. of @filepath{dispatchers/dispatch-servlets.ss} and @filepath{dispatchers/dispatch-lang.ss}.
@ -193,6 +199,8 @@ of servlets can share different sets of modules.
@section[#:tag "responders.ss"]{Standard Responders} @section[#:tag "responders.ss"]{Standard Responders}
@require[(for-label web-server/configuration/responders)] @require[(for-label web-server/configuration/responders)]
@defmodule[web-server/configuration/responders]
@filepath{configuration/responders.ss} provides some functions that help constructing HTTP responders. @filepath{configuration/responders.ss} provides some functions that help constructing HTTP responders.
These functions are used by the default dispatcher constructor (see @secref["web-server-unit.ss"]) to These functions are used by the default dispatcher constructor (see @secref["web-server-unit.ss"]) to
turn the paths given in the @scheme[configuration-table] into responders for the associated circumstance. turn the paths given in the @scheme[configuration-table] into responders for the associated circumstance.

4
collects/web-server/docs/reference/dispatchers.scrbl
View File

@ -34,6 +34,8 @@ documentation will be useful.
@section[#:tag "dispatch.ss"]{General} @section[#:tag "dispatch.ss"]{General}
@require[(for-label web-server/dispatchers/dispatch)] @require[(for-label web-server/dispatchers/dispatch)]
@defmodule[web-server/dispatchers/dispatch]
@filepath{dispatchers/dispatch.ss} provides a few functions for dispatchers in general. @filepath{dispatchers/dispatch.ss} provides a few functions for dispatchers in general.
@defthing[dispatcher? contract?]{ @defthing[dispatcher? contract?]{
@ -77,6 +79,8 @@ Consider the following example dispatcher, that captures the essence of URL rewr
@section[#:tag "filesystem-map.ss"]{Mapping URLs to Paths} @section[#:tag "filesystem-map.ss"]{Mapping URLs to Paths}
@require[(for-label web-server/dispatchers/filesystem-map)] @require[(for-label web-server/dispatchers/filesystem-map)]
@defmodule[web-server/dispatchers/filesystem-map]
@filepath{dispatchers/filesystem-map.ss} provides a means of mapping @filepath{dispatchers/filesystem-map.ss} provides a means of mapping
URLs to paths on the filesystem. URLs to paths on the filesystem.

10
collects/web-server/docs/reference/lang.scrbl
View File

@ -14,6 +14,8 @@ is different and what API is provided.
@section[#:tag "lang-servlets"]{Definition} @section[#:tag "lang-servlets"]{Definition}
@require[(for-label "dummy-language-servlet.ss")] ; to give a binding context @require[(for-label "dummy-language-servlet.ss")] ; to give a binding context
@declare-exporting[web-server/docs/reference/dummy-language-servlet]
A @defterm{Web language servlet} is a module written in the A @defterm{Web language servlet} is a module written in the
@scheme[(lib "lang.ss" "web-server")] module language. It should provide @scheme[(lib "lang.ss" "web-server")] module language. It should provide
the following identifier: the following identifier:
@ -102,6 +104,8 @@ by the Web language API.
@section[#:tag "lang/web.ss"]{Web} @section[#:tag "lang/web.ss"]{Web}
@require[(for-label web-server/lang/web)] @require[(for-label web-server/lang/web)]
@defmodule[web-server/lang/web]
@filepath{lang/web.ss} provides the most basic Web functionality. @filepath{lang/web.ss} provides the most basic Web functionality.
@defproc[(send/suspend/url [response-generator (url? . -> . response?)]) @defproc[(send/suspend/url [response-generator (url? . -> . response?)])
@ -142,6 +146,8 @@ by the Web language API.
@section[#:tag "lang/stuff-url.ss"]{Stuff URL} @section[#:tag "lang/stuff-url.ss"]{Stuff URL}
@require[(for-label web-server/lang/stuff-url)] @require[(for-label web-server/lang/stuff-url)]
@defmodule[web-server/lang/stuff-url]
@filepath{lang/stuff-url.ss} provides an interface for "stuffing" @filepath{lang/stuff-url.ss} provides an interface for "stuffing"
serializable values into URLs. Currently there is a particular serializable values into URLs. Currently there is a particular
hard-coded behavior, but we hope to make it more flexible in hard-coded behavior, but we hope to make it more flexible in
@ -196,6 +202,8 @@ See @schememodname[web-server/servlet/web].}
@section[#:tag "lang/file-box.ss"]{File Boxes} @section[#:tag "lang/file-box.ss"]{File Boxes}
@require[(for-label web-server/lang/file-box)] @require[(for-label web-server/lang/file-box)]
@defmodule[web-server/lang/file-box]
As mentioned earlier, it is dangerous to rely on the store in As mentioned earlier, it is dangerous to rely on the store in
Web Language servlets, due to the deployment scenarios available Web Language servlets, due to the deployment scenarios available
to them. @filepath{lang/file-box.ss} provides a simple API to replace to them. @filepath{lang/file-box.ss} provides a simple API to replace
@ -234,6 +242,8 @@ are on a shared medium.}
@section[#:tag "lang/web-param.ss"]{Web Parameters} @section[#:tag "lang/web-param.ss"]{Web Parameters}
@require[(for-label web-server/lang/web-param)] @require[(for-label web-server/lang/web-param)]
@defmodule[web-server/lang/web-param]
As mentioned earlier, it is not easy to use @scheme[parameterize] in the As mentioned earlier, it is not easy to use @scheme[parameterize] in the
Web Language. @filepath{lang/web-param.ss} provides (roughly) the same Web Language. @filepath{lang/web-param.ss} provides (roughly) the same
functionality in a way that is serializable. Like other serializable functionality in a way that is serializable. Like other serializable

8
collects/web-server/docs/reference/managers.scrbl
View File

@ -17,6 +17,8 @@ pluggable through the manager interface.
@section[#:tag "manager.ss"]{General} @section[#:tag "manager.ss"]{General}
@require[(for-label web-server/managers/manager)] @require[(for-label web-server/managers/manager)]
@defmodule[web-server/managers/manager]
@filepath{managers/manager.ss} defines the manager interface. It is required by @filepath{managers/manager.ss} defines the manager interface. It is required by
the users and implementers of managers. the users and implementers of managers.
@ -61,6 +63,8 @@ the users and implementers of managers.
@section[#:tag "none.ss"]{No Continuations} @section[#:tag "none.ss"]{No Continuations}
@require[(for-label web-server/managers/none)] @require[(for-label web-server/managers/none)]
@defmodule[web-server/managers/none]
@filepath{managers/none.ss} defines a manager constructor: @filepath{managers/none.ss} defines a manager constructor:
@defproc[(create-none-manager (instance-expiration-handler expiration-handler?)) @defproc[(create-none-manager (instance-expiration-handler expiration-handler?))
@ -78,6 +82,8 @@ Web Language. (See @secref["lang"].)
@section[#:tag "timeouts.ss"]{Timeouts} @section[#:tag "timeouts.ss"]{Timeouts}
@require[(for-label web-server/managers/timeouts)] @require[(for-label web-server/managers/timeouts)]
@defmodule[web-server/managers/timeouts]
@filepath{managers/timeouts.ss} defines a manager constructor: @filepath{managers/timeouts.ss} defines a manager constructor:
@defproc[(create-timeout-manager [instance-exp-handler expiration-handler?] @defproc[(create-timeout-manager [instance-exp-handler expiration-handler?]
@ -106,6 +112,8 @@ deployments of the @web-server .
@section[#:tag "lru.ss"]{LRU} @section[#:tag "lru.ss"]{LRU}
@require[(for-label web-server/managers/lru)] @require[(for-label web-server/managers/lru)]
@defmodule[web-server/managers/lru]
@filepath{managers/lru.ss} defines a manager constructor: @filepath{managers/lru.ss} defines a manager constructor:
@defproc[(create-LRU-manager @defproc[(create-LRU-manager

38
collects/web-server/docs/reference/private.scrbl
View File

@ -15,6 +15,8 @@ Some of these are documented here.
@section[#:tag "timer.ss"]{Timers} @section[#:tag "timer.ss"]{Timers}
@require[(for-label web-server/private/timer)] @require[(for-label web-server/private/timer)]
@defmodule[web-server/private/timer]
@filepath{private/timer.ss} provides a functionality for running @filepath{private/timer.ss} provides a functionality for running
procedures after a given amount of time, that may be extended. procedures after a given amount of time, that may be extended.
@ -61,6 +63,8 @@ procedures after a given amount of time, that may be extended.
@section[#:tag "connection-manager.ss"]{Connection Manager} @section[#:tag "connection-manager.ss"]{Connection Manager}
@require[(for-label web-server/private/connection-manager)] @require[(for-label web-server/private/connection-manager)]
@defmodule[web-server/private/connection-manager]
@filepath{private/connection-manager.ss} provides functionality for managing pairs of @filepath{private/connection-manager.ss} provides functionality for managing pairs of
input and output ports. We have plans to allow a number of different strategies input and output ports. We have plans to allow a number of different strategies
for doing this. for doing this.
@ -120,9 +124,23 @@ This dispatching server component is useful on its own.
The @schememodname[web-server/private/dispatch-server-sig] library The @schememodname[web-server/private/dispatch-server-sig] library
provides two signatures. provides two signatures.
@defsignature[dispatch-server^ ()]{
The @scheme[dispatch-server^] signature is an alias for The @scheme[dispatch-server^] signature is an alias for
@scheme[web-server^]. @scheme[web-server^].
@defproc[(serve) (-> void)]{
Runs the server and returns a procedure that shuts down the server.
}
@defproc[(serve-ports [ip input-port?]
[op output-port?])
void]{
Serves a single connection represented by the ports @scheme[ip] and
@scheme[op].
}
}
@defsignature[dispatch-server-config^ ()]{ @defsignature[dispatch-server-config^ ()]{
@defthing[port port?]{Specifies the port to serve on.} @defthing[port port?]{Specifies the port to serve on.}
@ -160,6 +178,8 @@ provides the unit that actually implements a dispatching server.
@require[(for-label web-server/private/closure)] @require[(for-label web-server/private/closure)]
@require[(for-label web-server/private/define-closure)] @require[(for-label web-server/private/define-closure)]
@defmodule[web-server/private/closure]
The defunctionalization process of the Web Language (see @secref["lang"]) The defunctionalization process of the Web Language (see @secref["lang"])
requires an explicit representation of closures that is serializable. requires an explicit representation of closures that is serializable.
@filepath{private/closure.ss} is this representation. It provides: @filepath{private/closure.ss} is this representation. It provides:
@ -183,6 +203,9 @@ requires an explicit representation of closures that is serializable.
These are difficult to use directly, so @filepath{private/define-closure.ss} These are difficult to use directly, so @filepath{private/define-closure.ss}
defines a helper form: defines a helper form:
@subsection[#:style 'hidden]{Define Closure}
@defmodule[web-server/private/define-closure]
@defform[(define-closure tag formals (free-vars ...) body)]{ @defform[(define-closure tag formals (free-vars ...) body)]{
Defines a closure, constructed with @scheme[make-tag] that accepts Defines a closure, constructed with @scheme[make-tag] that accepts
@scheme[freevars ...], that when invoked with @scheme[formals] @scheme[freevars ...], that when invoked with @scheme[formals]
@ -195,6 +218,8 @@ defines a helper form:
@section[#:tag "cache-table.ss"]{Cache Table} @section[#:tag "cache-table.ss"]{Cache Table}
@require[(for-label web-server/private/cache-table)] @require[(for-label web-server/private/cache-table)]
@defmodule[web-server/private/cache-table]
@filepath{private/cache-table.ss} provides a set of caching hash table @filepath{private/cache-table.ss} provides a set of caching hash table
functions. functions.
@ -225,6 +250,8 @@ functions.
@section[#:tag "mime-types.ss"]{MIME Types} @section[#:tag "mime-types.ss"]{MIME Types}
@require[(for-label web-server/private/mime-types)] @require[(for-label web-server/private/mime-types)]
@defmodule[web-server/private/mime-types]
@filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types} @filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types}
files. files.
@ -245,8 +272,11 @@ files.
@section[#:tag "mod-map.ss"]{Serialization Utilities} @section[#:tag "mod-map.ss"]{Serialization Utilities}
@require[(for-label web-server/private/mod-map)] @require[(for-label web-server/private/mod-map)]
@scheme[(lib "serialize.ss")] provides the functionality of serializing @defmodule[web-server/private/mod-map]
values. @filepath{private/mod-map.ss} compresses the serialized representation.
The @schememodname[scheme/serialize] library provides the
functionality of serializing values. @filepath{private/mod-map.ss}
compresses the serialized representation.
@defproc[(compress-serial [sv serialized-value?]) @defproc[(compress-serial [sv serialized-value?])
compressed-serialized-value?]{ compressed-serialized-value?]{
@ -264,6 +294,8 @@ values. @filepath{private/mod-map.ss} compresses the serialized representation.
@section[#:tag "url-param.ss"]{URL Param} @section[#:tag "url-param.ss"]{URL Param}
@require[(for-label web-server/private/url-param)] @require[(for-label web-server/private/url-param)]
@defmodule[web-server/private/url-param]
The @web-server needs to encode information in URLs. If this data The @web-server needs to encode information in URLs. If this data
is stored in the query string, than it will be overridden by browsers that is stored in the query string, than it will be overridden by browsers that
make GET requests to those URLs with more query data. So, it must be encoded make GET requests to those URLs with more query data. So, it must be encoded
@ -289,6 +321,8 @@ with this process.
@section[#:tag "util.ss"]{Miscellaneous Utilities} @section[#:tag "util.ss"]{Miscellaneous Utilities}
@require[(for-label web-server/private/util)] @require[(for-label web-server/private/util)]
@defmodule[web-server/private/util]
There are a number of other miscellaneous utilities the @web-server There are a number of other miscellaneous utilities the @web-server
needs. They are provided by @filepath{private/util.ss}. needs. They are provided by @filepath{private/util.ss}.

2
collects/web-server/docs/reference/running.scrbl
View File

@ -34,6 +34,8 @@ the server runs until the process is killed.
@section[#:tag "web-server.ss"]{Functional} @section[#:tag "web-server.ss"]{Functional}
@require[(for-label web-server/web-server)] @require[(for-label web-server/web-server)]
@defmodule[web-server/web-server]
@filepath{web-server.ss} provides a number of functions for easing embedding @filepath{web-server.ss} provides a number of functions for easing embedding
of the @web-server in other applications, or loading a custom of the @web-server in other applications, or loading a custom
dispatcher. See @filepath{run.ss} for an example of such a script. dispatcher. See @filepath{run.ss} for an example of such a script.

2
collects/web-server/docs/reference/servlet-env.scrbl
View File

@ -5,6 +5,8 @@
#:style 'toc]{Environment} #:style 'toc]{Environment}
@require[(for-label web-server/servlet-env)] @require[(for-label web-server/servlet-env)]
@defmodule[web-server/servlet-env]
The @web-server provides a means of running Scheme servlets The @web-server provides a means of running Scheme servlets
from within DrScheme, or any other REPL. from within DrScheme, or any other REPL.

16
collects/web-server/docs/reference/servlet.scrbl
View File

@ -14,6 +14,8 @@ of these servlets. This API is provided by @filepath{servlet.ss}.
@section[#:tag "module-servlets"]{Definition} @section[#:tag "module-servlets"]{Definition}
@require[(for-label "dummy-servlet.ss")] ; to give a binding context @require[(for-label "dummy-servlet.ss")] ; to give a binding context
@declare-exporting[web-server/docs/reference/dummy-servlet]
A @defterm{servlet} is a module that provides the following: A @defterm{servlet} is a module that provides the following:
@defthing[interface-version (or/c 'v1 'v2)]{ @defthing[interface-version (or/c 'v1 'v2)]{
@ -46,6 +48,8 @@ A @defterm{servlet} is a module that provides the following:
@section[#:tag "servlet-structs.ss"]{Contracts} @section[#:tag "servlet-structs.ss"]{Contracts}
@require[(for-label web-server/servlet/servlet-structs)] @require[(for-label web-server/servlet/servlet-structs)]
@defmodule[web-server/servlet/servlet-structs]
@filepath{servlet/servlet-structs.ss} provides a number of contracts @filepath{servlet/servlet-structs.ss} provides a number of contracts
for use in servlets. for use in servlets.
@ -63,6 +67,8 @@ for use in servlets.
@section[#:tag "request-structs.ss"]{HTTP Requests} @section[#:tag "request-structs.ss"]{HTTP Requests}
@require[(for-label web-server/private/request-structs)] @require[(for-label web-server/private/request-structs)]
@defmodule[web-server/private/request-structs]
@; XXX Create http sub-directory @; XXX Create http sub-directory
@; XXX Have this include read-request and write-response @; XXX Have this include read-request and write-response
@filepath{private/request-structs.ss} provides a number of structures and functions @filepath{private/request-structs.ss} provides a number of structures and functions
@ -118,6 +124,8 @@ related to HTTP request data structures.
@section[#:tag "bindings.ss"]{Request Bindings} @section[#:tag "bindings.ss"]{Request Bindings}
@require[(for-label web-server/servlet/bindings)] @require[(for-label web-server/servlet/bindings)]
@defmodule[web-server/servlet/bindings]
@filepath{servlet/bindings.ss} provides a number of helper functions @filepath{servlet/bindings.ss} provides a number of helper functions
for accessing request bindings. for accessing request bindings.
@ -169,6 +177,8 @@ you lose the filename.
@section[#:tag "response-structs.ss"]{HTTP Responses} @section[#:tag "response-structs.ss"]{HTTP Responses}
@require[(for-label web-server/private/response-structs)] @require[(for-label web-server/private/response-structs)]
@defmodule[web-server/private/response-structs]
@filepath{private/response-structs.ss} provides structures and functions related to @filepath{private/response-structs.ss} provides structures and functions related to
HTTP responses. HTTP responses.
@ -305,6 +315,8 @@ functions of interest for the servlet developer.}
@section[#:tag "helpers.ss"]{Helpers} @section[#:tag "helpers.ss"]{Helpers}
@require[(for-label web-server/servlet/helpers)] @require[(for-label web-server/servlet/helpers)]
@defmodule[web-server/servlet/helpers]
@filepath{servlet/helpers.ss} provides functions built on @filepath{servlet/helpers.ss} provides functions built on
@filepath{servlet/web.ss} that are useful in many servlets. @filepath{servlet/web.ss} that are useful in many servlets.
@ -340,6 +352,8 @@ functions of interest for the servlet developer.}
@section[#:tag "servlet-url.ss"]{Servlet URLs} @section[#:tag "servlet-url.ss"]{Servlet URLs}
@require[(for-label web-server/servlet/servlet-url)] @require[(for-label web-server/servlet/servlet-url)]
@defmodule[web-server/servlet/servlet-url]
@filepath{servlet/servlet-url.ss} provides functions that might be useful to you. @filepath{servlet/servlet-url.ss} provides functions that might be useful to you.
They may eventually provided by another module. They may eventually provided by another module.
@ -357,6 +371,8 @@ They may eventually provided by another module.
@section[#:tag "basic-auth.ss"]{Basic Authentication} @section[#:tag "basic-auth.ss"]{Basic Authentication}
@require[(for-label web-server/servlet/basic-auth)] @require[(for-label web-server/servlet/basic-auth)]
@defmodule[web-server/servlet/basic-auth]
@filepath{servlet/basic-auth.ss} provides a function for helping with @filepath{servlet/basic-auth.ss} provides a function for helping with
implementation of HTTP Basic Authentication. implementation of HTTP Basic Authentication.

8
collects/web-server/docs/web-server.ss
View File

@ -1,6 +1,9 @@
#lang scheme/base #lang scheme/base
(require (lib "manual.ss" "scribble") (require (lib "manual.ss" "scribble")
(lib "eval.ss" "scribble")) (lib "eval.ss" "scribble")
(for-label scheme/base
scheme/contract
scheme/unit))
(define web-server "Web Server") (define web-server "Web Server")
@ -19,6 +22,9 @@
(provide (all-from-out (lib "manual.ss" "scribble")) (provide (all-from-out (lib "manual.ss" "scribble"))
(all-from-out (lib "eval.ss" "scribble")) (all-from-out (lib "eval.ss" "scribble"))
(for-label (all-from-out scheme/base
scheme/contract
scheme/unit))
web-server web-server
author author
warning warning

262
src/mzscheme/src/cstartup.inc
View File

@ -1,10 +1,10 @@
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,56,50,0,0,0,1,0,0,6,0,9, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,57,50,0,0,0,1,0,0,6,0,9,
0,14,0,18,0,23,0,28,0,32,0,39,0,42,0,55,0,62,0,69,0, 0,14,0,18,0,23,0,28,0,32,0,39,0,42,0,55,0,62,0,69,0,
78,0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155, 78,0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,
0,177,0,179,0,193,0,203,0,209,0,227,0,26,1,36,1,53,1,86,1, 0,177,0,179,0,193,0,203,0,209,0,232,0,33,1,43,1,60,1,93,1,
119,1,178,1,223,1,45,2,90,2,95,2,115,2,245,2,9,3,57,3,123, 126,1,185,1,230,1,52,2,97,2,102,2,122,2,252,2,16,3,64,3,130,
3,6,4,148,4,191,4,202,4,25,5,0,0,29,7,0,0,65,98,101,103, 3,13,4,155,4,198,4,209,4,32,5,0,0,50,7,0,0,65,98,101,103,
105,110,29,11,11,64,108,101,116,42,63,108,101,116,64,119,104,101,110,64,99, 105,110,29,11,11,64,108,101,116,42,63,108,101,116,64,119,104,101,110,64,99,
111,110,100,63,97,110,100,66,108,101,116,114,101,99,62,111,114,72,112,97,114, 111,110,100,63,97,110,100,66,108,101,116,114,101,99,62,111,114,72,112,97,114,
97,109,101,116,101,114,105,122,101,66,100,101,102,105,110,101,66,117,110,108,101, 97,109,101,116,101,114,105,122,101,66,100,101,102,105,110,101,66,117,110,108,101,
@ -14,63 +14,64 @@
101,115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97, 101,115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,
109,98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111, 109,98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,
110,45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115, 110,45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,
95,8,240,48,117,0,0,11,16,0,95,8,193,11,16,0,96,35,11,93,158, 95,8,240,48,117,0,0,11,16,0,95,8,193,11,16,0,96,35,11,93,159,
2,16,34,16,2,2,13,159,2,2,35,2,13,97,10,34,11,94,158,2,15, 2,16,34,35,16,2,2,13,161,2,2,35,2,13,2,2,2,13,97,10,34,
34,158,2,16,34,16,20,2,9,2,2,2,3,2,2,2,4,2,2,2,5, 11,94,159,2,15,34,34,159,2,16,34,34,16,20,2,9,2,2,2,3,2,
2,2,2,10,2,2,2,7,2,2,2,8,2,2,2,6,2,2,2,11,2, 2,2,4,2,2,2,5,2,2,2,10,2,2,2,7,2,2,2,8,2,2,
2,2,12,2,2,13,16,4,34,29,11,11,2,2,11,18,98,64,104,101,114, 2,6,2,2,2,11,2,2,2,12,2,2,13,16,4,34,29,11,11,2,2,
101,8,31,8,30,8,29,8,28,8,27,27,248,22,178,3,195,249,22,171,3, 11,18,98,64,104,101,114,101,8,31,8,30,8,29,8,28,8,27,27,248,22,
80,158,37,34,251,22,73,2,17,248,22,88,199,12,249,22,63,2,1,248,22, 178,3,195,249,22,171,3,80,158,37,34,251,22,73,2,17,248,22,88,199,12,
90,201,27,248,22,178,3,195,249,22,171,3,80,158,37,34,251,22,73,2,17, 249,22,63,2,1,248,22,90,201,27,248,22,178,3,195,249,22,171,3,80,158,
248,22,88,199,249,22,63,2,1,248,22,90,201,12,27,248,22,65,248,22,178, 37,34,251,22,73,2,17,248,22,88,199,249,22,63,2,1,248,22,90,201,12,
3,196,28,248,22,71,193,20,15,159,35,34,35,28,248,22,71,248,22,65,194, 27,248,22,65,248,22,178,3,196,28,248,22,71,193,20,15,159,35,34,35,28,
248,22,64,193,249,22,171,3,80,158,37,34,251,22,73,2,17,248,22,64,199, 248,22,71,248,22,65,194,248,22,64,193,249,22,171,3,80,158,37,34,251,22,
249,22,63,2,7,248,22,65,201,11,18,100,10,8,31,8,30,8,29,8,28, 73,2,17,248,22,64,199,249,22,63,2,7,248,22,65,201,11,18,100,10,8,
8,27,16,4,11,11,2,18,3,1,7,101,110,118,54,55,55,56,16,4,11, 31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,
11,2,19,3,1,7,101,110,118,54,55,55,57,27,248,22,65,248,22,178,3, 54,55,55,56,16,4,11,11,2,19,3,1,7,101,110,118,54,55,55,57,27,
196,28,248,22,71,193,20,15,159,35,34,35,28,248,22,71,248,22,65,194,248, 248,22,65,248,22,178,3,196,28,248,22,71,193,20,15,159,35,34,35,28,248,
22,64,193,249,22,171,3,80,158,37,34,250,22,73,2,20,248,22,73,249,22, 22,71,248,22,65,194,248,22,64,193,249,22,171,3,80,158,37,34,250,22,73,
73,248,22,73,2,21,248,22,64,201,251,22,73,2,17,2,21,2,21,249,22, 2,20,248,22,73,249,22,73,248,22,73,2,21,248,22,64,201,251,22,73,2,
63,2,9,248,22,65,204,18,100,11,8,31,8,30,8,29,8,28,8,27,16, 17,2,21,2,21,249,22,63,2,9,248,22,65,204,18,100,11,8,31,8,30,
4,11,11,2,18,3,1,7,101,110,118,54,55,56,49,16,4,11,11,2,19, 8,29,8,28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,54,55,56,
3,1,7,101,110,118,54,55,56,50,248,22,178,3,193,27,248,22,178,3,194, 49,16,4,11,11,2,19,3,1,7,101,110,118,54,55,56,50,248,22,178,3,
249,22,63,248,22,73,248,22,64,196,248,22,65,195,27,248,22,65,248,22,178, 193,27,248,22,178,3,194,249,22,63,248,22,73,248,22,64,196,248,22,65,195,
3,196,249,22,171,3,80,158,37,34,28,248,22,51,248,22,172,3,248,22,64, 27,248,22,65,248,22,178,3,196,249,22,171,3,80,158,37,34,28,248,22,51,
197,27,249,22,2,32,0,89,162,8,36,35,41,9,222,33,39,248,22,178,3, 248,22,172,3,248,22,64,197,27,249,22,2,32,0,89,162,8,36,35,41,9,
248,22,88,199,250,22,73,2,22,248,22,73,249,22,73,248,22,73,248,22,64, 222,33,39,248,22,178,3,248,22,88,199,250,22,73,2,22,248,22,73,249,22,
203,250,22,74,2,23,249,22,2,22,64,203,248,22,90,205,249,22,63,248,22, 73,248,22,73,248,22,64,203,250,22,74,2,23,249,22,2,22,64,203,248,22,
64,201,249,22,2,22,88,199,250,22,74,2,20,249,22,2,32,0,89,162,34, 90,205,249,22,63,248,22,64,201,249,22,2,22,88,199,250,22,74,2,20,249,
35,45,9,222,33,40,248,22,178,3,248,22,64,201,248,22,65,198,27,248,22, 22,2,32,0,89,162,34,35,45,9,222,33,40,248,22,178,3,248,22,64,201,
178,3,194,249,22,63,248,22,73,248,22,64,196,248,22,65,195,27,248,22,65, 248,22,65,198,27,248,22,178,3,194,249,22,63,248,22,73,248,22,64,196,248,
248,22,178,3,196,249,22,171,3,80,158,37,34,250,22,74,2,22,249,22,2, 22,65,195,27,248,22,65,248,22,178,3,196,249,22,171,3,80,158,37,34,250,
32,0,89,162,34,35,45,9,222,33,42,248,22,178,3,248,22,64,201,248,22, 22,74,2,22,249,22,2,32,0,89,162,34,35,45,9,222,33,42,248,22,178,
65,198,27,248,22,65,248,22,178,3,196,27,248,22,178,3,248,22,64,195,249, 3,248,22,64,201,248,22,65,198,27,248,22,65,248,22,178,3,196,27,248,22,
22,171,3,80,158,38,34,28,248,22,71,195,250,22,74,2,20,9,248,22,65, 178,3,248,22,64,195,249,22,171,3,80,158,38,34,28,248,22,71,195,250,22,
199,250,22,73,2,4,248,22,73,248,22,64,199,250,22,74,2,3,248,22,65, 74,2,20,9,248,22,65,199,250,22,73,2,4,248,22,73,248,22,64,199,250,
201,248,22,65,202,27,248,22,65,248,22,178,3,196,27,249,22,1,22,77,249, 22,74,2,3,248,22,65,201,248,22,65,202,27,248,22,65,248,22,178,3,196,
22,2,22,178,3,248,22,178,3,248,22,64,199,249,22,171,3,80,158,38,34, 27,249,22,1,22,77,249,22,2,22,178,3,248,22,178,3,248,22,64,199,249,
251,22,73,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111, 22,171,3,80,158,38,34,251,22,73,1,22,119,105,116,104,45,99,111,110,116,
110,45,109,97,114,107,2,24,250,22,74,1,23,101,120,116,101,110,100,45,112, 105,110,117,97,116,105,111,110,45,109,97,114,107,2,24,250,22,74,1,23,101,
97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111, 120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,
110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102, 110,21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,
105,114,115,116,11,2,24,201,250,22,74,2,20,9,248,22,65,203,27,248,22, 107,45,115,101,116,45,102,105,114,115,116,11,2,24,201,250,22,74,2,20,9,
65,248,22,178,3,196,28,248,22,71,193,20,15,159,35,34,35,249,22,171,3, 248,22,65,203,27,248,22,65,248,22,178,3,196,28,248,22,71,193,20,15,159,
80,158,37,34,27,248,22,178,3,248,22,64,197,28,249,22,137,8,62,61,62, 35,34,35,249,22,171,3,80,158,37,34,27,248,22,178,3,248,22,64,197,28,
248,22,172,3,248,22,88,196,250,22,73,2,20,248,22,73,249,22,73,21,93, 249,22,137,8,62,61,62,248,22,172,3,248,22,88,196,250,22,73,2,20,248,
2,25,248,22,64,199,250,22,74,2,6,249,22,73,2,25,249,22,73,248,22, 22,73,249,22,73,21,93,2,25,248,22,64,199,250,22,74,2,6,249,22,73,
97,203,2,25,248,22,65,202,251,22,73,2,17,28,249,22,137,8,248,22,172, 2,25,249,22,73,248,22,97,203,2,25,248,22,65,202,251,22,73,2,17,28,
3,248,22,64,200,64,101,108,115,101,10,248,22,64,197,250,22,74,2,20,9, 249,22,137,8,248,22,172,3,248,22,64,200,64,101,108,115,101,10,248,22,64,
248,22,65,200,249,22,63,2,6,248,22,65,202,99,8,31,8,30,8,29,8, 197,250,22,74,2,20,9,248,22,65,200,249,22,63,2,6,248,22,65,202,99,
28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,54,56,48,52,16,4, 8,31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,7,101,110,
11,11,2,19,3,1,7,101,110,118,54,56,48,53,18,158,94,10,64,118,111, 118,54,56,48,52,16,4,11,11,2,19,3,1,7,101,110,118,54,56,48,53,
105,100,8,47,27,248,22,65,248,22,178,3,196,249,22,171,3,80,158,37,34, 18,158,94,10,64,118,111,105,100,8,47,27,248,22,65,248,22,178,3,196,249,
28,248,22,51,248,22,172,3,248,22,64,197,250,22,73,2,26,248,22,73,248, 22,171,3,80,158,37,34,28,248,22,51,248,22,172,3,248,22,64,197,250,22,
22,64,199,248,22,88,198,27,248,22,172,3,248,22,64,197,250,22,73,2,26, 73,2,26,248,22,73,248,22,64,199,248,22,88,198,27,248,22,172,3,248,22,
248,22,73,248,22,64,197,250,22,74,2,23,248,22,65,199,248,22,65,202,159, 64,197,250,22,73,2,26,248,22,73,248,22,64,197,250,22,74,2,23,248,22,
34,20,102,159,34,16,1,20,24,2,1,16,0,83,158,40,20,99,131,69,35, 65,199,248,22,65,202,159,34,20,102,159,34,16,1,20,24,2,1,16,0,83,
37,109,105,110,45,115,116,120,2,2,10,11,10,10,10,10,34,80,158,34,34, 158,40,20,99,134,69,35,37,109,105,110,45,115,116,120,2,2,10,11,10,10,
20,102,159,34,16,0,16,0,11,11,16,0,34,11,11,16,0,16,0,16,0, 10,10,34,80,158,34,34,20,102,159,34,16,0,16,0,11,11,16,0,34,11,
34,34,11,16,0,16,0,16,0,34,34,11,16,10,2,3,2,4,2,5,2, 11,11,16,0,16,0,16,0,34,34,11,11,16,0,16,0,16,0,34,34,11,
16,10,9,9,9,9,9,9,9,9,9,9,16,10,2,3,2,4,2,5,2,
6,2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11, 6,2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11,
11,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2, 11,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,
10,2,11,2,12,34,44,16,11,16,5,93,2,13,20,15,159,34,34,34,34, 10,2,11,2,12,34,44,16,11,16,5,93,2,13,20,15,159,34,34,34,34,
@ -92,16 +93,16 @@
2,2,13,16,1,33,48,11,16,5,93,2,11,89,162,8,36,35,52,9,223, 2,2,13,16,1,33,48,11,16,5,93,2,11,89,162,8,36,35,52,9,223,
0,33,49,34,20,102,159,34,16,1,20,25,159,35,2,2,2,13,16,0,11, 0,33,49,34,20,102,159,34,16,1,20,25,159,35,2,2,2,13,16,0,11,
16,0,94,2,16,2,15,93,2,16,9,0}; 16,0,94,2,16,2,15,93,2,16,9,0};
EVAL_ONE_SIZED_STR((char *)expr, 1943); EVAL_ONE_SIZED_STR((char *)expr, 1964);
} }
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,56,61,0,0,0,1,0,0,3,0,16, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,57,61,0,0,0,1,0,0,3,0,16,
0,21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0, 0,21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,
200,0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112, 200,0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,
1,157,1,202,1,226,1,9,2,11,2,20,2,71,2,87,3,96,3,126,3, 1,157,1,202,1,226,1,9,2,11,2,20,2,71,2,87,3,96,3,126,3,
170,4,242,4,58,5,146,5,158,5,201,5,217,5,204,6,218,6,69,7,8, 170,4,242,4,58,5,146,5,158,5,201,5,217,5,204,6,218,6,69,7,8,
8,202,8,209,8,215,8,75,9,87,9,155,9,1,10,14,10,36,10,170,10, 8,202,8,209,8,215,8,75,9,87,9,155,9,1,10,14,10,36,10,170,10,
36,11,37,12,45,12,53,12,79,12,159,12,0,0,195,15,0,0,29,11,11, 36,11,37,12,45,12,53,12,79,12,159,12,0,0,210,15,0,0,29,11,11,
72,112,97,116,104,45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111, 72,112,97,116,104,45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,
114,109,97,108,45,99,97,115,101,45,112,97,116,104,74,45,99,104,101,99,107, 114,109,97,108,45,99,97,115,101,45,112,97,116,104,74,45,99,104,101,99,107,
45,114,101,108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101, 45,114,101,108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101,
@ -256,7 +257,7 @@
192,192,34,27,27,248,22,154,3,200,28,192,192,34,27,249,22,183,4,197,89, 192,192,34,27,27,248,22,154,3,200,28,192,192,34,27,249,22,183,4,197,89,
162,8,36,34,46,9,224,4,3,33,59,27,248,22,170,4,194,87,94,248,22, 162,8,36,34,46,9,224,4,3,33,59,27,248,22,170,4,194,87,94,248,22,
134,4,21,94,2,17,2,29,248,80,159,41,53,35,193,159,34,20,102,159,34, 134,4,21,94,2,17,2,29,248,80,159,41,53,35,193,159,34,20,102,159,34,
16,1,20,24,65,98,101,103,105,110,16,0,83,158,40,20,99,131,67,35,37, 16,1,20,24,65,98,101,103,105,110,16,0,83,158,40,20,99,134,67,35,37,
117,116,105,108,115,2,1,11,10,10,10,10,10,41,80,158,34,34,20,102,159, 117,116,105,108,115,2,1,11,10,10,10,10,10,41,80,158,34,34,20,102,159,
37,16,17,30,2,1,2,2,193,30,2,1,2,3,193,30,2,1,2,4,193, 37,16,17,30,2,1,2,2,193,30,2,1,2,3,193,30,2,1,2,4,193,
30,2,1,2,5,193,30,2,1,2,6,193,30,2,1,2,7,193,30,2,1, 30,2,1,2,5,193,30,2,1,2,6,193,30,2,1,2,7,193,30,2,1,
@ -265,62 +266,62 @@
2,15,193,30,2,1,2,16,193,30,2,18,1,20,112,97,114,97,109,101,116, 2,15,193,30,2,1,2,16,193,30,2,18,1,20,112,97,114,97,109,101,116,
101,114,105,122,97,116,105,111,110,45,107,101,121,4,30,2,18,1,23,101,120, 101,114,105,122,97,116,105,111,110,45,107,101,121,4,30,2,18,1,23,101,120,
116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
3,16,0,11,11,16,4,2,6,2,5,2,3,2,9,38,11,11,16,0,16, 3,16,0,11,11,16,4,2,6,2,5,2,3,2,9,38,11,11,11,16,0,
0,16,0,34,34,11,16,0,16,0,16,0,34,34,11,16,11,2,8,2,7, 16,0,16,0,34,34,11,11,16,0,16,0,16,0,34,34,11,16,11,9,9,
2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,16,11,11, 9,9,9,9,9,9,9,9,9,16,11,2,8,2,7,2,16,2,15,2,13,
11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,16,2,15,2, 2,12,2,4,2,11,2,14,2,10,2,2,16,11,11,11,11,11,11,11,11,
13,2,12,2,4,2,11,2,14,2,10,2,2,45,45,16,0,16,18,83,158, 11,11,11,11,16,11,2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,
34,16,2,89,162,34,35,47,2,19,223,0,33,30,80,159,34,53,35,83,158, 11,2,14,2,10,2,2,45,45,16,0,16,18,83,158,34,16,2,89,162,34,
34,16,2,89,162,34,35,54,2,19,223,0,33,31,80,159,34,52,35,83,158, 35,47,2,19,223,0,33,30,80,159,34,53,35,83,158,34,16,2,89,162,34,
34,16,2,89,162,8,36,35,43,9,223,0,33,32,80,159,34,51,35,83,158, 35,54,2,19,223,0,33,31,80,159,34,52,35,83,158,34,16,2,89,162,8,
34,16,2,32,0,89,162,34,35,43,2,2,222,33,33,80,159,34,34,35,83, 36,35,43,9,223,0,33,32,80,159,34,51,35,83,158,34,16,2,32,0,89,
158,34,16,2,249,22,135,6,7,92,7,92,80,159,34,35,35,83,158,34,16, 162,34,35,43,2,2,222,33,33,80,159,34,34,35,83,158,34,16,2,249,22,
2,89,162,34,35,52,2,4,223,0,33,34,80,159,34,36,35,83,158,34,16, 135,6,7,92,7,92,80,159,34,35,35,83,158,34,16,2,89,162,34,35,52,
2,32,0,89,162,34,36,48,2,5,222,33,35,80,159,34,37,35,83,158,34, 2,4,223,0,33,34,80,159,34,36,35,83,158,34,16,2,32,0,89,162,34,
16,2,32,0,89,162,34,37,49,2,6,222,33,37,80,159,34,38,35,83,158, 36,48,2,5,222,33,35,80,159,34,37,35,83,158,34,16,2,32,0,89,162,
34,16,2,89,162,8,37,36,46,2,7,223,0,33,39,80,159,34,39,35,83, 34,37,49,2,6,222,33,37,80,159,34,38,35,83,158,34,16,2,89,162,8,
158,34,16,2,32,0,89,162,34,38,50,2,8,222,33,42,80,159,34,40,35, 37,36,46,2,7,223,0,33,39,80,159,34,39,35,83,158,34,16,2,32,0,
83,158,34,16,2,32,0,89,162,34,37,48,2,9,222,33,43,80,159,34,41, 89,162,34,38,50,2,8,222,33,42,80,159,34,40,35,83,158,34,16,2,32,
35,83,158,34,16,2,32,0,89,162,34,36,51,2,10,222,33,44,80,159,34, 0,89,162,34,37,48,2,9,222,33,43,80,159,34,41,35,83,158,34,16,2,
42,35,83,158,34,16,2,32,0,89,162,34,36,52,2,11,222,33,45,80,159, 32,0,89,162,34,36,51,2,10,222,33,44,80,159,34,42,35,83,158,34,16,
34,43,35,83,158,34,16,2,32,0,89,162,34,35,42,2,12,222,33,46,80, 2,32,0,89,162,34,36,52,2,11,222,33,45,80,159,34,43,35,83,158,34,
159,34,44,35,83,158,34,16,2,83,158,37,20,96,95,2,13,89,162,34,34, 16,2,32,0,89,162,34,35,42,2,12,222,33,46,80,159,34,44,35,83,158,
41,9,223,0,33,47,89,162,34,35,51,9,223,0,33,48,80,159,34,45,35, 34,16,2,83,158,37,20,96,95,2,13,89,162,34,34,41,9,223,0,33,47,
83,158,34,16,2,27,248,22,140,13,248,22,144,7,27,28,249,22,137,8,247, 89,162,34,35,51,9,223,0,33,48,80,159,34,45,35,83,158,34,16,2,27,
22,152,7,2,21,6,1,1,59,6,1,1,58,250,22,181,6,6,14,14,40, 248,22,140,13,248,22,144,7,27,28,249,22,137,8,247,22,152,7,2,21,6,
91,94,126,97,93,42,41,126,97,40,46,42,41,195,195,89,162,34,36,46,2, 1,1,59,6,1,1,58,250,22,181,6,6,14,14,40,91,94,126,97,93,42,
14,223,0,33,51,80,159,34,46,35,83,158,34,16,2,83,158,37,20,96,96, 41,126,97,40,46,42,41,195,195,89,162,34,36,46,2,14,223,0,33,51,80,
2,15,89,162,8,36,37,52,9,223,0,33,56,89,162,34,36,45,9,223,0, 159,34,46,35,83,158,34,16,2,83,158,37,20,96,96,2,15,89,162,8,36,
33,57,89,162,34,35,44,9,223,0,33,58,80,159,34,47,35,83,158,34,16, 37,52,9,223,0,33,56,89,162,34,36,45,9,223,0,33,57,89,162,34,35,
2,89,162,34,36,49,2,16,223,0,33,60,80,159,34,48,35,94,29,94,2, 44,9,223,0,33,58,80,159,34,47,35,83,158,34,16,2,89,162,34,36,49,
17,2,29,11,29,94,2,17,69,35,37,109,105,110,45,115,116,120,11,9,9, 2,16,223,0,33,60,80,159,34,48,35,94,29,94,2,17,2,29,11,29,94,
0}; 2,17,69,35,37,109,105,110,45,115,116,120,11,9,9,0};
EVAL_ONE_SIZED_STR((char *)expr, 4179); EVAL_ONE_SIZED_STR((char *)expr, 4194);
} }
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,56,7,0,0,0,1,0,0,6,0,19, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,57,7,0,0,0,1,0,0,6,0,19,
0,34,0,48,0,62,0,76,0,0,0,245,0,0,0,65,113,117,111,116,101, 0,34,0,48,0,62,0,76,0,0,0,253,0,0,0,65,113,117,111,116,101,
29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,110, 29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,110,
101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,11, 101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,11,
29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,37, 29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,37,
107,101,114,110,101,108,11,159,34,20,102,159,34,16,1,20,24,65,98,101,103, 107,101,114,110,101,108,11,159,34,20,102,159,34,16,1,20,24,65,98,101,103,
105,110,16,0,83,158,40,20,99,131,69,35,37,98,117,105,108,116,105,110,29, 105,110,16,0,83,158,40,20,99,134,69,35,37,98,117,105,108,116,105,110,29,
11,11,10,10,18,94,11,97,10,34,11,97,158,2,2,34,158,2,3,34,158, 11,11,10,10,18,94,11,97,10,34,11,97,159,2,2,34,34,159,2,3,34,
2,4,34,158,2,5,34,158,2,6,34,16,0,18,94,11,95,35,11,16,0, 34,159,2,4,34,34,159,2,5,34,34,159,2,6,34,34,16,0,18,94,11,
10,18,94,11,95,8,240,48,117,0,0,11,16,0,34,80,158,34,34,20,102, 95,35,11,16,0,10,18,94,11,95,8,240,48,117,0,0,11,16,0,34,80,
159,34,16,0,16,0,11,11,16,0,34,11,11,16,0,16,0,16,0,34,34, 158,34,34,20,102,159,34,16,0,16,0,11,11,16,0,34,11,11,11,16,0,
11,16,0,16,0,16,0,34,34,11,16,0,16,0,16,0,34,34,16,0,16, 16,0,16,0,34,34,11,11,16,0,16,0,16,0,34,34,11,11,16,0,16,
0,98,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11, 0,16,0,34,34,16,0,16,0,98,2,6,2,5,29,94,2,1,69,35,37,
2,4,2,3,2,2,9,9,0}; 102,111,114,101,105,103,110,11,2,4,2,3,2,2,9,9,0};
EVAL_ONE_SIZED_STR((char *)expr, 281); EVAL_ONE_SIZED_STR((char *)expr, 289);
} }
{ {
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,56,52,0,0,0,1,0,0,3,0,14, static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,57,52,0,0,0,1,0,0,3,0,14,
0,41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0, 0,41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,
200,0,223,0,3,1,8,1,13,1,18,1,23,1,54,1,58,1,66,1,74, 200,0,223,0,3,1,8,1,13,1,18,1,23,1,54,1,58,1,66,1,74,
1,82,1,163,1,199,1,216,1,245,1,17,2,47,2,57,2,87,2,97,2, 1,82,1,163,1,199,1,216,1,245,1,17,2,47,2,57,2,87,2,97,2,
104,2,178,3,190,3,209,3,33,4,45,4,173,4,185,4,30,5,36,5,50, 104,2,178,3,190,3,209,3,33,4,45,4,173,4,185,4,30,5,36,5,50,
5,77,5,148,5,150,5,203,5,93,10,152,10,184,10,0,0,114,13,0,0, 5,77,5,148,5,150,5,203,5,93,10,152,10,184,10,0,0,119,13,0,0,
29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117, 29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,
108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65, 108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,
113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94,2, 113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94,2,
@ -452,7 +453,7 @@
89,162,34,37,47,9,223,1,33,43,89,162,34,38,8,30,9,225,2,3,0, 89,162,34,37,47,9,223,1,33,43,89,162,34,38,8,30,9,225,2,3,0,
33,49,208,87,95,248,22,130,4,248,80,158,36,48,247,22,146,11,248,22,184, 33,49,208,87,95,248,22,130,4,248,80,158,36,48,247,22,146,11,248,22,184,
5,80,158,35,35,248,22,132,12,80,159,35,40,35,159,34,20,102,159,34,16, 5,80,158,35,35,248,22,132,12,80,159,35,40,35,159,34,20,102,159,34,16,
1,20,24,65,98,101,103,105,110,16,0,83,158,40,20,99,131,66,35,37,98, 1,20,24,65,98,101,103,105,110,16,0,83,158,40,20,99,134,66,35,37,98,
111,111,116,2,1,11,10,10,10,10,10,36,80,158,34,34,20,102,159,38,16, 111,111,116,2,1,11,10,10,10,10,10,36,80,158,34,34,20,102,159,38,16,
19,30,2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104, 19,30,2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,
45,115,116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100, 45,115,116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,
@ -466,24 +467,25 @@
112,97,116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101, 112,97,116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,
45,115,117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,11,2, 45,115,117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,11,2,
10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,14, 10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,14,
45,11,11,16,0,16,0,16,0,34,34,11,16,0,16,0,16,0,34,34,11, 45,11,11,11,16,0,16,0,16,0,34,34,11,11,16,0,16,0,16,0,34,
16,1,2,16,16,1,11,16,1,2,16,35,35,16,0,16,16,83,158,34,16, 34,11,16,1,9,16,1,2,16,16,1,11,16,1,2,16,35,35,16,0,16,
2,89,162,34,35,43,9,223,0,33,23,80,159,34,56,35,83,158,34,16,2, 16,83,158,34,16,2,89,162,34,35,43,9,223,0,33,23,80,159,34,56,35,
89,162,8,36,35,43,9,223,0,33,24,80,159,34,55,35,83,158,34,16,2, 83,158,34,16,2,89,162,8,36,35,43,9,223,0,33,24,80,159,34,55,35,
89,162,34,35,47,67,103,101,116,45,100,105,114,223,0,33,25,80,159,34,54, 83,158,34,16,2,89,162,34,35,47,67,103,101,116,45,100,105,114,223,0,33,
35,83,158,34,16,2,89,162,34,36,47,68,119,105,116,104,45,100,105,114,223, 25,80,159,34,54,35,83,158,34,16,2,89,162,34,36,47,68,119,105,116,104,
0,33,26,80,159,34,53,35,83,158,34,16,2,248,22,152,7,69,115,111,45, 45,100,105,114,223,0,33,26,80,159,34,53,35,83,158,34,16,2,248,22,152,
115,117,102,102,105,120,80,159,34,34,35,83,158,34,16,2,89,162,34,36,58, 7,69,115,111,45,115,117,102,102,105,120,80,159,34,34,35,83,158,34,16,2,
2,3,223,0,33,35,80,159,34,35,35,83,158,34,16,2,32,0,89,162,8, 89,162,34,36,58,2,3,223,0,33,35,80,159,34,35,35,83,158,34,16,2,
36,35,40,2,7,222,192,80,159,34,40,35,83,158,34,16,2,248,22,120,2, 32,0,89,162,8,36,35,40,2,7,222,192,80,159,34,40,35,83,158,34,16,
18,80,159,34,41,35,83,158,34,16,2,249,22,120,2,18,65,101,113,117,97, 2,248,22,120,2,18,80,159,34,41,35,83,158,34,16,2,249,22,120,2,18,
108,80,159,34,42,35,83,158,34,16,2,247,22,59,80,159,34,43,35,83,158, 65,101,113,117,97,108,80,159,34,42,35,83,158,34,16,2,247,22,59,80,159,
34,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103, 34,43,35,83,158,34,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,
80,159,34,44,35,83,158,34,16,2,11,80,158,34,45,83,158,34,16,2,11, 97,100,105,110,103,80,159,34,44,35,83,158,34,16,2,11,80,158,34,45,83,
80,158,34,46,83,158,34,16,2,32,0,89,162,34,36,43,2,14,222,33,41, 158,34,16,2,11,80,158,34,46,83,158,34,16,2,32,0,89,162,34,36,43,
80,159,34,47,35,83,158,34,16,2,89,162,8,36,35,43,2,15,223,0,33, 2,14,222,33,41,80,159,34,47,35,83,158,34,16,2,89,162,8,36,35,43,
50,80,159,34,48,35,83,158,34,16,2,89,162,34,34,42,2,16,223,0,33, 2,15,223,0,33,50,80,159,34,48,35,83,158,34,16,2,89,162,34,34,42,
51,80,159,34,52,35,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11, 2,16,223,0,33,51,80,159,34,52,35,95,29,94,2,4,68,35,37,107,101,
29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,0}; 114,110,101,108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,
EVAL_ONE_SIZED_STR((char *)expr, 3568); 5,9,9,0};
EVAL_ONE_SIZED_STR((char *)expr, 3573);
} }

7
src/mzscheme/src/env.c
View File

@ -1121,6 +1121,7 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
env->module->self_modidx, env->module->self_modidx,
n, n,
env->mod_phase, env->mod_phase,
-1,
0); 0);
} }
} }
@ -1844,7 +1845,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
existing rename. */ existing rename. */
if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (is_def != 2)) { if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (is_def != 2)) {
Scheme_Object *mod, *nm = id; Scheme_Object *mod, *nm = id;
mod = scheme_stx_module_name(&nm, env->phase, NULL, NULL, NULL); mod = scheme_stx_module_name(&nm, env->phase, NULL, NULL, NULL, NULL);
if (mod /* must refer to env->module, otherwise there would if (mod /* must refer to env->module, otherwise there would
have been an error before getting here */ have been an error before getting here */
&& NOT_SAME_OBJ(nm, sym)) && NOT_SAME_OBJ(nm, sym))
@ -2445,7 +2446,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
} }
src_find_id = find_id; src_find_id = find_id;
modidx = scheme_stx_module_name(&find_id, phase, NULL, NULL, &mod_defn_phase); modidx = scheme_stx_module_name(&find_id, phase, NULL, NULL, &mod_defn_phase, NULL);
/* Used out of context? */ /* Used out of context? */
if (SAME_OBJ(modidx, scheme_undefined)) { if (SAME_OBJ(modidx, scheme_undefined)) {
@ -2708,7 +2709,7 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok
if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) { if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) {
return 1; return 1;
} else { } else {
mod = scheme_stx_module_name(&id, env->phase, NULL, NULL, NULL); mod = scheme_stx_module_name(&id, env->phase, NULL, NULL, NULL, NULL);
if (SAME_OBJ(mod, scheme_undefined)) if (SAME_OBJ(mod, scheme_undefined))
return 1; return 1;
} }

2
src/mzscheme/src/error.c
View File

@ -1553,7 +1553,7 @@ static void do_wrong_syntax(const char *where,
if (scheme_current_thread->current_local_env) if (scheme_current_thread->current_local_env)
phase = scheme_current_thread->current_local_env->genv->phase; phase = scheme_current_thread->current_local_env->genv->phase;
else phase = 0; else phase = 0;
scheme_stx_module_name(&first, phase, &mod, &nomwho, NULL); scheme_stx_module_name(&first, phase, &mod, &nomwho, NULL, NULL);
} }
} }
} else { } else {

2
src/mzscheme/src/eval.c
View File

@ -4851,7 +4851,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* Since the module has a rename for this id, it's certainly defined. */ /* Since the module has a rename for this id, it's certainly defined. */
} else { } else {
modidx = scheme_stx_module_name(&symbol, env->genv->phase, NULL, NULL, NULL); modidx = scheme_stx_module_name(&symbol, env->genv->phase, NULL, NULL, NULL, NULL);
if (modidx) { if (modidx) {
/* If it's an access path, resolve it: */ /* If it's an access path, resolve it: */
if (env->genv->module if (env->genv->module

261
src/mzscheme/src/module.c
View File

@ -187,7 +187,8 @@ static Scheme_Object *global_shift_cache;
static Scheme_Bucket_Table *modpath_table; static Scheme_Bucket_Table *modpath_table;
#define SCHEME_MODNAMEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type) #define SCHEME_MODNAMEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)
typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *nominal_modname, typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name,
Scheme_Object *nominal_modname, Scheme_Object *nominal_export,
Scheme_Object *modname, Scheme_Object *srcname, Scheme_Object *modname, Scheme_Object *srcname,
int isval, void *data, Scheme_Object *e, Scheme_Object *form, int isval, void *data, Scheme_Object *e, Scheme_Object *form,
Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *err_src, Scheme_Object *mark_src,
@ -240,6 +241,7 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj
static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv); static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv);
static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets,
Scheme_Object **exsnoms,
int start, int count, int do_uninterned); int start, int count, int do_uninterned);
#define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0])) #define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0]))
@ -533,7 +535,7 @@ void scheme_finish_kernel(Scheme_Env *env)
rn = scheme_make_module_rename(0, mzMOD_RENAME_NORMAL, NULL); rn = scheme_make_module_rename(0, mzMOD_RENAME_NORMAL, NULL);
for (i = kernel->me->rt->num_provides; i--; ) { for (i = kernel->me->rt->num_provides; i--; ) {
scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], 0, 0); scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], 0, 0, 0);
} }
scheme_sys_wraps(NULL); scheme_sys_wraps(NULL);
@ -638,7 +640,7 @@ void scheme_require_from_original_env(Scheme_Env *env, int syntax_only)
} }
mod_sym = scheme_intern_symbol("module"); mod_sym = scheme_intern_symbol("module");
scheme_extend_module_rename(rn, kernel_modidx, mod_sym, mod_sym, kernel_modidx, mod_sym, 0, 0); scheme_extend_module_rename(rn, kernel_modidx, mod_sym, mod_sym, kernel_modidx, mod_sym, 0, 0, 0);
} }
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env) Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env)
@ -1932,7 +1934,7 @@ static int do_add_require_renames(Scheme_Object *rn,
if (with_shared) { if (with_shared) {
if (!pt->src_modidx) if (!pt->src_modidx)
pt->src_modidx = im->me->src_modidx; pt->src_modidx = im->me->src_modidx;
scheme_extend_module_rename_with_shared(rn, idx, pt, marshal_k, 1); scheme_extend_module_rename_with_shared(rn, idx, pt, marshal_k, 0, 1);
} }
mark_src = scheme_rename_to_stx(rn); mark_src = scheme_rename_to_stx(rn);
@ -1949,13 +1951,13 @@ static int do_add_require_renames(Scheme_Object *rn,
midx = idx; midx = idx;
if (!with_shared) { if (!with_shared) {
scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i],
exets ? exets[i] : 0, 1); exets ? exets[i] : 0, pt->phase_index, 1);
} }
if (SAME_OBJ(exs[i], module_begin_symbol)) if (SAME_OBJ(exs[i], module_begin_symbol))
saw_mb = 1; saw_mb = 1;
if (required) { if (required) {
vec = scheme_make_vector(8, NULL); vec = scheme_make_vector(7, NULL);
nml = scheme_make_pair(idx, scheme_null); nml = scheme_make_pair(idx, scheme_null);
SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[0] = nml;
SCHEME_VEC_ELS(vec)[1] = midx; SCHEME_VEC_ELS(vec)[1] = midx;
@ -1964,7 +1966,6 @@ static int do_add_require_renames(Scheme_Object *rn,
SCHEME_VEC_ELS(vec)[4] = exs[i]; SCHEME_VEC_ELS(vec)[4] = exs[i];
SCHEME_VEC_ELS(vec)[5] = orig_src; SCHEME_VEC_ELS(vec)[5] = orig_src;
SCHEME_VEC_ELS(vec)[6] = mark_src; SCHEME_VEC_ELS(vec)[6] = mark_src;
SCHEME_VEC_ELS(vec)[7] = scheme_make_integer(0x1);
scheme_hash_set(required, exs[i], vec); scheme_hash_set(required, exs[i], vec);
} }
} }
@ -1980,7 +1981,7 @@ static int do_add_require_renames(Scheme_Object *rn,
numvals = kernel->me->rt->num_var_provides; numvals = kernel->me->rt->num_var_provides;
for (i = kernel->me->rt->num_provides; i--; ) { for (i = kernel->me->rt->num_provides; i--; ) {
if (!SAME_OBJ(pt->kernel_exclusion, exs[i])) { if (!SAME_OBJ(pt->kernel_exclusion, exs[i])) {
vec = scheme_make_vector(8, NULL); vec = scheme_make_vector(7, NULL);
nml = scheme_make_pair(idx, scheme_null); nml = scheme_make_pair(idx, scheme_null);
SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[0] = nml;
SCHEME_VEC_ELS(vec)[1] = kernel_modidx; SCHEME_VEC_ELS(vec)[1] = kernel_modidx;
@ -1989,7 +1990,6 @@ static int do_add_require_renames(Scheme_Object *rn,
SCHEME_VEC_ELS(vec)[4] = exs[i]; SCHEME_VEC_ELS(vec)[4] = exs[i];
SCHEME_VEC_ELS(vec)[5] = orig_src; SCHEME_VEC_ELS(vec)[5] = orig_src;
SCHEME_VEC_ELS(vec)[6] = mark_src; SCHEME_VEC_ELS(vec)[6] = mark_src;
SCHEME_VEC_ELS(vec)[7] = scheme_make_integer(0x1);
scheme_hash_set(required, exs[i], vec); scheme_hash_set(required, exs[i], vec);
} }
} }
@ -1998,7 +1998,8 @@ static int do_add_require_renames(Scheme_Object *rn,
if (!with_shared) { if (!with_shared) {
info = cons(idx, cons(scheme_make_integer(marshal_k), info = cons(idx, cons(scheme_make_integer(marshal_k),
cons(scheme_null, scheme_false))); cons(scheme_make_integer(0),
cons(scheme_null, scheme_false))));
scheme_save_module_rename_unmarshal(rn, info); scheme_save_module_rename_unmarshal(rn, info);
} }
@ -2086,13 +2087,13 @@ Scheme_Object *scheme_module_to_namespace(Scheme_Object *name, Scheme_Env *env)
for (i = 0; i < m->me->rt->num_provides; i++) { for (i = 0; i < m->me->rt->num_provides; i++) {
if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) { if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
name = m->me->rt->provides[i]; name = m->me->rt->provides[i];
scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0, 0); scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0, 0, 0);
} }
} }
/* Local, not provided: */ /* Local, not provided: */
for (i = 0; i < m->num_indirect_provides; i++) { for (i = 0; i < m->num_indirect_provides; i++) {
name = m->indirect_provides[i]; name = m->indirect_provides[i];
scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0, 0); scheme_extend_module_rename(rn, m->self_modidx, name, name, m->self_modidx, name, 0, 0, 0);
} }
/* Required: */ /* Required: */
@ -2340,6 +2341,15 @@ static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[])
return NULL; return NULL;
} }
static Scheme_Object *make_provide_desc(Scheme_Module_Phase_Exports *pt, int i)
{
return scheme_make_pair(pt->provides[i],
scheme_make_pair((pt->provide_nominal_srcs
? pt->provide_nominal_srcs[i]
: scheme_null),
scheme_null));
}
static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]) static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[])
{ {
Scheme_Module *m; Scheme_Module *m;
@ -2369,10 +2379,10 @@ static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[])
vl = scheme_null; vl = scheme_null;
n = pt->num_var_provides; n = pt->num_var_provides;
for (i = pt->num_provides - 1; i >= n; --i) { for (i = pt->num_provides - 1; i >= n; --i) {
ml = scheme_make_pair(pt->provides[i], ml); ml = scheme_make_pair(make_provide_desc(pt, i), ml);
} }
for (; i >= 0; --i) { for (; i >= 0; --i) {
vl = scheme_make_pair(pt->provides[i], vl); vl = scheme_make_pair(make_provide_desc(pt, i), vl);
} }
a[2 * k] = vl; a[2 * k] = vl;
@ -2418,14 +2428,21 @@ static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[])
static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]) static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[])
{ {
if (SCHEME_MODNAMEP(argv[0])) if (!SCHEME_PATHP(argv[0])
scheme_wrong_type("module-path-index-join", "non-resolved-module-path", 0, argc, argv); && !scheme_is_module_path(argv[0])
&& !SCHEME_FALSEP(argv[0]))
scheme_wrong_type("module-path-index-join", "module path, path, or #f", 0, argc, argv);
if (argv[1]) { /* mzc will generate NULL sometimes; see scheme_declare_module(), below */ if (argv[1]) { /* mzc will generate NULL sometimes; see scheme_declare_module(), below */
if (SCHEME_TRUEP(argv[1]) if (SCHEME_TRUEP(argv[1])
&& !SCHEME_MODNAMEP(argv[1]) && !SCHEME_MODNAMEP(argv[1])
&& !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_module_index_type)) && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_module_index_type))
scheme_wrong_type("module-path-index-join", "module-path-index, resolved-module-path, or #f", 1, argc, argv); scheme_wrong_type("module-path-index-join", "module-path-index, resolved-module-path, or #f", 1, argc, argv);
if (SCHEME_FALSEP(argv[0]) && !SCHEME_FALSEP(argv[1]))
scheme_arg_mismatch("module-path-index-join",
"first argument cannot be #f when second argument is not #f: ",
argv[1]);
} }
return scheme_make_modidx(argv[0], argv[1], scheme_false); return scheme_make_modidx(argv[0], argv[1], scheme_false);
@ -2619,8 +2636,9 @@ static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx,
a[3] = (load_it ? scheme_true : scheme_false); a[3] = (load_it ? scheme_true : scheme_false);
if (SCHEME_FALSEP(a[0])) { if (SCHEME_FALSEP(a[0])) {
scheme_wrong_syntax("require", NULL, NULL, scheme_arg_mismatch("module-path-index-resolve",
"broken compiled/expanded code: unresolved module index without path"); "\"self\" index has no resolution: ",
modidx);
} }
name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a); name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a);
@ -3768,7 +3786,7 @@ void scheme_finish_primitive_module(Scheme_Env *env)
m->me->rt->num_provides = count; m->me->rt->num_provides = count;
m->me->rt->num_var_provides = count; m->me->rt->num_var_provides = count;
qsort_provides(exs, NULL, NULL, NULL, NULL, 0, count, 1); qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, 0, count, 1);
env->running = 1; env->running = 1;
} }
@ -3869,14 +3887,17 @@ static Scheme_Module_Exports *make_module_exports()
pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports);
SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports); SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports);
pt->phase_index = 0;
me->rt = pt; me->rt = pt;
pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports);
SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports); SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports);
pt->phase_index = 1;
me->et = pt; me->et = pt;
pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports);
SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports); SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports);
pt->phase_index = 2;
me->dt = pt; me->dt = pt;
return me; return me;
@ -4899,7 +4920,23 @@ Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *e
/* #%module-begin */ /* #%module-begin */
/**********************************************************************/ /**********************************************************************/
static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *nominal_modidx, Scheme_Object *scheme_phase_index_symbol(int src_phase_index)
{
switch (src_phase_index) {
case 0:
default:
return scheme_false;
case 1:
return for_syntax_symbol;
case 2:
return for_label_symbol;
case 3:
return for_template_symbol;
}
}
static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name,
Scheme_Object *nominal_modidx, Scheme_Object *nominal_name,
Scheme_Object *modidx, Scheme_Object *exname, Scheme_Object *modidx, Scheme_Object *exname,
int isval, void *tables, Scheme_Object *e, Scheme_Object *form, int isval, void *tables, Scheme_Object *e, Scheme_Object *form,
Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *err_src, Scheme_Object *mark_src,
@ -4920,6 +4957,15 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc
} }
} }
if (src_phase_index || !SAME_OBJ(nominal_name, prnt_name)) {
Scheme_Object *v;
v = scheme_phase_index_symbol(src_phase_index);
nominal_modidx = scheme_make_pair(nominal_modidx,
scheme_make_pair(v,
scheme_make_pair(nominal_name,
scheme_null)));
}
/* Not required, or required from same module: */ /* Not required, or required from same module: */
vec = scheme_hash_get(required, name); vec = scheme_hash_get(required, name);
if (vec) { if (vec) {
@ -4933,8 +4979,6 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc
and also add source phase for re-provides. */ and also add source phase for re-provides. */
nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]); nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]);
SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[0] = nml;
SCHEME_VEC_ELS(vec)[7] = scheme_make_integer(SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[7])
| (1 << src_phase_index));
return; return;
} }
@ -4970,7 +5014,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc
} }
/* Remember require: */ /* Remember require: */
vec = scheme_make_vector(8, NULL); vec = scheme_make_vector(7, NULL);
nml = scheme_make_pair(nominal_modidx, scheme_null); nml = scheme_make_pair(nominal_modidx, scheme_null);
SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[0] = nml;
SCHEME_VEC_ELS(vec)[1] = modidx; SCHEME_VEC_ELS(vec)[1] = modidx;
@ -4979,7 +5023,6 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc
SCHEME_VEC_ELS(vec)[4] = prnt_name; SCHEME_VEC_ELS(vec)[4] = prnt_name;
SCHEME_VEC_ELS(vec)[5] = (err_src ? err_src : scheme_false); SCHEME_VEC_ELS(vec)[5] = (err_src ? err_src : scheme_false);
SCHEME_VEC_ELS(vec)[6] = (mark_src ? mark_src : scheme_false); SCHEME_VEC_ELS(vec)[6] = (mark_src ? mark_src : scheme_false);
SCHEME_VEC_ELS(vec)[7] = scheme_make_integer(1 << src_phase_index);
scheme_hash_set(required, name, vec); scheme_hash_set(required, name, vec);
} }
@ -5032,7 +5075,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
scheme_add_global_symbol(name, scheme_undefined, env->genv); scheme_add_global_symbol(name, scheme_undefined, env->genv);
/* Add a renaming: */ /* Add a renaming: */
scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, 0); scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, -1, 0);
id = scheme_add_rename(*_id, rn); id = scheme_add_rename(*_id, rn);
*_id = id; *_id = id;
@ -5379,9 +5422,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Add a renaming: */ /* Add a renaming: */
if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name))
scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, 0); scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, -1, 0);
else else
scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, 0); scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, -1, 0);
vars = SCHEME_STX_CDR(vars); vars = SCHEME_STX_CDR(vars);
} }
@ -5460,10 +5503,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name))
scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name, scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name,
for_stx ? 1 : 0, 0); for_stx ? 1 : 0, -1, 0);
else else
scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name,
for_stx ? 1 : 0, 0); for_stx ? 1 : 0, -1, 0);
count++; count++;
} }
@ -5865,7 +5908,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
exicount = count; exicount = count;
qsort_provides(exis, NULL, NULL, NULL, NULL, 0, exicount, 1); qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
} }
if (!rec[drec].comp) { if (!rec[drec].comp) {
@ -6116,10 +6159,13 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
if (vec) { if (vec) {
/* Check for nominal modidx in list */ /* Check for nominal modidx in list */
Scheme_Object *nml; Scheme_Object *nml, *nml_modidx;
nml = SCHEME_VEC_ELS(vec)[0]; nml = SCHEME_VEC_ELS(vec)[0];
for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), SCHEME_CAR(nml))) nml_modidx = SCHEME_CAR(nml);
if (SCHEME_PAIRP(nml_modidx))
nml_modidx = SCHEME_CAR(nml_modidx);
if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nml_modidx))
break; break;
} }
if (!SCHEME_PAIRP(nml)) if (!SCHEME_PAIRP(nml))
@ -6168,11 +6214,22 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
outname = SCHEME_VEC_ELS(required->vals[i])[4]; outname = SCHEME_VEC_ELS(required->vals[i])[4];
mark_src = SCHEME_VEC_ELS(required->vals[i])[6]; mark_src = SCHEME_VEC_ELS(required->vals[i])[6];
if (SCHEME_INT_VAL(SCHEME_VEC_ELS(required->vals[i])[7]) & (1 << src_phase_index)) {
for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) {
for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
nominal_modidx = SCHEME_CAR(nml); nominal_modidx = SCHEME_CAR(nml);
if (SCHEME_PAIRP(nominal_modidx))
nominal_modidx = SCHEME_CAR(nominal_modidx);
if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) { if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) {
Scheme_Object *pi, *nml_pi;
if (SCHEME_PAIRP(SCHEME_CAR(nml))) {
nml_pi = SCHEME_CADR(SCHEME_CAR(nml));
} else
nml_pi = scheme_false;
pi = scheme_phase_index_symbol(src_phase_index);
if (SAME_OBJ(pi, nml_pi)) {
Scheme_Object *exns, *ree; Scheme_Object *exns, *ree;
break_outer = 1; break_outer = 1;
@ -6387,6 +6444,37 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind
return scheme_values(3, a); return scheme_values(3, a);
} }
static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object *in_name, Scheme_Object *noms)
{
Scheme_Object *first = scheme_null, *last = NULL, *p, *a;
if (SAME_OBJ(in_name, out_name))
return noms;
while (SCHEME_PAIRP(noms)) {
a = SCHEME_CAR(noms);
if (SCHEME_PAIRP(a)) {
/* no change */
} else {
a = scheme_make_pair(a,
scheme_make_pair(scheme_false,
scheme_make_pair(in_name,
scheme_null)));
}
p = scheme_make_pair(a, scheme_null);
if (last)
SCHEME_CDR(last) = p;
else
first = p;
last = p;
noms = SCHEME_CDR(noms);
}
return first;
}
char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *required, char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *required,
Scheme_Module_Phase_Exports *pt, Scheme_Module_Phase_Exports *pt,
Scheme_Env *genv, int def_phase, Scheme_Env *genv, int def_phase,
@ -6395,7 +6483,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
const char *def_way) const char *def_way)
{ {
int i, count; int i, count;
Scheme_Object **exs, **exsns, **exss; Scheme_Object **exs, **exsns, **exss, **exsnoms;
char *exps, *exets; char *exps, *exets;
int excount, exvcount; int excount, exvcount;
@ -6409,6 +6497,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
exs = MALLOC_N(Scheme_Object *, count); exs = MALLOC_N(Scheme_Object *, count);
exsns = MALLOC_N(Scheme_Object *, count); exsns = MALLOC_N(Scheme_Object *, count);
exss = MALLOC_N(Scheme_Object *, count); exss = MALLOC_N(Scheme_Object *, count);
exsnoms = MALLOC_N(Scheme_Object *, count);
exps = MALLOC_N_ATOMIC(char, count); exps = MALLOC_N_ATOMIC(char, count);
if (def_phase) { if (def_phase) {
exets = MALLOC_N_ATOMIC(char, count); exets = MALLOC_N_ATOMIC(char, count);
@ -6439,6 +6528,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
exs[count] = provided->keys[i]; exs[count] = provided->keys[i];
exsns[count] = name; exsns[count] = name;
exss[count] = scheme_false; /* means "self" */ exss[count] = scheme_false; /* means "self" */
exsnoms[count] = scheme_null; /* since "self" */
exps[count] = protected; exps[count] = protected;
if (exets) if (exets)
exets[count] = def_phase; exets[count] = def_phase;
@ -6458,9 +6548,12 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
&& SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) { && SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) {
/* skip */ /* skip */
} else { } else {
Scheme_Object *noms;
exs[count] = provided->keys[i]; exs[count] = provided->keys[i];
exsns[count] = SCHEME_VEC_ELS(v)[2]; exsns[count] = SCHEME_VEC_ELS(v)[2];
exss[count] = SCHEME_VEC_ELS(v)[1]; exss[count] = SCHEME_VEC_ELS(v)[1];
noms = adjust_for_rename(exs[count], name, SCHEME_VEC_ELS(v)[0]);
exsnoms[count] = noms;
exps[count] = protected; exps[count] = protected;
count++; count++;
} }
@ -6496,6 +6589,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
exs[count] = provided->keys[i]; exs[count] = provided->keys[i];
exsns[count] = name; exsns[count] = name;
exss[count] = scheme_false; /* means "self" */ exss[count] = scheme_false; /* means "self" */
exsnoms[count] = scheme_null; /* since "self" */
exps[count] = protected; exps[count] = protected;
if (exets) if (exets)
exets[count] = def_phase; exets[count] = def_phase;
@ -6509,9 +6603,12 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
&& SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) { && SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) {
/* skip */ /* skip */
} else { } else {
Scheme_Object *noms;
exs[count] = provided->keys[i]; exs[count] = provided->keys[i];
exsns[count] = SCHEME_VEC_ELS(v)[2]; exsns[count] = SCHEME_VEC_ELS(v)[2];
exss[count] = SCHEME_VEC_ELS(v)[1]; exss[count] = SCHEME_VEC_ELS(v)[1];
noms = adjust_for_rename(exs[count], name, SCHEME_VEC_ELS(v)[0]);
exsnoms[count] = noms;
exps[count] = protected; exps[count] = protected;
count++; count++;
} }
@ -6522,16 +6619,26 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
excount = count; excount = count;
/* Discard exsnom[n]s if there are no re-exports */
for (i = 0; i < excount; i++) {
if (!SCHEME_NULLP(exsnoms[count]))
break;
}
if (i >= excount) {
exsnoms = NULL;
}
/* Sort provide array for variables: interned followed by /* Sort provide array for variables: interned followed by
uninterned, alphabetical within each. This is important for uninterned, alphabetical within each. This is important for
having a consistent provide arrays. */ having a consistent provide arrays. */
qsort_provides(exs, exsns, exss, exps, exets, 0, exvcount, 1); qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, exvcount, 1);
pt->num_provides = excount; pt->num_provides = excount;
pt->num_var_provides = exvcount; pt->num_var_provides = exvcount;
pt->provides = exs; pt->provides = exs;
pt->provide_src_names = exsns; pt->provide_src_names = exsns;
pt->provide_srcs = exss; pt->provide_srcs = exss;
pt->provide_nominal_srcs = exsnoms;
if (exets) { if (exets) {
for (i = 0; i < excount; i++) { for (i = 0; i < excount; i++) {
if (exets[i]) if (exets[i])
@ -6546,11 +6653,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req
} }
/* Helper: */ /* Helper: */
static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss,
char *exps, char *exets,
Scheme_Object **exsnoms,
int start, int count, int do_uninterned) int start, int count, int do_uninterned)
{ {
int i, j; int i, j;
Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *pivot; Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *pivot;
char tmp_exp, tmp_exet; char tmp_exp, tmp_exet;
if (do_uninterned) { if (do_uninterned) {
@ -6585,6 +6694,13 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob
exets[i] = exets[j]; exets[i] = exets[j];
exets[j] = tmp_exet; exets[j] = tmp_exet;
} }
if (exsnoms) {
tmp_exsnom = exsnoms[i];
exsnoms[i] = exsnoms[j];
exsnoms[j] = tmp_exsnom;
}
j--; j--;
/* Skip over uninterns already at the end: */ /* Skip over uninterns already at the end: */
@ -6598,8 +6714,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob
} }
/* Sort interned and uninterned separately: */ /* Sort interned and uninterned separately: */
qsort_provides(exs, exsns, exss, exps, exets, 0, j + 1, 0); qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, j + 1, 0);
qsort_provides(exs, exsns, exss, exps, exets, j + 1, count - j - 1, 0); qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j + 1, count - j - 1, 0);
} else { } else {
j = start; j = start;
while (count > 1) { while (count > 1) {
@ -6632,6 +6748,14 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob
exets[j] = tmp_exet; exets[j] = tmp_exet;
} }
if (exsnoms) {
tmp_exsnom = exsnoms[k];
exsnoms[k] = exsnoms[j];
exsnoms[j] = tmp_exsnom;
}
j++; j++;
} }
} }
@ -6644,8 +6768,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob
} }
if (count > 1) { if (count > 1) {
qsort_provides(exs, exsns, exss, exps, exets, start, j - start, 0); qsort_provides(exs, exsns, exss, exps, exets, exsnoms, start, j - start, 0);
qsort_provides(exs, exsns, exss, exps, exets, j, count - (j - start), 0); qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j, count - (j - start), 0);
} }
} }
} }
@ -7263,7 +7387,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
/* Simple "import everything" whose mappings can be shared via the exporting module: */ /* Simple "import everything" whose mappings can be shared via the exporting module: */
if (!pt->src_modidx) if (!pt->src_modidx)
pt->src_modidx = me->src_modidx; pt->src_modidx = me->src_modidx;
scheme_extend_module_rename_with_shared(rn, idx, pt, k + base_k, 1); scheme_extend_module_rename_with_shared(rn, idx, pt, k + base_k, src_phase_index, 1);
skip_rename = 1; skip_rename = 1;
} else } else
skip_rename = 0; skip_rename = 0;
@ -7343,7 +7467,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
} }
if (ck) if (ck)
ck(prnt_iname, iname, nominal_modidx, modidx, exsns[j], (j < var_count), ck(prnt_iname, iname, nominal_modidx, exs[j], modidx, exsns[j], (j < var_count),
data, cki, form, err_src, mark_src, src_phase_index); data, cki, form, err_src, mark_src, src_phase_index);
if (!is_kern) { if (!is_kern) {
@ -7362,6 +7486,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
scheme_extend_module_rename((has_context ? post_ex_rn : rn), scheme_extend_module_rename((has_context ? post_ex_rn : rn),
modidx, iname, exsns[j], nominal_modidx, exs[j], modidx, iname, exsns[j], nominal_modidx, exs[j],
exets ? exets[j] : 0, exets ? exets[j] : 0,
src_phase_index,
for_unmarshal || (!has_context && can_save_marshal)); for_unmarshal || (!has_context && can_save_marshal));
} }
} }
@ -7410,7 +7535,8 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
/* The format of this data is checked in stxobj for unmarshaling /* The format of this data is checked in stxobj for unmarshaling
a Module_Renames. Also the idx must be first, to support shifting. */ a Module_Renames. Also the idx must be first, to support shifting. */
info = cons(orig_idx, cons(scheme_make_integer(k+base_k), info = cons(orig_idx, cons(scheme_make_integer(k+base_k),
cons(exns, prefix ? prefix : scheme_false))); cons(scheme_make_integer(src_phase_index),
cons(exns, prefix ? prefix : scheme_false))));
scheme_save_module_rename_unmarshal(rn, info); scheme_save_module_rename_unmarshal(rn, info);
@ -7428,22 +7554,25 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
Scheme_Hash_Table *export_registry) Scheme_Hash_Table *export_registry)
{ {
Scheme_Object *orig_idx, *exns, *prefix, *idx, *name, *kv; Scheme_Object *orig_idx, *exns, *prefix, *idx, *name, *kv, *spi;
Scheme_Module_Exports *me; Scheme_Module_Exports *me;
Scheme_Env *env; Scheme_Env *env;
int share_all; int share_all, src_phase_index;
idx = SCHEME_CAR(info); idx = SCHEME_CAR(info);
orig_idx = idx; orig_idx = idx;
info = SCHEME_CDR(info); info = SCHEME_CDR(info);
kv = SCHEME_CAR(info);
info = SCHEME_CDR(info);
if (SCHEME_INTP(info)) { if (SCHEME_INTP(info)) {
share_all = 1; share_all = 1;
kv = info; spi = info;
exns = NULL; exns = NULL;
prefix = NULL; prefix = NULL;
} else { } else {
share_all = 0; share_all = 0;
kv = SCHEME_CAR(info); spi = SCHEME_CAR(info);
info = SCHEME_CDR(info); info = SCHEME_CDR(info);
exns = SCHEME_CAR(info); exns = SCHEME_CAR(info);
prefix = SCHEME_CDR(info); prefix = SCHEME_CDR(info);
@ -7479,6 +7608,8 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
} }
} }
src_phase_index = SCHEME_INT_VAL(spi);
if (share_all) { if (share_all) {
Scheme_Module_Phase_Exports *pt; Scheme_Module_Phase_Exports *pt;
int k = SCHEME_INT_VAL(kv); int k = SCHEME_INT_VAL(kv);
@ -7498,9 +7629,9 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
if (!pt->src_modidx) if (!pt->src_modidx)
pt->src_modidx = me->src_modidx; pt->src_modidx = me->src_modidx;
scheme_extend_module_rename_with_shared(rn, orig_idx, pt, k, 0); scheme_extend_module_rename_with_shared(rn, orig_idx, pt, k, src_phase_index, 0);
} else { } else {
add_single_require(me, SCHEME_INT_VAL(kv), 0, orig_idx, NULL, add_single_require(me, SCHEME_INT_VAL(kv), src_phase_index, orig_idx, NULL,
rn, NULL, rn, NULL,
NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL,
@ -7881,7 +8012,8 @@ void parse_requires(Scheme_Object *form,
} }
} }
static void check_dup_require(Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *nominal_modidx, static void check_dup_require(Scheme_Object *prnt_name, Scheme_Object *name,
Scheme_Object *nominal_modidx, Scheme_Object *nominal_name,
Scheme_Object *modidx, Scheme_Object *srcname, Scheme_Object *modidx, Scheme_Object *srcname,
int isval, void *ht, Scheme_Object *e, Scheme_Object *form, int isval, void *ht, Scheme_Object *e, Scheme_Object *form,
Scheme_Object *err_src, Scheme_Object *mark_src, int src_phase_index) Scheme_Object *err_src, Scheme_Object *mark_src, int src_phase_index)
@ -8164,6 +8296,16 @@ static Scheme_Object *write_module(Scheme_Object *obj)
} }
l = cons(v, l); l = cons(v, l);
if (pt->provide_nominal_srcs) {
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = pt->provide_nominal_srcs[i];
}
l = cons(v, l);
} else {
l = cons(scheme_false, l);
}
if (pt->provide_src_phases) { if (pt->provide_src_phases) {
v = scheme_make_vector(count, NULL); v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) { for (i = 0; i < count; i++) {
@ -8246,7 +8388,7 @@ static Scheme_Object *read_module(Scheme_Object *obj)
{ {
Scheme_Module *m; Scheme_Module *m;
Scheme_Object *ie, *nie; Scheme_Object *ie, *nie;
Scheme_Object *esp, *esn, *esph, *es, *e, *nve, *ne, **v; Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
Scheme_Module_Exports *me; Scheme_Module_Exports *me;
Scheme_Module_Phase_Exports *pt; Scheme_Module_Phase_Exports *pt;
char *ps, *sps; char *ps, *sps;
@ -8360,6 +8502,10 @@ static Scheme_Object *read_module(Scheme_Object *obj)
esph = SCHEME_CAR(obj); esph = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj); obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL();
esnom = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL(); if (!SCHEME_PAIRP(obj)) return_NULL();
esn = SCHEME_CAR(obj); esn = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj); obj = SCHEME_CDR(obj);
@ -8405,6 +8551,17 @@ static Scheme_Object *read_module(Scheme_Object *obj)
} }
pt->provide_src_names = v; pt->provide_src_names = v;
if (SCHEME_FALSEP(esnom)) {
pt->provide_nominal_srcs = NULL;
} else {
if (!SCHEME_VECTORP(esnom) || (SCHEME_VEC_SIZE(esnom) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) {
v[i] = SCHEME_VEC_ELS(esnom)[i];
}
pt->provide_nominal_srcs = v;
}
if (SCHEME_FALSEP(esph)) if (SCHEME_FALSEP(esph))
sps = NULL; sps = NULL;
else { else {

2
src/mzscheme/src/mzmark.c
View File

@ -2421,6 +2421,7 @@ static int module_phase_exports_val_MARK(void *p) {
gcMARK(m->provides); gcMARK(m->provides);
gcMARK(m->provide_srcs); gcMARK(m->provide_srcs);
gcMARK(m->provide_src_names); gcMARK(m->provide_src_names);
gcMARK(m->provide_nominal_srcs);
gcMARK(m->provide_src_phases); gcMARK(m->provide_src_phases);
gcMARK(m->kernel_exclusion); gcMARK(m->kernel_exclusion);
@ -2440,6 +2441,7 @@ static int module_phase_exports_val_FIXUP(void *p) {
gcFIXUP(m->provides); gcFIXUP(m->provides);
gcFIXUP(m->provide_srcs); gcFIXUP(m->provide_srcs);
gcFIXUP(m->provide_src_names); gcFIXUP(m->provide_src_names);
gcFIXUP(m->provide_nominal_srcs);
gcFIXUP(m->provide_src_phases); gcFIXUP(m->provide_src_phases);
gcFIXUP(m->kernel_exclusion); gcFIXUP(m->kernel_exclusion);

1
src/mzscheme/src/mzmarksrc.c
View File

@ -966,6 +966,7 @@ module_phase_exports_val {
gcMARK(m->provides); gcMARK(m->provides);
gcMARK(m->provide_srcs); gcMARK(m->provide_srcs);
gcMARK(m->provide_src_names); gcMARK(m->provide_src_names);
gcMARK(m->provide_nominal_srcs);
gcMARK(m->provide_src_phases); gcMARK(m->provide_src_phases);
gcMARK(m->kernel_exclusion); gcMARK(m->kernel_exclusion);

10
src/mzscheme/src/schpriv.h
View File

@ -662,9 +662,10 @@ Scheme_Object *scheme_make_module_rename(long phase, int kind, Scheme_Hash_Table
void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname, void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname,
Scheme_Object *locname, Scheme_Object *exname, Scheme_Object *locname, Scheme_Object *exname,
Scheme_Object *nominal_src, Scheme_Object *nominal_ex, Scheme_Object *nominal_src, Scheme_Object *nominal_ex,
int mod_phase, int drop_for_marshal); int mod_phase, int src_phase_index, int drop_for_marshal);
void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx,
struct Scheme_Module_Phase_Exports *pt, int k, struct Scheme_Module_Phase_Exports *pt, int k,
int src_phase_index,
int save_unmarshal); int save_unmarshal);
void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src); void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src);
void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info); void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info);
@ -689,7 +690,7 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase);
Scheme_Object *scheme_stx_module_name(Scheme_Object **name, long phase, Scheme_Object *scheme_stx_module_name(Scheme_Object **name, long phase,
Scheme_Object **nominal_modidx, Scheme_Object **nominal_modidx,
Scheme_Object **nominal_name, Scheme_Object **nominal_name,
int *mod_phase); int *mod_phase, int *src_phase_index);
Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a, long phase); Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a, long phase);
int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx);
@ -748,6 +749,8 @@ int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *certs,
Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i); Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i);
XFORM_NONGCING Scheme_Object *scheme_phase_index_symbol(int src_phase_index);
Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht); Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht);
/*========================================================================*/ /*========================================================================*/
@ -2408,11 +2411,14 @@ typedef struct Scheme_Module_Phase_Exports
{ {
MZTAG_IF_REQUIRED MZTAG_IF_REQUIRED
int phase_index;
Scheme_Object *src_modidx; /* same as in enclosing Scheme_Module_Exports */ Scheme_Object *src_modidx; /* same as in enclosing Scheme_Module_Exports */
Scheme_Object **provides; /* symbols (extenal names) */ Scheme_Object **provides; /* symbols (extenal names) */
Scheme_Object **provide_srcs; /* module access paths, #f for self */ Scheme_Object **provide_srcs; /* module access paths, #f for self */
Scheme_Object **provide_src_names; /* symbols (original internal names) */ Scheme_Object **provide_src_names; /* symbols (original internal names) */
Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */
char *provide_src_phases; /* NULL, or src phase for for-syntax import */ char *provide_src_phases; /* NULL, or src phase for for-syntax import */
int num_provides; int num_provides;
int num_var_provides; /* non-syntax listed first in provides */ int num_var_provides; /* non-syntax listed first in provides */

4
src/mzscheme/src/schvers.h
View File

@ -10,12 +10,12 @@
The string and the separate X/Y/Z/W numbers must The string and the separate X/Y/Z/W numbers must
be updated consistently. */ be updated consistently. */
#define MZSCHEME_VERSION "3.99.0.8" #define MZSCHEME_VERSION "3.99.0.9"
#define MZSCHEME_VERSION_X 3 #define MZSCHEME_VERSION_X 3
#define MZSCHEME_VERSION_Y 99 #define MZSCHEME_VERSION_Y 99
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 8 #define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

201
src/mzscheme/src/stxobj.c
View File

@ -121,10 +121,11 @@ typedef struct Module_Renames {
Scheme_Hash_Table *ht; /* localname -> modidx OR Scheme_Hash_Table *ht; /* localname -> modidx OR
(cons modidx exportname) OR (cons modidx exportname) OR
(cons modidx nominal_modidx) OR (cons modidx nominal_modidx) OR
(list* modidx exportname nominal_modidx nominal_exportname) OR (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR
(list* modidx mod-phase exportname nominal_modidx nominal_exportname) */ (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname)
nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix phase-index-int) */
Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */ Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */
Scheme_Object *shared_pes; /* list of (cons modidx phase_export) like nomarshal ht, but shared from provider */ Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase-index-int)) like nomarshal ht, but shared from provider */
Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module; Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module;
this table maps a top-level-bound identifier with a non-empty mark this table maps a top-level-bound identifier with a non-empty mark
set to a gensym created for the binding */ set to a gensym created for the binding */
@ -1065,6 +1066,16 @@ void scheme_extend_module_rename_with_kernel(Scheme_Object *mrn, Scheme_Object *
((Module_Renames *)mrn)->plus_kernel_nominal_source = nominal_mod; ((Module_Renames *)mrn)->plus_kernel_nominal_source = nominal_mod;
} }
static int phase_to_index(int phase)
{
if (phase == MZ_LABEL_PHASE)
return 2;
else if (phase == -1)
return 3;
else
return phase;
}
void scheme_extend_module_rename(Scheme_Object *mrn, void scheme_extend_module_rename(Scheme_Object *mrn,
Scheme_Object *modname, /* actual source module */ Scheme_Object *modname, /* actual source module */
Scheme_Object *localname, /* name in local context */ Scheme_Object *localname, /* name in local context */
@ -1072,20 +1083,28 @@ void scheme_extend_module_rename(Scheme_Object *mrn,
Scheme_Object *nominal_mod, /* nominal source module */ Scheme_Object *nominal_mod, /* nominal source module */
Scheme_Object *nominal_ex, /* nominal import before local renaming */ Scheme_Object *nominal_ex, /* nominal import before local renaming */
int mod_phase, /* phase of source defn */ int mod_phase, /* phase of source defn */
int src_phase_index, /* nominal import phase */
int unmarshal_drop) /* 1 => can be reconstructed from unmarshal info */ int unmarshal_drop) /* 1 => can be reconstructed from unmarshal info */
{ {
Scheme_Object *elem; Scheme_Object *elem;
int phase_index;
phase_index = phase_to_index(((Module_Renames *)mrn)->phase);
if (src_phase_index < 0)
src_phase_index = phase_index;
if (SAME_OBJ(modname, nominal_mod) if (SAME_OBJ(modname, nominal_mod)
&& SAME_OBJ(exname, nominal_ex) && SAME_OBJ(exname, nominal_ex)
&& !mod_phase) { && !mod_phase
&& src_phase_index == phase_index) {
if (SAME_OBJ(localname, exname)) if (SAME_OBJ(localname, exname))
elem = modname; elem = modname;
else else
elem = CONS(modname, exname); elem = CONS(modname, exname);
} else if (SAME_OBJ(exname, nominal_ex) } else if (SAME_OBJ(exname, nominal_ex)
&& SAME_OBJ(localname, exname) && SAME_OBJ(localname, exname)
&& !mod_phase) { && !mod_phase
&& src_phase_index == phase_index) {
/* It's common that a sequence of similar mappings shows up, /* It's common that a sequence of similar mappings shows up,
e.g., '(#%kernel . mzscheme) */ e.g., '(#%kernel . mzscheme) */
if (nominal_ipair_cache if (nominal_ipair_cache
@ -1097,7 +1116,11 @@ void scheme_extend_module_rename(Scheme_Object *mrn,
nominal_ipair_cache = elem; nominal_ipair_cache = elem;
} }
} else { } else {
elem = CONS(exname, CONS(nominal_mod, nominal_ex)); if (src_phase_index == phase_index)
elem = nominal_mod;
else
elem = CONS(nominal_mod, scheme_make_integer(src_phase_index));
elem = CONS(exname, CONS(elem, nominal_ex));
if (mod_phase) if (mod_phase)
elem = CONS(scheme_make_integer(mod_phase), elem); elem = CONS(scheme_make_integer(mod_phase), elem);
elem = CONS(modname, elem); elem = CONS(modname, elem);
@ -1116,17 +1139,21 @@ void scheme_extend_module_rename(Scheme_Object *mrn,
void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx,
Scheme_Module_Phase_Exports *pt, int k, Scheme_Module_Phase_Exports *pt, int k,
int src_phase_index,
int save_unmarshal) int save_unmarshal)
{ {
Module_Renames *mrn = (Module_Renames *)rn; Module_Renames *mrn = (Module_Renames *)rn;
Scheme_Object *pr; Scheme_Object *pr;
pr = scheme_make_pair(scheme_make_pair(modidx, (Scheme_Object *)pt), pr = scheme_make_pair(scheme_make_pair(modidx,
scheme_make_pair((Scheme_Object *)pt,
scheme_make_integer(src_phase_index))),
mrn->shared_pes); mrn->shared_pes);
mrn->shared_pes = pr; mrn->shared_pes = pr;
if (save_unmarshal) { if (save_unmarshal) {
pr = scheme_make_pair(scheme_make_pair(modidx, scheme_make_integer(k)), pr = scheme_make_pair(scheme_make_pair(modidx, scheme_make_pair(scheme_make_integer(k),
scheme_make_integer(src_phase_index))),
mrn->unmarshal_info); mrn->unmarshal_info);
mrn->unmarshal_info = pr; mrn->unmarshal_info = pr;
} }
@ -1195,7 +1222,7 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
/* Shift the modidx part */ /* Shift the modidx part */
if (SCHEME_PAIRP(v)) { if (SCHEME_PAIRP(v)) {
if (SCHEME_PAIRP(SCHEME_CDR(v))) { if (SCHEME_PAIRP(SCHEME_CDR(v))) {
/* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) */ /* (list* modidx [mod-phase] exportname nominal_modidx+index nominal_exportname) */
Scheme_Object *midx1, *midx2; Scheme_Object *midx1, *midx2;
int mod_phase; int mod_phase;
midx1 = SCHEME_CAR(v); midx1 = SCHEME_CAR(v);
@ -1207,7 +1234,12 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
mod_phase = 0; mod_phase = 0;
midx2 = SCHEME_CAR(SCHEME_CDR(v)); midx2 = SCHEME_CAR(SCHEME_CDR(v));
midx1 = scheme_modidx_shift(midx1, old_midx, new_midx); midx1 = scheme_modidx_shift(midx1, old_midx, new_midx);
if (SCHEME_PAIRP(midx2)) {
midx2 = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(midx2), old_midx, new_midx),
SCHEME_CDR(midx2));
} else {
midx2 = scheme_modidx_shift(midx2, old_midx, new_midx); midx2 = scheme_modidx_shift(midx2, old_midx, new_midx);
}
v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v)))); v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v))));
if (mod_phase) if (mod_phase)
v = CONS(scheme_make_integer(mod_phase), v); v = CONS(scheme_make_integer(mod_phase), v);
@ -1278,7 +1310,7 @@ void scheme_list_module_rename(Scheme_Object *src, Scheme_Hash_Table *ht)
} }
for (pr = ((Module_Renames *)src)->shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { for (pr = ((Module_Renames *)src)->shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
pt = (Scheme_Module_Phase_Exports *)SCHEME_CDR(SCHEME_CAR(pr)); pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr));
for (i = pt->num_provides; i--; ) { for (i = pt->num_provides; i--; ) {
scheme_hash_set(ht, pt->provides[i], scheme_false); scheme_hash_set(ht, pt->provides[i], scheme_false);
} }
@ -2686,7 +2718,7 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme
int i, phase; int i, phase;
for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
pt = (Scheme_Module_Phase_Exports *)SCHEME_CDR(SCHEME_CAR(pr)); pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr));
if (!pt->ht) { if (!pt->ht) {
/* Lookup table (which is created lazily) not yet created, so do that now... */ /* Lookup table (which is created lazily) not yet created, so do that now... */
@ -2715,8 +2747,8 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme
if (get_names) { if (get_names) {
/* If module bound, result is module idx, and get_names[0] is set to source name, /* If module bound, result is module idx, and get_names[0] is set to source name,
get_names[1] is set to the nominal source module, get_names[2] is set to get_names[1] is set to the nominal source module, get_names[2] is set to
the nominal source module's export, and get_names[3] is set to the phase of the nominal source module's export, get_names[3] is set to the phase of
the source definition */ the source definition, and get_names[4] is set to the nominal phase index */
if (pt->provide_src_phases) if (pt->provide_src_phases)
phase = pt->provide_src_phases[i]; phase = pt->provide_src_phases[i];
@ -2727,6 +2759,7 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme
get_names[1] = idx; get_names[1] = idx;
get_names[2] = glob_id; get_names[2] = glob_id;
get_names[3] = scheme_make_integer(phase); get_names[3] = scheme_make_integer(phase);
get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr)));
} }
if (SCHEME_FALSEP(src)) { if (SCHEME_FALSEP(src)) {
@ -2749,6 +2782,7 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme
get_names[1] = idx; get_names[1] = idx;
get_names[2] = glob_id; get_names[2] = glob_id;
get_names[3] = scheme_make_integer(0); get_names[3] = scheme_make_integer(0);
get_names[4] = scheme_make_integer(pt->phase_index);
} }
return scheme_get_kernel_modidx(); return scheme_get_kernel_modidx();
} }
@ -2779,8 +2813,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
/* Module binding ignored if w_mod is 0. /* Module binding ignored if w_mod is 0.
If module bound, result is module idx, and get_names[0] is set to source name, If module bound, result is module idx, and get_names[0] is set to source name,
get_names[1] is set to the nominal source module, get_names[2] is set to get_names[1] is set to the nominal source module, get_names[2] is set to
the nominal source module's export, and get_names[3] is set to the phase of the nominal source module's export, get_names[3] is set to the phase of
the source definition the source definition, and get_names[4] is set to the nominal phase index.
If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined. If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined.
If neither, result is #f and get_names[0] is either unchanged or NULL. */ If neither, result is #f and get_names[0] is either unchanged or NULL. */
{ {
@ -2914,7 +2948,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
modidx_shift_from, modidx_shift_from,
modidx_shift_to); modidx_shift_to);
if (get_names && !get_names_done) { if (get_names) {
int no_shift = 0;
if (!get_names_done) {
if (SCHEME_PAIRP(rename)) { if (SCHEME_PAIRP(rename)) {
if (nom_mod_p(rename)) { if (nom_mod_p(rename)) {
/* (cons modidx nominal_modidx) case */ /* (cons modidx nominal_modidx) case */
@ -2931,6 +2968,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} }
get_names[0] = SCHEME_CAR(rename); get_names[0] = SCHEME_CAR(rename);
get_names[1] = SCHEME_CADR(rename); get_names[1] = SCHEME_CADR(rename);
if (SCHEME_PAIRP(get_names[1])) {
get_names[4] = SCHEME_CDR(get_names[1]);
get_names[1] = SCHEME_CAR(get_names[1]);
}
get_names[2] = SCHEME_CDDR(rename); get_names[2] = SCHEME_CDDR(rename);
} else { } else {
/* (cons modidx exportname) case */ /* (cons modidx exportname) case */
@ -2947,10 +2988,27 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
get_names[2] = get_names[0]; get_names[2] = get_names[0];
if (nominal) if (nominal)
get_names[1] = nominal; get_names[1] = nominal;
else else {
no_shift = 1;
get_names[1] = mresult; get_names[1] = mresult;
} }
} }
if (!get_names[4]) {
GC_CAN_IGNORE Scheme_Object *pi;
pi = scheme_make_integer(phase_to_index(mrn->phase));
get_names[4] = pi;
}
}
if (modidx_shift_from && !no_shift) {
Scheme_Object *nom;
nom = get_names[1];
nom = scheme_modidx_shift(nom,
modidx_shift_from,
modidx_shift_to);
get_names[1] = nom;
}
}
} else { } else {
mresult = scheme_false; mresult = scheme_false;
if (get_names) if (get_names)
@ -3264,16 +3322,17 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase)
Scheme_Object *scheme_stx_module_name(Scheme_Object **a, long phase, Scheme_Object *scheme_stx_module_name(Scheme_Object **a, long phase,
Scheme_Object **nominal_modidx, Scheme_Object **nominal_modidx,
Scheme_Object **nominal_name, Scheme_Object **nominal_name,
int *mod_phase) int *mod_phase, int *src_phase_index)
/* If module bound, result is module idx, and a is set to source name. /* If module bound, result is module idx, and a is set to source name.
If lexically bound, result is scheme_undefined and a is unchanged. If lexically bound, result is scheme_undefined and a is unchanged.
If neither, result is NULL and a is unchanged. */ If neither, result is NULL and a is unchanged. */
{ {
if (SCHEME_STXP(*a)) { if (SCHEME_STXP(*a)) {
Scheme_Object *modname, *names[4]; Scheme_Object *modname, *names[5];
names[0] = NULL; names[0] = NULL;
names[3] = scheme_make_integer(0); names[3] = scheme_make_integer(0);
names[4] = NULL;
modname = resolve_env(NULL, *a, phase, 1, names, NULL); modname = resolve_env(NULL, *a, phase, 1, names, NULL);
@ -3288,6 +3347,8 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, long phase,
*nominal_name = names[2]; *nominal_name = names[2];
if (mod_phase) if (mod_phase)
*mod_phase = SCHEME_INT_VAL(names[3]); *mod_phase = SCHEME_INT_VAL(names[3]);
if (src_phase_index)
*src_phase_index = SCHEME_INT_VAL(names[4]);
return modname; return modname;
} }
} else } else
@ -4135,7 +4196,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
if (!local_key) { if (!local_key) {
/* Convert hash table to vector: */ /* Convert hash table to vector: */
int i, j, count = 0; int i, j, count = 0;
Scheme_Object *l, *idi; Scheme_Object *l;
count = mrn->ht->count; count = mrn->ht->count;
@ -4144,21 +4205,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
for (i = mrn->ht->size, j = 0; i--; ) { for (i = mrn->ht->size, j = 0; i--; ) {
if (mrn->ht->vals[i]) { if (mrn->ht->vals[i]) {
SCHEME_VEC_ELS(l)[j++] = mrn->ht->keys[i]; SCHEME_VEC_ELS(l)[j++] = mrn->ht->keys[i];
idi = mrn->ht->vals[i]; SCHEME_VEC_ELS(l)[j++] = mrn->ht->vals[i];
/* Drop info on nominals, if any: */
if (SCHEME_PAIRP(idi)) {
if (nom_mod_p(idi))
idi = SCHEME_CAR(idi);
else if (SCHEME_PAIRP(SCHEME_CDR(idi))) {
if (SCHEME_INTP(SCHEME_CADR(idi))) {
idi = CONS(SCHEME_CAR(idi),
CONS(SCHEME_CADR(idi),
SCHEME_CADR(SCHEME_CDR(idi))));
} else
idi = CONS(SCHEME_CAR(idi), SCHEME_CADR(idi));
}
}
SCHEME_VEC_ELS(l)[j++] = idi;
} }
} }
@ -4184,7 +4231,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
l = CONS(scheme_make_integer(mrn->phase), l); l = CONS(scheme_make_integer(mrn->phase), l);
if (mrn->plus_kernel) { if (mrn->plus_kernel) {
l = CONS(scheme_true,l); l = CONS(scheme_true,l);
/* note: information on nominals intentially omitted */ /* FIXME: plus-kernel nominal omitted */
} }
local_key = scheme_marshal_lookup(mt, a); local_key = scheme_marshal_lookup(mt, a);
@ -4773,7 +4820,6 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL); mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL);
mrn->plus_kernel = plus_kernel; mrn->plus_kernel = plus_kernel;
/* note: information on nominals has been dropped */
if (!SCHEME_PAIRP(a)) return_NULL; if (!SCHEME_PAIRP(a)) return_NULL;
mns = SCHEME_CDR(a); mns = SCHEME_CDR(a);
@ -4793,19 +4839,32 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
return_NULL; return_NULL;
mli = SCHEME_CDR(mli); mli = SCHEME_CDR(mli);
if (SCHEME_INTP(mli)) {
/* For a shared table */
} else {
if (!SCHEME_PAIRP(mli)) return_NULL; if (!SCHEME_PAIRP(mli)) return_NULL;
/* A phase/dimension index (temporarily optional) */ /* A phase/dimension index */
p = SCHEME_CAR(mli); p = SCHEME_CAR(mli);
if ((SCHEME_INT_VAL(p) < 0) if ((SCHEME_INT_VAL(p) < 0)
|| (SCHEME_INT_VAL(p) > 2)) || (SCHEME_INT_VAL(p) > 2))
return_NULL; return_NULL;
mli = SCHEME_CDR(mli);
p = SCHEME_CDR(mli);
if (SCHEME_INTP(p)) {
/* For a shared table: (cons k src-phase-index) */
if ((SCHEME_INT_VAL(p) < 0)
|| (SCHEME_INT_VAL(p) > 3))
return_NULL;
} else {
mli = p;
if (!SCHEME_PAIRP(mli)) return_NULL; if (!SCHEME_PAIRP(mli)) return_NULL;
/* For a shared table: (cons k src-phase-index) */
p = SCHEME_CAR(mli);
if (!SCHEME_INTP(p)
|| (SCHEME_INT_VAL(p) < 0)
|| (SCHEME_INT_VAL(p) > 3))
return_NULL;
mli = SCHEME_CDR(mli);
/* A list of symbols: */ /* A list of symbols: */
p = SCHEME_CAR(mli); p = SCHEME_CAR(mli);
while (SCHEME_PAIRP(p)) { while (SCHEME_PAIRP(p)) {
@ -4842,29 +4901,59 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
if (!SCHEME_SYMBOLP(key)) return_NULL; if (!SCHEME_SYMBOLP(key)) return_NULL;
if (SCHEME_SYMBOLP(p) if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) {
|| SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) {
/* Ok */ /* Ok */
} else if (SCHEME_PAIRP(p)) { } else if (SCHEME_PAIRP(p)) {
Scheme_Object *midx; Scheme_Object *midx;
midx = SCHEME_CAR(p); midx = SCHEME_CAR(p);
if (!SCHEME_SYMBOLP(midx) if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type))
&& !SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type))
return_NULL; return_NULL;
if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { if (SCHEME_SYMBOLP(SCHEME_CDR(p))) {
/* Ok */ /* Ok */
} else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) {
/* Ok */
} else { } else {
if (!SCHEME_PAIRP(SCHEME_CDR(p))) Scheme_Object *ap, *bp;
ap = SCHEME_CDR(p);
if (!SCHEME_PAIRP(ap))
return_NULL; return_NULL;
if (!SCHEME_INTP(SCHEME_CADR(p)))
/* mod-phase, maybe */
if (SCHEME_INTP(SCHEME_CAR(ap))) {
bp = SCHEME_CDR(ap);
} else
bp = ap;
/* exportname */
if (!SCHEME_PAIRP(bp))
return_NULL; return_NULL;
if (!SCHEME_SYMBOLP(SCHEME_CDDR(p))) ap = SCHEME_CAR(bp);
if (!SCHEME_SYMBOLP(ap))
return_NULL;
/* nominal_modidx_plus_phase */
bp = SCHEME_CDR(bp);
if (!SCHEME_PAIRP(bp))
return_NULL;
ap = SCHEME_CAR(bp);
if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) {
/* Ok */
} else if (SCHEME_PAIRP(ap)) {
if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type))
return_NULL;
ap = SCHEME_CDR(ap);
if ((SCHEME_INT_VAL(ap) < 0) || (SCHEME_INT_VAL(ap) > 3))
return_NULL;
} else
return_NULL;
/* nominal_exportname */
ap = SCHEME_CDR(bp);
if (!SCHEME_SYMBOLP(ap))
return_NULL; return_NULL;
p = CONS(midx, CONS(SCHEME_CADR(p),
CONS(SCHEME_CDDR(p),
CONS(midx, SCHEME_CDDR(p)))));
} }
} else } else
return_NULL; return_NULL;
@ -5984,7 +6073,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
Scheme_Object *a, *m, *nom_mod, *nom_a; Scheme_Object *a, *m, *nom_mod, *nom_a;
int mod_phase; int mod_phase, src_phase_index;
a = argv[0]; a = argv[0];
@ -5998,7 +6087,8 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
? p->current_local_env->genv->phase ? p->current_local_env->genv->phase
: p->current_phase_shift))), : p->current_phase_shift))),
&nom_mod, &nom_a, &nom_mod, &nom_a,
&mod_phase); &mod_phase,
&src_phase_index);
if (!m) if (!m)
return scheme_false; return scheme_false;
@ -6008,7 +6098,8 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
return CONS(m, CONS(a, CONS(nom_mod, return CONS(m, CONS(a, CONS(nom_mod,
CONS(nom_a, CONS(nom_a,
CONS(mod_phase ? scheme_true : scheme_false, CONS(mod_phase ? scheme_true : scheme_false,
scheme_null))))); CONS(scheme_phase_index_symbol(src_phase_index),
scheme_null))))));
} }
static Scheme_Object *module_binding(int argc, Scheme_Object **argv) static Scheme_Object *module_binding(int argc, Scheme_Object **argv)