diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 1a43ab876d..cb1d30913d 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -2380,9 +2380,7 @@ If the namespace does not, they are colored the unbound color. (syntax-span stx)) (let* ([start (- (syntax-position stx) 1)] [fin (+ start (syntax-span stx))] - [source-mod (list-ref binding-info 0)] - [source-id (list-ref binding-info 1)] - [definition-tag (xref-binding->definition-tag (get-xref) source-mod source-id)]) + [definition-tag (xref-binding->definition-tag (get-xref) binding-info #f)]) (when definition-tag (let-values ([(path tag) (xref-tag->path+anchor (get-xref) definition-tag)]) (when path diff --git a/collects/games/cards/doc.scrbl b/collects/games/cards/doc.scrbl index 196e872d1e..69c88176f8 100644 --- a/collects/games/cards/doc.scrbl +++ b/collects/games/cards/doc.scrbl @@ -1,12 +1,12 @@ #lang scribble/doc @require[scribble/manual - (for-label "cards.ss" - mred)] + (for-label "main.ss" + scheme/gui/base)] @title{Virtual Playing Cards Library} -@defmodule[games/cards]{The @scheme[games/cards] module provides a -toolbox for creating cards games.} +@defmodule[games/cards/main]{The @schememodname[games/cards/main] +module provides a toolbox for creating cards games.} @; ---------------------------------------------------------------------- @section{Creating Tables and Cards} diff --git a/collects/lang/htdp-intermediate-lambda.ss b/collects/lang/htdp-intermediate-lambda.ss index 5d80ca9202..00bf0a9a07 100644 --- a/collects/lang/htdp-intermediate-lambda.ss +++ b/collects/lang/htdp-intermediate-lambda.ss @@ -45,4 +45,4 @@ ;; procedures: (provide-and-document procedures - (all-from beginner: lang/htdp-intermediate procedures))) + (all-from intermediate: lang/htdp-intermediate procedures))) diff --git a/collects/lang/private/advanced-funs.ss b/collects/lang/private/advanced-funs.ss index fda99c5d42..dc11dcd73f 100644 --- a/collects/lang/private/advanced-funs.ss +++ b/collects/lang/private/advanced-funs.ss @@ -8,14 +8,8 @@ "../posn.ss" (for-syntax scheme/base)) - (define-syntax (freshen-export stx) - (syntax-case stx () - [(_ new-name orig-name) - #'(define-syntax new-name (make-rename-transformer #'orig-name))])) - - (provide-and-document/wrap + (provide-and-document procedures - freshen-export ("Reading and Printing" (print (any -> void) diff --git a/collects/lang/private/intermediate-funs.ss b/collects/lang/private/intermediate-funs.ss index 58df768bf8..c2cfd0f135 100644 --- a/collects/lang/private/intermediate-funs.ss +++ b/collects/lang/private/intermediate-funs.ss @@ -5,14 +5,8 @@ syntax/docprovide (for-syntax scheme/base)) - (define-syntax (freshen-export stx) - (syntax-case stx () - [(_ new-name orig-name) - #'(define-syntax new-name (make-rename-transformer #'orig-name))])) - - (provide-and-document/wrap + (provide-and-document procedures - freshen-export (all-from beginner: lang/private/beginner-funs procedures) ("Higher-Order Functions" diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss index d8345684f3..6959f808c7 100644 --- a/collects/lang/private/teach.ss +++ b/collects/lang/private/teach.ss @@ -1889,7 +1889,7 @@ ;; new syntax object that is an `intermediate-define' form; ;; that's important for syntax errors, so that they ;; report `advanced-define' as the source. - (define/proc #f #t stx)] + (define/proc #f #t stx #'beginner-lambda)] [_else (bad-use-error 'define stx)])) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index b336ee4c72..2a62af4e31 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -57,10 +57,10 @@ ...))]))))]))))) (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!) 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 _fixint _ufixint _fixnum _ufixnum _float _double _double* @@ -138,8 +138,8 @@ (define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1))) (define lib-suffix-re (regexp (string-append "\\." lib-suffix "$"))) -(provide (rename-out [get-ffi-lib ffi-lib]) - ffi-lib? ffi-lib-name) +(provide* (unsafe (rename-out [get-ffi-lib ffi-lib])) + ffi-lib? ffi-lib-name) (define get-ffi-lib (case-lambda [(name) (get-ffi-lib name "")] @@ -204,7 +204,7 @@ (ptr-set! ffi-obj type new))) ;; This is better handled with `make-c-parameter' -(provide* ffi-obj-ref) +(provide* (unsafe ffi-obj-ref)) (define ffi-obj-ref (case-lambda [(name lib) (ffi-obj-ref name lib #f)] @@ -1559,7 +1559,8 @@ (define killer-executor (make-will-executor)) (define killer-thread #f) -(define* (register-finalizer obj finalizer) +(provide* (unsafe register-finalizer)) +(define (register-finalizer obj finalizer) (unless killer-thread (set! killer-thread (thread (lambda () (let loop () (will-execute killer-executor) (loop)))))) (will-register killer-executor obj finalizer)) diff --git a/collects/net/doc/smtp.scrbl b/collects/net/doc/smtp.scrbl index 43f523b97c..6307155d13 100644 --- a/collects/net/doc/smtp.scrbl +++ b/collects/net/doc/smtp.scrbl @@ -106,7 +106,7 @@ probably will not).} @section{SMTP Unit} -@defmodule[net/SMTP-unit] +@defmodule[net/smtp-unit] @defthing[smtp@ unit?]{ diff --git a/collects/net/doc/url.scrbl b/collects/net/doc/url.scrbl index f806a6a09a..2193515fba 100644 --- a/collects/net/doc/url.scrbl +++ b/collects/net/doc/url.scrbl @@ -27,10 +27,10 @@ library. @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 -provided by the @schememodname[net/url-struct] library, and +@defmodule*/no-declare[(net/url-structs)]{The URL structure types are +provided by the @schememodname[net/url-structs] library, and re-exported by @schememodname[net/url].} @; ---------------------------------------- @@ -43,7 +43,7 @@ re-exported by @schememodname[net/url].} [path-absolute? boolean?] [path (listof path/param?)] [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 @cite["RFC3986"]. The following diagram illustrates the parts: diff --git a/collects/scheme/gui.ss b/collects/scheme/gui.ss index b6f7897813..380e2bdd77 100644 --- a/collects/scheme/gui.ss +++ b/collects/scheme/gui.ss @@ -1,4 +1,4 @@ (module gui scheme - (require mred) + (require scheme/gui/base) (provide (all-from-out scheme) - (all-from-out mred))) + (all-from-out scheme/gui/base))) diff --git a/collects/scheme/help.ss b/collects/scheme/help.ss index 15c1803646..4cc8681872 100644 --- a/collects/scheme/help.ss +++ b/collects/scheme/help.ss @@ -65,22 +65,22 @@ lib)))) (define (find-help id) - (let ([b (or (identifier-label-binding id) - (identifier-binding id))] - [xref (load-collections-xref - (lambda () - (printf "Loading help index...\n")))]) - (if b + (let* ([lb (identifier-label-binding id)] + [b (and (not lb) (identifier-binding id))] + [xref (load-collections-xref + (lambda () + (printf "Loading help index...\n")))]) + (if (or lb b) (let ([tag (xref-binding->definition-tag xref - (car b) - (cadr b))]) + (or lb b) + (if lb 'for-label #f))]) (if tag (go-to-tag xref tag) (error 'help "no documentation found for: ~e provided by: ~a" (syntax-e id) - (module-path-index-resolve (car b))))) + (module-path-index-resolve (caddr b))))) (search-for-exports xref (syntax-e id))))) (define (search-for-exports xref sym) diff --git a/collects/scheme/private/serialize.ss b/collects/scheme/private/serialize.ss index 26582ea018..ee49cbf38f 100644 --- a/collects/scheme/private/serialize.ss +++ b/collects/scheme/private/serialize.ss @@ -38,7 +38,8 @@ (box? v) (void? v) (date? v) - (arity-at-least? v))) + (arity-at-least? v) + (module-path-index? v))) ;; If a module is dynamic-required through a path, ;; then it can cause simplified module paths to be paths; @@ -192,6 +193,10 @@ (loop v)))] [(arity-at-least? 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 'serialize "serializable object" @@ -262,6 +267,11 @@ [(arity-at-least? v) (cons 'arity-at-least ((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")])) ((serial check-share?) v)) @@ -389,6 +399,8 @@ (apply make-immutable-hash-table al (caddr v))))] [(date) (apply make-date (map 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")])]))) (define (deserial-shell v mod-map fixup n) @@ -442,7 +454,9 @@ [(date) (error 'deserialize "cannot restore date in cycle")] [(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) (let-values ([(vers l) diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 86951b1261..c7b4468071 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -4,7 +4,8 @@ mzlib/class mzlib/serialize scheme/file - scheme/path) + scheme/path + setup/main-collects) (provide render%) @@ -74,7 +75,9 @@ (make-hash-table 'equal) (make-hash-table) (make-hash-table) - "")]) + "" + (make-hash-table) + null)]) (start-collect ds fns ci) ci)) @@ -92,7 +95,9 @@ (string-append (collect-info-gen-prefix ci) (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) (collect-content (part-title-content d) p-ci)) (collect-part-tags d p-ci number) @@ -184,16 +189,28 @@ (blockquote-paragraphs i))) (define/public (collect-element i ci) - (when (target-element? i) - (collect-target-element i ci)) - (when (index-element? i) - (collect-index-element i ci)) - (when (collect-element? i) - ((collect-element-collect i) ci)) - (when (element? i) - (for-each (lambda (e) - (collect-element e ci)) - (element-content i)))) + (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) + (collect-target-element i ci)) + (when (index-element? i) + (collect-index-element i ci)) + (when (collect-element? i) + ((collect-element-collect i) ci)) + (when (element? i) + (for-each (lambda (e) + (collect-element e ci)) + (element-content i)))))) (define/public (collect-target-element i ci) (collect-put! ci @@ -213,6 +230,7 @@ (define/public (resolve ds fns ci) (let ([ri (make-resolve-info ci (make-hash-table) + (make-hash-table 'equal) (make-hash-table 'equal))]) (start-resolve ds fns ri) ri)) @@ -269,6 +287,8 @@ (define/public (resolve-element i d ri) (cond + [(part-relative-element? i) + (resolve-content (part-relative-element-content i ri) d ri)] [(delayed-element? i) (resolve-content (or (hash-table-get (resolve-info-delays ri) i @@ -372,6 +392,8 @@ (render-content (element-content i) part ri)] [(delayed-element? i) (render-content (delayed-element-content i ri) part ri)] + [(part-relative-element? i) + (render-content (part-relative-element-content i ri) part ri)] [else (render-other i part ri)])) diff --git a/collects/scribble/basic.ss b/collects/scribble/basic.ss index 82faf9ba1a..ef6fcbbb15 100644 --- a/collects/scribble/basic.ss +++ b/collects/scribble/basic.ss @@ -47,20 +47,20 @@ style 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)]) (make-part-start 1 (prefix->string prefix) (convert-tag tag content) - #f + style 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)]) (make-part-start 2 (prefix->string prefix) (convert-tag tag content) - #f + style content))) (define (subsubsub*section #:tag [tag #f] . str) diff --git a/collects/scribble/decode.ss b/collects/scribble/decode.ss index d62a12ac31..53989fb19e 100644 --- a/collects/scribble/decode.ss +++ b/collects/scribble/decode.ss @@ -27,7 +27,8 @@ [splice ([run list?])] [part-index-decl ([plain-seq (listof string?)] [entry-seq list?])] - [part-collect-decl ([element element?])] + [part-collect-decl ([element (or/c element? + part-relative-element?)])] [part-tag-decl ([tag tag?])]) (define (decode-string s) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 1e4c82d341..d5596700fe 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -251,8 +251,11 @@ (append (loop (element-content a)) (loop (cdr c)))] [(delayed-element? a) - (loop (cons (delayed-element-content a ri) - (cdr c)))] + (loop (append (delayed-element-content a ri) + (cdr c)))] + [(part-relative-element? a) + (loop (append (part-relative-element-content a ri) + (cdr c)))] [else (loop (cdr c))]))])))] [table-targets diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index a014bc0927..94efd8ba0e 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -3,6 +3,7 @@ (require "decode.ss" "struct.ss" "scheme.ss" + "search.ss" "config.ss" "basic.ss" "manual-struct.ss" @@ -10,6 +11,7 @@ scheme/class scheme/stxparam mzlib/serialize + setup/main-collects (for-syntax scheme/base) (for-label scheme/base 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?) (let ([sig (current-signature)]) (if sig - (make-link-element (if form? - "schemesyntaxlink" - "schemevaluelink") - (list (schemefont (symbol->string name))) - `(,(if form? 'sig-form 'sig-val) - ,(format "~a::~a" (sig-tagstr sig) name))) + (*sig-elem (sig-id sig) name) (annote-exporting-library (to-element (make-just-context name stx-id)))))) - (define (id-to-tag id) - (add-signature-tag id #f)) + (define (libs->str libs) + (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) - (add-signature-tag id #t)) + (define (id-to-target-maker id dep?) + (*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)]) - (if sig - `(,(if form? 'sig-form 'sig-val) - ,(format "~a::~a" (sig-tagstr sig) (syntax-e id))) - (if form? - (register-scheme-form-definition id) - (register-scheme-definition id #t))))) + (lambda (content mk) + (make-part-relative-element + (lambda (ci) + (let ([e (ormap (lambda (p) + (ormap (lambda (e) + (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)) @@ -344,21 +386,25 @@ (*sig-elem (quote-syntax sig) 'elem)) (define (*sig-elem sig elem) - (let ([s (to-element elem)] - [tag (format "~a::~a" - (register-scheme-form-definition sig #t) - elem)]) + (let ([s (to-element/no-color elem)]) (make-delayed-element (lambda (renderer sec ri) - (let* ([vtag `(sig-val ,tag)] - [stag `(sig-form ,tag)] - [sd (resolve-get/tentative sec ri stag)]) + (let* ([tag (find-scheme-tag sec ri sig 'for-label)] + [str (and tag (format "~a::~a" (cadr tag) elem))] + [vtag (and tag `(sig-val ,str))] + [stag (and tag `(sig-form ,str))] + [sd (and stag (resolve-get/tentative sec ri stag))]) (list - (cond - [sd - (make-link-element "schemesyntaxlink" (list s) stag)] - [else - (make-link-element "schemevaluelink" (list s) vtag)])))) + (make-element + "schemesymbol" + (list + (cond + [sd + (make-link-element "schemesyntaxlink" (list s) stag)] + [vtag + (make-link-element "schemevaluelink" (list s) vtag)] + [else + s])))))) (lambda () s) (lambda () s)))) @@ -379,15 +425,29 @@ (elem (method a b) " in " (scheme a))])) (define (*method sym id) - (**method sym (id-to-tag id))) + (**method sym id)) - (define (**method sym tag) - (make-element - "schemesymbol" - (list (make-link-element - "schemevaluelink" - (list (symbol->string sym)) - (method-tag tag sym))))) + (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 + "schemesymbol" + (list (make-link-element + "schemevaluelink" + content + (method-tag tag sym)))))))) (define (method-tag vtag sym) (list 'meth @@ -458,12 +518,18 @@ (syntax-rules () [(_ lib ...) (*declare-exporting '(lib ...))])) + (define-struct (exporting-libraries element) (libs)) + (define (*declare-exporting libs) - (make-part-collect-decl - (make-collect-element #f - null - (lambda (ri) - (collect-put! ri '(exporting-libraries #f)libs))))) + (make-splice + (list + (make-part-collect-decl + (make-collect-element #f + null + (lambda (ri) + (collect-put! ri '(exporting-libraries #f) libs)))) + (make-part-collect-decl + (make-exporting-libraries #f null libs))))) (define-syntax (quote-syntax/loc stx) (syntax-case stx () @@ -1016,45 +1082,51 @@ (hspace 1) (if first? (let* ([mname (extract-id prototype)] - [ctag (id-to-tag within-id)] - [tag (method-tag ctag mname)] + [target-maker (id-to-target-maker within-id #f)] [content (list (*method mname within-id))]) - (if tag - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string mname)) - content - (with-exporting-libraries - (lambda (libs) - (make-method-index-desc - (syntax-e within-id) - libs - mname - ctag))))) - tag) + (if target-maker + (target-maker + content + (lambda (ctag) + (let ([tag (method-tag ctag mname)]) + (make-toc-target-element + #f + (list (make-index-element #f + content + tag + (list (symbol->string mname)) + content + (with-exporting-libraries + (lambda (libs) + (make-method-index-desc + (syntax-e within-id) + libs + mname + ctag))))) + tag)))) (car content))) (*method (extract-id prototype) within-id))))] [else (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))]) - (if tag - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string (extract-id prototype))) - content - (with-exporting-libraries - (lambda (libs) - (make-procedure-index-desc - (extract-id prototype) - libs))))) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (list (make-index-element #f + content + tag + (list (symbol->string (extract-id prototype))) + content + (with-exporting-libraries + (lambda (libs) + (make-procedure-index-desc + (extract-id prototype) + libs))))) + tag))) (car content))) (annote-exporting-library (to-element (make-just-context (extract-id prototype) @@ -1241,27 +1313,31 @@ (let* ([name (apply string-append (map symbol->string (cdar wrappers)))] - [tag - (id-to-tag + [target-maker + (id-to-target-maker (datum->syntax stx-id (string->symbol - name)))]) - (if tag - (inner-make-target-element - #f - (list - (make-index-element #f - (list content) - tag - (list name) - (list (schemeidfont (make-element "schemevaluelink" (list name)))) - (with-exporting-libraries - (lambda (libs) - (let ([name (string->symbol name)]) - (if (eq? 'info (caar wrappers)) - (make-struct-index-desc name libs) - (make-procedure-index-desc name libs))))))) - tag) + name)) + #t)]) + (if target-maker + (target-maker + (list content) + (lambda (tag) + (inner-make-target-element + #f + (list + (make-index-element #f + (list content) + tag + (list name) + (list (schemeidfont (make-element "schemevaluelink" (list name)))) + (with-exporting-libraries + (lambda (libs) + (let ([name (string->symbol name)]) + (if (eq? 'info (caar wrappers)) + (make-struct-index-desc name libs) + (make-procedure-index-desc name libs))))))) + tag))) content)) (cdr wrappers)))) @@ -1454,20 +1530,24 @@ (list (make-flow (list (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?))]) - (if tag - (make-toc-target-element - #f - (list (make-index-element #f - content - tag - (list (symbol->string name)) - content - (with-exporting-libraries - (lambda (libs) - (make-thing-index-desc name libs))))) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (list + (make-index-element #f + content + tag + (list (symbol->string name)) + content + (with-exporting-libraries + (lambda (libs) + (make-thing-index-desc name libs))))) + tag))) (car content))) spacer ":" spacer)))) (make-flow @@ -1520,31 +1600,29 @@ `(,x . ,(cdr form))))))) (and kw-id (eq? form (car forms)) - (let ([tag (id-to-tag kw-id)] - [stag (id-to-form-tag kw-id)] + (let ([target-maker (id-to-form-target-maker kw-id #t)] [content (list (definition-site (if (pair? form) (car form) form) kw-id #t))]) - (if tag - (make-target-element - #f - (list - (make-toc-target-element - #f - (if kw-id - (list (make-index-element #f - content - tag - (list (symbol->string (syntax-e kw-id))) - content - (with-exporting-libraries - (lambda (libs) - (make-form-index-desc (syntax-e kw-id) libs))))) - content) - stag)) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + (make-toc-target-element + #f + (if kw-id + (list (make-index-element #f + content + tag + (list (symbol->string (syntax-e kw-id))) + content + (with-exporting-libraries + (lambda (libs) + (make-form-index-desc (syntax-e kw-id) libs))))) + content) + tag))) (car content))))))))) forms form-procs) (if (null? sub-procs) @@ -1680,9 +1758,19 @@ (make-link-element (if u? #f "plainlink") null `(part ,(doc-prefix doc 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)))) + (define (*schemelink stx-id id . s) - (make-link-element #f (decode-content s) (or (register-scheme-definition stx-id) - (format "--UNDEFINED:~a--" (syntax-e stx-id))))) + (let ([content (decode-content s)]) + (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 (syntax-rules () [(_ id . content) (*schemelink (quote-syntax id) 'id . content)])) @@ -1841,28 +1929,45 @@ (define-struct spec (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 (make-inherited-table r d ri decl) - (let* ([start (let ([key (register-scheme-definition (decl-name decl))]) - (list (cons key (lookup-cls/intf d ri key))))] - [supers (cdr - (let loop ([supers start][accum null]) - (cond - [(null? supers) (reverse accum)] - [(memq (car supers) accum) - (loop (cdr supers) accum)] - [else - (let ([super (car supers)]) - (loop (append (map (lambda (i) - (cons i (lookup-cls/intf d ri i))) - (reverse (cls/intf-intfs (cdr super)))) - (let ([s (cls/intf-super (cdr super))]) - (if s - (list (cons s (lookup-cls/intf d ri s))) - null)) - (cdr supers)) - (cons super accum)))])))] + (let* ([start (let ([key (find-scheme-tag d ri (decl-name decl) 'for-label)]) + (if key + (list (cons key (lookup-cls/intf d ri key))) + null))] + [supers (if (null? start) + null + (cdr + (let loop ([supers start][accum null]) + (cond + [(null? supers) (reverse accum)] + [(memq (car supers) accum) + (loop (cdr supers) accum)] + [else + (let ([super (car supers)]) + (loop (append (filter values + (map (lambda (i) + (let ([key (find-scheme-tag d ri i 'for-label)]) + (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 + (list (cons s (lookup-cls/intf d ri s))) + null)) + (cdr supers)) + (cons super accum)))]))))] [ht (let ([ht (make-hash-table)]) (for-each (lambda (i) (when (meth? i) @@ -1902,27 +2007,29 @@ (define (make-decl-collect decl) (make-part-collect-decl - (make-collect-element - #f null - (lambda (ci) - (let ([tag (register-scheme-definition (decl-name decl))]) - (collect-put! ci - `(cls/intf ,tag) - (make-cls/intf - (make-element - "schemesymbol" - (list (make-link-element - "schemevaluelink" - (list (symbol->string (syntax-e (decl-name decl)))) - tag))) - (and (decl-super decl) - (not (free-label-identifier=? (quote-syntax object%) - (decl-super decl))) - (register-scheme-definition (decl-super decl))) - (map register-scheme-definition (decl-intfs decl)) - (map (lambda (m) - (meth-name m)) - (filter meth? (decl-body decl)))))))))) + ((id-to-target-maker (decl-name decl) #f) + (list "ignored") + (lambda (tag) + (make-collect-element + #f null + (lambda (ci) + (collect-put! ci + `(cls/intf ,(cadr tag)) + (make-cls/intf + (make-element + "schemesymbol" + (list (make-link-element + "schemevaluelink" + (list (symbol->string (syntax-e (decl-name decl)))) + tag))) + (and (decl-super decl) + (not (free-label-identifier=? (quote-syntax object%) + (decl-super decl))) + (id-info (decl-super decl))) + (map id-info (decl-intfs decl)) + (map (lambda (m) + (meth-name m)) + (filter meth? (decl-body decl))))))))))) (define (build-body decl body) (append @@ -1969,22 +2076,26 @@ (list (make-flow (list (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)))]) - (if tag - ((if whole-page? - make-page-target-element - make-toc-target-element) - #f - (list (make-index-element #f - content - tag - (list (symbol->string (syntax-e stx-id))) - content - (with-exporting-libraries - (lambda (libs) - (make-index-desc (syntax-e stx-id) libs))))) - tag) + (if target-maker + (target-maker + content + (lambda (tag) + ((if whole-page? + make-page-target-element + make-toc-target-element) + #f + (list + (make-index-element #f + content + tag + (list (symbol->string (syntax-e stx-id))) + content + (with-exporting-libraries + (lambda (libs) + (make-index-desc (syntax-e stx-id) libs))))) + tag))) (car content))) spacer ":" spacer (case kind @@ -2222,36 +2333,38 @@ (define (*xmethod/super cname name) (let ([get (lambda (d ri key) - (let ([v (lookup-cls/intf d ri key)]) - (if v - (cons (cls/intf-super v) - (cls/intf-intfs v)) - null)))] - [ctag (id-to-tag cname)]) + (if key + (let ([v (lookup-cls/intf d ri key)]) + (if v + (cons (cls/intf-super v) + (cls/intf-intfs v)) + null)) + null))]) (make-delayed-element (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 [(null? search) (list (make-element #f '("")))] [(not (car search)) (loop (cdr search))] [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 (member name (cls/intf-methods v)) (list (make-element #f - (list (**method name (car search)) + (list (**method name a-key) " in " (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))))]))) (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) - (let ([v (resolve-get d ri `(cls/intf ,name))]) + (define (lookup-cls/intf d ri tag) + (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))]) (or v (make-cls/intf "unknown" #f @@ -2294,8 +2407,7 @@ #t (list (make-element #f '("signature"))) (lambda () - (let ([in (parameterize ([current-signature (make-sig - (id-to-form-tag stx-id))]) + (let ([in (parameterize ([current-signature (make-sig stx-id)]) (body-thunk))]) (if indent? (let-values ([(pre-body post-body) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index e73736a320..44a76ea3fd 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -1,10 +1,12 @@ (module scheme scheme/base (require "struct.ss" "basic.ss" + "search.ss" mzlib/class mzlib/for setup/main-collects syntax/modresolve + syntax/modcode (for-syntax scheme/base)) (provide define-code @@ -12,8 +14,6 @@ to-element/no-color to-paragraph to-paragraph/prefix - register-scheme-definition - register-scheme-form-definition syntax-ize syntax-ize-hook current-keyword-list @@ -73,28 +73,30 @@ (values (substring s 1) #t #f) (values s #f #f))))]) (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 (if (and (identifier? c) color? (quote-depth . <= . 0) (not (or it? is-var?))) - (let ([tag (register-scheme c)]) - (if tag - (make-delayed-element - (lambda (renderer sec ri) - (let* ([vtag `(def ,tag)] - [stag `(form ,tag)] - [sd (resolve-get/tentative sec ri stag)]) - (list - (cond - [sd - (make-link-element "schemesyntaxlink" (list s) stag)] - [else - (make-link-element "schemevaluelink" (list s) vtag)])))) - (lambda () s) - (lambda () s)) - s)) + (if (pair? (identifier-label-binding c)) + (make-delayed-element + (lambda (renderer sec ri) + (let* ([tag (find-scheme-tag sec ri c 'for-label)]) + (if tag + (list + (case (car tag) + [(form) + (make-link-element "schemesyntaxlink" (list s) tag)] + [else + (make-link-element "schemevaluelink" (list s) tag)])) + (list + (make-element "badlink" + (list (make-element "schemevaluelink" (list s)))))))) + (lambda () s) + (lambda () s)) + s) (literalize-spaces s)) (cond [(positive? quote-depth) value-color] @@ -155,6 +157,8 @@ (element-width v)] [(delayed-element? v) (element-width v)] + [(part-relative-element? v) + (element-width v)] [(spaces? v) (+ (sz-loop (car (element-content v))) (spaces-cnt v) @@ -538,41 +542,6 @@ [(_ 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 (vector->short-list v extract) diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss new file mode 100644 index 0000000000..bc2e5cfae5 --- /dev/null +++ b/collects/scribble/search.ss @@ -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)))))))]))))))) \ No newline at end of file diff --git a/collects/scribble/struct.ss b/collects/scribble/struct.ss index 98f45a4033..f4be3e8451 100644 --- a/collects/scribble/struct.ss +++ b/collects/scribble/struct.ss @@ -6,8 +6,8 @@ ;; ---------------------------------------- - (define-struct collect-info (ht ext-ht parts tags gen-prefix)) - (define-struct resolve-info (ci delays undef)) + (define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents)) + (define-struct resolve-info (ci delays undef searches)) (define (part-collected-info part ri) (hash-table-get (collect-info-parts (resolve-info-ci ri)) @@ -49,6 +49,18 @@ #t)) 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) (let-values ([(v ext?) (resolve-get/where part ri key)]) v)) @@ -69,6 +81,7 @@ part-collected-info collect-put! resolve-get + resolve-search resolve-get/tentative resolve-get-keys) @@ -163,12 +176,11 @@ [target-url ([addr string?])] [image-file ([path path-string?])]) - + ;; ---------------------------------------- ;; Delayed element has special serialization support: (define-struct delayed-element (resolve sizer plain) - #:mutable #:property prop:serializable (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. ;; It uses the same delay -> value table as delayed-element (define-struct delayed-index-desc (resolve) @@ -336,6 +389,7 @@ [(c) (cond [(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)))] [(string? c) c] [else (case c @@ -356,6 +410,9 @@ [(delayed-element? c) (content->string (delayed-element-content c ri) renderer sec ri)] + [(part-relative-element? c) + (content->string (part-relative-element-content c ri) + renderer sec ri)] [else (element->string c)])])) (define (strip-aux content) @@ -376,6 +433,7 @@ [(string? s) (string-length s)] [(element? s) (apply + (map element-width (element-content s)))] [(delayed-element? s) (element-width ((delayed-element-sizer s)))] + [(part-relative-element? s) (element-width ((part-relative-element-sizer s)))] [else 1])) (define (paragraph-width s) diff --git a/collects/scribble/xref.ss b/collects/scribble/xref.ss index 4440ca82fd..85ff2ede8e 100644 --- a/collects/scribble/xref.ss +++ b/collects/scribble/xref.ss @@ -4,6 +4,7 @@ scribble/manual-struct scribble/decode-struct scribble/base-render + scribble/search (prefix-in html: scribble/html-render) scheme/class mzlib/serialize @@ -74,46 +75,50 @@ (void)))) ;; Returns (values ) -(define (xref-binding-tag xrefs src id) - (let ([search - (lambda (src) - (let ([base (format ":~a:~a" - (if (path? src) - (path->main-collects-relative src) - src) - id)] - [ht (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))]) - (let ([form-tag `(form ,base)] - [val-tag `(def ,base)]) - (if (hash-table-get ht form-tag #f) - (values form-tag #t) - (if (hash-table-get ht val-tag #f) - (values val-tag #f) - (values #f #f))))))]) - (let loop ([src src]) +(define xref-binding-tag + (case-lambda + [(xrefs id/binding mode) + (let ([search + (lambda (id/binding) + (let ([tag (find-scheme-tag #f (xrefs-ri xrefs) id/binding mode)]) + (if tag + (values tag (eq? (car tag) 'form)) + (values #f #f))))]) (cond - [(path? src) - (if (complete-path? src) - (search src) - (loop (path->complete-path src)))] - [(path-string? src) - (loop (path->complete-path src))] - [(resolved-module-path? src) - (let ([n (resolved-module-path-name src)]) - (if (pair? n) - (loop n) - (search n)))] - [(module-path-index? src) - (loop (module-path-index-resolve src))] - [(module-path? src) - (loop (module-path-index-join src #f))] - [else - (raise-type-error 'xref-binding-definition->tag - "module path, resolved module path, module path index, path, or string" - src)])))) + [(identifier? id/binding) + (search id/binding)] + [(and (list? id/binding) + (= 6 (length id/binding))) + (search id/binding)] + [(and (list? id/binding) + (= 2 (length id/binding))) + (let loop ([src (car id/binding)]) + (cond + [(path? src) + (if (complete-path? src) + (search (list src (cadr id/binding))) + (loop (path->complete-path src)))] + [(path-string? src) + (loop (path->complete-path src))] + [(resolved-module-path? src) + (let ([n (resolved-module-path-name src)]) + (if (pair? n) + (loop n) + (search n)))] + [(module-path-index? src) + (loop (module-path-index-resolve src))] + [(module-path? src) + (loop (module-path-index-join src #f))] + [else + (raise-type-error 'xref-binding-definition->tag + "list starting with module path, resolved module path, module path index, path, or string" + 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) - (let-values ([(tag form?) (xref-binding-tag xrefs src id)]) +(define (xref-binding->definition-tag xrefs id/binding mode) + (let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)]) tag)) (define (xref-tag->path+anchor xrefs tag #:render% [render% (html:render-mixin render%)]) diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index af55633a7d..829d99d733 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -5,30 +5,8 @@ @section[#:tag "foreign:tagged-pointers"]{Tagged C Pointer Types} -@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).} +The unsafe @scheme[cpointer-has-tag?] and @scheme[cpointer-push-tag!] +operations manage tags to distinguish pointer types. @defproc*[([(_cpointer [tag any/c] [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 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} 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?]{ @@ -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 @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?]{ @@ -237,11 +251,10 @@ just aliases for byte-string bindings: @scheme[make-u8vector], "Like " (scheme _cvector) ", but for vectors of " (scheme elem) " elements."))))]))) -@defform*[[(_u8vector mode type maybe-len) - _u8vector]]{ - -Like @scheme[_cvector], but for vectors of @scheme[_byte] elements.} +@srfi-4-vector/desc[u8 _uint8]{ +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[s16 _int16] diff --git a/collects/scribblings/foreign/foreign.scrbl b/collects/scribblings/foreign/foreign.scrbl index 09ca8a30b5..2b58317d56 100644 --- a/collects/scribblings/foreign/foreign.scrbl +++ b/collects/scribblings/foreign/foreign.scrbl @@ -13,8 +13,9 @@ interface}. Furthermore, since most APIs consist mostly of functions, the foreign interface is sometimes called a @defterm{foreign function interface}, abbreviated @deftech{FFI}. -@bold{Important:} Most of the bindings documented here are available -only after an @scheme[(unsafe!)] declaration in the importing module. +@bold{Important:} Many of the bindings documented here (the ones in +sections with titles starting ``Unsafe'') are available only after an +@scheme[(unsafe!)] declaration in the importing module. @table-of-contents[] diff --git a/collects/scribblings/foreign/intro.scrbl b/collects/scribblings/foreign/intro.scrbl index dad6bd359b..e472780a43 100644 --- a/collects/scribblings/foreign/intro.scrbl +++ b/collects/scribblings/foreign/intro.scrbl @@ -26,7 +26,9 @@ itself protected; see @secref[#:doc '(lib "scribblings/reference/reference.scrbl") "modprotect"].) Using this 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 -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 in the @filepath{ffi} collection. diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl index 2880189e3f..43189ea19a 100644 --- a/collects/scribblings/foreign/libs.scrbl +++ b/collects/scribblings/foreign/libs.scrbl @@ -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 @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)] [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}).} -@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?)] [lib (or/c ffi-lib? path-string? false/c)] [type ctype?] diff --git a/collects/scribblings/foreign/misc.scrbl b/collects/scribblings/foreign/misc.scrbl index b4c9bd45a6..c950cf25d1 100644 --- a/collects/scribblings/foreign/misc.scrbl +++ b/collects/scribblings/foreign/misc.scrbl @@ -46,6 +46,16 @@ using values from @scheme[lst] and the given @scheme[type]. The 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?]) 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.} -@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?]) vector?]{ diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index 9a80b7b45e..07d64c70cc 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -11,6 +11,63 @@ strings (used as memory blocks), some additional internal objects (@scheme[ffi-obj]s and callbacks, see @secref["foreign:c-only"]). 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?] [type ctype?] [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.} -@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?] [src-cptr cpointer?] [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 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, see @|InsideMzScheme|. diff --git a/collects/scribblings/foreign/unsafe-foreign.ss b/collects/scribblings/foreign/unsafe-foreign.ss index 2a2f0a8c0f..766bbdc086 100644 --- a/collects/scribblings/foreign/unsafe-foreign.ss +++ b/collects/scribblings/foreign/unsafe-foreign.ss @@ -1,8 +1,11 @@ #lang scheme/base (require scheme/foreign) + +(error 'unsafe! "only `for-label' use in the documentation") + (unsafe!) -(provide (all-defined-out) +(provide (protect-out (all-defined-out)) (all-from-out scheme/foreign)) diff --git a/collects/scribblings/gui/blurbs.ss b/collects/scribblings/gui/blurbs.ss index 9508fb4c95..cba3bfd0cc 100644 --- a/collects/scribblings/gui/blurbs.ss +++ b/collects/scribblings/gui/blurbs.ss @@ -4,7 +4,7 @@ scribble/manual scribble/scheme scribble/decode - (for-label mred)) + (for-label scheme/gui/base)) (provide (except-out (all-defined-out) p)) diff --git a/collects/scribblings/gui/common.ss b/collects/scribblings/gui/common.ss index df2e0b23dd..8868619e7d 100644 --- a/collects/scribblings/gui/common.ss +++ b/collects/scribblings/gui/common.ss @@ -2,23 +2,23 @@ (module common scheme/base (require scribble/manual scribble/basic - mzlib/class - mzlib/contract + scheme/class + scheme/contract "blurbs.ss" (only-in "../reference/mz.ss" AllUnix exnraise)) (provide (all-from-out scribble/manual) (all-from-out scribble/basic) - (all-from-out mzlib/class) - (all-from-out mzlib/contract) + (all-from-out scheme/class) + (all-from-out scheme/contract) (all-from-out "blurbs.ss") (all-from-out "../reference/mz.ss")) - (require (for-label mred - mzlib/class - mzlib/contract + (require (for-label scheme/gui/base + scheme/class + scheme/contract scheme/base)) - (provide (for-label (all-from-out mred) - (all-from-out mzlib/class) - (all-from-out mzlib/contract) + (provide (for-label (all-from-out scheme/gui/base) + (all-from-out scheme/class) + (all-from-out scheme/contract) (all-from-out scheme/base)))) diff --git a/collects/scribblings/gui/diagrams.ss b/collects/scribblings/gui/diagrams.ss index 9dd8592bcb..7f1f1b0105 100644 --- a/collects/scribblings/gui/diagrams.ss +++ b/collects/scribblings/gui/diagrams.ss @@ -2,7 +2,7 @@ (require scribble/struct scribble/scheme scribble/manual - (for-label mred)) + (for-label scheme/gui/base)) (provide diagram->table short-windowing-diagram diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index db2a022953..5a9aa13fd7 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -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] - [redirect-ports? any/c @scheme[(not @scheme[eval-eventspace])]]) + [redirect-ports? any/c (not eval-eventspace)]) void?]{ Similar to MzScheme's @scheme[read-eval-print-loop], except that none of diff --git a/collects/scribblings/htdp-langs/advanced.scrbl b/collects/scribblings/htdp-langs/advanced.scrbl index 8753c79c82..7f6a0d81ec 100644 --- a/collects/scribblings/htdp-langs/advanced.scrbl +++ b/collects/scribblings/htdp-langs/advanced.scrbl @@ -4,18 +4,36 @@ "prim-ops.ss" (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 - (require (for-label lang/htdp-intermediate-lambda)) + (require (for-label lang/htdp-intermediate)) (define intm-define (scheme define)) (define intm-define-struct (scheme define-struct)) (define intm-lambda (scheme lambda)) - (define intm-let (scheme let)))) -@(bd intm-define intm-define-struct intm-lambda intm-let) + (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-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} +@declare-exporting[lang/htdp-advanced] + @schemegrammar*+qq[ #: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) @@ -255,9 +273,57 @@ first @scheme[expr] produces @scheme[false] instead of @scheme[true].} @section[#:tag "advanced-prim-ops"]{Primitive Operations} -The following primitives extend the set available though -@seclink["intermediate-prim-op"]{Intermediate}. +@prim-op-defns['(lib "htdp-advanced.ss" "lang") #'here '()] -@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|.} diff --git a/collects/scribblings/htdp-langs/beginner-abbr.scrbl b/collects/scribblings/htdp-langs/beginner-abbr.scrbl index accdc7b25a..bbd80d9938 100644 --- a/collects/scribblings/htdp-langs/beginner-abbr.scrbl +++ b/collects/scribblings/htdp-langs/beginner-abbr.scrbl @@ -4,8 +4,23 @@ "prim-ops.ss" (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} +@declare-exporting[lang/htdp-beginner-abbr] + @schemegrammar*+qq[ #:literals (define define-struct lambda cond else if and or empty true false require lib planet) [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 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|.} diff --git a/collects/scribblings/htdp-langs/beginner.scrbl b/collects/scribblings/htdp-langs/beginner.scrbl index aa31e6b229..ff43a7f1ba 100644 --- a/collects/scribblings/htdp-langs/beginner.scrbl +++ b/collects/scribblings/htdp-langs/beginner.scrbl @@ -4,15 +4,11 @@ "prim-ops.ss" (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} +@declare-exporting[lang/htdp-beginner] + @schemegrammar*+library[ #:literals (define define-struct lambda cond else if and or empty true false require lib planet) [program def-or-expr] @@ -175,8 +171,7 @@ end'' of the @scheme[cond] form.} @defidform[else]{ -The @scheme[else] keyword can be used only with @scheme[cond], or in -Advanced language, with @|adv-case|.} +The @scheme[else] keyword can be used only with @scheme[cond].} @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl index bb881b0f4c..3e61065ccc 100644 --- a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl +++ b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl @@ -4,15 +4,35 @@ "prim-ops.ss" (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 (require (for-label lang/htdp-intermediate)) - (define intm-define (scheme define)))) -@(bd intm-define) + (define intm-define (scheme 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} +@declare-exporting[lang/htdp-intermediate-lambda] + @schemegrammar*+qq[ #:literals (define define-struct lambda cond else if and or empty true false require lib planet 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 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|.} diff --git a/collects/scribblings/htdp-langs/intermediate.scrbl b/collects/scribblings/htdp-langs/intermediate.scrbl index 2a9c6c8588..33a2532404 100644 --- a/collects/scribblings/htdp-langs/intermediate.scrbl +++ b/collects/scribblings/htdp-langs/intermediate.scrbl @@ -4,16 +4,22 @@ "prim-ops.ss" (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 (require (for-label lang/htdp-beginner)) (define beg-define (scheme define)) - (define beg-define-struct (scheme define-struct)))) -@(bd beg-define beg-define-struct) - + (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]{Intermediate Student} +@declare-exporting[lang/htdp-intermediate] + @schemegrammar*+qq[ #:literals (define define-struct lambda cond else if and or empty true false require lib planet 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 the function's body.} -@prim-op-defns['(lib "htdp-intermediate.ss" "lang") - #'here - '((lib "htdp-beginner.ss" "lang"))] +@prim-op-defns['(lib "htdp-intermediate.ss" "lang") #'here '()] + +@; ---------------------------------------------------------------------- + +@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|.} diff --git a/collects/scribblings/quick/quick.scrbl b/collects/scribblings/quick/quick.scrbl index d330b54ae5..88a30bfdd4 100644 --- a/collects/scribblings/quick/quick.scrbl +++ b/collects/scribblings/quick/quick.scrbl @@ -15,7 +15,7 @@ "mred-doc.ss" (for-label scheme/base - mred/mred + scheme/gui/base scheme/class slideshow) diff --git a/collects/scribblings/reference/macros.scrbl b/collects/scribblings/reference/macros.scrbl index 96e930354d..d53ece240e 100644 --- a/collects/scribblings/reference/macros.scrbl +++ b/collects/scribblings/reference/macros.scrbl @@ -15,6 +15,7 @@ called. @include-section["stx-ops.scrbl"] @include-section["stx-comp.scrbl"] @include-section["stx-trans.scrbl"] +@include-section["stx-param.scrbl"] @include-section["stx-props.scrbl"] @include-section["stx-certs.scrbl"] @include-section["stx-expand.scrbl"] diff --git a/collects/scribblings/reference/module-reflect.scrbl b/collects/scribblings/reference/module-reflect.scrbl index 01cd6d85c9..bf5fe107a2 100644 --- a/collects/scribblings/reference/module-reflect.scrbl +++ b/collects/scribblings/reference/module-reflect.scrbl @@ -243,22 +243,56 @@ the module's declared name.} @defproc[(module-compiled-imports [compiled-module-code compiled-module-expression?]) (values (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: -a list of module references for the module's explicit imports, a list -of module references for the module's explicit for-syntax imports, and -a list of module references for the module's explicit for-template +Takes a module declaration in compiled form and returns four values: a +list of module references for the module's explicit imports, a list of +module references for the module's explicit for-syntax imports, a list +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.} @defproc[(module-compiled-exports [compiled-module-code compiled-module-expression?]) - (values (listof symbol?) - (listof symbol?))]{ + (values list? list? list? list? list? list?)]{ -Takes a module declaration in compiled form and returns two values: a -list of symbols for the module's explicit variable exports, a list -symbols for the module's explicit syntax exports.} +Returns six lists: one for the module's explicit variable exports, one +for the module's explicit syntax exports, one for the module's +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} diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 70ca13f609..87acfbdf4e 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -2,7 +2,7 @@ @(require "mz.ss" scheme/sandbox (for-label scheme/sandbox - (only-in mred/mred make-gui-namespace) + (only-in scheme/gui make-gui-namespace) scheme/gui/dynamic)) @title{Sandboxed Evaluation} diff --git a/collects/scribblings/reference/serialization.scrbl b/collects/scribblings/reference/serialization.scrbl index 27f0b4a383..ff8ee20812 100644 --- a/collects/scribblings/reference/serialization.scrbl +++ b/collects/scribblings/reference/serialization.scrbl @@ -41,9 +41,11 @@ The following kinds of values are serializable: @item{booleans, numbers, characters, symbols, strings, byte strings, 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 fails on deserialization (since dates are immutable; this case does not appear in output generated by - @scheme[serialize]); or} + @scheme[serialize]);} @item{@scheme['arity-at-least] for an @scheme[arity-at-least] structure, which fails on deserialization (since dates are immutable; this 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]).} } @@ -240,6 +247,11 @@ elements: and whose @scheme[cdr] is a serial; it represents an @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.} + }} }} diff --git a/collects/scribblings/reference/stx-comp.scrbl b/collects/scribblings/reference/stx-comp.scrbl index 26b783828f..4600700c4e 100644 --- a/collects/scribblings/reference/stx-comp.scrbl +++ b/collects/scribblings/reference/stx-comp.scrbl @@ -1,7 +1,5 @@ #lang scribble/doc -@(require "mz.ss" - (for-label scheme/stxparam - scheme/stxparam-exptime)) +@(require "mz.ss") @title[#:tag "stxcmp"]{Syntax Object Bindings} @@ -56,11 +54,12 @@ is @scheme[#f].} @defproc[(identifier-binding [id-stx syntax?]) (or/c (one-of 'lexical #f) - (listof (or/c module-path-index? symbol?) + (listof module-path-index? symbol? - (or/c module-path-index? symbol?) + module-path-index? symbol? - boolean?))]{ + boolean? + (one-of/c #f 'for-syntax 'for-template)))]{ Returns one of three kinds of values, depending on the binding of @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] 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 - nominal-source-mod nominal-source-id et?)]. + nominal-source-mod nominal-source-id et? mode)]. @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 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] @@ -113,11 +117,12 @@ Returns one of three kinds of values, depending on the binding of @defproc[(identifier-transformer-binding [id-stx syntax?]) (or/c (one-of 'lexical #f) - (listof (or/c module-path-index? symbol?) + (listof module-path-index? symbol? - (or/c module-path-index? symbol?) + module-path-index? symbol? - boolean?))]{ + boolean? + (one-of/c #f 'for-syntax 'for-template)))]{ Like @scheme[identifier-binding], but that the reported information is 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?]) (or/c (one-of 'lexical #f) - (listof (or/c module-path-index? symbol?) + (listof module-path-index? symbol? - (or/c module-path-index? symbol?) + module-path-index? symbol? - boolean?))]{ + boolean? + (one-of/c #f 'for-syntax 'for-template)))]{ Like @scheme[identifier-binding], but that the reported information is 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? (or/c module-path-index? symbol?) symbol? - boolean?))]{ + boolean? + (one-of/c #f 'for-label)))]{ Like @scheme[identifier-binding], but that the reported information is 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 @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].} diff --git a/collects/scribblings/reference/stx-param.scrbl b/collects/scribblings/reference/stx-param.scrbl new file mode 100644 index 0000000000..52e134e137 --- /dev/null +++ b/collects/scribblings/reference/stx-param.scrbl @@ -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].} diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index d848904f58..f9bdda2dc0 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -445,6 +445,61 @@ mark}. Multiple applications of the same @scheme[make-syntax-introducer] result procedure use the same mark, 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} @@ -530,6 +585,7 @@ A structure representing a single imported identifier: }} + @defstruct[import-source ([mod-path-stx (and/c syntax? (lambda (x) (module-path? (syntax->datum x))))] @@ -627,58 +683,3 @@ A structure representing a single imported identifier: 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].} diff --git a/collects/scribblings/scribble/bnf.scrbl b/collects/scribblings/scribble/bnf.scrbl index 72cd5a80f6..a8dc78af8f 100644 --- a/collects/scribblings/scribble/bnf.scrbl +++ b/collects/scribblings/scribble/bnf.scrbl @@ -3,7 +3,7 @@ "utils.ss" (for-label scribble/bnf)) -@title[#:tag "bnf"]{Typesetting Grammars} +@title[#:tag "bnf"]{BNF Grammars} @defmodule[scribble/bnf]{The @scheme[scribble/bnf] library provides utilities for typesetting grammars.} diff --git a/collects/scribblings/scribble/decode.scrbl b/collects/scribblings/scribble/decode.scrbl index f94a745935..95ba732c98 100644 --- a/collects/scribblings/scribble/decode.scrbl +++ b/collects/scribblings/scribble/decode.scrbl @@ -2,7 +2,7 @@ @require[scribble/manual] @require["utils.ss"] -@title[#:tag "decode"]{Text Decoder} +@title[#:tag "decode"]{Decoding Text} @defmodule[scribble/decode]{The @schememodname[scribble/decode] library helps you write document content in a natural way---more like diff --git a/collects/scribblings/scribble/doclang.scrbl b/collects/scribblings/scribble/doclang.scrbl index f2ebb8fe81..6805531399 100644 --- a/collects/scribblings/scribble/doclang.scrbl +++ b/collects/scribblings/scribble/doclang.scrbl @@ -2,9 +2,9 @@ @require[scribble/manual] @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 replaces the @scheme[#%module-begin] form.} diff --git a/collects/scribblings/scribble/docreader.scrbl b/collects/scribblings/scribble/docreader.scrbl index ebfc4899d4..5e484d88b3 100644 --- a/collects/scribblings/scribble/docreader.scrbl +++ b/collects/scribblings/scribble/docreader.scrbl @@ -5,7 +5,7 @@ @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 @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 diff --git a/collects/scribblings/scribble/how-to.scrbl b/collects/scribblings/scribble/how-to.scrbl index 09e785f011..3e8122d9fa 100644 --- a/collects/scribblings/scribble/how-to.scrbl +++ b/collects/scribblings/scribble/how-to.scrbl @@ -292,7 +292,9 @@ hyperlinks. To document a @scheme[my-helper] procedure that is exported by @filepath{helper.ss} in the collection that contains @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: @verbatim[#<definition-tag [xref xref?] - [mod (or/c module-path? - module-path-index? - path? - resolved-module-path?)] - [sym symbol?]) + [binding (or/c identifier? + (list/c (or/c module-path? + module-path-index? + path? + resolved-module-path?) + 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)]{ -Locates a tag in @scheme[xref] that documents @scheme[sym] as defined -by @scheme[mod]. The @scheme[sym] and @scheme[mod] combination -correspond to the first two elements of a @scheme[identifier-binding] -list result. +Locates a tag in @scheme[xref] that documents a module export. The +binding is specified in one of several ways, as described below; all +possibilities encode an exporting module and a symbolic name. The name +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, which might be used with @scheme[xref-tag->path+anchor] or embedded in diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 6ad6fe0584..abffeefa1b 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc @(require "ss.ss" - (for-label mred + (for-label scheme/gui slideshow/code slideshow/flash slideshow/face diff --git a/collects/scribblings/slideshow/slides.scrbl b/collects/scribblings/slideshow/slides.scrbl index 212aa31112..da118103c1 100644 --- a/collects/scribblings/slideshow/slides.scrbl +++ b/collects/scribblings/slideshow/slides.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc @require["ss.ss"] -@require[(for-label mred +@require[(for-label scheme/gui slideshow/step slideshow/slides-to-picts)] diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 9b0b03fd95..f92417d976 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -17,7 +17,7 @@ (define verbose (make-parameter #t)) (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? need-in-write? need-out-write? vers rendered?) @@ -71,7 +71,7 @@ null)))) infos dirs))]) (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 ([ht (make-hash-table 'equal)]) ;; Collect definitions @@ -116,22 +116,33 @@ (printf " [Removed Dependency: ~a]\n" (doc-src-file (info-doc info)))))))) (info-deps info)) - (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 one? - (fprintf (current-error-port) - "In ~a:\n" - (doc-src-file (info-doc info))) - (set! one? #t)) - (fprintf (current-error-port) - " undefined tag: ~s\n" - k))))) - (info-undef info)) + (let ([not-found + (lambda (k) + (unless one? + (fprintf (current-error-port) + "In ~a:\n" + (doc-src-file (info-doc info))) + (set! one? #t)) + (fprintf (current-error-port) + " undefined tag: ~s\n" + 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)) + (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 (verbose) (printf " [Added Dependency: ~a]\n" @@ -265,7 +276,11 @@ (max aux-time (file-or-directory-modify-seconds src-zo #f (lambda () +inf.0))))))]) (printf " [~a ~a]\n" - (if up-to-date? "Using" "Running") + (if up-to-date? + "Using" + (if can-run? + "Running" + "Skipping")) (doc-src-file doc)) (if up-to-date? ;; Load previously calculated info: @@ -285,50 +300,55 @@ (list-ref v-out 1) ; sci (list-ref v-out 2) ; provides (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... can-run? my-time info-out-time #f #f #f vers #f))) - ;; Run the doc once: - (parameterize ([current-directory (doc-src-dir doc)]) - (let ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) - (doc-src-file doc))] - [dest-dir (pick-dest latex-dest doc)]) - (let* ([ci (send renderer collect (list v) (list dest-dir))]) - (let ([ri (send renderer resolve (list v) (list dest-dir) ci)] - [out-v (and info-out-time - (with-handlers ([exn? (lambda (exn) #f)]) - (let ([v (with-input-from-file info-out-file read)]) - (unless (equal? (car v) (list vers (doc-flags doc))) - (error "old info has wrong version or flags")) - v)))]) - (let ([sci (send renderer serialize-info ri)] - [defs (send renderer get-defined ci)]) - (let ([need-out-write? - (or (not (equal? (list (list vers (doc-flags doc)) sci defs) - out-v)) - (info-out-time . > . (current-seconds)))]) - (when (verbose) - (when need-out-write? - (fprintf (current-error-port) - " [New out ~a]\n" - (doc-src-file doc)))) - (make-info doc - sci - defs - (send renderer get-undefined ri) - null ; no deps, yet - can-run? - -inf.0 - (if need-out-write? - (/ (current-inexact-milliseconds) 1000) - info-out-time) - #t - can-run? need-out-write? - vers - #f)))))))))))) + (if can-run? + ;; Run the doc once: + (parameterize ([current-directory (doc-src-dir doc)]) + (let ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) + (doc-src-file doc))] + [dest-dir (pick-dest latex-dest doc)]) + (let* ([ci (send renderer collect (list v) (list dest-dir))]) + (let ([ri (send renderer resolve (list v) (list dest-dir) ci)] + [out-v (and info-out-time + (with-handlers ([exn? (lambda (exn) #f)]) + (let ([v (with-input-from-file info-out-file read)]) + (unless (equal? (car v) (list vers (doc-flags doc))) + (error "old info has wrong version or flags")) + v)))]) + (let ([sci (send renderer serialize-info ri)] + [defs (send renderer get-defined ci)] + [searches (resolve-info-searches ri)]) + (let ([need-out-write? + (or (not (equal? (list (list vers (doc-flags doc)) sci defs) + out-v)) + (info-out-time . > . (current-seconds)))]) + (when (verbose) + (when need-out-write? + (fprintf (current-error-port) + " [New out ~a]\n" + (doc-src-file doc)))) + (make-info doc + sci + defs + (send renderer get-undefined ri) + searches + null ; no deps, yet + can-run? + -inf.0 + (if need-out-write? + (/ (current-inexact-milliseconds) 1000) + info-out-time) + #t + can-run? need-out-write? + vers + #f))))))) + #f)))))) (define (build-again! latex-dest info) (let* ([doc (info-doc info)] @@ -432,7 +452,8 @@ (info-undef info) (map (lambda (i) (path->string (doc-src-file (info-doc i)))) - (info-deps info))))))))))) + (info-deps info)) + (info-searches info)))))))))) (define (write-out info) (make-directory* (doc-dest-dir (info-doc info))) diff --git a/collects/teachpack/htdp/Docs/image.scrbl b/collects/teachpack/htdp/Docs/image.scrbl index 0305f81c25..61766505d3 100644 --- a/collects/teachpack/htdp/Docs/image.scrbl +++ b/collects/teachpack/htdp/Docs/image.scrbl @@ -8,6 +8,8 @@ @title[#:tag "image"]{Manipulating Images: image.ss} +@declare-exporting[teachpack/htdp/image] + The teachpack provides primitives for constructing and manipulating images. Basic images are created as outlines or solid shapes. Additional primitives allow for the composition of images. diff --git a/collects/teachpack/htdp/Docs/testing.scrbl b/collects/teachpack/htdp/Docs/testing.scrbl index 1830a00482..139183dcb7 100644 --- a/collects/teachpack/htdp/Docs/testing.scrbl +++ b/collects/teachpack/htdp/Docs/testing.scrbl @@ -8,6 +8,8 @@ @title[#:tag "testing"]{Testing: testing.ss} +@declare-exporting[teachpack/htdp/testing] + The @scheme[testing.ss] teachpack provides forms for formulating test cases and a primitive for reporting on test cases. diff --git a/collects/teachpack/htdp/Docs/world.scrbl b/collects/teachpack/htdp/Docs/world.scrbl index e26055a993..fc130197eb 100644 --- a/collects/teachpack/htdp/Docs/world.scrbl +++ b/collects/teachpack/htdp/Docs/world.scrbl @@ -8,6 +8,8 @@ @title[#:tag "world"]{Simulations and Animations: world.ss} +@declare-exporting[teachpack/htdp/world] + The teachpack provides two kinds of functions. The first five allow students to simulate a small world of animated drawings and games: diff --git a/collects/tests/mzscheme/stx.ss b/collects/tests/mzscheme/stx.ss index ef82c7ba7f..3e5a9e72c8 100644 --- a/collects/tests/mzscheme/stx.ss +++ b/collects/tests/mzscheme/stx.ss @@ -443,37 +443,37 @@ (cdddr b)) b))) -(test '('#%kernel case-lambda scheme/init case-lambda #f) identifier-binding* #'case-lambda) -(test '(scheme/promise delay scheme/init delay #f) identifier-binding* #'delay) -(test '('#%kernel #%module-begin scheme/init #%plain-module-begin #f) identifier-binding* #'#%plain-module-begin) +(test '('#%kernel case-lambda scheme/init case-lambda #f #f) identifier-binding* #'case-lambda) +(test '(scheme/promise delay scheme/init delay #f #f) identifier-binding* #'delay) +(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])) -(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 (require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons])) bcons)) () [(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print) void)) (let ([s (syntax cons)]) - (test 'beginner:cons syntax-e s) ; 'was 'bcons + (test 'bcons syntax-e s) s)]))]) (let-values ([(real real-base) (module-path-index-split (car b))] [(nominal nominal-base) (module-path-index-split (caddr b))]) (test '"teachprims.ss" values real) (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))) (let ([b (identifier-binding (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss") cons)) () [(mod m beg (#%mod-beg cons)) (let ([s (syntax cons)]) - (test 'beginner:cons syntax-e s) ; was 'cons + (test 'cons syntax-e s) s)]))]) (let-values ([(real real-base) (module-path-index-split (car b))] [(nominal nominal-base) (module-path-index-split (caddr b))]) (test '"teachprims.ss" values real) (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/web-server/docs/reference/configuration.scrbl b/collects/web-server/docs/reference/configuration.scrbl index dcdb682ad5..8221f547cc 100644 --- a/collects/web-server/docs/reference/configuration.scrbl +++ b/collects/web-server/docs/reference/configuration.scrbl @@ -13,6 +13,8 @@ configuring the @web-server . @section[#:tag "configuration-table-structs.ss"]{Configuration Table Structure} @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 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 @@ -81,6 +83,8 @@ the configuration table S-expression file format described in @section[#:tag "configuration-table.ss"]{Configuration Table} @require[(for-label web-server/configuration/configuration-table)] +@defmodule[web-server/configuration/configuration-table] + @filepath{configuration/configuration-table.ss} provides functions for reading, writing, parsing, and printing @scheme[configuration-table] structures. @@ -152,6 +156,8 @@ This function writes a @scheme[configuration-table] to @scheme[path]. @section[#:tag "namespace.ss"]{Servlet Namespaces} @require[(for-label web-server/configuration/namespace)] +@defmodule[web-server/configuration/namespace] + @filepath{configuration/namespace.ss} provides a function to help create the @scheme[make-servlet-namespace] procedure needed by the @scheme[make] functions 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} @require[(for-label web-server/configuration/responders)] +@defmodule[web-server/configuration/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 turn the paths given in the @scheme[configuration-table] into responders for the associated circumstance. diff --git a/collects/web-server/docs/reference/dispatchers.scrbl b/collects/web-server/docs/reference/dispatchers.scrbl index 47dc27c5f6..7d4bd3f6cf 100644 --- a/collects/web-server/docs/reference/dispatchers.scrbl +++ b/collects/web-server/docs/reference/dispatchers.scrbl @@ -34,6 +34,8 @@ documentation will be useful. @section[#:tag "dispatch.ss"]{General} @require[(for-label web-server/dispatchers/dispatch)] +@defmodule[web-server/dispatchers/dispatch] + @filepath{dispatchers/dispatch.ss} provides a few functions for dispatchers in general. @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} @require[(for-label web-server/dispatchers/filesystem-map)] +@defmodule[web-server/dispatchers/filesystem-map] + @filepath{dispatchers/filesystem-map.ss} provides a means of mapping URLs to paths on the filesystem. diff --git a/collects/web-server/docs/reference/lang.scrbl b/collects/web-server/docs/reference/lang.scrbl index a05b268f92..765fe5477b 100644 --- a/collects/web-server/docs/reference/lang.scrbl +++ b/collects/web-server/docs/reference/lang.scrbl @@ -14,6 +14,8 @@ is different and what API is provided. @section[#:tag "lang-servlets"]{Definition} @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 @scheme[(lib "lang.ss" "web-server")] module language. It should provide the following identifier: @@ -102,6 +104,8 @@ by the Web language API. @section[#:tag "lang/web.ss"]{Web} @require[(for-label web-server/lang/web)] +@defmodule[web-server/lang/web] + @filepath{lang/web.ss} provides the most basic Web functionality. @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} @require[(for-label web-server/lang/stuff-url)] +@defmodule[web-server/lang/stuff-url] + @filepath{lang/stuff-url.ss} provides an interface for "stuffing" serializable values into URLs. Currently there is a particular 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} @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 Web Language servlets, due to the deployment scenarios available 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} @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 Web Language. @filepath{lang/web-param.ss} provides (roughly) the same functionality in a way that is serializable. Like other serializable diff --git a/collects/web-server/docs/reference/managers.scrbl b/collects/web-server/docs/reference/managers.scrbl index 4076ed00f6..cf1a39ea8b 100644 --- a/collects/web-server/docs/reference/managers.scrbl +++ b/collects/web-server/docs/reference/managers.scrbl @@ -17,6 +17,8 @@ pluggable through the manager interface. @section[#:tag "manager.ss"]{General} @require[(for-label web-server/managers/manager)] +@defmodule[web-server/managers/manager] + @filepath{managers/manager.ss} defines the manager interface. It is required by the users and implementers of managers. @@ -61,6 +63,8 @@ the users and implementers of managers. @section[#:tag "none.ss"]{No Continuations} @require[(for-label web-server/managers/none)] +@defmodule[web-server/managers/none] + @filepath{managers/none.ss} defines a manager constructor: @defproc[(create-none-manager (instance-expiration-handler expiration-handler?)) @@ -78,6 +82,8 @@ Web Language. (See @secref["lang"].) @section[#:tag "timeouts.ss"]{Timeouts} @require[(for-label web-server/managers/timeouts)] +@defmodule[web-server/managers/timeouts] + @filepath{managers/timeouts.ss} defines a manager constructor: @defproc[(create-timeout-manager [instance-exp-handler expiration-handler?] @@ -106,6 +112,8 @@ deployments of the @web-server . @section[#:tag "lru.ss"]{LRU} @require[(for-label web-server/managers/lru)] +@defmodule[web-server/managers/lru] + @filepath{managers/lru.ss} defines a manager constructor: @defproc[(create-LRU-manager diff --git a/collects/web-server/docs/reference/private.scrbl b/collects/web-server/docs/reference/private.scrbl index a3bbe34b50..98e91203f0 100644 --- a/collects/web-server/docs/reference/private.scrbl +++ b/collects/web-server/docs/reference/private.scrbl @@ -15,6 +15,8 @@ Some of these are documented here. @section[#:tag "timer.ss"]{Timers} @require[(for-label web-server/private/timer)] +@defmodule[web-server/private/timer] + @filepath{private/timer.ss} provides a functionality for running 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} @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 input and output ports. We have plans to allow a number of different strategies 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 provides two signatures. +@defsignature[dispatch-server^ ()]{ + The @scheme[dispatch-server^] signature is an alias for @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^ ()]{ @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/define-closure)] +@defmodule[web-server/private/closure] + The defunctionalization process of the Web Language (see @secref["lang"]) requires an explicit representation of closures that is serializable. @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} defines a helper form: +@subsection[#:style 'hidden]{Define Closure} +@defmodule[web-server/private/define-closure] + @defform[(define-closure tag formals (free-vars ...) body)]{ Defines a closure, constructed with @scheme[make-tag] that accepts @scheme[freevars ...], that when invoked with @scheme[formals] @@ -195,6 +218,8 @@ defines a helper form: @section[#:tag "cache-table.ss"]{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 functions. @@ -225,6 +250,8 @@ functions. @section[#:tag "mime-types.ss"]{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} files. @@ -245,8 +272,11 @@ files. @section[#:tag "mod-map.ss"]{Serialization Utilities} @require[(for-label web-server/private/mod-map)] -@scheme[(lib "serialize.ss")] provides the functionality of serializing -values. @filepath{private/mod-map.ss} compresses the serialized representation. +@defmodule[web-server/private/mod-map] + +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?]) compressed-serialized-value?]{ @@ -264,6 +294,8 @@ values. @filepath{private/mod-map.ss} compresses the serialized representation. @section[#:tag "url-param.ss"]{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 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 @@ -289,6 +321,8 @@ with this process. @section[#:tag "util.ss"]{Miscellaneous Utilities} @require[(for-label web-server/private/util)] +@defmodule[web-server/private/util] + There are a number of other miscellaneous utilities the @web-server needs. They are provided by @filepath{private/util.ss}. diff --git a/collects/web-server/docs/reference/running.scrbl b/collects/web-server/docs/reference/running.scrbl index 4654328893..7482807943 100644 --- a/collects/web-server/docs/reference/running.scrbl +++ b/collects/web-server/docs/reference/running.scrbl @@ -34,6 +34,8 @@ the server runs until the process is killed. @section[#:tag "web-server.ss"]{Functional} @require[(for-label web-server/web-server)] +@defmodule[web-server/web-server] + @filepath{web-server.ss} provides a number of functions for easing embedding of the @web-server in other applications, or loading a custom dispatcher. See @filepath{run.ss} for an example of such a script. diff --git a/collects/web-server/docs/reference/servlet-env.scrbl b/collects/web-server/docs/reference/servlet-env.scrbl index 0dee8f7ea2..afd122fc8c 100644 --- a/collects/web-server/docs/reference/servlet-env.scrbl +++ b/collects/web-server/docs/reference/servlet-env.scrbl @@ -5,6 +5,8 @@ #:style 'toc]{Environment} @require[(for-label web-server/servlet-env)] +@defmodule[web-server/servlet-env] + The @web-server provides a means of running Scheme servlets from within DrScheme, or any other REPL. diff --git a/collects/web-server/docs/reference/servlet.scrbl b/collects/web-server/docs/reference/servlet.scrbl index e0544f3a45..66f85e678f 100644 --- a/collects/web-server/docs/reference/servlet.scrbl +++ b/collects/web-server/docs/reference/servlet.scrbl @@ -14,6 +14,8 @@ of these servlets. This API is provided by @filepath{servlet.ss}. @section[#:tag "module-servlets"]{Definition} @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: @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} @require[(for-label web-server/servlet/servlet-structs)] +@defmodule[web-server/servlet/servlet-structs] + @filepath{servlet/servlet-structs.ss} provides a number of contracts for use in servlets. @@ -63,6 +67,8 @@ for use in servlets. @section[#:tag "request-structs.ss"]{HTTP Requests} @require[(for-label web-server/private/request-structs)] +@defmodule[web-server/private/request-structs] + @; XXX Create http sub-directory @; XXX Have this include read-request and write-response @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} @require[(for-label web-server/servlet/bindings)] +@defmodule[web-server/servlet/bindings] + @filepath{servlet/bindings.ss} provides a number of helper functions for accessing request bindings. @@ -169,6 +177,8 @@ you lose the filename. @section[#:tag "response-structs.ss"]{HTTP Responses} @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 HTTP responses. @@ -305,6 +315,8 @@ functions of interest for the servlet developer.} @section[#:tag "helpers.ss"]{Helpers} @require[(for-label web-server/servlet/helpers)] +@defmodule[web-server/servlet/helpers] + @filepath{servlet/helpers.ss} provides functions built on @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} @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. 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} @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 implementation of HTTP Basic Authentication. diff --git a/collects/web-server/docs/web-server.ss b/collects/web-server/docs/web-server.ss index 218d39c1ad..249f60e65b 100644 --- a/collects/web-server/docs/web-server.ss +++ b/collects/web-server/docs/web-server.ss @@ -1,6 +1,9 @@ #lang scheme/base (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") @@ -19,6 +22,9 @@ (provide (all-from-out (lib "manual.ss" "scribble")) (all-from-out (lib "eval.ss" "scribble")) + (for-label (all-from-out scheme/base + scheme/contract + scheme/unit)) web-server author warning diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 25f3c56317..95e2e69817 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -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, 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, -119,1,178,1,223,1,45,2,90,2,95,2,115,2,245,2,9,3,57,3,123, -3,6,4,148,4,191,4,202,4,25,5,0,0,29,7,0,0,65,98,101,103, +0,177,0,179,0,193,0,203,0,209,0,232,0,33,1,43,1,60,1,93,1, +126,1,185,1,230,1,52,2,97,2,102,2,122,2,252,2,16,3,64,3,130, +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, 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, @@ -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, 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, -95,8,240,48,117,0,0,11,16,0,95,8,193,11,16,0,96,35,11,93,158, -2,16,34,16,2,2,13,159,2,2,35,2,13,97,10,34,11,94,158,2,15, -34,158,2,16,34,16,20,2,9,2,2,2,3,2,2,2,4,2,2,2,5, -2,2,2,10,2,2,2,7,2,2,2,8,2,2,2,6,2,2,2,11,2, -2,2,12,2,2,13,16,4,34,29,11,11,2,2,11,18,98,64,104,101,114, -101,8,31,8,30,8,29,8,28,8,27,27,248,22,178,3,195,249,22,171,3, -80,158,37,34,251,22,73,2,17,248,22,88,199,12,249,22,63,2,1,248,22, -90,201,27,248,22,178,3,195,249,22,171,3,80,158,37,34,251,22,73,2,17, -248,22,88,199,249,22,63,2,1,248,22,90,201,12,27,248,22,65,248,22,178, -3,196,28,248,22,71,193,20,15,159,35,34,35,28,248,22,71,248,22,65,194, -248,22,64,193,249,22,171,3,80,158,37,34,251,22,73,2,17,248,22,64,199, -249,22,63,2,7,248,22,65,201,11,18,100,10,8,31,8,30,8,29,8,28, -8,27,16,4,11,11,2,18,3,1,7,101,110,118,54,55,55,56,16,4,11, -11,2,19,3,1,7,101,110,118,54,55,55,57,27,248,22,65,248,22,178,3, -196,28,248,22,71,193,20,15,159,35,34,35,28,248,22,71,248,22,65,194,248, -22,64,193,249,22,171,3,80,158,37,34,250,22,73,2,20,248,22,73,249,22, -73,248,22,73,2,21,248,22,64,201,251,22,73,2,17,2,21,2,21,249,22, -63,2,9,248,22,65,204,18,100,11,8,31,8,30,8,29,8,28,8,27,16, -4,11,11,2,18,3,1,7,101,110,118,54,55,56,49,16,4,11,11,2,19, -3,1,7,101,110,118,54,55,56,50,248,22,178,3,193,27,248,22,178,3,194, -249,22,63,248,22,73,248,22,64,196,248,22,65,195,27,248,22,65,248,22,178, -3,196,249,22,171,3,80,158,37,34,28,248,22,51,248,22,172,3,248,22,64, -197,27,249,22,2,32,0,89,162,8,36,35,41,9,222,33,39,248,22,178,3, -248,22,88,199,250,22,73,2,22,248,22,73,249,22,73,248,22,73,248,22,64, -203,250,22,74,2,23,249,22,2,22,64,203,248,22,90,205,249,22,63,248,22, -64,201,249,22,2,22,88,199,250,22,74,2,20,249,22,2,32,0,89,162,34, -35,45,9,222,33,40,248,22,178,3,248,22,64,201,248,22,65,198,27,248,22, -178,3,194,249,22,63,248,22,73,248,22,64,196,248,22,65,195,27,248,22,65, -248,22,178,3,196,249,22,171,3,80,158,37,34,250,22,74,2,22,249,22,2, -32,0,89,162,34,35,45,9,222,33,42,248,22,178,3,248,22,64,201,248,22, -65,198,27,248,22,65,248,22,178,3,196,27,248,22,178,3,248,22,64,195,249, -22,171,3,80,158,38,34,28,248,22,71,195,250,22,74,2,20,9,248,22,65, -199,250,22,73,2,4,248,22,73,248,22,64,199,250,22,74,2,3,248,22,65, -201,248,22,65,202,27,248,22,65,248,22,178,3,196,27,249,22,1,22,77,249, -22,2,22,178,3,248,22,178,3,248,22,64,199,249,22,171,3,80,158,38,34, -251,22,73,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111, -110,45,109,97,114,107,2,24,250,22,74,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,21,95,1,27,99,111, -110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102, -105,114,115,116,11,2,24,201,250,22,74,2,20,9,248,22,65,203,27,248,22, -65,248,22,178,3,196,28,248,22,71,193,20,15,159,35,34,35,249,22,171,3, -80,158,37,34,27,248,22,178,3,248,22,64,197,28,249,22,137,8,62,61,62, -248,22,172,3,248,22,88,196,250,22,73,2,20,248,22,73,249,22,73,21,93, -2,25,248,22,64,199,250,22,74,2,6,249,22,73,2,25,249,22,73,248,22, -97,203,2,25,248,22,65,202,251,22,73,2,17,28,249,22,137,8,248,22,172, -3,248,22,64,200,64,101,108,115,101,10,248,22,64,197,250,22,74,2,20,9, -248,22,65,200,249,22,63,2,6,248,22,65,202,99,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,54,56,48,52,16,4, -11,11,2,19,3,1,7,101,110,118,54,56,48,53,18,158,94,10,64,118,111, -105,100,8,47,27,248,22,65,248,22,178,3,196,249,22,171,3,80,158,37,34, -28,248,22,51,248,22,172,3,248,22,64,197,250,22,73,2,26,248,22,73,248, -22,64,199,248,22,88,198,27,248,22,172,3,248,22,64,197,250,22,73,2,26, -248,22,73,248,22,64,197,250,22,74,2,23,248,22,65,199,248,22,65,202,159, -34,20,102,159,34,16,1,20,24,2,1,16,0,83,158,40,20,99,131,69,35, -37,109,105,110,45,115,116,120,2,2,10,11,10,10,10,10,34,80,158,34,34, -20,102,159,34,16,0,16,0,11,11,16,0,34,11,11,16,0,16,0,16,0, -34,34,11,16,0,16,0,16,0,34,34,11,16,10,2,3,2,4,2,5,2, +95,8,240,48,117,0,0,11,16,0,95,8,193,11,16,0,96,35,11,93,159, +2,16,34,35,16,2,2,13,161,2,2,35,2,13,2,2,2,13,97,10,34, +11,94,159,2,15,34,34,159,2,16,34,34,16,20,2,9,2,2,2,3,2, +2,2,4,2,2,2,5,2,2,2,10,2,2,2,7,2,2,2,8,2,2, +2,6,2,2,2,11,2,2,2,12,2,2,13,16,4,34,29,11,11,2,2, +11,18,98,64,104,101,114,101,8,31,8,30,8,29,8,28,8,27,27,248,22, +178,3,195,249,22,171,3,80,158,37,34,251,22,73,2,17,248,22,88,199,12, +249,22,63,2,1,248,22,90,201,27,248,22,178,3,195,249,22,171,3,80,158, +37,34,251,22,73,2,17,248,22,88,199,249,22,63,2,1,248,22,90,201,12, +27,248,22,65,248,22,178,3,196,28,248,22,71,193,20,15,159,35,34,35,28, +248,22,71,248,22,65,194,248,22,64,193,249,22,171,3,80,158,37,34,251,22, +73,2,17,248,22,64,199,249,22,63,2,7,248,22,65,201,11,18,100,10,8, +31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,7,101,110,118, +54,55,55,56,16,4,11,11,2,19,3,1,7,101,110,118,54,55,55,57,27, +248,22,65,248,22,178,3,196,28,248,22,71,193,20,15,159,35,34,35,28,248, +22,71,248,22,65,194,248,22,64,193,249,22,171,3,80,158,37,34,250,22,73, +2,20,248,22,73,249,22,73,248,22,73,2,21,248,22,64,201,251,22,73,2, +17,2,21,2,21,249,22,63,2,9,248,22,65,204,18,100,11,8,31,8,30, +8,29,8,28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,54,55,56, +49,16,4,11,11,2,19,3,1,7,101,110,118,54,55,56,50,248,22,178,3, +193,27,248,22,178,3,194,249,22,63,248,22,73,248,22,64,196,248,22,65,195, +27,248,22,65,248,22,178,3,196,249,22,171,3,80,158,37,34,28,248,22,51, +248,22,172,3,248,22,64,197,27,249,22,2,32,0,89,162,8,36,35,41,9, +222,33,39,248,22,178,3,248,22,88,199,250,22,73,2,22,248,22,73,249,22, +73,248,22,73,248,22,64,203,250,22,74,2,23,249,22,2,22,64,203,248,22, +90,205,249,22,63,248,22,64,201,249,22,2,22,88,199,250,22,74,2,20,249, +22,2,32,0,89,162,34,35,45,9,222,33,40,248,22,178,3,248,22,64,201, +248,22,65,198,27,248,22,178,3,194,249,22,63,248,22,73,248,22,64,196,248, +22,65,195,27,248,22,65,248,22,178,3,196,249,22,171,3,80,158,37,34,250, +22,74,2,22,249,22,2,32,0,89,162,34,35,45,9,222,33,42,248,22,178, +3,248,22,64,201,248,22,65,198,27,248,22,65,248,22,178,3,196,27,248,22, +178,3,248,22,64,195,249,22,171,3,80,158,38,34,28,248,22,71,195,250,22, +74,2,20,9,248,22,65,199,250,22,73,2,4,248,22,73,248,22,64,199,250, +22,74,2,3,248,22,65,201,248,22,65,202,27,248,22,65,248,22,178,3,196, +27,249,22,1,22,77,249,22,2,22,178,3,248,22,178,3,248,22,64,199,249, +22,171,3,80,158,38,34,251,22,73,1,22,119,105,116,104,45,99,111,110,116, +105,110,117,97,116,105,111,110,45,109,97,114,107,2,24,250,22,74,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,21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114, +107,45,115,101,116,45,102,105,114,115,116,11,2,24,201,250,22,74,2,20,9, +248,22,65,203,27,248,22,65,248,22,178,3,196,28,248,22,71,193,20,15,159, +35,34,35,249,22,171,3,80,158,37,34,27,248,22,178,3,248,22,64,197,28, +249,22,137,8,62,61,62,248,22,172,3,248,22,88,196,250,22,73,2,20,248, +22,73,249,22,73,21,93,2,25,248,22,64,199,250,22,74,2,6,249,22,73, +2,25,249,22,73,248,22,97,203,2,25,248,22,65,202,251,22,73,2,17,28, +249,22,137,8,248,22,172,3,248,22,64,200,64,101,108,115,101,10,248,22,64, +197,250,22,74,2,20,9,248,22,65,200,249,22,63,2,6,248,22,65,202,99, +8,31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,7,101,110, +118,54,56,48,52,16,4,11,11,2,19,3,1,7,101,110,118,54,56,48,53, +18,158,94,10,64,118,111,105,100,8,47,27,248,22,65,248,22,178,3,196,249, +22,171,3,80,158,37,34,28,248,22,51,248,22,172,3,248,22,64,197,250,22, +73,2,26,248,22,73,248,22,64,199,248,22,88,198,27,248,22,172,3,248,22, +64,197,250,22,73,2,26,248,22,73,248,22,64,197,250,22,74,2,23,248,22, +65,199,248,22,65,202,159,34,20,102,159,34,16,1,20,24,2,1,16,0,83, +158,40,20,99,134,69,35,37,109,105,110,45,115,116,120,2,2,10,11,10,10, +10,10,34,80,158,34,34,20,102,159,34,16,0,16,0,11,11,16,0,34,11, +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, 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, @@ -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, 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}; - 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, 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, 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, -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, 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, @@ -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, 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, -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, 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, @@ -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, 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, -3,16,0,11,11,16,4,2,6,2,5,2,3,2,9,38,11,11,16,0,16, -0,16,0,34,34,11,16,0,16,0,16,0,34,34,11,16,11,2,8,2,7, -2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,16,11,11, -11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,16,2,15,2, -13,2,12,2,4,2,11,2,14,2,10,2,2,45,45,16,0,16,18,83,158, -34,16,2,89,162,34,35,47,2,19,223,0,33,30,80,159,34,53,35,83,158, -34,16,2,89,162,34,35,54,2,19,223,0,33,31,80,159,34,52,35,83,158, -34,16,2,89,162,8,36,35,43,9,223,0,33,32,80,159,34,51,35,83,158, -34,16,2,32,0,89,162,34,35,43,2,2,222,33,33,80,159,34,34,35,83, -158,34,16,2,249,22,135,6,7,92,7,92,80,159,34,35,35,83,158,34,16, -2,89,162,34,35,52,2,4,223,0,33,34,80,159,34,36,35,83,158,34,16, -2,32,0,89,162,34,36,48,2,5,222,33,35,80,159,34,37,35,83,158,34, -16,2,32,0,89,162,34,37,49,2,6,222,33,37,80,159,34,38,35,83,158, -34,16,2,89,162,8,37,36,46,2,7,223,0,33,39,80,159,34,39,35,83, -158,34,16,2,32,0,89,162,34,38,50,2,8,222,33,42,80,159,34,40,35, -83,158,34,16,2,32,0,89,162,34,37,48,2,9,222,33,43,80,159,34,41, -35,83,158,34,16,2,32,0,89,162,34,36,51,2,10,222,33,44,80,159,34, -42,35,83,158,34,16,2,32,0,89,162,34,36,52,2,11,222,33,45,80,159, -34,43,35,83,158,34,16,2,32,0,89,162,34,35,42,2,12,222,33,46,80, -159,34,44,35,83,158,34,16,2,83,158,37,20,96,95,2,13,89,162,34,34, -41,9,223,0,33,47,89,162,34,35,51,9,223,0,33,48,80,159,34,45,35, -83,158,34,16,2,27,248,22,140,13,248,22,144,7,27,28,249,22,137,8,247, -22,152,7,2,21,6,1,1,59,6,1,1,58,250,22,181,6,6,14,14,40, -91,94,126,97,93,42,41,126,97,40,46,42,41,195,195,89,162,34,36,46,2, -14,223,0,33,51,80,159,34,46,35,83,158,34,16,2,83,158,37,20,96,96, -2,15,89,162,8,36,37,52,9,223,0,33,56,89,162,34,36,45,9,223,0, -33,57,89,162,34,35,44,9,223,0,33,58,80,159,34,47,35,83,158,34,16, -2,89,162,34,36,49,2,16,223,0,33,60,80,159,34,48,35,94,29,94,2, -17,2,29,11,29,94,2,17,69,35,37,109,105,110,45,115,116,120,11,9,9, -0}; - EVAL_ONE_SIZED_STR((char *)expr, 4179); +3,16,0,11,11,16,4,2,6,2,5,2,3,2,9,38,11,11,11,16,0, +16,0,16,0,34,34,11,11,16,0,16,0,16,0,34,34,11,16,11,9,9, +9,9,9,9,9,9,9,9,9,16,11,2,8,2,7,2,16,2,15,2,13, +2,12,2,4,2,11,2,14,2,10,2,2,16,11,11,11,11,11,11,11,11, +11,11,11,11,16,11,2,8,2,7,2,16,2,15,2,13,2,12,2,4,2, +11,2,14,2,10,2,2,45,45,16,0,16,18,83,158,34,16,2,89,162,34, +35,47,2,19,223,0,33,30,80,159,34,53,35,83,158,34,16,2,89,162,34, +35,54,2,19,223,0,33,31,80,159,34,52,35,83,158,34,16,2,89,162,8, +36,35,43,9,223,0,33,32,80,159,34,51,35,83,158,34,16,2,32,0,89, +162,34,35,43,2,2,222,33,33,80,159,34,34,35,83,158,34,16,2,249,22, +135,6,7,92,7,92,80,159,34,35,35,83,158,34,16,2,89,162,34,35,52, +2,4,223,0,33,34,80,159,34,36,35,83,158,34,16,2,32,0,89,162,34, +36,48,2,5,222,33,35,80,159,34,37,35,83,158,34,16,2,32,0,89,162, +34,37,49,2,6,222,33,37,80,159,34,38,35,83,158,34,16,2,89,162,8, +37,36,46,2,7,223,0,33,39,80,159,34,39,35,83,158,34,16,2,32,0, +89,162,34,38,50,2,8,222,33,42,80,159,34,40,35,83,158,34,16,2,32, +0,89,162,34,37,48,2,9,222,33,43,80,159,34,41,35,83,158,34,16,2, +32,0,89,162,34,36,51,2,10,222,33,44,80,159,34,42,35,83,158,34,16, +2,32,0,89,162,34,36,52,2,11,222,33,45,80,159,34,43,35,83,158,34, +16,2,32,0,89,162,34,35,42,2,12,222,33,46,80,159,34,44,35,83,158, +34,16,2,83,158,37,20,96,95,2,13,89,162,34,34,41,9,223,0,33,47, +89,162,34,35,51,9,223,0,33,48,80,159,34,45,35,83,158,34,16,2,27, +248,22,140,13,248,22,144,7,27,28,249,22,137,8,247,22,152,7,2,21,6, +1,1,59,6,1,1,58,250,22,181,6,6,14,14,40,91,94,126,97,93,42, +41,126,97,40,46,42,41,195,195,89,162,34,36,46,2,14,223,0,33,51,80, +159,34,46,35,83,158,34,16,2,83,158,37,20,96,96,2,15,89,162,8,36, +37,52,9,223,0,33,56,89,162,34,36,45,9,223,0,33,57,89,162,34,35, +44,9,223,0,33,58,80,159,34,47,35,83,158,34,16,2,89,162,34,36,49, +2,16,223,0,33,60,80,159,34,48,35,94,29,94,2,17,2,29,11,29,94, +2,17,69,35,37,109,105,110,45,115,116,120,11,9,9,0}; + 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, -0,34,0,48,0,62,0,76,0,0,0,245,0,0,0,65,113,117,111,116,101, + 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,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, 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, 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, -11,11,10,10,18,94,11,97,10,34,11,97,158,2,2,34,158,2,3,34,158, -2,4,34,158,2,5,34,158,2,6,34,16,0,18,94,11,95,35,11,16,0, -10,18,94,11,95,8,240,48,117,0,0,11,16,0,34,80,158,34,34,20,102, -159,34,16,0,16,0,11,11,16,0,34,11,11,16,0,16,0,16,0,34,34, -11,16,0,16,0,16,0,34,34,11,16,0,16,0,16,0,34,34,16,0,16, -0,98,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11, -2,4,2,3,2,2,9,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 281); +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,159,2,2,34,34,159,2,3,34, +34,159,2,4,34,34,159,2,5,34,34,159,2,6,34,34,16,0,18,94,11, +95,35,11,16,0,10,18,94,11,95,8,240,48,117,0,0,11,16,0,34,80, +158,34,34,20,102,159,34,16,0,16,0,11,11,16,0,34,11,11,11,16,0, +16,0,16,0,34,34,11,11,16,0,16,0,16,0,34,34,11,11,16,0,16, +0,16,0,34,34,16,0,16,0,98,2,6,2,5,29,94,2,1,69,35,37, +102,111,114,101,105,103,110,11,2,4,2,3,2,2,9,9,0}; + 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, 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, 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, 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, @@ -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, 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, -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, 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, @@ -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, 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, -45,11,11,16,0,16,0,16,0,34,34,11,16,0,16,0,16,0,34,34,11, -16,1,2,16,16,1,11,16,1,2,16,35,35,16,0,16,16,83,158,34,16, -2,89,162,34,35,43,9,223,0,33,23,80,159,34,56,35,83,158,34,16,2, -89,162,8,36,35,43,9,223,0,33,24,80,159,34,55,35,83,158,34,16,2, -89,162,34,35,47,67,103,101,116,45,100,105,114,223,0,33,25,80,159,34,54, -35,83,158,34,16,2,89,162,34,36,47,68,119,105,116,104,45,100,105,114,223, -0,33,26,80,159,34,53,35,83,158,34,16,2,248,22,152,7,69,115,111,45, -115,117,102,102,105,120,80,159,34,34,35,83,158,34,16,2,89,162,34,36,58, -2,3,223,0,33,35,80,159,34,35,35,83,158,34,16,2,32,0,89,162,8, -36,35,40,2,7,222,192,80,159,34,40,35,83,158,34,16,2,248,22,120,2, -18,80,159,34,41,35,83,158,34,16,2,249,22,120,2,18,65,101,113,117,97, -108,80,159,34,42,35,83,158,34,16,2,247,22,59,80,159,34,43,35,83,158, -34,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103, -80,159,34,44,35,83,158,34,16,2,11,80,158,34,45,83,158,34,16,2,11, -80,158,34,46,83,158,34,16,2,32,0,89,162,34,36,43,2,14,222,33,41, -80,159,34,47,35,83,158,34,16,2,89,162,8,36,35,43,2,15,223,0,33, -50,80,159,34,48,35,83,158,34,16,2,89,162,34,34,42,2,16,223,0,33, -51,80,159,34,52,35,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11, -29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 3568); +45,11,11,11,16,0,16,0,16,0,34,34,11,11,16,0,16,0,16,0,34, +34,11,16,1,9,16,1,2,16,16,1,11,16,1,2,16,35,35,16,0,16, +16,83,158,34,16,2,89,162,34,35,43,9,223,0,33,23,80,159,34,56,35, +83,158,34,16,2,89,162,8,36,35,43,9,223,0,33,24,80,159,34,55,35, +83,158,34,16,2,89,162,34,35,47,67,103,101,116,45,100,105,114,223,0,33, +25,80,159,34,54,35,83,158,34,16,2,89,162,34,36,47,68,119,105,116,104, +45,100,105,114,223,0,33,26,80,159,34,53,35,83,158,34,16,2,248,22,152, +7,69,115,111,45,115,117,102,102,105,120,80,159,34,34,35,83,158,34,16,2, +89,162,34,36,58,2,3,223,0,33,35,80,159,34,35,35,83,158,34,16,2, +32,0,89,162,8,36,35,40,2,7,222,192,80,159,34,40,35,83,158,34,16, +2,248,22,120,2,18,80,159,34,41,35,83,158,34,16,2,249,22,120,2,18, +65,101,113,117,97,108,80,159,34,42,35,83,158,34,16,2,247,22,59,80,159, +34,43,35,83,158,34,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111, +97,100,105,110,103,80,159,34,44,35,83,158,34,16,2,11,80,158,34,45,83, +158,34,16,2,11,80,158,34,46,83,158,34,16,2,32,0,89,162,34,36,43, +2,14,222,33,41,80,159,34,47,35,83,158,34,16,2,89,162,8,36,35,43, +2,15,223,0,33,50,80,159,34,48,35,83,158,34,16,2,89,162,34,34,42, +2,16,223,0,33,51,80,159,34,52,35,95,29,94,2,4,68,35,37,107,101, +114,110,101,108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2, +5,9,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 3573); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 9a9264c2ec..2a1bdd4e3d 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1121,6 +1121,7 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo) env->module->self_modidx, n, env->mod_phase, + -1, 0); } } @@ -1844,7 +1845,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec existing rename. */ if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (is_def != 2)) { 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 have been an error before getting here */ && 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; - 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? */ 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)) { return 1; } 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)) return 1; } diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 33fd01d27c..ecfb4d27a2 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -1553,7 +1553,7 @@ static void do_wrong_syntax(const char *where, if (scheme_current_thread->current_local_env) phase = scheme_current_thread->current_local_env->genv->phase; else phase = 0; - scheme_stx_module_name(&first, phase, &mod, &nomwho, NULL); + scheme_stx_module_name(&first, phase, &mod, &nomwho, NULL, NULL); } } } else { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1bcd6af234..6db15d030c 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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))) { /* Since the module has a rename for this id, it's certainly defined. */ } 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 it's an access path, resolve it: */ if (env->genv->module diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index ce299d5744..41a497c633 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -187,7 +187,8 @@ static Scheme_Object *global_shift_cache; static Scheme_Bucket_Table *modpath_table; #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, int isval, void *data, Scheme_Object *e, Scheme_Object *form, 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 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); #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); 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); @@ -638,7 +640,7 @@ void scheme_require_from_original_env(Scheme_Env *env, int syntax_only) } 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) @@ -1932,7 +1934,7 @@ static int do_add_require_renames(Scheme_Object *rn, if (with_shared) { if (!pt->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); @@ -1949,13 +1951,13 @@ static int do_add_require_renames(Scheme_Object *rn, midx = idx; if (!with_shared) { 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)) saw_mb = 1; if (required) { - vec = scheme_make_vector(8, NULL); + vec = scheme_make_vector(7, NULL); nml = scheme_make_pair(idx, scheme_null); SCHEME_VEC_ELS(vec)[0] = nml; 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)[5] = orig_src; SCHEME_VEC_ELS(vec)[6] = mark_src; - SCHEME_VEC_ELS(vec)[7] = scheme_make_integer(0x1); 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; for (i = kernel->me->rt->num_provides; 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); SCHEME_VEC_ELS(vec)[0] = nml; 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)[5] = orig_src; SCHEME_VEC_ELS(vec)[6] = mark_src; - SCHEME_VEC_ELS(vec)[7] = scheme_make_integer(0x1); scheme_hash_set(required, exs[i], vec); } } @@ -1998,7 +1998,8 @@ static int do_add_require_renames(Scheme_Object *rn, if (!with_shared) { 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); } @@ -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++) { if (SCHEME_FALSEP(m->me->rt->provide_srcs[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: */ for (i = 0; i < m->num_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: */ @@ -2340,6 +2341,15 @@ static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[]) 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[]) { Scheme_Module *m; @@ -2369,10 +2379,10 @@ static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]) vl = scheme_null; n = pt->num_var_provides; 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) { - vl = scheme_make_pair(pt->provides[i], vl); + vl = scheme_make_pair(make_provide_desc(pt, i), 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[]) { - if (SCHEME_MODNAMEP(argv[0])) - scheme_wrong_type("module-path-index-join", "non-resolved-module-path", 0, argc, argv); + if (!SCHEME_PATHP(argv[0]) + && !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 (SCHEME_TRUEP(argv[1]) && !SCHEME_MODNAMEP(argv[1]) && !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); + + 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); @@ -2619,8 +2636,9 @@ static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx, a[3] = (load_it ? scheme_true : scheme_false); if (SCHEME_FALSEP(a[0])) { - scheme_wrong_syntax("require", NULL, NULL, - "broken compiled/expanded code: unresolved module index without path"); + scheme_arg_mismatch("module-path-index-resolve", + "\"self\" index has no resolution: ", + modidx); } 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_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; } @@ -3869,14 +3887,17 @@ static Scheme_Module_Exports *make_module_exports() pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports); + pt->phase_index = 0; me->rt = pt; pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports); + pt->phase_index = 1; me->et = pt; pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); SET_REQUIRED_TAG(pt->type = scheme_rt_module_phase_exports); + pt->phase_index = 2; me->dt = pt; return me; @@ -4899,7 +4920,23 @@ Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *e /* #%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, int isval, void *tables, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, @@ -4919,6 +4956,15 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc scheme_wrong_syntax("module", prnt_name, form, "imported identifier already defined"); } } + + 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: */ vec = scheme_hash_get(required, name); @@ -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. */ nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]); 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; } @@ -4970,7 +5014,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc } /* Remember require: */ - vec = scheme_make_vector(8, NULL); + vec = scheme_make_vector(7, NULL); nml = scheme_make_pair(nominal_modidx, scheme_null); SCHEME_VEC_ELS(vec)[0] = nml; 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)[5] = (err_src ? err_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); } @@ -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); /* 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 = id; @@ -5379,9 +5422,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, /* Add a renaming: */ 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 - 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); } @@ -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)) 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 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++; } @@ -5865,7 +5908,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, 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) { @@ -6116,10 +6159,13 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov if (vec) { /* Check for nominal modidx in list */ - Scheme_Object *nml; + Scheme_Object *nml, *nml_modidx; nml = SCHEME_VEC_ELS(vec)[0]; 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; } 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]; 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 (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { - nominal_modidx = SCHEME_CAR(nml); - if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) { + for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { + for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(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)) { + 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; break_outer = 1; @@ -6387,6 +6444,37 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind 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, Scheme_Module_Phase_Exports *pt, 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) { int i, count; - Scheme_Object **exs, **exsns, **exss; + Scheme_Object **exs, **exsns, **exss, **exsnoms; char *exps, *exets; 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); exsns = MALLOC_N(Scheme_Object *, count); exss = MALLOC_N(Scheme_Object *, count); + exsnoms = MALLOC_N(Scheme_Object *, count); exps = MALLOC_N_ATOMIC(char, count); if (def_phase) { 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]; exsns[count] = name; exss[count] = scheme_false; /* means "self" */ + exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; if (exets) 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])) { /* skip */ } else { + Scheme_Object *noms; exs[count] = provided->keys[i]; exsns[count] = SCHEME_VEC_ELS(v)[2]; 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; count++; } @@ -6496,6 +6589,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req exs[count] = provided->keys[i]; exsns[count] = name; exss[count] = scheme_false; /* means "self" */ + exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; if (exets) 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])) { /* skip */ } else { + Scheme_Object *noms; exs[count] = provided->keys[i]; exsns[count] = SCHEME_VEC_ELS(v)[2]; 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; count++; } @@ -6522,16 +6619,26 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req 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 uninterned, alphabetical within each. This is important for 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_var_provides = exvcount; pt->provides = exs; pt->provide_src_names = exsns; pt->provide_srcs = exss; + pt->provide_nominal_srcs = exsnoms; if (exets) { for (i = 0; i < excount; i++) { if (exets[i]) @@ -6546,11 +6653,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *provided, Scheme_Hash_Table *req } /* Helper: */ -static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, - int start, int count, int do_uninterned) +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 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; if (do_uninterned) { @@ -6585,6 +6694,13 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exets[i] = exets[j]; exets[j] = tmp_exet; } + if (exsnoms) { + tmp_exsnom = exsnoms[i]; + + exsnoms[i] = exsnoms[j]; + + exsnoms[j] = tmp_exsnom; + } j--; /* 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: */ - qsort_provides(exs, exsns, exss, exps, exets, 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, 0, j + 1, 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j + 1, count - j - 1, 0); } else { j = start; while (count > 1) { @@ -6631,7 +6747,15 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exets[k] = exets[j]; exets[j] = tmp_exet; } - + + if (exsnoms) { + tmp_exsnom = exsnoms[k]; + + exsnoms[k] = exsnoms[j]; + + exsnoms[j] = tmp_exsnom; + } + j++; } } @@ -6644,8 +6768,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob } if (count > 1) { - qsort_provides(exs, exsns, exss, exps, exets, start, j - start, 0); - qsort_provides(exs, exsns, exss, exps, exets, j, count - (j - start), 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, start, 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: */ if (!pt->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; } else skip_rename = 0; @@ -7343,7 +7467,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ } 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); 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), modidx, iname, exsns[j], nominal_modidx, exs[j], exets ? exets[j] : 0, + src_phase_index, 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 a Module_Renames. Also the idx must be first, to support shifting. */ 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); @@ -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_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_Env *env; - int share_all; + int share_all, src_phase_index; idx = SCHEME_CAR(info); orig_idx = idx; info = SCHEME_CDR(info); + kv = SCHEME_CAR(info); + info = SCHEME_CDR(info); if (SCHEME_INTP(info)) { share_all = 1; - kv = info; + spi = info; + exns = NULL; prefix = NULL; } else { share_all = 0; - kv = SCHEME_CAR(info); + spi = SCHEME_CAR(info); info = SCHEME_CDR(info); exns = SCHEME_CAR(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) { Scheme_Module_Phase_Exports *pt; 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) 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 { - 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, 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, int isval, void *ht, Scheme_Object *e, Scheme_Object *form, 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); + 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) { v = scheme_make_vector(count, NULL); for (i = 0; i < count; i++) { @@ -8246,7 +8388,7 @@ static Scheme_Object *read_module(Scheme_Object *obj) { Scheme_Module *m; 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_Phase_Exports *pt; char *ps, *sps; @@ -8360,6 +8502,10 @@ static Scheme_Object *read_module(Scheme_Object *obj) esph = SCHEME_CAR(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(); esn = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); @@ -8405,6 +8551,17 @@ static Scheme_Object *read_module(Scheme_Object *obj) } 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)) sps = NULL; else { diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index bfaae62416..36f1d424f9 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -2421,6 +2421,7 @@ static int module_phase_exports_val_MARK(void *p) { gcMARK(m->provides); gcMARK(m->provide_srcs); gcMARK(m->provide_src_names); + gcMARK(m->provide_nominal_srcs); gcMARK(m->provide_src_phases); gcMARK(m->kernel_exclusion); @@ -2440,6 +2441,7 @@ static int module_phase_exports_val_FIXUP(void *p) { gcFIXUP(m->provides); gcFIXUP(m->provide_srcs); gcFIXUP(m->provide_src_names); + gcFIXUP(m->provide_nominal_srcs); gcFIXUP(m->provide_src_phases); gcFIXUP(m->kernel_exclusion); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index b8adf73c77..7ae9bac768 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -966,6 +966,7 @@ module_phase_exports_val { gcMARK(m->provides); gcMARK(m->provide_srcs); gcMARK(m->provide_src_names); + gcMARK(m->provide_nominal_srcs); gcMARK(m->provide_src_phases); gcMARK(m->kernel_exclusion); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index c969b4e48f..ec6e4594b1 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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, Scheme_Object *locname, Scheme_Object *exname, 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, struct Scheme_Module_Phase_Exports *pt, int k, + int src_phase_index, int save_unmarshal); 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); @@ -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 **nominal_modidx, 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); 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); +XFORM_NONGCING Scheme_Object *scheme_phase_index_symbol(int src_phase_index); + 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 + int phase_index; + Scheme_Object *src_modidx; /* same as in enclosing Scheme_Module_Exports */ Scheme_Object **provides; /* symbols (extenal names) */ Scheme_Object **provide_srcs; /* module access paths, #f for self */ 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 */ int num_provides; int num_var_provides; /* non-syntax listed first in provides */ diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index c554649c12..8cde526dd3 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -10,12 +10,12 @@ The string and the separate X/Y/Z/W numbers must 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_Y 99 #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_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 6be94e877b..3c70734776 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -121,10 +121,11 @@ typedef struct Module_Renames { Scheme_Hash_Table *ht; /* localname -> modidx OR (cons modidx exportname) OR (cons modidx nominal_modidx) OR - (list* modidx exportname nominal_modidx nominal_exportname) OR - (list* modidx mod-phase exportname nominal_modidx nominal_exportname) */ + (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR + (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_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; this table maps a top-level-bound identifier with a non-empty mark 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; } +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, Scheme_Object *modname, /* actual source module */ 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_ex, /* nominal import before local renaming */ int mod_phase, /* phase of source defn */ + int src_phase_index, /* nominal import phase */ int unmarshal_drop) /* 1 => can be reconstructed from unmarshal info */ { 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) && SAME_OBJ(exname, nominal_ex) - && !mod_phase) { + && !mod_phase + && src_phase_index == phase_index) { if (SAME_OBJ(localname, exname)) elem = modname; else elem = CONS(modname, exname); } else if (SAME_OBJ(exname, nominal_ex) && SAME_OBJ(localname, exname) - && !mod_phase) { + && !mod_phase + && src_phase_index == phase_index) { /* It's common that a sequence of similar mappings shows up, e.g., '(#%kernel . mzscheme) */ if (nominal_ipair_cache @@ -1097,7 +1116,11 @@ void scheme_extend_module_rename(Scheme_Object *mrn, nominal_ipair_cache = elem; } } 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) elem = CONS(scheme_make_integer(mod_phase), 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, Scheme_Module_Phase_Exports *pt, int k, + int src_phase_index, int save_unmarshal) { Module_Renames *mrn = (Module_Renames *)rn; 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 = pr; 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 = pr; } @@ -1195,7 +1222,7 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, /* Shift the modidx part */ if (SCHEME_PAIRP(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; int mod_phase; midx1 = SCHEME_CAR(v); @@ -1207,7 +1234,12 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, mod_phase = 0; midx2 = SCHEME_CAR(SCHEME_CDR(v)); midx1 = scheme_modidx_shift(midx1, old_midx, new_midx); - midx2 = scheme_modidx_shift(midx2, 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); + } v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v)))); if (mod_phase) 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)) { - 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--; ) { 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; 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) { /* 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 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 - the nominal source module's export, and get_names[3] is set to the phase of - the source definition */ + the nominal source module's export, get_names[3] is set to the phase of + the source definition, and get_names[4] is set to the nominal phase index */ if (pt->provide_src_phases) 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[2] = glob_id; get_names[3] = scheme_make_integer(phase); + get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr))); } 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[2] = glob_id; get_names[3] = scheme_make_integer(0); + get_names[4] = scheme_make_integer(pt->phase_index); } 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. 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 - the nominal source module's export, and get_names[3] is set to the phase of - the source definition + the nominal source module's export, get_names[3] is set to the phase of + 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 neither, result is #f and get_names[0] is either unchanged or NULL. */ { @@ -2914,43 +2948,67 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, modidx_shift_from, modidx_shift_to); - if (get_names && !get_names_done) { - if (SCHEME_PAIRP(rename)) { - if (nom_mod_p(rename)) { - /* (cons modidx nominal_modidx) case */ - get_names[0] = glob_id; - get_names[1] = SCHEME_CDR(rename); - get_names[2] = get_names[0]; - } else { - rename = SCHEME_CDR(rename); - if (SCHEME_PAIRP(rename)) { - /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ - if (SCHEME_INTP(SCHEME_CAR(rename))) { - get_names[3] = SCHEME_CAR(rename); - rename = SCHEME_CDR(rename); - } - get_names[0] = SCHEME_CAR(rename); - get_names[1] = SCHEME_CADR(rename); - get_names[2] = SCHEME_CDDR(rename); - } else { - /* (cons modidx exportname) case */ - get_names[0] = rename; - get_names[2] = NULL; /* finish below */ - } - } - } else { - get_names[0] = glob_id; - get_names[2] = NULL; /* finish below */ - } + if (get_names) { + int no_shift = 0; - if (!get_names[2]) { - get_names[2] = get_names[0]; - if (nominal) - get_names[1] = nominal; - else - get_names[1] = mresult; - } - } + if (!get_names_done) { + if (SCHEME_PAIRP(rename)) { + if (nom_mod_p(rename)) { + /* (cons modidx nominal_modidx) case */ + get_names[0] = glob_id; + get_names[1] = SCHEME_CDR(rename); + get_names[2] = get_names[0]; + } else { + rename = SCHEME_CDR(rename); + if (SCHEME_PAIRP(rename)) { + /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ + if (SCHEME_INTP(SCHEME_CAR(rename))) { + get_names[3] = SCHEME_CAR(rename); + rename = SCHEME_CDR(rename); + } + get_names[0] = SCHEME_CAR(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); + } else { + /* (cons modidx exportname) case */ + get_names[0] = rename; + get_names[2] = NULL; /* finish below */ + } + } + } else { + get_names[0] = glob_id; + get_names[2] = NULL; /* finish below */ + } + + if (!get_names[2]) { + get_names[2] = get_names[0]; + if (nominal) + get_names[1] = nominal; + else { + no_shift = 1; + 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 { mresult = scheme_false; 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 **nominal_modidx, 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 lexically bound, result is scheme_undefined and a is unchanged. If neither, result is NULL and a is unchanged. */ { if (SCHEME_STXP(*a)) { - Scheme_Object *modname, *names[4]; + Scheme_Object *modname, *names[5]; names[0] = NULL; names[3] = scheme_make_integer(0); + names[4] = 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]; if (mod_phase) *mod_phase = SCHEME_INT_VAL(names[3]); + if (src_phase_index) + *src_phase_index = SCHEME_INT_VAL(names[4]); return modname; } } else @@ -4135,7 +4196,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, if (!local_key) { /* Convert hash table to vector: */ int i, j, count = 0; - Scheme_Object *l, *idi; + Scheme_Object *l; 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--; ) { if (mrn->ht->vals[i]) { SCHEME_VEC_ELS(l)[j++] = mrn->ht->keys[i]; - idi = 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; + SCHEME_VEC_ELS(l)[j++] = mrn->ht->vals[i]; } } @@ -4184,7 +4231,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, l = CONS(scheme_make_integer(mrn->phase), l); if (mrn->plus_kernel) { l = CONS(scheme_true,l); - /* note: information on nominals intentially omitted */ + /* FIXME: plus-kernel nominal omitted */ } 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->plus_kernel = plus_kernel; - /* note: information on nominals has been dropped */ if (!SCHEME_PAIRP(a)) return_NULL; mns = SCHEME_CDR(a); @@ -4793,18 +4839,31 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, return_NULL; mli = SCHEME_CDR(mli); - if (SCHEME_INTP(mli)) { - /* For a shared table */ + if (!SCHEME_PAIRP(mli)) return_NULL; + + /* A phase/dimension index */ + p = SCHEME_CAR(mli); + if ((SCHEME_INT_VAL(p) < 0) + || (SCHEME_INT_VAL(p) > 2)) + return_NULL; + + 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; - /* A phase/dimension index (temporarily optional) */ + /* For a shared table: (cons k src-phase-index) */ p = SCHEME_CAR(mli); - if ((SCHEME_INT_VAL(p) < 0) - || (SCHEME_INT_VAL(p) > 2)) + if (!SCHEME_INTP(p) + || (SCHEME_INT_VAL(p) < 0) + || (SCHEME_INT_VAL(p) > 3)) return_NULL; mli = SCHEME_CDR(mli); - if (!SCHEME_PAIRP(mli)) return_NULL; /* A list of symbols: */ p = SCHEME_CAR(mli); @@ -4842,29 +4901,59 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, if (!SCHEME_SYMBOLP(key)) return_NULL; - if (SCHEME_SYMBOLP(p) - || SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { + if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { /* Ok */ } else if (SCHEME_PAIRP(p)) { Scheme_Object *midx; midx = SCHEME_CAR(p); - if (!SCHEME_SYMBOLP(midx) - && !SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) + if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) return_NULL; if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { /* Ok */ + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { + /* Ok */ } else { - if (!SCHEME_PAIRP(SCHEME_CDR(p))) + Scheme_Object *ap, *bp; + + ap = SCHEME_CDR(p); + if (!SCHEME_PAIRP(ap)) 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; - 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; - p = CONS(midx, CONS(SCHEME_CADR(p), - CONS(SCHEME_CDDR(p), - CONS(midx, SCHEME_CDDR(p))))); + 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; } } else 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_Object *a, *m, *nom_mod, *nom_a; - int mod_phase; + int mod_phase, src_phase_index; 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_phase_shift))), &nom_mod, &nom_a, - &mod_phase); + &mod_phase, + &src_phase_index); if (!m) 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, CONS(nom_a, 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)