finish mzlib docs, except for contracts
svn: r8623
This commit is contained in:
Matthew Flatt
parent
533266f2dd
commit
b03e7426eb
|
|
@ -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)))))))))
|
||||
|
||||
)
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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?]{
|
||||
|
||||
|
|
|
|||
25
collects/mzlib/scribblings/unit.scrbl
Normal file
25
collects/mzlib/scribblings/unit.scrbl
Normal file
|
|
@ -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.}
|
||||
|
|
@ -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))))))
|
||||
)
|
||||
4
collects/scheme/unit-exptime.ss
Normal file
4
collects/scheme/unit-exptime.ss
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require mzlib/unit-exptime)
|
||||
(provide (all-from-out mzlib/unit-exptime))
|
||||
|
|
@ -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))]
|
||||
|
|
|
|||
|
|
@ -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?]{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.}
|
||||
|
||||
|
|
|
|||
|
|
@ -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.}
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user