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

3.99.0.9: binding links in docs use nominal import sources

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

4
collects/drscheme/syncheck.ss
View File

@ -2380,9 +2380,7 @@ If the namespace does not, they are colored the unbound color.
(syntax-span stx))
(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

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

@ -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}

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

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

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

@ -8,14 +8,8 @@
"../posn.ss"
(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)

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

@ -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"

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

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

13
collects/mzlib/foreign.ss
View File

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

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

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

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

@ -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:

4
collects/scheme/gui.ss
View File

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

18
collects/scheme/help.ss
View File

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

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

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

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

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

8
collects/scribble/basic.ss
View File

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

3
collects/scribble/decode.ss
View File

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

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

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

510
collects/scribble/manual.ss
View File

@ -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 '("<method not found>")))]
[(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)

77
collects/scribble/scheme.ss
View File

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

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

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

64
collects/scribble/struct.ss
View File

@ -6,8 +6,8 @@
;; ----------------------------------------
(define-struct collect-info (ht ext-ht parts tags gen-prefix))
(define-struct 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)
@ -168,7 +181,6 @@
;; 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)

81
collects/scribble/xref.ss
View File

@ -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 <tag-or-#f> <form?>)
(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%)])

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

@ -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]

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

@ -13,8 +13,9 @@ interface}. Furthermore, since most APIs consist mostly of functions,
the foreign interface is sometimes called a @defterm{foreign function
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[]

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

@ -26,7 +26,9 @@ itself protected; see @secref[#:doc '(lib
"scribblings/reference/reference.scrbl") "modprotect"].) Using this
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.

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

@ -9,6 +9,19 @@ from @as-index{shared objects} (a.k.a. @defterm{@as-index{shared
libraries}} or @defterm{@as-index{dynamically loaded libraries}}). The
@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?]

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

@ -46,6 +46,16 @@ using values from @scheme[lst] and the given @scheme[type]. The
according to the given @scheme[type].}
@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?]{

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

@ -11,6 +11,63 @@ strings (used as memory blocks), some additional internal objects
(@scheme[ffi-obj]s and callbacks, see @secref["foreign:c-only"]).
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|.

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

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

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

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

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

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

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

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

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

@ -268,7 +268,7 @@ The result depends on @scheme[what], and a @scheme[#f] result is only
}
@defproc[(graphical-read-eval-print-loop [eval-eventspace eventspace #f]
[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

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

@ -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|.}

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

@ -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|.}

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

@ -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].}
@; ----------------------------------------------------------------------

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

@ -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|.}

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

@ -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|.}

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

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

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

@ -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"]

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

@ -243,22 +243,56 @@ the module's declared name.}
@defproc[(module-compiled-imports [compiled-module-code compiled-module-expression?])
(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}

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

@ -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}

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

@ -41,9 +41,11 @@ The following kinds of values are serializable:
@item{booleans, numbers, characters, symbols, strings, byte strings,
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.}
}}
}}

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

@ -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].}

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

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

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

@ -445,6 +445,61 @@ mark}. Multiple applications of the same
@scheme[make-syntax-introducer] result procedure use the same mark,
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].}

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

@ -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.}

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

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

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

@ -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.}

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

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

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

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

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

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

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

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

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

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

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

@ -39,17 +39,67 @@ get all cross-reference information for installed documentation.}
@defproc[(xref-binding->definition-tag [xref xref?]
[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

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

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

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

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

137
collects/setup/scribble.ss
View File

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

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

@ -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.

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

@ -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.

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

@ -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:

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

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

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

@ -13,6 +13,8 @@ configuring the @web-server .
@section[#:tag "configuration-table-structs.ss"]{Configuration Table Structure}
@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.

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

@ -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.

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

@ -14,6 +14,8 @@ is different and what API is provided.
@section[#:tag "lang-servlets"]{Definition}
@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

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

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

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

@ -15,6 +15,8 @@ Some of these are documented here.
@section[#:tag "timer.ss"]{Timers}
@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}.

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

@ -34,6 +34,8 @@ the server runs until the process is killed.
@section[#:tag "web-server.ss"]{Functional}
@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.

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

@ -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.

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

@ -14,6 +14,8 @@ of these servlets. This API is provided by @filepath{servlet.ss}.
@section[#:tag "module-servlets"]{Definition}
@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.

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

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

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

@ -1,10 +1,10 @@
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,56,50,0,0,0,1,0,0,6,0,9,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,51,46,57,57,46,48,46,57,50,0,0,0,1,0,0,6,0,9,
0,14,0,18,0,23,0,28,0,32,0,39,0,42,0,55,0,62,0,69,0,
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);
}

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

@ -1121,6 +1121,7 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
env->module->self_modidx,
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;
}

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

@ -1553,7 +1553,7 @@ static void do_wrong_syntax(const char *where,
if (scheme_current_thread->current_local_env)
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 {

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

@ -4851,7 +4851,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* 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

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

@ -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,
@ -4920,6 +4957,15 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc
}
}
if (src_phase_index || !SAME_OBJ(nominal_name, prnt_name)) {
Scheme_Object *v;
v = scheme_phase_index_symbol(src_phase_index);
nominal_modidx = scheme_make_pair(nominal_modidx,
scheme_make_pair(v,
scheme_make_pair(nominal_name,
scheme_null)));
}
/* Not required, or required from same module: */
vec = scheme_hash_get(required, name);
if (vec) {
@ -4933,8 +4979,6 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc
and also add source phase for re-provides. */
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) {
@ -6632,6 +6748,14 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob
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 {

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

@ -2421,6 +2421,7 @@ static int module_phase_exports_val_MARK(void *p) {
gcMARK(m->provides);
gcMARK(m->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);

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

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

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

@ -662,9 +662,10 @@ Scheme_Object *scheme_make_module_rename(long phase, int kind, Scheme_Hash_Table
void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname,
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 */

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

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

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

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