diff --git a/collects/mzlib/package.ss b/collects/mzlib/package.ss deleted file mode 100644 index 279c91bc8f..0000000000 --- a/collects/mzlib/package.ss +++ /dev/null @@ -1,672 +0,0 @@ -;; `package' and `open' correspond to Chez's `module' and `import' --- -;; without making `import' a part of the primitive expander mechanism, -;; which would require special handling for anything that uses -;; `local-expand'. -;; -;; The main idea is to hide package definitions by "introducing" the -;; identifier (i.e., applying a fresh mark for each definition). -;; -;; Beyond the main strategy, there are two major problems: -;; -;; 1. Making `package' declarations available to immediately -;; following `open' declarations in an internal-definition -;; context: (let () (package p ...) (open p) ...) -;; -;; The problem is that `open' needs to inspect the package -;; to decide what variables it binds, but the package -;; descriptor isn't executed until the defn context has -;; dertemined the full set of names to be defined. -;; -;; We work around this problem by keeping our own table -;; of "recently" processed `package' declarations. The -;; `syntax-local-context' function lets us key this to -;; specific internal-definition contexts. -;; -;; 2. Implementing the binding effect of an `open', which needs -;; to expose the bindings hidden by a `package', but also -;; needs to override shadowing. -;; -;; The `syntax-local-get-shadower' MzScheme function provides -;; the key ingredient for this part, but it doesn't quite work -;; when `open' appears within `package'. In that case, we -;; need to first take into account the package's introductions -;; that hide definitions. - -(module package mzscheme - (require (lib "etc.ss") - (lib "stxparam.ss")) - (require-for-syntax "private/package-helper.ss" - (lib "kerncase.ss" "syntax") - (lib "stx.ss" "syntax") - (lib "boundmap.ss" "syntax") - (lib "context.ss" "syntax") - (lib "define.ss" "syntax") - (lib "list.ss") - (lib "stxparam.ss")) - - (provide package package* - open define-dot - open* define*-dot - dot - define*-syntax define* - define*-syntaxes define*-values - open/derived open*/derived package/derived - define-dot/derived define*-dot/derived - rename-potential-package rename*-potential-package) - - ;; Used to communicate to `open' - ;; when an expression is within the body of a `package' declaration. - ;; This matters for choosing the right shadower of an id. - ;; The value of current-pack is a list of (cons id num), - ;; where num is the size of the applicable tail of the rename list - ;; for the package named id. - (define-syntax-parameter current-package null) - - ;; The *ed define forms are the same as the usual - ;; forms, except inside a package, where the - ;; *ed names are specially detected. - (define-syntax-set (define*-syntaxes - define*-values - define*-syntax - define*) - (define (check-formals s) - (let loop ([s s]) - (cond - [(stx-null? s) #t] - [(identifier? s) #t] - [(and (stx-pair? s) - (identifier? (stx-car s))) - (loop (stx-cdr s))] - [else #f]))) - - (define (multi stx def) - (syntax-case stx () - ((_ (id ...) body) - (andmap identifier? (syntax->list #'(id ...))) - (quasisyntax/loc stx (#,def (id ...) body))))) - - (define (define*-syntaxes/proc stx) - (multi stx #'define-syntaxes)) - - (define (define*-values/proc stx) - (multi stx #'define-values)) - - (define (single stx def-vals) - (let-values ([(id rhs) (normalize-definition stx #'lambda)]) - (quasisyntax/loc stx (#,def-vals (#,id) #,rhs)))) - - (define (define*-syntax/proc stx) - (single stx #'define*-syntaxes)) - - (define (define*/proc stx) - (single stx #'define*-values))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; The main `package' implementation (actually, package/derived) - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define-syntax-set (package/derived) - - ;; Adds the *ed "primitive" definition forms to the - ;; kernel-form list: - (define kernel-form-identifier-list+defines - (append (list #'define*-values #'define*-syntaxes) - (kernel-form-identifier-list))) - - ;; Ensures that a single package element is a definition: - (define (fix-expr e) - (kernel-syntax-case e #f - ((define-values x y) e) - ((define-syntaxes x y) e) - ((d x y) (and (identifier? #'d) - (or (module-identifier=? (quote-syntax define*-values) #'d) - (module-identifier=? (quote-syntax define*-syntaxes) #'d))) - e) - (x #`(define-values () (begin x (values)))))) - - ;; Partially expands all body expressions, and wraps expressions - ;; in empty `define-values'; the result is a list of definitions - (define (get-defs expand-context defs exports) - (let ([stop-list (append kernel-form-identifier-list+defines - exports)]) - (map fix-expr - (apply append - (map (letrec ([ex - (lambda (d) - (let ([_e (local-expand - d - expand-context - stop-list)]) - (syntax-case _e (begin) - [(begin e ...) - (apply - append - (map (lambda (s) - (ex (syntax-track-origin s _e #'begin))) - (syntax->list #'(e ...))))] - [else (list _e)])))]) - ex) - defs))))) - - ;; Extracts all defined names, and also checks for duplicates - ;; in the * forms. - (define (extract-ids defs stx) - (let loop ([defs defs][normal-defs null][let*-defs null]) - (if (null? defs) - (values normal-defs let*-defs) - (syntax-case (car defs) () - [(dv (id ...) expr) - (and (identifier? #'dv) - (or (module-identifier=? #'dv #'define-values) - (module-identifier=? #'dv #'define-syntaxes)) - (andmap identifier? (syntax->list #'(id ...)))) - (loop (cdr defs) - (append normal-defs (syntax->list #'(id ...))) - let*-defs)] - [(dv . _) - (and (identifier? #'dv) - (or (module-identifier=? #'dv #'define-values) - (module-identifier=? #'dv #'define-syntaxes))) - (raise-syntax-error #f "bad syntax" (car defs))] - [(dv (id ...) expr) - (and (identifier? #'dv) - (or (module-identifier=? #'dv #'define*-values) - (module-identifier=? #'dv #'define*-syntaxes)) - (andmap identifier? (syntax->list #'(id ...)))) - ;; Check that the identifiers in a single set are distinct - (let ([ids (syntax->list #'(id ...))]) - (let ([dup (check-duplicate-identifier ids)]) - (when dup - (raise-syntax-error - #f - "identifier defined multiple times in a single set" - stx - dup))) - (loop (cdr defs) - normal-defs - (append let*-defs ids)))] - [(dv . _) - (and (identifier? #'dv) - (or (module-identifier=? #'dv #'define*-values) - (module-identifier=? #'dv #'define*-syntaxes))) - (raise-syntax-error #f "illegal definition form" (car defs))])))) - - ;; Extracts one set of starred names: - (define (get/let*-ids def) - (syntax-case def () - ((d vars body) (or (module-identifier=? (quote-syntax define*-values) #'d) - (module-identifier=? (quote-syntax define*-syntaxes) #'d)) - (syntax->list #'vars)) - (_ null))) - - ;; Combines parts of a transformed definition in a package: - (define (rebuild-def orig package-name rename-length kw ids body compile-time?) - (datum->syntax-object - orig - `(,kw ,ids ,(if compile-time? - body - #`(syntax-parameterize ([current-package - (cons - (cons - (quote-syntax #,package-name) - #,rename-length) - (syntax-parameter-value - (quote-syntax current-package)))]) - #,body))) - orig - orig)) - - ;; mark-ids : defn-stx - ;; (list (cons id-stx (stx . -> . stx))) - ;; id-stx - ;; -> (list (cons id-stx (stx . -> . stx))) - ;; Convert a definition from a package body, and add marks as - ;; appropriate to map to hidden names within the package. Also - ;; accumulate new hidden names from starred bindings. - (define (mark-ids def introducers package-name expand-ctx) - ;; Note: new-ids is null if this is a non-* definition - (let ([new-ids (map (lambda (id) (cons id (make-syntax-introducer))) - (get/let*-ids def))] - [rename-length (length introducers)]) - (values - (syntax-case def () - ((ds vars body) - (module-identifier=? (quote-syntax define-syntaxes) #'ds) - (rebuild-def def package-name rename-length - #'ds - (mark-to-localize #'vars (append new-ids introducers) #'protect) - (mark-to-localize #'body (append new-ids introducers) #'protect) - #t)) - ((dv vars body) - (module-identifier=? (quote-syntax define-values) #'dv) - (rebuild-def def package-name rename-length - #'dv - (mark-to-localize #'vars (append new-ids introducers) #'protect) - (mark-to-localize #'body (append new-ids introducers) #'protect) - #f)) - ((d vars body) - (module-identifier=? (quote-syntax define*-values) #'d) - (rebuild-def def package-name rename-length - #'define-values - (mark-to-localize #'vars (append new-ids introducers) #'protect) - (mark-to-localize #'body introducers #'protect) - #f)) - ((d vars body) - (module-identifier=? (quote-syntax define*-syntaxes) #'d) - (rebuild-def def package-name rename-length - #'define-syntaxes - (mark-to-localize #'vars (append new-ids introducers) #'protect) - (mark-to-localize #'body introducers #'protect) - #t))) - new-ids))) - - ;; For top-level definitions, we need to "declare" - ;; the defined variables before we might use them. - ;; We declare the variable by compiling a dummy - ;; define-values expression. - (define (extract-declarations converted-defs) - (let loop ([converted-defs converted-defs] - [pre-accum null]) - (if (null? converted-defs) - (values (reverse pre-accum)) - (syntax-case (car converted-defs) (define-values) - [(define-values (id ...) body) - (loop (cdr converted-defs) - (list* #'(define-syntaxes (id ...) (values)) - pre-accum))] - [_ (loop (cdr converted-defs) - pre-accum)])))) - - ;; The main package/derived transformer: - (define (package/derived/proc derived-stx) - (syntax-case derived-stx () - ((_ orig-stx name provides body ...) - (let ([stx #'orig-stx]) - ;; --- Error checking - (check-defn-context stx) - (unless (identifier? #'name) - (raise-syntax-error #f "structure name must be an identifier" stx #'name)) - (unless (or (and (identifier? #'provides) - (module-identifier=? (quote-syntax all-defined) #'provides)) - (and (stx-list? #'provides) - (andmap identifier? (stx->list #'provides)))) - (if (eq? 'all-defined (syntax-e #'provides)) - (raise-syntax-error - #f - "`all-defined' keyword has a binding, so it is disallowed as an export" - stx - #'provides) - (raise-syntax-error - #f - "exports must have the form `all-defined' or `(identifier ...)'" - stx - #'provides))) - (let ([specific-exports (if (identifier? #'provides) - #f - (syntax->list #'provides))]) - (when specific-exports - (let ([dup (check-duplicate-identifier specific-exports)]) - (when dup - (raise-syntax-error - #f - "identifier exported multiple times" - stx - dup)))) - ;; --- Parse package body - (let*-values ([(expand-context) (build-expand-context (gensym 'package-define))] - [(defs) (get-defs expand-context - (syntax->list #'(body ...)) - (or specific-exports - null))] - ;; normal-ids and let*-ids are in same order as in package: - [(normal-ids let*-ids) (extract-ids defs stx)] - [(bt) (make-bound-identifier-mapping)]) - ;; --- More error checking (duplicate defns) - (for-each (lambda (id) - (when (bound-identifier-mapping-get bt id (lambda () #f)) - (raise-syntax-error - #f - "identifier defined multiple times" - stx - id)) - (bound-identifier-mapping-put! bt id #t)) - normal-ids) - (for-each (lambda (id) - (when (bound-identifier-mapping-get bt id (lambda () #f)) - (raise-syntax-error - #f - "identifier for * definition has a non-* definition" - stx - id))) - let*-ids) - ;; --- Convert package body, accumulating introducers - ;; The `defined-ids' variable is a (list (cons id-stx (stx . -> . stx))) - (let-values ([(converted-defs defined-ids) - (let loop ((defined-ids (map (lambda (id) (cons id (make-syntax-introducer))) - normal-ids)) - (defs defs) - (accum null)) - (cond - ((null? defs) - (values (reverse accum) defined-ids)) - (else - (let-values (((marked-def new-defined-ids) - (mark-ids (car defs) defined-ids #'name expand-context))) - (loop (append new-defined-ids defined-ids) - (cdr defs) - (cons marked-def accum))))))] - [(reverse-orig-ids) (reverse (append normal-ids let*-ids))]) - ;; --- Create the list of exported identifiers - (let ([export-renames - (remove-dups - (cond - [(not specific-exports) - (map (lambda (id) - (cons (car id) - ((cdr id) (car id)))) - defined-ids)] - [else - (map (lambda (provide) - (let ((introducer (stx-assoc provide defined-ids))) - (unless introducer - (raise-syntax-error - #f - "exported identifier not defined" - stx - provide)) - (cons (car introducer) - ((cdr introducer) provide)))) - specific-exports)]))] - [all-renames (map (lambda (id) - (cons (car id) - ((cdr id) (car id)))) - defined-ids)]) - ;; --- Shuffle the package body to put syntax definitions first - (let ([pre-decls - (if (eq? 'top-level (syntax-local-context)) - (extract-declarations converted-defs) - null)] - [converted-syntax-defs (filter (lambda (def) - (or (module-identifier=? (stx-car def) #'define-syntaxes) - (module-identifier=? (stx-car def) #'define*-syntaxes))) - converted-defs)] - [converted-value-defs (filter (lambda (def) - (or (module-identifier=? (stx-car def) #'define-values) - (module-identifier=? (stx-car def) #'define*-values))) - converted-defs)]) - ;; --- Register this package, in case an `open' appears before the - ;; syntax definition is executed. - ;; export-renames provides an (id-stx . id-stx) mapping for exported ids - ;; all-renames is (id-stx . id-stx) mapping for all ids (superset of export-renames) - (pre-register-package expand-context #'name export-renames all-renames defined-ids #'protect) - ;; --- Assemble the result - #`(begin - (define-syntaxes (name) - (make-str (list #,@(map (lambda (i) - ;; Use of `protect' keeps the id from being localized - ;; if this package is in another. That way, the - ;; source name in the mapping is always the original - ;; name. - #`(cons (protect #,(car i)) - (quote-syntax #,(cdr i)))) - export-renames)) - (list #,@(map (lambda (i) - #`(cons (protect #,(car i)) - (quote-syntax #,(cdr i)))) - all-renames)))) - #,@pre-decls - #,@converted-syntax-defs - #,@converted-value-defs)))))))))) - ) - - (define-syntax (package* stx) - (syntax-case stx () - [(package* name exports body ...) - (with-syntax ([this-pkg (car (generate-temporaries '(this-pkg)))]) - #`(begin - (package/derived #,stx this-pkg exports - body ...) - (rename*-potential-package name this-pkg)))])) - - (define-syntax (package stx) - (syntax-case stx () - [(package* name exports body ...) - #`(package/derived #,stx name exports - body ...)])) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; The main `open' implementation - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define-syntax-set (open/derived open*/derived open open* - define-dot define*-dot define-dot/derived define*-dot/derived - rename-potential-package rename*-potential-package) - (define (do-open stx orig-name - path - ex-name bind-name - def) - (let* (;; If we're in an enclosing package's body, get it's rename environment, etc. - ;; env is an (id-stx . id-stx) mapping - names exported by the package - ;; rns is an (id-stx . id-stx) mapping - names defined in the package - ;; subs is a table mapping defined id-stx to sub-package mappings - [cps (syntax-parameter-value #'current-package)] - [cp-env+rns+subs+ispre/s (map (lambda (cp) (open (car cp) (car cp) stx)) - cps)] - ;; Reverse-map renaming due to being in a package body. In other words, - ;; we find id "x", but it's been renamed because we're in an enclosing - ;; package, and we're about to look in a table that maps original - ;; names to something, so we need to reverse-map the name. - [cp-orig-name (lambda (id) - (let loop ([id id][cp-env+rns+subs+ispre/s cp-env+rns+subs+ispre/s][cps cps]) - (if (null? cp-env+rns+subs+ispre/s) - id - (let ([in-pack-bind - (ormap (lambda (p) - (and (bound-identifier=? (cdr p) id) - p)) - (let ([l (cadr (car cp-env+rns+subs+ispre/s))]) - (list-tail l (- (length l) (cdar cps)))))]) - (loop (if in-pack-bind - (car in-pack-bind) - id) - (cdr cp-env+rns+subs+ispre/s) - (cdr cps))))))] - ;; Reverse-map renaming due to being in a package - ;; body. For example, we have an "x" that we want to - ;; shadow, but the correct shadower must use the new name - ;; in the enclosing package. - [cp-current-name (lambda (id) - (let loop ([id id][cp-env+rns+subs+ispre/s cp-env+rns+subs+ispre/s][cps cps]) - (if (null? cp-env+rns+subs+ispre/s) - id - (let* ([l (cadr (car cp-env+rns+subs+ispre/s))] - [l (list-tail l (- (length l) (cdar cps)))]) - (let ([in-pack-bind (stx-assoc id l)]) - (loop (if in-pack-bind - (cdr in-pack-bind) - id) - (cdr cp-env+rns+subs+ispre/s) - (cdr cps)))))))]) - ;; Find the package. See above for a remainder of env+rns+subs+ispre. - ;; The `rename-chain' variable binds an (stx . -> stx). - (let*-values ([(env+rns+subs+ispre rename-chain) - ;; Find the initial package. `open' reports an error if it can't find one - (let ([env+rns+subs+ispre (open (car path) orig-name stx)]) - (walk-path (cdr path) env+rns+subs+ispre stx values cp-orig-name))]) - (let* ([env (and env+rns+subs+ispre - (let ([e (car env+rns+subs+ispre)]) - (if ex-name - (let ([a (stx-assoc - (let ([id (syntax-local-introduce ex-name)]) - (cp-orig-name id)) - (car env+rns+subs+ispre))]) - (unless a - (raise-syntax-error - #f - "no such export from package" - stx - ex-name)) - (list a)) - e)))] - ;; Find the names that `open' is supposed to bind - [shadowers (if bind-name - (list bind-name) - (map (lambda (x) - (syntax-local-get-shadower - (cp-current-name - (car x)))) - env))]) - ;; Set up the defined-name -> opened-name mapping - (with-syntax ([((pub . hid) ...) - (map (lambda (x shadower) - (cons (if bind-name - shadower ; which is bind-name - (syntax-local-introduce shadower)) - ;; If the source module is defined in the same - ;; internal-definition context as this open, then we must - ;; introduce the use of the package export. - ;; - ;; If the source source module comes from elsewhere, we - ;; must not introduce it, in case the new and original - ;; name are the same (so the new binding might capture - ;; the reference to the original binding. - ;; - ;; Note that if the names are the same and the - ;; context are the same, the choise doens't matter, - ;; because a dup-defn error will be reported. - ((if (cadddr env+rns+subs+ispre) - syntax-local-introduce - values) - (cp-current-name (cdr x))))) - env shadowers)] - [def-stxes def]) - ;; In case another `open' follows this one in an - ;; internal-defn position, register renames for - ;; packages that we just made available: - (let* ([ctx (syntax-local-context)] - [subs (caddr env+rns+subs+ispre)]) - (when (pair? ctx) - (for-each (lambda (x shadower) - (re-pre-register-package subs ctx - (if bind-name - (syntax-local-introduce shadower) - shadower) - (if subs - (car x) - (cdr x)))) - env shadowers))) - ;; Open produces a syntax binding to map to the opened names: - (syntax/loc stx - (def-stxes (pub ...) - (values (make-rename-transformer (quote-syntax hid)) ...)))))))) - - (define (generic-open stx def) - (check-defn-context stx) - (syntax-case stx () - [(_ elem1 elem ...) - (do-open stx #f (syntax->list #'(elem1 elem ...)) - #f #f - def)])) - - (define (generic-open/derived stx def) - (syntax-case stx () - [(_ orig-stx name elem ...) - (do-open #'orig-stx #'name (syntax->list #'(elem ...)) - #f #f - def)])) - - (define (open/proc stx) - (generic-open stx #'define-syntaxes)) - (define (open*/proc stx) - (generic-open stx #'define*-syntaxes)) - - (define (open/derived/proc stx) - (generic-open/derived stx #'define-syntaxes)) - (define (open*/derived/proc stx) - (generic-open/derived stx #'define*-syntaxes)) - - (define (do-define-dot stx def-stxes path bind-name) - (unless (identifier? bind-name) - (raise-syntax-error #f "not an identifier" stx bind-name)) - (let-values ([(path last) (split path)]) - (do-open stx #f - path - last bind-name - def-stxes))) - - (define (generic-define-dot stx def-stxes) - (check-defn-context stx) - (syntax-case stx () - ((_ bind-name path1 path2 path3 ...) - (do-define-dot stx def-stxes (syntax->list #'(path1 path2 path3 ...)) #'bind-name)))) - - (define (generic-define-dot/derived stx def-stxes) - (check-defn-context stx) - (syntax-case stx () - ((_ orig-stx bind-name path1 path2 path3 ...) - (do-define-dot #'orig-stx def-stxes (syntax->list #'(path1 path2 path3 ...)) #'bind-name)))) - - (define (define-dot/proc stx) - (generic-define-dot stx #'define-syntaxes)) - - (define (define*-dot/proc stx) - (generic-define-dot stx #'define*-syntaxes)) - - (define (define-dot/derived/proc stx) - (generic-define-dot/derived stx #'define-syntaxes)) - - (define (define*-dot/derived/proc stx) - (generic-define-dot/derived stx #'define*-syntaxes)) - - (define (do-rename stx def-stxes) - (syntax-case stx () - [(_ new-name old-name) - (begin - (unless (identifier? #'new-name) - (raise-syntax-error #f "new name must be an identifier" stx #'new-name)) - (unless (identifier? #'old-name) - (raise-syntax-error #f "old name must be an identifier" stx #'old-name)) - ;; Re-register if in nested int-def context, and if old-name has - ;; a package mapping: - (let ([ctx (syntax-local-context)]) - (when (list? ctx) - (re-pre-register-package #f (syntax-local-context) - (syntax-local-introduce #'new-name) - (syntax-local-introduce #'old-name)))) - ;; Produce syntax-level renaming: - #`(#,def-stxes (new-name) (make-rename-transformer (quote-syntax old-name))))])) - - (define (rename-potential-package/proc stx) - (do-rename stx #'define-syntaxes)) - (define (rename*-potential-package/proc stx) - (do-rename stx #'define*-syntaxes))) - - (define-syntax (dot stx) - (syntax-case stx () - ((_ path1 path2 path-rest ...) - (let ([path (syntax->list #'(path1 path2 path-rest ...))]) - (for-each (lambda (elem) - (unless (identifier? elem) - (raise-syntax-error - #f - "path element must be an identfier" - stx - elem))) - path) - (let*-values ([(path field) (split path)]) - (quasisyntax/loc - stx - (let () - (package this-pkg all-defined - (open/derived #,stx #f #,@path)) - (let-syntax ([#,field (lambda (stx) - (raise-syntax-error - #f - "no such exported identifier" - (quote-syntax #,stx) - stx))]) - (open/derived #f #f this-pkg) - (let () - #,field))))))))) - - ) \ No newline at end of file diff --git a/collects/mzlib/scribblings/etc.scrbl b/collects/mzlib/scribblings/etc.scrbl index 6841649dec..b33e31c984 100644 --- a/collects/mzlib/scribblings/etc.scrbl +++ b/collects/mzlib/scribblings/etc.scrbl @@ -14,7 +14,7 @@ @(begin (define-syntax-rule (bind id) (begin - (require scheme/base) + (require (for-label scheme/base)) (define id (scheme lambda)))) (bind base-lambda)) diff --git a/collects/mzlib/scribblings/kw.scrbl b/collects/mzlib/scribblings/kw.scrbl index d76cccd645..34e87d7ad5 100644 --- a/collects/mzlib/scribblings/kw.scrbl +++ b/collects/mzlib/scribblings/kw.scrbl @@ -12,7 +12,7 @@ @(begin (define-syntax-rule (bind id) (begin - (require scheme/base) + (require (for-label scheme/base)) (define id (scheme lambda)))) (bind base-lambda)) diff --git a/collects/mzlib/scribblings/mzlib.scrbl b/collects/mzlib/scribblings/mzlib.scrbl index f6eb0378e2..832ab72110 100644 --- a/collects/mzlib/scribblings/mzlib.scrbl +++ b/collects/mzlib/scribblings/mzlib.scrbl @@ -269,6 +269,40 @@ Re-exports @schememodname[scheme/trait]. @; ---------------------------------------------------------------------- +@include-section["unit.scrbl"] + +@; ---------------------------------------------------------------------- + +@mzlib[unit-exptime] + +Re-exports @schememodname[scheme/unit-exptime]. + +@; ---------------------------------------- + +@mzlib[unit200] + +The @schememodname[mzlib/unit200] library provides an old +implementation of units. See archived version 360 documentation on the +@filepath{unit.ss} library of the @filepath{mzlib} collection for +information about this library. + +@; ---------------------------------------- + +@mzlib[unitsig200] + +The @schememodname[mzlib/unit200] library provides an old +implementation of units. See archived version 360 documentation on the +@filepath{unitsig.ss} library of the @filepath{mzlib} collection for +information about this library. + +@; ---------------------------------------- + +@mzlib[zip] + +Re-exports @schememodname[file/zip]. + +@; ---------------------------------------------------------------------- + @(bibliography (bib-entry #:key "Shivers06" diff --git a/collects/mzlib/scribblings/port.scrbl b/collects/mzlib/scribblings/port.scrbl index 3b92d914d9..61bae42214 100644 --- a/collects/mzlib/scribblings/port.scrbl +++ b/collects/mzlib/scribblings/port.scrbl @@ -5,7 +5,7 @@ @mzlib[#:mode title port] The @schememodname[mzlib/port] library mostly re-provides -@scheme[scheme/port]. +@schememodname[scheme/port]. @defproc[(strip-shell-command-start [in input-port?]) void?]{ diff --git a/collects/mzlib/scribblings/unit.scrbl b/collects/mzlib/scribblings/unit.scrbl new file mode 100644 index 0000000000..26839c01f3 --- /dev/null +++ b/collects/mzlib/scribblings/unit.scrbl @@ -0,0 +1,25 @@ +#lang scribble/doc +@(require "common.ss" + (for-label mzlib/unit)) + +@(begin + (define-syntax-rule (bind id) + (begin + (require (for-label scheme/unit)) + (define id (scheme struct)))) + (bind scheme-struct)) + +@mzlib[#:mode title unit] + +The @schememodname[mzlib/unit] library mostly re-provides +@schememodname[scheme/unit], except for @scheme-struct from +@schememodname[scheme/unit]. + +@defform/subs[(struct id (field-id ...) omit-decl ...) + ([omit-decl -type + -selectors + -setters + -constructor])]{ + +A signature form like @scheme-struct from @schememodname[scheme/unit], +but with a different syntax for the options that limit exports.} diff --git a/collects/mzlib/structure.ss b/collects/mzlib/structure.ss deleted file mode 100644 index 68be8451f6..0000000000 --- a/collects/mzlib/structure.ss +++ /dev/null @@ -1,224 +0,0 @@ -(module structure mzscheme - (require (lib "etc.ss")) - (require-for-syntax "private/structure-helper.ss" - (lib "kerncase.ss" "syntax") - (lib "stx.ss" "syntax") - (lib "list.ss")) - - (provide structure dot open open-in-context open-as) - - ;; Dangerous, but seems to work. - (define-syntax define-syntaxes-ml - (syntax-rules () - ((_ . x) (define-syntaxes . x)))) - - (define-syntax-set (structure) - - (define kernel-form-identifier-list/no-begin - (append (map (lambda (x) (datum->syntax-object #'here x)) - `(define-values-ml define-syntaxes-ml)) - (filter (lambda (id) (not (eq? 'begin (syntax-e id)))) - (kernel-form-identifier-list)))) - - (define (stx-assoc id renames) - (cond - ((null? renames) #f) - ((bound-identifier=? id (caar renames)) (car renames)) - (else (stx-assoc id (cdr renames))))) - - (define (remove-begins def) - (kernel-syntax-case def #f - ((begin defs ...) - (apply append (map remove-begins (syntax->list #'(defs ...))))) - (_ (list def)))) - - (define (fix-expr e) - (kernel-syntax-case e #f - ((define-values x y) e) - ((define-syntaxes x y) e) - ((d x y) (or (module-identifier=? (quote-syntax define-values-ml) #'d) - (module-identifier=? (quote-syntax define-syntaxes-ml) #'d)) - e) - (x #`(define-values () (begin x (values)))))) - - (define (get-defs defs) - (map fix-expr - (apply append - (map (lambda (d) - (remove-begins - (local-expand d - (syntax-local-context) - kernel-form-identifier-list/no-begin))) - defs)))) - - (define (get-ids def) - (kernel-syntax-case def #f - ((define-syntaxes vars body) (syntax->list #'vars)) - ((define-values vars body) (syntax->list #'vars)) - ((d vars body) (or (module-identifier=? (quote-syntax define-values-ml) #'d) - (module-identifier=? (quote-syntax define-syntaxes-ml) #'d)) - (syntax->list #'vars)) - (_ (raise-syntax-error 'structure "Internal error" def)))) - - (define (rebuild ctxt val) - (if (syntax? ctxt) - (datum->syntax-object ctxt val ctxt ctxt) - val)) - - (define (rebuild-cons car cdr stx) - (rebuild stx (cons car cdr))) - - (define (mark-ids def introducers) - (let ((new-ids (map (lambda (id) (cons id (make-syntax-introducer))) - (get-ids def)))) - (values - (syntax-case def () - ((ds . x) (module-identifier=? (quote-syntax define-syntaxes) #'ds) - (rebuild-cons #'ds (mark-ids-helper #'x (append new-ids introducers)) def)) - ((dv . x) (module-identifier=? (quote-syntax define-values) #'dv) - (rebuild-cons #'dv (mark-ids-helper #'x (append new-ids introducers)) def)) - ((d vars body) (module-identifier=? (quote-syntax define-values-ml) #'d) - (rebuild def `(,(datum->syntax-object #'here 'define-values #'d #'d) - ,(mark-ids-helper #'vars (append new-ids introducers)) - ,(mark-ids-helper #'body introducers)))) - ((d vars body) (module-identifier=? (quote-syntax define-syntaxes-ml) #'d) - (rebuild def `(,(datum->syntax-object #'here 'define-syntaxes #'d #'d) - ,(mark-ids-helper #'vars (append new-ids introducers)) - ,(mark-ids-helper #'body introducers))))) - new-ids))) - - (define (mark-ids-helper def introducers) - (let ((contents - (if (syntax? def) - (syntax-e def) - def))) - (cond - ((symbol? contents) - (let ((introducer (stx-assoc def introducers))) - (if introducer ((cdr introducer) def) def))) - ((pair? contents) - (rebuild-cons (mark-ids-helper (car contents) introducers) - (mark-ids-helper (cdr contents) introducers) - def)) - ((vector? contents) - (rebuild def (list->vector - (map (lambda (x) (mark-ids-helper x introducers)) - (vector->list contents))))) - (else def)))) - - (define (structure/proc stx) - (syntax-case stx () - ((_ name provides body ...) - (let ((defs (get-defs (syntax->list #'(body ...))))) - (unless (identifier? #'name) - (raise-syntax-error 'structure "Structure name must be an identifier" #'name)) - #`(begin - #,@(let loop ((defined-ids null) - (defs defs)) - (cond - ((null? defs) - (list - #`(define-syntaxes-ml (name) - (make-str - (remove-dups - (list - #,@(syntax-case #'provides () - (all (and (identifier? #'all) - (module-identifier=? (quote-syntax provide-all) - #'all)) - (map (lambda (id) - `(cons - (quote ,(car id)) - (quote-syntax ,((cdr id) - (car id))))) - (filter (lambda (id) - (bound-identifier=? - (car id) - (datum->syntax-object - #'provides - (syntax-object->datum (car id))))) - defined-ids))) - ((provides ...) - (map (lambda (provide) - (let ((introducer (stx-assoc provide defined-ids))) - (unless introducer - (raise-syntax-error - 'structure - "Attempt to export undefined identifier" - provide)) - `(cons - (quote ,provide) - (quote-syntax ,((cdr introducer) provide))))) - (syntax->list #'(provides ...)))) - (p - (cond - ((eq? 'provide-all (syntax-e #'p)) - (raise-syntax-error - 'structure - "provide-all has been rebound" - #'provides)) - (else - (raise-syntax-error - 'structure - "Export must have the form \"provide-all\" or \"(identifier ...)\"" - #'provides))))))))))) - (else - (let-values (((marked-def new-defined-ids) - (mark-ids (car defs) defined-ids))) - (cons marked-def - (loop (append new-defined-ids defined-ids) - (cdr defs)))))))))))) - ) - - (define-syntax (open stx) - (syntax-case stx () - ((_ top-name path ...) - (datum->syntax-object #'here - `(open-in-context ,#'top-name ,#'top-name ,@(syntax->list #'(path ...))) - stx)))) - - (define-syntax (open-in-context stx) - (syntax-case stx () - ((_ context top-name path ...) - (let ((env (open (cons #'top-name (syntax->list #'(path ...))) 'open))) - (with-syntax ((((pub . hid) ...) - (map (lambda (x) - (cons (datum->syntax-object #'context (car x) stx) - (cdr x))) - env))) - #`(define-syntaxes-ml (pub ...) - (values (make-rename-transformer (quote-syntax hid)) ...))))))) - - - (define-syntax (dot-helper stx) - (syntax-case stx () - ((_ path field) - (begin - (unless (identifier? #'field) - (raise-syntax-error 'dot "Field to open must be an identifier" #'field)) - (cond - ((stx-null? #'path) #'field) - (else - (let ((hid (assq (syntax-object->datum #'field) - (open (stx->list #'path) 'dot)))) - (unless hid - (raise-syntax-error 'dot "Unknown field" #'field)) - (cdr hid)))))))) - - (define-syntax (dot stx) - (syntax-case stx () - ((_ path1 path-rest ...) - (let*-values (((path field) - (split (cons #'path1 (syntax->list #'(path-rest ...)))))) - #`(begin0 (dot-helper #,path #,field)))))) - - (define-syntax (open-as stx) - (syntax-case stx () - ((_ rename top-name path1 path-rest ...) - (let-values (((path field) - (split (cons #'top-name (cons #'path1 (syntax->list #'(path-rest ...))))))) - (unless (identifier? #'rename) - (raise-syntax-error 'open-as "First position must be an identifier" #'rename)) - #`(define-syntaxes-ml (rename) - (open-as-helper #'#,path #'#,field)))))) - ) diff --git a/collects/scheme/unit-exptime.ss b/collects/scheme/unit-exptime.ss new file mode 100644 index 0000000000..e7a34fa4bb --- /dev/null +++ b/collects/scheme/unit-exptime.ss @@ -0,0 +1,4 @@ +#lang scheme/base + +(require mzlib/unit-exptime) +(provide (all-from-out mzlib/unit-exptime)) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index aa11e6d710..0291c510fa 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -716,10 +716,14 @@ (syntax-rules () [(_ name fields #:mutable #:inspector #f desc ...) (**defstruct name fields #f #t desc ...)] + [(_ name fields #:mutable #:transparent desc ...) + (**defstruct name fields #f #t desc ...)] [(_ name fields #:mutable desc ...) (**defstruct name fields #f #f desc ...)] [(_ name fields #:inspector #f desc ...) (**defstruct name fields #t #t desc ...)] + [(_ name fields #:transparent desc ...) + (**defstruct name fields #t #t desc ...)] [(_ name fields desc ...) (**defstruct name fields #t #f desc ...)])) (define-syntax **defstruct @@ -1521,9 +1525,7 @@ (to-flow spacer) (to-flow (make-element #f - (list (to-element '#:inspector) - spacer - (to-element #f) + (list (to-element '#:transparent) (schemeparenfont ")")))) 'cont 'cont))] @@ -1543,9 +1545,7 @@ (to-flow spacer) (to-flow (make-element #f - (list (to-element '#:inspector) - spacer - (to-element #f) + (list (to-element '#:transparent) (schemeparenfont ")")))) 'cont 'cont))] diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 49f8182d1e..51a7d3a4df 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -295,6 +295,16 @@ collected by sandbox evaluators. Use @scheme[get-uncovered-expressions] to retrieve coverage information.} +@defboolparam[sandbox-propagate-breaks propagate?]{ + +When this boolean parameter is true, breaking while an evaluator is +running evaluator propagates the break signal to the sandboxed +context. This makes the sandboxed evaluator break, typically, but +beware that sandboxed evaluation can capture and avoid the breaks (so +if safe execution of code is your goal, make sure you use it with a +time limit). The default is @scheme[#t].} + + @defparam[sandbox-namespace-specs spec (cons/c (-> namespace?) (listof module-path?))]{ @@ -412,6 +422,13 @@ around each use of the evaluator, so consuming too much time or memory results in an exception. Change the limits of a running evaluator using @scheme[set-eval-limits].} + +@defparam[sandbox-make-inspector make (-> inspector?)]{ + +A parameter that determines the procedure used to create the inspector +for sandboxed evaluation. The procedure is called when initializing an +evaluator, and the default parameter value is @scheme[make-inspector].} + @; ---------------------------------------------------------------------- @section{Interacting with Evaluators} @@ -434,6 +451,13 @@ the evaluator, except that an @scheme[eof] value will raise an error immediately.} +@defproc[(break-evaluator [evaluator (any/c . -> . any)]) void?]{ + +Sends a break to the running evaluator. The effect of this is as if +Ctrl-C was typed when the evaluator is currently executing, which +propagates the break to the evaluator's context.} + + @defproc[(set-eval-limits [evaluator (any/c . -> . any)] [secs (or/c exact-nonnegative-integer? false/c)] [mb (or/c exact-nonnegative-integer? false/c)]) void?]{ diff --git a/collects/scribblings/reference/serialization.scrbl b/collects/scribblings/reference/serialization.scrbl index b6b707bfb4..79b7535ac4 100644 --- a/collects/scribblings/reference/serialization.scrbl +++ b/collects/scribblings/reference/serialization.scrbl @@ -75,7 +75,7 @@ elements: @item{An optional list @scheme['(1)] that represents the version of the serialization format. If the first element of a - representation \var{v} is not a list, then the version is + representation is not a list, then the version is @scheme[0]. Version 1 adds support for mutable pairs.} @item{A non-negative exact integer @scheme[_s-count] that represents the diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl index 0939c73081..b8d2eae8de 100644 --- a/collects/scribblings/reference/time.scrbl +++ b/collects/scribblings/reference/time.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc -@require["mz.ss"] +@(require "mz.ss" + (for-label scheme/date)) @title[#:tag "time"]{Time} @@ -32,7 +33,7 @@ portability is needed.} [hour (integer-in 0 23)] [day (integer-in 1 31)] [month (integer-in 1 12)] - [year nonnegative-exact-integer?] + [year exact-nonnegative-integer?] [week-day (integer-in 0 6)] [year-day (integer-in 0 365)] [dst? boolean?] @@ -51,7 +52,9 @@ of GMT for the current time zone (e.g., Pacific Standard Time is The value produced for the @scheme[time-zone-offset] field tends to be sensitive to the value of the @envvar{TZ} environment variable, especially on Unix platforms; consult the system documentation -(usually under @tt{tzset}) for details.} +(usually under @tt{tzset}) for details. + +See also the @schememodname[scheme/date] library.} @defproc[(current-milliseconds) exact-integer?]{ @@ -111,3 +114,57 @@ include work performed by other threads.} Reports @scheme[time-apply]-style timing information for the evaluation of @scheme[expr] directly to the current output port. The result is the result of @scheme[expr].} + +@; ---------------------------------------------------------------------- + +@section[#:tag "date-string"]{Date Utilities} + +@defmodule[scheme/date] + +@defproc[(date->string [date date?][time? any/c #f]) string?]{ + +Converts a date to a string. The returned string contains the time of +day only if @scheme[time?]. See also @scheme[date-display-format].} + + +@defparam[date-display-format format (one-of/c 'american + 'chinese + 'german + 'indian + 'irish + 'iso-8601 + 'rfc2822 + 'julian)]{ + +Parameter that determines the date string format. The initial format +is @scheme['american].} + + +@defproc[(find-seconds [second (integer-in 0 61)] + [minute (integer-in 0 59)] + [hour (integer-in 0 23)] + [day (integer-in 1 31)] + [month (integer-in 1 12)] + [year exact-nonnegative-integer?]) + exact-integer?]{ + +Finds the representation of a date in platform-specific seconds. The +arguments correspond to the fields of the @scheme[date] structure. If +the platform cannot represent the specified date, an error is +signaled, otherwise an integer is returned.} + + +@defproc[(date->julian/scalinger [date date?]) exact-integer?]{ + +Converts a date structure (up to 2099 BCE Gregorian) into a Julian +date number. The returned value is not a strict Julian number, but +rather Scalinger's version, which is off by one for easier +calculations.} + + +@defproc[(julian/scalinger->string [date-number exact-integer?]) + string?]{ + +Converts a Julian number (Scalinger's off-by-one version) into a +string.} + diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index 148b127ba6..52129a43b6 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -1,8 +1,7 @@ #lang scribble/doc -@require[(except-in "mz.ss" link)] -@require[scheme/unit] -@require[(for-syntax scheme/base)] -@require[(for-label scheme/unit)] +@(require (except-in "mz.ss" link) + (for-label scheme/unit-exptime)) + @begin[ (define-syntax defkeywords @@ -38,9 +37,9 @@ itself imports variables that will be propagated to unresolved imported variables in the linked units, and re-exports some variables from the linked units for further linking. -@note-lib[scheme/unit]{The @schememodname[scheme/unit] module name can -be used as a language name with @schemefont{#lang}; see -@secref["single-unit"].} +@note-lib[scheme/unit #:use-sources (mzlib/unit)]{The +@schememodname[scheme/unit] module name can be used as a language name +with @schemefont{#lang}; see @secref["single-unit"].} @local-table-of-contents[] @@ -685,3 +684,70 @@ without the directory and file suffix). If the module name ends in @schemeidfont{-sig}, then @scheme[_base] corresponds to the module name before @schemeidfont{-sig}. Otherwise, the module name serves as @scheme[_base]. + +@; ---------------------------------------------------------------------- + +@section{Transformer Helpers} + +@defmodule[scheme/unit-exptime #:use-sources (mzlib/unit-exptime)] + +The @schememodname[scheme/unit-exptime] library provides procedures +that are intended for use by macro transformers. In particular, the +library is typically imported using @scheme[for-syntax] into a module +that defines macro with @scheme[define-syntax]. + +@defproc[(unit-static-signatures [unit-identifier identifier?] + [err-syntax syntax?]) + (values (list-of (cons/c (or/c symbol? false/c) + identifier?)) + (list-of (cons/c (or/c symbol? false/c) + identifier?)))]{ + +If @scheme[unit-identifier] is bound to static unit information via +@scheme[define-unit] (or other such forms), the result is two +values. The first value is for the unit's imports, and the second is +for the unit's exports. Each result value is a list, where each list +element pairs a symbol or @scheme[#f] with an identifier. The symbol +or @scheme[#f] indicates the import's or export's tag (where +@scheme[#f] indicates no tag), and the identifier indicates the +binding of the corresponding signature. + +If @scheme[unit-identifier] is not bound to static unit information, +then the @exnraise[exn:fail:syntax]. In that case, the given +@scheme[err-syntax] argument is used as the source of the error, where +@scheme[unit-identifer] is used as the detail source location.} + + +@defproc[(signature-members [sig-identifier identifier?] + [err-syntax syntax?]) + (values (or/c identifier? false/c) + (listof identifier?) + (listof identifier?) + (listof identifier?))]{ + +If @scheme[sig-identifier] is bound to static unit information via +@scheme[define-signature] (or other such forms), the result is four +values: + +@itemize{ + + @item{an identifier or @scheme[#f] indicating the signature (of any) + that is extended by the @scheme[sig-identifier] binding;} + + @item{a list of identifiers representing the variables + supplied/required by the signature;} + + @item{a list of identifiers for variable definitions in the + signature (i.e., variable bindings that are provided on + import, but not defined by units that implement the + signature); and} + + @item{a list of identifiers with syntax definitions in the signature.} + +} + +If @scheme[sig-identifier] is not bound to a signature, then the +@exnraise[exn:fail:syntax]. In that case, the given +@scheme[err-syntax] argument is used as the source of the error, where +@scheme[sig-identifier] is used as the detail source location.} + diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 71893d46b2..32b76fa388 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -365,7 +365,12 @@ (make-info doc (list-ref v-out 1) ; sci (list-ref v-out 2) ; provides - (list-ref v-in 1) ; undef + (let ([v (list-ref v-in 1)]) ; undef + (if (not (and (pair? v) ; temporary compatibility; used to be not serialized + (pair? (car v)) + (integer? (caar v)))) + v + (deserialize v))) (let ([v (list-ref v-in 3)]) ; searches (if (hash-table? v) ; temporary compatibility; used to be not serialized v @@ -520,7 +525,7 @@ (info-provides info))) (lambda () (list (list (info-vers info) (doc-flags doc)) - (info-undef info) + (serialize (info-undef info)) (map (lambda (i) (path->rel (doc-src-file (info-doc i)))) (info-deps info))