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

Moving unit system from mzscheme->scheme/base, reformatting and small changes

Browse Source 
as necessary.  Ran the quiet testsuite, unit tests, and setup-plt, all good.

svn: r17582
This commit is contained in:
Stevie Strickland 2010-01-08 21:44:42 +00:00
parent d846d22b9e
commit 73d68593af
7 changed files with 2879 additions and 2883 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

304
collects/mzlib/private/unit-compiletime.ss
View File

@ -1,21 +1,21 @@
(module unit-compiletime mzscheme #lang scheme/base
(require syntax/boundmap
mzlib/list
"unit-syntax.ss"
(only scheme/base define-struct struct-out)
(rename scheme/base provide* provide))
(require-for-template mzscheme
"unit-keywords.ss"
"unit-runtime.ss")
(require scheme/private/define-struct)
(provide* (struct-out var-info) (require scheme/list
syntax/boundmap
"unit-syntax.ss")
(require (for-syntax scheme/base))
(require (for-template scheme/base
"unit-keywords.ss"
"unit-runtime.ss"))
(require scheme/private/define-struct)
(provide (struct-out var-info)
(struct-out signature) (struct-out signature)
(struct-out signature-form) (struct-out signature-form)
(struct-out unit-info) (struct-out unit-info)
(struct-out link-record)) (struct-out link-record)
(provide (rename build-siginfo make-siginfo) (rename-out [build-siginfo make-siginfo])
siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype
unprocess-link-record-bind unprocess-link-record-use unprocess-link-record-bind unprocess-link-record-use
set!-trans-extract set!-trans-extract
@ -24,13 +24,13 @@
map-sig split-requires split-requires* apply-mac complete-exports complete-imports check-duplicate-subs map-sig split-requires split-requires* apply-mac complete-exports complete-imports check-duplicate-subs
process-spec) process-spec)
(define-syntax (apply-mac stx) (define-syntax (apply-mac stx)
(syntax-case stx () (syntax-case stx ()
((_ f x) ((syntax-e #'f) #'x)))) ((_ f x) ((syntax-e #'f) #'x))))
;; split-requires* : (listof identifier) -> (listof syntax) -> (values (listof syntax) (listof syntax)) ;; split-requires* : (listof identifier) -> (listof syntax) -> (values (listof syntax) (listof syntax))
;; Parameterized over identifiers for require forms. ;; Parameterized over identifiers for require forms.
(define ((split-requires* req-forms) l) (define ((split-requires* req-forms) l)
(let loop ((l l) (let loop ((l l)
(requires null)) (requires null))
(cond (cond
@ -38,47 +38,47 @@
(else (else
(syntax-case (car l) () (syntax-case (car l) ()
((r . x) ((r . x)
(ormap (lambda (req) (module-identifier=? #'r req)) (ormap (lambda (req) (free-identifier=? #'r req))
req-forms) req-forms)
(loop (cdr l) (cons (car l) requires))) (loop (cdr l) (cons (car l) requires)))
(_ (_
(cons (reverse requires) l))))))) (cons (reverse requires) l)))))))
;; split-requires : (listof syntax) -> (values (listof syntax) (listof syntax)) ;; split-requires : (listof syntax) -> (values (listof syntax) (listof syntax))
;; Recognizes mzscheme require forms. ;; Recognizes mzscheme require forms.
(define split-requires (define split-requires
(split-requires* (split-requires*
(list #'require #'require-for-syntax #'require-for-template))) (list #'require #'require-for-syntax #'require-for-template)))
;; (make-var-info bool bool identifier (U #f syntax-object)) ;; (make-var-info bool bool identifier (U #f syntax-object))
(define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable])) (define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable]))
(define-syntax define-struct/proc (define-syntax define-struct/proc
(syntax-rules () (syntax-rules ()
((_ name (field ...) p) ((_ name (field ...) p)
(define-struct name (field ...) #:property prop:procedure p)))) (define-struct name (field ...) #:property prop:procedure p))))
;; An int/ext is ;; An int/ext is
;; - (cons identifier identifier) ;; - (cons identifier identifier)
;; A def is ;; A def is
;; - (listof (cons (listof int/ext) syntax-object)) ;; - (listof (cons (listof int/ext) syntax-object))
;; A ctc is ;; A ctc is
;; - syntax-object ;; - syntax-object
;; - #f ;; - #f
;; A sig is ;; A sig is
;; - (list (listof int/ext) (listof def) (listof def) (listof ctc)) ;; - (list (listof int/ext) (listof def) (listof def) (listof ctc))
;; A tagged-sig is ;; A tagged-sig is
;; - (listof (cons #f siginfo) (cons #f identifier) sig) ;; - (listof (cons #f siginfo) (cons #f identifier) sig)
;; - (listof (cons symbol siginfo) (cons symbol identifier) sig) ;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
;; A siginfo is ;; A siginfo is
;; - (make-siginfo (listof symbol) (listof symbol) (listof identifier) (hash-tableof symbol bool)) ;; - (make-siginfo (listof symbol) (listof symbol) (listof identifier) (hash-tableof symbol bool))
;; where the car of each list represents the signature, and the cdr represents ;; where the car of each list represents the signature, and the cdr represents
;; its super signatures. All lists are non-empty and the same length. ;; its super signatures. All lists are non-empty and the same length.
(define-struct siginfo (names ctime-ids rtime-ids super-table)) (define-struct siginfo (names ctime-ids rtime-ids super-table))
;; build-siginfo : (listof symbol) (listof symbol) (listof identifier) -> siginfo ;; build-siginfo : (listof symbol) (listof symbol) (listof identifier) -> siginfo
(define (build-siginfo names rtime-ids) (define (build-siginfo names rtime-ids)
(define ctime-ids (define ctime-ids
(cons (gensym) (cons (gensym)
(if (null? (cdr names)) (if (null? (cdr names))
@ -89,35 +89,35 @@
(make-siginfo names (make-siginfo names
ctime-ids ctime-ids
rtime-ids rtime-ids
(make-immutable-hash-table (map (λ (x) `(,x . #t)) ctime-ids)))) (make-immutable-hasheq (map (λ (x) `(,x . #t)) ctime-ids))))
;; siginfo-subtype : siginfo siginfo -> bool ;; siginfo-subtype : siginfo siginfo -> bool
(define (siginfo-subtype s1 s2) (define (siginfo-subtype s1 s2)
(hash-table-get (siginfo-super-table s1) (hash-ref (siginfo-super-table s1)
(car (siginfo-ctime-ids s2)) (car (siginfo-ctime-ids s2))
(λ () #f))) (λ () #f)))
;; A signature is ;; A signature is
;; (make-signature siginfo ;; (make-signature siginfo
;; (listof identifier) ;; (listof identifier)
;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object))
;; (listof (cons (listof identifier) syntax-object)) ;; (listof (cons (listof identifier) syntax-object))
;; (listof (U syntax-object #f)) ;; (listof (U syntax-object #f))
;; identifier) ;; identifier)
(define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder) (define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder)
(lambda (_ stx) (lambda (_ stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature name")))) (raise-stx-err "illegal use of signature name"))))
;; (make-signature-form (syntax-object -> any)) ;; (make-signature-form (syntax-object -> any))
(define-struct/proc signature-form (f) (define-struct/proc signature-form (f)
(lambda (_ stx) (lambda (_ stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature form")))) (raise-stx-err "illegal use of signature form"))))
;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier boolean) ;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier boolean)
(define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder contracted?) (define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder contracted?)
(lambda (struct stx) (lambda (struct stx)
(with-syntax ((u (unit-info-unit-id struct))) (with-syntax ((u (unit-info-unit-id struct)))
(syntax-case stx (set!) (syntax-case stx (set!)
@ -136,9 +136,9 @@
(x (x
(identifier? #'x) (identifier? #'x)
(quasisyntax/loc stx (values u))))))) ;; The apparently superfluous values is so the certificates aren't (quasisyntax/loc stx (values u))))))) ;; The apparently superfluous values is so the certificates aren't
;; too permissive ;; too permissive
(define (lookup id err-msg) (define (lookup id err-msg)
(check-id id) (check-id id)
(let ((s (set!-trans-extract (let ((s (set!-trans-extract
(syntax-local-value (syntax-local-value
@ -147,27 +147,27 @@
(raise-stx-err err-msg id)))))) (raise-stx-err err-msg id))))))
s)) s))
;; lookup-signature : syntax-object -> signature ;; lookup-signature : syntax-object -> signature
(define (lookup-signature id) (define (lookup-signature id)
(let ((s (lookup id "unknown signature"))) (let ((s (lookup id "unknown signature")))
(unless (signature? s) (unless (signature? s)
(raise-stx-err "not a signature" id)) (raise-stx-err "not a signature" id))
s)) s))
(define (set!-trans-extract x) (define (set!-trans-extract x)
(if (set!-transformer? x) (if (set!-transformer? x)
(set!-transformer-procedure x) (set!-transformer-procedure x)
x)) x))
(define (lookup-def-unit id) (define (lookup-def-unit id)
(let ((u (lookup id "unknown unit definition"))) (let ((u (lookup id "unknown unit definition")))
(unless (unit-info? u) (unless (unit-info? u)
(raise-stx-err "not a unit definition" id)) (raise-stx-err "not a unit definition" id))
u)) u))
;; check-bound-id-subset : (listof syntax-object) (listof identifier) syntax-object -> ;; check-bound-id-subset : (listof syntax-object) (listof identifier) syntax-object ->
;; ensures each element of i1 is an identifier bound-identifier=? to an identifier in i2 ;; ensures each element of i1 is an identifier bound-identifier=? to an identifier in i2
(define (check-bound-id-subset i1 i2) (define (check-bound-id-subset i1 i2)
(let ((ht (make-bound-identifier-mapping))) (let ((ht (make-bound-identifier-mapping)))
(for-each (lambda (id) (for-each (lambda (id)
(bound-identifier-mapping-put! ht id #t)) (bound-identifier-mapping-put! ht id #t))
@ -179,10 +179,10 @@
(raise-stx-err "listed identifier not present in signature specification" id))) (raise-stx-err "listed identifier not present in signature specification" id)))
i1))) i1)))
;; do-rename : sig syntax-object syntax-object -> sig ;; do-rename : sig syntax-object syntax-object -> sig
;; internals and externals must both be of the form (x ...) ;; internals and externals must both be of the form (x ...)
;; ensures that each x above is an identifier ;; ensures that each x above is an identifier
(define (do-rename sig internals externals) (define (do-rename sig internals externals)
(check-bound-id-subset (syntax->list externals) (check-bound-id-subset (syntax->list externals)
(sig-int-names sig)) (sig-int-names sig))
(let ((ht (make-bound-identifier-mapping))) (let ((ht (make-bound-identifier-mapping)))
@ -200,19 +200,19 @@
(lambda (x) x) (lambda (x) x)
sig))) sig)))
;; do-prefix : id id -> id ;; do-prefix : id id -> id
;; ensures that pid is an identifier ;; ensures that pid is an identifier
(define (do-prefix stx pid) (define (do-prefix stx pid)
(if (identifier? stx) (if (identifier? stx)
(datum->syntax-object (datum->syntax
stx stx
(string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx))) (string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx)))
stx) stx)
stx)) stx))
;; do-only/except : sig (listof identifier) -> sig ;; do-only/except : sig (listof identifier) -> sig
;; ensures that only-ids are identifiers and are mentioned in the signature ;; ensures that only-ids are identifiers and are mentioned in the signature
(define (do-only/except sig only/except-ids put get) (define (do-only/except sig only/except-ids put get)
(check-bound-id-subset only/except-ids (check-bound-id-subset only/except-ids
(sig-int-names sig)) (sig-int-names sig))
(let ((ht (make-bound-identifier-mapping))) (let ((ht (make-bound-identifier-mapping)))
@ -227,8 +227,8 @@
(lambda (x) x) (lambda (x) x)
sig))) sig)))
;; do-identifier : identifier (box (cons identifier siginfo)) -> sig ;; do-identifier : identifier (box (cons identifier siginfo)) -> sig
(define (do-identifier spec res bind? add-prefix) (define (do-identifier spec res bind? add-prefix)
(let* ((sig (lookup-signature spec)) (let* ((sig (lookup-signature spec))
(vars (signature-vars sig)) (vars (signature-vars sig))
(vals (signature-val-defs sig)) (vals (signature-val-defs sig))
@ -261,62 +261,62 @@
stxs) stxs)
ctcs)))) ctcs))))
(define (sig-names sig) (define (sig-names sig)
(append (car sig) (append (car sig)
(apply append (map car (cadr sig))) (apply append (map car (cadr sig)))
(apply append (map car (caddr sig))))) (apply append (map car (caddr sig)))))
(define (sig-int-names sig) (define (sig-int-names sig)
(map car (sig-names sig))) (map car (sig-names sig)))
(define (sig-ext-names sig) (define (sig-ext-names sig)
(map cdr (sig-names sig))) (map cdr (sig-names sig)))
;; map-def : (identifier -> identifier) (syntax-object -> syntax-object) def -> def ;; map-def : (identifier -> identifier) (syntax-object -> syntax-object) def -> def
(define (map-def f g def) (define (map-def f g def)
(cons (map (lambda (x) (cons (map (lambda (x)
(cons (f (car x)) (g (cdr x)))) (cons (f (car x)) (g (cdr x))))
(car def)) (car def))
(g (cdr def)))) (g (cdr def))))
;; map-ctc : (identifier -> identifier) (syntax-object -> syntax-object) ctc -> ctc ;; map-ctc : (identifier -> identifier) (syntax-object -> syntax-object) ctc -> ctc
(define (map-ctc f g ctc) (define (map-ctc f g ctc)
(if ctc (if ctc
(g ctc) (g ctc)
ctc)) ctc))
;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig ;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig
;; applies f to the internal parts, and g to the external parts. ;; applies f to the internal parts, and g to the external parts.
(define (map-sig f g sig) (define (map-sig f g sig)
(list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig)) (list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig))
(map (lambda (x) (map-def f g x)) (cadr sig)) (map (lambda (x) (map-def f g x)) (cadr sig))
(map (lambda (x) (map-def f g x)) (caddr sig)) (map (lambda (x) (map-def f g x)) (caddr sig))
(map (lambda (x) (map-ctc f g x)) (cadddr sig)))) (map (lambda (x) (map-ctc f g x)) (cadddr sig))))
;; An import-spec is one of ;; An import-spec is one of
;; - signature-name ;; - signature-name
;; - (only import-spec identifier ...) ;; - (only import-spec identifier ...)
;; - (except import-spec identifier ...) ;; - (except import-spec identifier ...)
;; - (prefix prefix-identifier import-spec) ;; - (prefix prefix-identifier import-spec)
;; - (rename import-spec (local-identifier signature-identifier) ...) ;; - (rename import-spec (local-identifier signature-identifier) ...)
;; An export-spec is one of ;; An export-spec is one of
;; - signature-name ;; - signature-name
;; - (prefix prefix-identifier export-spec) ;; - (prefix prefix-identifier export-spec)
;; - (rename export-spec (local-identifier signature-identifier) ...) ;; - (rename export-spec (local-identifier signature-identifier) ...)
;; A tagged-import-spec is one of ;; A tagged-import-spec is one of
;; - import-spec ;; - import-spec
;; - (tag symbol import-spec) ;; - (tag symbol import-spec)
;; A tagged-export-spec is one of ;; A tagged-export-spec is one of
;; - export-spec ;; - export-spec
;; - (tag symbol export-spec) ;; - (tag symbol export-spec)
;; process-tagged-import/export : syntax-object boolean -> tagged-sig ;; process-tagged-import/export : syntax-object boolean -> tagged-sig
(define (process-tagged-import/export spec import? bind?) (define (process-tagged-import/export spec import? bind?)
(define res (box #f)) (define res (box #f))
(check-tagged-spec-syntax spec import? identifier?) (check-tagged-spec-syntax spec import? identifier?)
(syntax-case spec (tag) (syntax-case spec (tag)
@ -332,11 +332,11 @@
(cons #f (car (unbox res))) (cons #f (car (unbox res)))
s))))) s)))))
(define (add-prefixes add-prefix l) (define (add-prefixes add-prefix l)
(map add-prefix (syntax->list l))) (map add-prefix (syntax->list l)))
;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig ;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig
(define (process-import/export spec res bind? add-prefix) (define (process-import/export spec res bind? add-prefix)
(syntax-case spec (only except prefix rename) (syntax-case spec (only except prefix rename)
(_ (_
(identifier? spec) (identifier? spec)
@ -361,7 +361,7 @@
(let* ((sig-res (let* ((sig-res
(do-rename (process-import/export #'sub-spec res bind? add-prefix) (do-rename (process-import/export #'sub-spec res bind? add-prefix)
#'(internal ...) #'(internal ...)
(datum->syntax-object #f (add-prefixes add-prefix #'(external ...))))) (datum->syntax #f (add-prefixes add-prefix #'(external ...)))))
(dup (check-duplicate-identifier (sig-int-names sig-res)))) (dup (check-duplicate-identifier (sig-int-names sig-res))))
(when dup (when dup
(raise-stx-err (raise-stx-err
@ -369,13 +369,13 @@
spec)) spec))
sig-res)))) sig-res))))
(define (process-tagged-import spec) (define (process-tagged-import spec)
(process-tagged-import/export spec #t #t)) (process-tagged-import/export spec #t #t))
(define (process-tagged-export spec) (define (process-tagged-export spec)
(process-tagged-import/export spec #f #t)) (process-tagged-import/export spec #f #t))
;; process-spec : syntax-object -> sig ;; process-spec : syntax-object -> sig
(define (process-spec spec) (define (process-spec spec)
(check-tagged-spec-syntax spec #f identifier?) (check-tagged-spec-syntax spec #f identifier?)
(process-import/export spec (box #f) #t values)) (process-import/export spec (box #f) #t values))
@ -396,8 +396,8 @@
;; check-duplicate-subs : (listof (cons symbol siginfo)) (listof syntax-object) -> ;; check-duplicate-subs : (listof (cons symbol siginfo)) (listof syntax-object) ->
(define (check-duplicate-subs tagged-siginfos sources) (define (check-duplicate-subs tagged-siginfos sources)
(for-each (for-each
(λ (tinfo1 s1) (λ (tinfo1 s1)
(for-each (for-each
@ -406,7 +406,7 @@
(when (and (eq? (car tinfo1) (car tinfo2)) (when (and (eq? (car tinfo1) (car tinfo2))
(siginfo-subtype (cdr tinfo1) (cdr tinfo2))) (siginfo-subtype (cdr tinfo1) (cdr tinfo2)))
(raise-stx-err (format "the signature of ~a extends this signature" (raise-stx-err (format "the signature of ~a extends this signature"
(syntax-object->datum s1)) (syntax->datum s1))
s2)))) s2))))
tagged-siginfos tagged-siginfos
sources)) sources))
@ -414,15 +414,15 @@
sources)) sources))
;; A link-record is ;; A link-record is
;; (make-link-record (or symbol #f) (or identifier #f) identifier siginfo) ;; (make-link-record (or symbol #f) (or identifier #f) identifier siginfo)
(define-struct link-record (tag linkid sigid siginfo)) (define-struct link-record (tag linkid sigid siginfo))
;; complete-exports : (listof link-record) (listof link-record) -> (listof link-record) ;; complete-exports : (listof link-record) (listof link-record) -> (listof link-record)
;; The export-bindings should not contain two bindings that are related as subsignatures. ;; The export-bindings should not contain two bindings that are related as subsignatures.
(define (complete-exports unit-exports given-bindings) (define (complete-exports unit-exports given-bindings)
(define binding-table (make-hash-table 'equal)) (define binding-table (make-hash))
(define used-binding-table (make-hash-table 'equal)) (define used-binding-table (make-hash))
(check-duplicate-subs (check-duplicate-subs
(map (λ (ts) (cons (link-record-tag ts) (link-record-siginfo ts))) given-bindings) (map (λ (ts) (cons (link-record-tag ts) (link-record-siginfo ts))) given-bindings)
@ -430,7 +430,7 @@
(for-each (for-each
(λ (b) (λ (b)
(hash-table-put! binding-table (hash-set! binding-table
(cons (link-record-tag b) (cons (link-record-tag b)
(car (siginfo-ctime-ids (link-record-siginfo b)))) (car (siginfo-ctime-ids (link-record-siginfo b))))
(link-record-linkid b))) (link-record-linkid b)))
@ -443,12 +443,12 @@
(ormap (ormap
(λ (ctime-id) (λ (ctime-id)
(define key (cons (link-record-tag export) ctime-id)) (define key (cons (link-record-tag export) ctime-id))
(define used (hash-table-get used-binding-table key (λ () #f))) (define used (hash-ref used-binding-table key (λ () #f)))
(when used (when used
(raise-stx-err "this export is supplied multiple times by the given unit" used)) (raise-stx-err "this export is supplied multiple times by the given unit" used))
(let ([r (hash-table-get binding-table key (λ () #f))]) (let ([r (hash-ref binding-table key (λ () #f))])
(when r (when r
(hash-table-put! used-binding-table key r)) (hash-set! used-binding-table key r))
r)) r))
(siginfo-ctime-ids (link-record-siginfo export)))) (siginfo-ctime-ids (link-record-siginfo export))))
(make-link-record (make-link-record
@ -460,27 +460,27 @@
(link-record-siginfo export))) (link-record-siginfo export)))
unit-exports) unit-exports)
(hash-table-for-each (hash-for-each
binding-table binding-table
(λ (k v) (λ (k v)
(unless (hash-table-get used-binding-table k (λ () #f)) (unless (hash-ref used-binding-table k (λ () #f))
(raise-stx-err "this export is not supplied by the given unit" v)))))) (raise-stx-err "this export is not supplied by the given unit" v))))))
(define (name-form n) (syntax-object->datum n)) (define (name-form n) (syntax->datum n))
;; complete-imports : (hash-tableof symbol (or identifier 'duplicate)) ;; complete-imports : (hash-tableof symbol (or identifier 'duplicate))
;; (listof link-record) ;; (listof link-record)
;; (listof (list symbol identifier siginfo)) -> ;; (listof (list symbol identifier siginfo)) ->
;; (listof (cons symbol identifier)) ;; (listof (cons symbol identifier))
(define (complete-imports sig-table given-links unit-imports src) (define (complete-imports sig-table given-links unit-imports src)
(define linked-sigs-table (make-hash-table 'equal)) (define linked-sigs-table (make-hash))
(for-each (for-each
(λ (link) (λ (link)
(define tag (link-record-tag link)) (define tag (link-record-tag link))
(for-each (for-each
(λ (cid) (λ (cid)
(define there? (hash-table-get linked-sigs-table (cons tag cid) (λ () #f))) (define there? (hash-ref linked-sigs-table (cons tag cid) (λ () #f)))
(hash-table-put! linked-sigs-table (cons tag cid) (if there? 'duplicate #t))) (hash-set! linked-sigs-table (cons tag cid) (if there? 'duplicate #t)))
(siginfo-ctime-ids (link-record-siginfo link)))) (siginfo-ctime-ids (link-record-siginfo link))))
given-links) given-links)
@ -494,7 +494,7 @@
[ctime-ids (siginfo-ctime-ids (link-record-siginfo import))] [ctime-ids (siginfo-ctime-ids (link-record-siginfo import))]
[tag (link-record-tag import)] [tag (link-record-tag import)]
[there? [there?
(hash-table-get linked-sigs-table (hash-ref linked-sigs-table
(cons tag (car ctime-ids)) (cons tag (car ctime-ids))
(λ () #f))]) (λ () #f))])
(cond (cond
@ -509,7 +509,7 @@
[there? [there?
(loop (cdr unit-imports))] (loop (cdr unit-imports))]
[else [else
(let ([there?2 (hash-table-get sig-table (let ([there?2 (hash-ref sig-table
(car ctime-ids) (car ctime-ids)
(λ () #f))]) (λ () #f))])
(cond (cond
@ -524,7 +524,7 @@
[there?2 [there?2
(for-each (for-each
(λ (cid) (λ (cid)
(hash-table-put! linked-sigs-table (hash-set! linked-sigs-table
(cons tag cid) (cons tag cid)
#t)) #t))
ctime-ids) ctime-ids)
@ -542,20 +542,20 @@
(name-form (car (siginfo-names (link-record-siginfo import)))))) (name-form (car (siginfo-names (link-record-siginfo import))))))
src)]))]))])))) src)]))]))]))))
(define (unprocess-link-record-bind lr) (define (unprocess-link-record-bind lr)
(if (link-record-tag lr) (if (link-record-tag lr)
#`(#,(link-record-linkid lr) : (tag #,(link-record-tag lr) #,(link-record-sigid lr))) #`(#,(link-record-linkid lr) : (tag #,(link-record-tag lr) #,(link-record-sigid lr)))
#`(#,(link-record-linkid lr) : #,(link-record-sigid lr)))) #`(#,(link-record-linkid lr) : #,(link-record-sigid lr))))
(define (unprocess-link-record-use lr) (define (unprocess-link-record-use lr)
(if (link-record-tag lr) (if (link-record-tag lr)
#`(tag #,(link-record-tag lr) #,(link-record-linkid lr)) #`(tag #,(link-record-tag lr) #,(link-record-linkid lr))
(link-record-linkid lr))) (link-record-linkid lr)))
(define (make-id-mappers . unbox-stxes) (define (make-id-mappers . unbox-stxes)
(apply values (map make-id-mapper unbox-stxes))) (apply values (map make-id-mapper unbox-stxes)))
(define (make-id-mapper unbox-stx) (define (make-id-mapper unbox-stx)
(make-set!-transformer (make-set!-transformer
(lambda (sstx) (lambda (sstx)
(syntax-case sstx (set!) (syntax-case sstx (set!)
@ -568,7 +568,7 @@
"cannot set! imported or exported variables" "cannot set! imported or exported variables"
sstx)] sstx)]
[(_ . x) [(_ . x)
(datum->syntax-object (datum->syntax
sstx sstx
(cons unbox-stx #'x) (cons unbox-stx #'x)
sstx)]))))) sstx)]))))

89
collects/mzlib/private/unit-runtime.ss
View File

@ -1,34 +1,35 @@
(module unit-runtime mzscheme #lang scheme/base
(require-for-syntax "unit-syntax.ss")
(provide define-syntax/err-param (require (for-syntax "unit-syntax.ss" scheme/base))
undefined (rename make-a-unit make-unit) unit-import-sigs unit-export-sigs unit-go unit? unit-deps (provide define-syntax/err-param
undefined (rename-out [make-a-unit make-unit]) unit-import-sigs unit-export-sigs unit-go unit? unit-deps
check-unit check-no-imports check-sigs check-deps check-helper) check-unit check-no-imports check-sigs check-deps check-helper)
(define-syntax define-syntax/err-param (define-syntax define-syntax/err-param
(syntax-rules () (syntax-rules ()
((_ (name arg) body) ((_ (name arg) body)
(define-syntax (name arg) (define-syntax (name arg)
(parameterize ((error-syntax arg)) (parameterize ((error-syntax arg))
body))))) body)))))
;; initial value ;; initial value
(define undefined (letrec ([x x]) x)) (define undefined (letrec ([x x]) x))
;; for named structures ;; for named structures
(define insp (current-inspector)) (define insp (current-inspector))
;; (make-unit (listof (cons symbol symbol)) (listof (cons symbol symbol)) (listof nat) thunk) ;; (make-unit (listof (cons symbol symbol)) (listof (cons symbol symbol)) (listof nat) thunk)
;; Runtime representation of a unit ;; Runtime representation of a unit
(define-struct unit (import-sigs export-sigs deps go)) (define-struct unit (import-sigs export-sigs deps go))
;; For units with inferred names, generate a struct that prints using the name: ;; For units with inferred names, generate a struct that prints using the name:
(define (make-naming-constructor type name) (define (make-naming-constructor type name)
(let-values ([(struct: make- ? -accessor -mutator) (let-values ([(struct: make- ? -accessor -mutator)
(make-struct-type name type 0 0 #f null insp)]) (make-struct-type name type 0 0 #f null insp)])
make-)) make-))
;; Make a unit value (call by the macro expansion of `unit') ;; Make a unit value (call by the macro expansion of `unit')
(define (make-a-unit name num-imports exports deps go) (define (make-a-unit name num-imports exports deps go)
((if name ((if name
(make-naming-constructor (make-naming-constructor
struct:unit struct:unit
@ -36,29 +37,29 @@
make-unit) make-unit)
num-imports exports deps go)) num-imports exports deps go))
;; check-unit : X symbol -> ;; check-unit : X symbol ->
;; ensure that u is a unit value ;; ensure that u is a unit value
(define (check-unit u name) (define (check-unit u name)
(unless (unit? u) (unless (unit? u)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(format "~a: result of unit expression was not a unit: ~e" name u) (format "~a: result of unit expression was not a unit: ~e" name u)
(current-continuation-marks))))) (current-continuation-marks)))))
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol))))) ;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
; (vectorof (cons symbol (vectorof (cons symbol symbol))))) ; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
;; symbol symbol -> ;; symbol symbol ->
;; ensure that the unit's signatures match the expected signatures. ;; ensure that the unit's signatures match the expected signatures.
(define (check-helper sub-sig super-sig name import?) (define (check-helper sub-sig super-sig name import?)
(define t (make-hash-table 'equal)) (define t (make-hash))
(let loop ([i (sub1 (vector-length sub-sig))]) (let loop ([i (sub1 (vector-length sub-sig))])
(when (>= i 0) (when (>= i 0)
(let ([v (cdr (vector-ref sub-sig i))]) (let ([v (cdr (vector-ref sub-sig i))])
(let loop ([j (sub1 (vector-length v))]) (let loop ([j (sub1 (vector-length v))])
(when (>= j 0) (when (>= j 0)
(let ([vj (vector-ref v j)]) (let ([vj (vector-ref v j)])
(hash-table-put! t vj (hash-set! t vj
(if (hash-table-get t vj #f) (if (hash-ref t vj #f)
'amb 'amb
#t))) #t)))
(loop (sub1 j))))) (loop (sub1 j)))))
@ -66,7 +67,7 @@
(let loop ([i (sub1 (vector-length super-sig))]) (let loop ([i (sub1 (vector-length super-sig))])
(when (>= i 0) (when (>= i 0)
(let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)] (let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)]
[r (hash-table-get t v0 #f)]) [r (hash-ref t v0 #f)])
(when (or (eq? r 'amb) (not r)) (when (or (eq? r 'amb) (not r))
(let ([tag (if (pair? v0) (car v0) #f)] (let ([tag (if (pair? v0) (car v0) #f)]
[sub-name (car (vector-ref super-sig i))] [sub-name (car (vector-ref super-sig i))]
@ -101,13 +102,13 @@
(current-continuation-marks)))))) (current-continuation-marks))))))
(loop (sub1 i))))) (loop (sub1 i)))))
;; check-deps : (hash-tableof (cons symbol (or symbol #f)) (cons symbol symbol)) unit symbol -> ;; check-deps : (hash-tableof (cons symbol (or symbol #f)) (cons symbol symbol)) unit symbol ->
;; The hash table keys are the tag and runtime signature id ;; The hash table keys are the tag and runtime signature id
;; The values are the name of the signature and the linkage ;; The values are the name of the signature and the linkage
(define (check-deps dep-table unit name) (define (check-deps dep-table unit name)
(for-each (for-each
(λ (dep) (λ (dep)
(let ([r (hash-table-get dep-table dep #f)]) (let ([r (hash-ref dep-table dep #f)])
(when r (when r
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
@ -119,18 +120,16 @@
(current-continuation-marks)))))) (current-continuation-marks))))))
(unit-deps unit))) (unit-deps unit)))
;; check-no-imports : unit symbol -> ;; check-no-imports : unit symbol ->
;; ensures that the unit has no imports ;; ensures that the unit has no imports
(define (check-no-imports unit name) (define (check-no-imports unit name)
(check-helper (vector) (unit-import-sigs unit) name #t)) (check-helper (vector) (unit-import-sigs unit) name #t))
;; check-sigs : unit ;; check-sigs : unit
;; (vectorof (cons symbol (vectorof (cons symbol symbol))))) ;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
;; (vectorof (cons symbol (vectorof (cons symbol symbol))))) ;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
;; symbol -> ;; symbol ->
;; ensures that unit has the given signatures ;; ensures that unit has the given signatures
(define (check-sigs unit expected-imports expected-exports name) (define (check-sigs unit expected-imports expected-exports name)
(check-helper expected-imports (unit-import-sigs unit) name #t) (check-helper expected-imports (unit-import-sigs unit) name #t)
(check-helper (unit-export-sigs unit) expected-exports name #f))) (check-helper (unit-export-sigs unit) expected-exports name #f))

106
collects/mzlib/private/unit-syntax.ss
View File

@ -1,23 +1,24 @@
(module unit-syntax mzscheme #lang scheme/base
(require syntax/stx)
(require-for-template "unit-keywords.ss")
(provide (all-defined)) (require syntax/stx)
(require (for-template "unit-keywords.ss"))
(define error-syntax (make-parameter #f)) (provide (all-defined-out))
(define raise-stx-err
(define error-syntax (make-parameter #f))
(define raise-stx-err
(case-lambda (case-lambda
((msg) (raise-syntax-error #f msg (error-syntax))) ((msg) (raise-syntax-error #f msg (error-syntax)))
((msg stx) (raise-syntax-error #f msg (error-syntax) stx)))) ((msg stx) (raise-syntax-error #f msg (error-syntax) stx))))
;; check-id: syntax-object -> identifier ;; check-id: syntax-object -> identifier
(define (check-id id) (define (check-id id)
(unless (identifier? id) (unless (identifier? id)
(raise-stx-err "not an identifier" id)) (raise-stx-err "not an identifier" id))
id) id)
;; checked-syntax->list : syntax-object -> (listof syntax-object) ;; checked-syntax->list : syntax-object -> (listof syntax-object)
(define (checked-syntax->list s) (define (checked-syntax->list s)
(define l (syntax->list s)) (define l (syntax->list s))
(unless (or (stx-pair? s) (stx-null? s)) (unless (or (stx-pair? s) (stx-null? s))
(raise-stx-err "bad syntax (not a list)" s)) (raise-stx-err "bad syntax (not a list)" s))
@ -25,8 +26,8 @@
(raise-stx-err "bad syntax (illegal use of `.')" s)) (raise-stx-err "bad syntax (illegal use of `.')" s))
l) l)
;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X) ;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
(define (check-tagged check) (define (check-tagged check)
(λ (o) (λ (o)
(syntax-case o (tag) (syntax-case o (tag)
((tag . s) ((tag . s)
@ -40,9 +41,9 @@
(_ (_
(cons #f (check o)))))) (cons #f (check o))))))
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier) ;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
;; ensures that clause matches (a : b) or (a : (tag t b)) ;; ensures that clause matches (a : b) or (a : (tag t b))
(define (check-tagged-:-clause clause) (define (check-tagged-:-clause clause)
(checked-syntax->list clause) (checked-syntax->list clause)
(syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) (syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
((a : b) ((a : b)
@ -53,21 +54,21 @@
"expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))" "expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))"
clause)))) clause))))
(define check-tagged-id (check-tagged check-id)) (define check-tagged-id (check-tagged check-id))
;; check-spec-syntax : syntax-object boolean (syntax-object -> boolean) -> ;; check-spec-syntax : syntax-object boolean (syntax-object -> boolean) ->
;; ensures that s matches spec. ;; ensures that s matches spec.
;; tag-spec ::= spec ;; tag-spec ::= spec
;; | (tag symbol spec) ;; | (tag symbol spec)
;; spec ::= prim-spec ;; spec ::= prim-spec
;; | (prefix identifier spec) ;; | (prefix identifier spec)
;; | (rename spec (identifier identifier) ...) ;; | (rename spec (identifier identifier) ...)
;; | (only spec identifier ...) only if import? is true ;; | (only spec identifier ...) only if import? is true
;; | (except spec identifier ...) only if import? is true ;; | (except spec identifier ...) only if import? is true
(define (check-tagged-spec-syntax s import? prim-spec?) (define (check-tagged-spec-syntax s import? prim-spec?)
((check-tagged (λ (s) (check-spec-syntax s import? prim-spec?))) s)) ((check-tagged (λ (s) (check-spec-syntax s import? prim-spec?))) s))
(define (check-spec-syntax s import? prim-spec?) (define (check-spec-syntax s import? prim-spec?)
(unless (prim-spec? s) (unless (prim-spec? s)
(let ((ie (if import? 'import 'export))) (let ((ie (if import? 'import 'export)))
(unless (stx-pair? s) (unless (stx-pair? s)
@ -75,8 +76,8 @@
(checked-syntax->list s) (checked-syntax->list s)
(syntax-case s (prefix rename) (syntax-case s (prefix rename)
((key . x) ((key . x)
(or (module-identifier=? #'key #'only) (or (free-identifier=? #'key #'only)
(module-identifier=? #'key #'except)) (free-identifier=? #'key #'except))
(begin (begin
(unless import? (unless import?
(raise-stx-err (raise-stx-err
@ -125,11 +126,11 @@
((k . x) ((k . x)
(raise-stx-err (format "bad ~a-spec keyword" ie) #'k)))))) (raise-stx-err (format "bad ~a-spec keyword" ie) #'k))))))
;; check-unit-syntax : syntax-object -> syntax-object ;; check-unit-syntax : syntax-object -> syntax-object
;; ensures that stx matches ((import i ...) (export e ...) b ...) ;; ensures that stx matches ((import i ...) (export e ...) b ...)
;; or ((import i ...) (export e ...) (init-depend id ...) b ...) ;; or ((import i ...) (export e ...) (init-depend id ...) b ...)
;; and returns syntax that matches the latter ;; and returns syntax that matches the latter
(define (check-unit-syntax stx) (define (check-unit-syntax stx)
(syntax-case stx (import export init-depend) (syntax-case stx (import export init-depend)
(((import . isig) (export . esig) (init-depend . id) . body) (((import . isig) (export . esig) (init-depend . id) . body)
(begin (begin
@ -155,11 +156,11 @@
(raise-stx-err "import clause must start with keyword \"import\"" #'i)))) (raise-stx-err "import clause must start with keyword \"import\"" #'i))))
;; check-unit-body-syntax : syntax-object -> syntax-object ;; check-unit-body-syntax : syntax-object -> syntax-object
;; ensures that stx matches (exp (import i ...) (export e ...)) ;; ensures that stx matches (exp (import i ...) (export e ...))
;; or (exp (import i ...) (export e ...) (init-depend id ...)) ;; or (exp (import i ...) (export e ...) (init-depend id ...))
;; and returns syntax that matches the latter ;; and returns syntax that matches the latter
(define (check-unit-body-syntax stx) (define (check-unit-body-syntax stx)
(checked-syntax->list stx) (checked-syntax->list stx)
(syntax-case stx (import export init-depend) (syntax-case stx (import export init-depend)
((exp (import . isig) (export . esig) (init-depend . id)) ((exp (import . isig) (export . esig) (init-depend . id))
@ -192,9 +193,9 @@
;; check-link-line-syntax : syntax-object -> ;; check-link-line-syntax : syntax-object ->
;; ensures that l matches ((x ...) u y ...) ;; ensures that l matches ((x ...) u y ...)
(define (check-link-line-syntax l) (define (check-link-line-syntax l)
(unless (stx-pair? l) (unless (stx-pair? l)
(raise-stx-err "bad linking line" l)) (raise-stx-err "bad linking line" l))
(checked-syntax->list l) (checked-syntax->list l)
@ -208,11 +209,11 @@
(raise-stx-err "bad export list" #'x)) (raise-stx-err "bad export list" #'x))
(checked-syntax->list #'x))))) (checked-syntax->list #'x)))))
;; check-compound-syntax : syntax-object -> syntax-object ;; check-compound-syntax : syntax-object -> syntax-object
;; ensures that clauses has exactly one clause matching each of ;; ensures that clauses has exactly one clause matching each of
;; (import i ...), (export e ...), and (link i ...), in any order. ;; (import i ...), (export e ...), and (link i ...), in any order.
;; returns #'((i ...) (e ...) (l ...)) ;; returns #'((i ...) (e ...) (l ...))
(define (check-compound-syntax c) (define (check-compound-syntax c)
(define clauses (checked-syntax->list c)) (define clauses (checked-syntax->list c))
(define im #f) (define im #f)
(define ex #f) (define ex #f)
@ -250,10 +251,10 @@
(raise-stx-err "missing link clause" )) (raise-stx-err "missing link clause" ))
#`(#,im #,ex #,li)) #`(#,im #,ex #,li))
;; check-def-syntax : syntax-object -> ;; check-def-syntax : syntax-object ->
;; d must be a syntax-pair ;; d must be a syntax-pair
;; ensures that d matches (_ (x ...) e) ;; ensures that d matches (_ (x ...) e)
(define (check-def-syntax d) (define (check-def-syntax d)
(unless (syntax->list d) (unless (syntax->list d)
(raise-syntax-error (raise-syntax-error
#f #f
@ -281,6 +282,3 @@
(format "bad syntax (has ~a parts after keyword)" (format "bad syntax (has ~a parts after keyword)"
(sub1 (length (syntax->list d)))) (sub1 (length (syntax->list d))))
d)))) d))))
)
;(load "test-unit-syntax.ss")

2
collects/mzlib/private/unit-utils.ss
View File

@ -4,7 +4,7 @@
syntax/boundmap syntax/boundmap
"unit-compiletime.ss" "unit-compiletime.ss"
"unit-syntax.ss") "unit-syntax.ss")
mzlib/contract) scheme/contract/base)
(provide (for-syntax build-key (provide (for-syntax build-key
check-duplicate-sigs check-duplicate-sigs

17
collects/mzlib/private/unitidmap.ss
View File

@ -1,8 +1,7 @@
#lang scheme/base
(module unitidmap mzscheme ;; Help Desk binding info:
(define (binding binder bound stx)
;; Help Desk binding info:
(define (binding binder bound stx)
stx stx
;; This 'bound-in-source is no longer needed ;; This 'bound-in-source is no longer needed
#; #;
@ -11,15 +10,15 @@
'bound-in-source 'bound-in-source
(cons binder (syntax-local-introduce bound)))) (cons binder (syntax-local-introduce bound))))
(define (make-id-mapper unbox-stx the-binder) (define (make-id-mapper unbox-stx the-binder)
(let ([set!-stx (datum->syntax-object unbox-stx 'set! #f)]) (let ([set!-stx (datum->syntax unbox-stx 'set! #f)])
(make-set!-transformer (make-set!-transformer
(lambda (sstx) (lambda (sstx)
(cond (cond
[(identifier? sstx) [(identifier? sstx)
(binding the-binder sstx (binding the-binder sstx
unbox-stx)] unbox-stx)]
[(module-identifier=? set!-stx (car (syntax-e sstx))) [(free-identifier=? set!-stx (car (syntax-e sstx)))
(raise-syntax-error (raise-syntax-error
'unit 'unit
"cannot set! imported or exported variables" "cannot set! imported or exported variables"
@ -27,10 +26,10 @@
[else [else
(binding (binding
the-binder (car (syntax-e sstx)) the-binder (car (syntax-e sstx))
(datum->syntax-object (datum->syntax
sstx sstx
(cons unbox-stx (cdr (syntax-e sstx))) (cons unbox-stx (cdr (syntax-e sstx)))
sstx))]))))) sstx))])))))
(provide make-id-mapper)) (provide make-id-mapper)

13
collects/mzlib/unit-exptime.ss
View File

@ -1,17 +1,18 @@
(module unit-exptime mzscheme #lang scheme/base
(require "private/unit-syntax.ss"
(require "private/unit-syntax.ss"
"private/unit-compiletime.ss") "private/unit-compiletime.ss")
(provide unit-static-signatures (provide unit-static-signatures
signature-members) signature-members)
(define (unit-static-signatures name err-stx) (define (unit-static-signatures name err-stx)
(parameterize ((error-syntax err-stx)) (parameterize ((error-syntax err-stx))
(let ((ui (lookup-def-unit name))) (let ((ui (lookup-def-unit name)))
(values (apply list (unit-info-import-sig-ids ui)) (values (apply list (unit-info-import-sig-ids ui))
(apply list (unit-info-export-sig-ids ui)))))) (apply list (unit-info-export-sig-ids ui))))))
(define (signature-members name err-stx) (define (signature-members name err-stx)
(parameterize ((error-syntax err-stx)) (parameterize ((error-syntax err-stx))
(let ([s (lookup-signature name)]) (let ([s (lookup-signature name)])
(values (values
@ -23,4 +24,4 @@
;; defined vars ;; defined vars
(apply list (apply append (map car (signature-val-defs s)))) (apply list (apply append (map car (signature-val-defs s))))
;; defined stxs ;; defined stxs
(apply list (apply append (map car (signature-stx-defs s))))))))) (apply list (apply append (map car (signature-stx-defs s))))))))

277
collects/mzlib/unit.ss
View File

@ -1,5 +1,7 @@
(module unit mzscheme #lang scheme/base
(require-for-syntax mzlib/list
(require (for-syntax scheme/base
scheme/list
syntax/boundmap syntax/boundmap
syntax/context syntax/context
syntax/kerncase syntax/kerncase
@ -9,21 +11,21 @@
syntax/stx syntax/stx
"private/unit-contract-syntax.ss" "private/unit-contract-syntax.ss"
"private/unit-compiletime.ss" "private/unit-compiletime.ss"
"private/unit-syntax.ss") "private/unit-syntax.ss"))
(require mzlib/etc (require mzlib/etc
mzlib/contract scheme/contract/base
mzlib/stxparam scheme/stxparam
"private/unit-contract.ss" "private/unit-contract.ss"
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.ss" "private/unit-runtime.ss"
"private/unit-utils.ss") "private/unit-utils.ss")
(provide define-signature-form struct struct/ctc open (provide define-signature-form struct struct/ctc open
define-signature provide-signature-elements define-signature provide-signature-elements
only except rename import export prefix link tag init-depend extends contracted only except rename import export prefix link tag init-depend extends contracted
unit? unit?
(rename :unit unit) define-unit (rename-out [:unit unit]) define-unit
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
invoke-unit define-values/invoke-unit invoke-unit define-values/invoke-unit
invoke-unit/infer define-values/invoke-unit/infer invoke-unit/infer define-values/invoke-unit/infer
@ -33,7 +35,7 @@
unit/s define-unit/s unit/s define-unit/s
unit/c define-unit/contract) unit/c define-unit/contract)
(define-syntax/err-param (define-signature-form stx) (define-syntax/err-param (define-signature-form stx)
(syntax-case stx () (syntax-case stx ()
((_ (name arg) . val) ((_ (name arg) . val)
(begin (begin
@ -53,7 +55,7 @@
"expected syntax matching (identifier identifier)" "expected syntax matching (identifier identifier)"
(car l))))))) (car l)))))))
(define-signature-form (struct stx) (define-signature-form (struct stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
(syntax-case stx () (syntax-case stx ()
((_ name (field ...) . omissions) ((_ name (field ...) . omissions)
@ -90,16 +92,16 @@
(lambda (omission) (lambda (omission)
(cond (cond
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-selectors)) (free-identifier=? omission #'-selectors))
(set! omit-selectors #t)) (set! omit-selectors #t))
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-setters)) (free-identifier=? omission #'-setters))
(set! omit-setters #t)) (set! omit-setters #t))
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-constructor)) (free-identifier=? omission #'-constructor))
(set! omit-constructor #t)) (set! omit-constructor #t))
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-type)) (free-identifier=? omission #'-type))
(set! omit-type #t)) (set! omit-type #t))
(else (else
(raise-stx-err (raise-stx-err
@ -126,7 +128,7 @@
((_) ((_)
(raise-stx-err "missing name and fields"))))) (raise-stx-err "missing name and fields")))))
(define-signature-form (struct/ctc stx) (define-signature-form (struct/ctc stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
(syntax-case stx () (syntax-case stx ()
((_ name ([field ctc] ...) . omissions) ((_ name ([field ctc] ...) . omissions)
@ -170,16 +172,16 @@
(lambda (omission) (lambda (omission)
(cond (cond
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-selectors)) (free-identifier=? omission #'-selectors))
(set! omit-selectors #t)) (set! omit-selectors #t))
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-setters)) (free-identifier=? omission #'-setters))
(set! omit-setters #t)) (set! omit-setters #t))
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-constructor)) (free-identifier=? omission #'-constructor))
(set! omit-constructor #t)) (set! omit-constructor #t))
((and (identifier? omission) ((and (identifier? omission)
(module-identifier=? omission #'-type)) (free-identifier=? omission #'-type))
(set! omit-type #t)) (set! omit-type #t))
(else (else
(raise-stx-err (raise-stx-err
@ -211,8 +213,8 @@
(raise-stx-err "missing name and fields"))))) (raise-stx-err "missing name and fields")))))
;; build-val+macro-defs : sig -> (list syntax-object^3) ;; build-val+macro-defs : sig -> (list syntax-object^3)
(define-for-syntax (build-val+macro-defs sig) (define-for-syntax (build-val+macro-defs sig)
(with-syntax ([(((int-ivar . ext-ivar) ...) (with-syntax ([(((int-ivar . ext-ivar) ...)
((((int-vid . ext-vid) ...) . vbody) ...) ((((int-vid . ext-vid) ...) . vbody) ...)
((((int-sid . ext-sid) ...) . sbody) ...) ((((int-sid . ext-sid) ...) . sbody) ...)
@ -233,7 +235,7 @@
#'(((int-vid ...) vbody) ...)))) #'(((int-vid ...) vbody) ...))))
(define-signature-form (open stx) (define-signature-form (open stx)
(define (build-sig-elems sig) (define (build-sig-elems sig)
(map (λ (p c) (map (λ (p c)
(if c #`(contracted [#,(car p) #,c]) (car p))) (if c #`(contracted [#,(car p) #,c]) (car p)))
@ -259,12 +261,12 @@
(syntax-e (stx-car stx)))))))) (syntax-e (stx-car stx))))))))
(define-for-syntax (introduce-def d) (define-for-syntax (introduce-def d)
(cons (map syntax-local-introduce (car d)) (cons (map syntax-local-introduce (car d))
(syntax-local-introduce (cdr d)))) (syntax-local-introduce (cdr d))))
;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object ;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
(define-for-syntax (build-define-signature sigid super-sigid sig-exprs) (define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
(unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs)) (unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
(raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs)) (raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
(let ([ses (checked-syntax->list sig-exprs)]) (let ([ses (checked-syntax->list sig-exprs)])
@ -350,7 +352,7 @@
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs))) (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs)))
((x (y z) ...) ((x (y z) ...)
(and (identifier? #'x) (and (identifier? #'x)
(module-identifier=? #'x #'contracted) (free-identifier=? #'x #'contracted)
(andmap identifier? (syntax->list #'(y ...)))) (andmap identifier? (syntax->list #'(y ...))))
(loop (cdr sig-exprs) (loop (cdr sig-exprs)
(append (syntax->list #'(y ...)) bindings) (append (syntax->list #'(y ...)) bindings)
@ -359,15 +361,15 @@
(append (syntax->list #'(z ...)) ctcs))) (append (syntax->list #'(z ...)) ctcs)))
((x . z) ((x . z)
(and (identifier? #'x) (and (identifier? #'x)
(module-identifier=? #'x #'contracted)) (free-identifier=? #'x #'contracted))
(raise-syntax-error (raise-syntax-error
'define-signature 'define-signature
"expected a list of [id contract] pairs after the contracted keyword" "expected a list of [id contract] pairs after the contracted keyword"
(car sig-exprs))) (car sig-exprs)))
((x . y) ((x . y)
(and (identifier? #'x) (and (identifier? #'x)
(or (module-identifier=? #'x #'define-values) (or (free-identifier=? #'x #'define-values)
(module-identifier=? #'x #'define-syntaxes))) (free-identifier=? #'x #'define-syntaxes)))
(begin (begin
(check-def-syntax (car sig-exprs)) (check-def-syntax (car sig-exprs))
(syntax-case #'y () (syntax-case #'y ()
@ -378,11 +380,11 @@
(let ((b #'body)) (let ((b #'body))
(loop (cdr sig-exprs) (loop (cdr sig-exprs)
bindings bindings
(if (module-identifier=? #'x #'define-values) (if (free-identifier=? #'x #'define-values)
(cons (cons (syntax->list #'(name ...)) b) (cons (cons (syntax->list #'(name ...)) b)
val-defs) val-defs)
val-defs) val-defs)
(if (module-identifier=? #'x #'define-syntaxes) (if (free-identifier=? #'x #'define-syntaxes)
(cons (cons (syntax->list #'(name ...)) b) (cons (cons (syntax->list #'(name ...)) b)
stx-defs) stx-defs)
stx-defs) stx-defs)
@ -411,7 +413,7 @@
#'x)))))))) #'x))))))))
(define-syntax/err-param (define-signature stx) (define-syntax/err-param (define-signature stx)
(syntax-case stx (extends) (syntax-case stx (extends)
((_ sig-name sig-exprs) ((_ sig-name sig-exprs)
(begin (begin
@ -429,12 +431,12 @@
(format "expected syntax matching (~a identifier (sig-expr ...)) or (~a identifier extends identifier (sig-expr ...))" (format "expected syntax matching (~a identifier (sig-expr ...)) or (~a identifier extends identifier (sig-expr ...))"
(syntax-e (stx-car stx)) (syntax-e (stx-car stx)))))))) (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))))))
(define-for-syntax (signature->identifiers sigids) (define-for-syntax (signature->identifiers sigids)
(define provide-tagged-sigs (map process-tagged-import sigids)) (define provide-tagged-sigs (map process-tagged-import sigids))
(define provide-sigs (map caddr provide-tagged-sigs)) (define provide-sigs (map caddr provide-tagged-sigs))
(map sig-int-names provide-sigs)) (map sig-int-names provide-sigs))
(define-syntax/err-param (provide-signature-elements stx) (define-syntax/err-param (provide-signature-elements stx)
(syntax-case stx () (syntax-case stx ()
((_ . p) ((_ . p)
(let* ((sigs (checked-syntax->list #'p)) (let* ((sigs (checked-syntax->list #'p))
@ -448,7 +450,7 @@
(filter (lambda (name) (filter (lambda (name)
(bound-identifier=? (bound-identifier=?
name name
(datum->syntax-object sig (syntax-e name)))) (datum->syntax sig (syntax-e name))))
names)) names))
sigs nameses)) sigs nameses))
(names (apply append nameses)) (names (apply append nameses))
@ -458,21 +460,21 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(provide #,@names)))))) (provide #,@names))))))
;; A unit is ;; A unit is
;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...) ;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...)
(define-for-syntax (localify exp def-ctx) (define-for-syntax (localify exp def-ctx)
(cadr (syntax->list (cadr (syntax->list
(local-expand #`(stop #,exp) (local-expand #`(stop #,exp)
'expression 'expression
(list #'stop) (list #'stop)
def-ctx)))) def-ctx))))
(define-for-syntax (tagged-sigid->tagged-siginfo x) (define-for-syntax (tagged-sigid->tagged-siginfo x)
(cons (car x) (cons (car x)
(signature-siginfo (lookup-signature (cdr x))))) (signature-siginfo (lookup-signature (cdr x)))))
(define-for-syntax (make-import-unboxing var renamings loc ctc) (define-for-syntax (make-import-unboxing var renamings loc ctc)
(if ctc (if ctc
(with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
@ -482,17 +484,17 @@
(current-contract-region) (current-contract-region)
#,(id->contract-src-info var)) #,(id->contract-src-info var))
(error 'unit "contracted import ~a used before definition" (error 'unit "contracted import ~a used before definition"
(quote #,(syntax-object->datum var)))))))) (quote #,(syntax->datum var))))))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (#,loc))))) (quote-syntax (#,loc)))))
;; build-unit : syntax-object -> ;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
;; constructs the code for a unit expression. stx must be ;; constructs the code for a unit expression. stx must be
;; such that it passes check-unit-syntax. ;; such that it passes check-unit-syntax.
;; The two additional values are the identifiers of the unit's import and export ;; The two additional values are the identifiers of the unit's import and export
;; signatures ;; signatures
(define-for-syntax (build-unit stx) (define-for-syntax (build-unit stx)
(syntax-case stx (import export init-depend) (syntax-case stx (import export init-depend)
(((import i ...) (((import i ...)
(export e ...) (export e ...)
@ -568,7 +570,7 @@
(values (values
(lambda (import-table) (lambda (import-table)
(let-values ([(iloc ...) (let-values ([(iloc ...)
(vector->values (hash-table-get import-table import-key) 0 icount)] (vector->values (hash-ref import-table import-key) 0 icount)]
...) ...)
(letrec-syntaxes (#,@(map (lambda (ivs e-ivs ils ics) (letrec-syntaxes (#,@(map (lambda (ivs e-ivs ils ics)
(with-syntax ([renamings (with-syntax ([renamings
@ -604,14 +606,14 @@
export-tagged-sigids export-tagged-sigids
dep-tagged-sigids)))))) dep-tagged-sigids))))))
(define-syntax/err-param (:unit stx) (define-syntax/err-param (:unit stx)
(syntax-case stx () (syntax-case stx ()
((_ . x) ((_ . x)
(begin (begin
(let-values (((u x y z) (build-unit (check-unit-syntax #'x)))) (let-values (((u x y z) (build-unit (check-unit-syntax #'x))))
u))))) u)))))
(define-syntax (unit-body stx) (define-syntax (unit-body stx)
(syntax-case stx () (syntax-case stx ()
((_ err-stx ivars evars elocs ectcs body ...) ((_ err-stx ivars evars elocs ectcs body ...)
(parameterize ((error-syntax #'err-stx)) (parameterize ((error-syntax #'err-stx))
@ -624,8 +626,8 @@
[definition? [definition?
(lambda (id) (lambda (id)
(and (identifier? id) (and (identifier? id)
(or (module-identifier=? id (quote-syntax define-values)) (or (free-identifier=? id (quote-syntax define-values))
(module-identifier=? id (quote-syntax define-syntaxes)))))] (free-identifier=? id (quote-syntax define-syntaxes)))))]
[expanded-body [expanded-body
(let expand-all ((defns&exprs (syntax->list #'(body ...)))) (let expand-all ((defns&exprs (syntax->list #'(body ...))))
;; Also lifted from Matthew, to expand the body enough ;; Also lifted from Matthew, to expand the body enough
@ -680,7 +682,7 @@
(raise-stx-err "variable defined twice" id)) (raise-stx-err "variable defined twice" id))
(bound-identifier-mapping-put! (bound-identifier-mapping-put!
table id table id
(make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes)) (make-var-info (free-identifier=? #'dv (quote-syntax define-syntaxes))
#f #f
id id
#f))) #f)))
@ -763,7 +765,7 @@
expanded-body))]) expanded-body))])
#'(begin-with-definitions defn-or-expr ...)))))))) #'(begin-with-definitions defn-or-expr ...))))))))
(define-for-syntax (redirect-imports/exports import?) (define-for-syntax (redirect-imports/exports import?)
(lambda (table-stx (lambda (table-stx
import-tagged-infos import-tagged-infos
import-sigs import-sigs
@ -775,7 +777,7 @@
(for-each (for-each
(lambda (tagged-info sig) (lambda (tagged-info sig)
(define v (define v
#`(hash-table-get #,table-stx #,(car (tagged-info->keys tagged-info)))) #`(hash-ref #,table-stx #,(car (tagged-info->keys tagged-info))))
(for-each (for-each
(lambda (int/ext-name index ctc) (lambda (int/ext-name index ctc)
(bound-identifier-mapping-put! def-table (bound-identifier-mapping-put! def-table
@ -840,17 +842,17 @@
#`(unit-export ((export-keys ...) #`(unit-export ((export-keys ...)
(vector-immutable eloc ...)) ...)))) (vector-immutable eloc ...)) ...))))
(define-for-syntax redirect-imports (redirect-imports/exports #t)) (define-for-syntax redirect-imports (redirect-imports/exports #t))
(define-for-syntax redirect-exports (redirect-imports/exports #f)) (define-for-syntax redirect-exports (redirect-imports/exports #f))
;; build-unit/new-import-export : syntax-object -> ;; build-unit/new-import-export : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
;; constructs the code for a unit expression that changes the import and export signatures ;; constructs the code for a unit expression that changes the import and export signatures
;; of another. stx must be such that it passes check-unit-syntax. ;; of another. stx must be such that it passes check-unit-syntax.
;; The two additional values are the identifiers of the unit's import and export ;; The two additional values are the identifiers of the unit's import and export
;; signatures ;; signatures
(define-for-syntax (build-unit/new-import-export stx) (define-for-syntax (build-unit/new-import-export stx)
(syntax-case stx (import export init-depend) (syntax-case stx (import export init-depend)
(((import i ...) (((import i ...)
(export e ...) (export e ...)
@ -954,20 +956,20 @@
dep-tagged-sigids))))))) dep-tagged-sigids)))))))
(define-syntax/err-param (unit/new-import-export stx) (define-syntax/err-param (unit/new-import-export stx)
(syntax-case stx () (syntax-case stx ()
((_ . x) ((_ . x)
(begin (begin
(let-values (((u x y z) (build-unit/new-import-export (check-unit-syntax #'x)))) (let-values (((u x y z) (build-unit/new-import-export (check-unit-syntax #'x))))
u))))) u)))))
;; build-compound-unit : syntax-object -> ;; build-compound-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
;; constructs the code for a compound-unit expression. stx match the return of ;; constructs the code for a compound-unit expression. stx match the return of
;; check-compound-syntax ;; check-compound-syntax
;; The two additional values are the identifiers of the compound-unit's import and export ;; The two additional values are the identifiers of the compound-unit's import and export
;; signatures ;; signatures
(define-for-syntax (build-compound-unit stx) (define-for-syntax (build-compound-unit stx)
(define-struct lnkid-record (access-code names ctime-ids rtime-ids source-idx sigid siginfo)) (define-struct lnkid-record (access-code names ctime-ids rtime-ids source-idx sigid siginfo))
(define (lnkid-rec->keys t rec) (define (lnkid-rec->keys t rec)
(map (lambda (rid) (build-key t rid)) (map (lambda (rid) (build-key t rid))
@ -1021,7 +1023,7 @@
bt bt
lnkid lnkid
(make-lnkid-record (make-lnkid-record
#`(hash-table-get #`(hash-ref
#,tableid #,tableid
#,(build-key (syntax-e tag) (car rtime-ids))) #,(build-key (syntax-e tag) (car rtime-ids)))
(siginfo-names siginfo) (siginfo-names siginfo)
@ -1047,7 +1049,7 @@
[link-deps [link-deps
(map (map
(lambda (tags lnkids i) (lambda (tags lnkids i)
(define ht (make-hash-table 'equal)) (define ht (make-hash))
(for-each (for-each
(lambda (t l) (lambda (t l)
(define et (syntax-e t)) (define et (syntax-e t))
@ -1057,7 +1059,7 @@
(define import-dep (= 0 (lnkid-record-source-idx rec))) (define import-dep (= 0 (lnkid-record-source-idx rec)))
(for-each (for-each
(lambda (ctime-id rtime-id name) (lambda (ctime-id rtime-id name)
(hash-table-put! ht (hash-set! ht
(build-key et ctime-id) (build-key et ctime-id)
(list forward-dep import-dep et rtime-id name el))) (list forward-dep import-dep et rtime-id name el)))
(lnkid-record-ctime-ids rec) (lnkid-record-ctime-ids rec)
@ -1065,7 +1067,7 @@
(lnkid-record-names rec))) (lnkid-record-names rec)))
(syntax->list tags) (syntax->list tags)
(syntax->list lnkids)) (syntax->list lnkids))
(hash-table-map ht (lambda (x y) y))) (hash-map ht (lambda (x y) y)))
(syntax->list #'((sub-in-tag ...) ...)) (syntax->list #'((sub-in-tag ...) ...))
(syntax->list #'((sub-in-lnkid ...) ...)) (syntax->list #'((sub-in-lnkid ...) ...))
(cdr idxs))]) (cdr idxs))])
@ -1182,7 +1184,7 @@
#,(syntax/loc #'sub-exp (check-deps fht sub-tmp 'form)) #,(syntax/loc #'sub-exp (check-deps fht sub-tmp 'form))
(for-each (for-each
(lambda (dep) (lambda (dep)
(when (hash-table-get rht dep #f) (when (hash-ref rht dep #f)
(set! deps (cons dep deps)))) (set! deps (cons dep deps))))
(unit-deps sub-tmp))))))) (unit-deps sub-tmp)))))))
(syntax->list #'((sub-exp (syntax->list #'((sub-exp
@ -1231,20 +1233,20 @@
(for-each check-link-line-syntax (syntax->list #'(l ...)))))) (for-each check-link-line-syntax (syntax->list #'(l ...))))))
(define-syntax/err-param (compound-unit stx) (define-syntax/err-param (compound-unit stx)
(let-values (((u x y z) (let-values (((u x y z)
(build-compound-unit (build-compound-unit
(check-compound-syntax (syntax-case stx () ((_ . x) #'x)))))) (check-compound-syntax (syntax-case stx () ((_ . x) #'x))))))
u)) u))
(define (invoke-unit/core unit) (define (invoke-unit/core unit)
(check-unit unit 'invoke-unit) (check-unit unit 'invoke-unit)
(check-no-imports unit 'invoke-unit) (check-no-imports unit 'invoke-unit)
(let-values ([(f exports) ((unit-go unit))]) (let-values ([(f exports) ((unit-go unit))])
(f #f))) (f #f)))
(define-syntax/err-param (define-values/invoke-unit/core stx) (define-syntax/err-param (define-values/invoke-unit/core stx)
(syntax-case stx () (syntax-case stx ()
((_ unit-expr . unit-out) ((_ unit-expr . unit-out)
(let* ((unit-out (checked-syntax->list #'unit-out)) (let* ((unit-out (checked-syntax->list #'unit-out))
@ -1323,7 +1325,7 @@
'define-values/invoke-unit) 'define-values/invoke-unit)
(let-values (((unit-fn export-table) (let-values (((unit-fn export-table)
((unit-go unit-tmp)))) ((unit-go unit-tmp))))
(let ([out-vec (hash-table-get export-table key1)] ...) (let ([out-vec (hash-ref export-table key1)] ...)
(unit-fn #f) (unit-fn #f)
(values out-code ... ...)))))) (values out-code ... ...))))))
(define-values (int-binding ... ...) (define-values (int-binding ... ...)
@ -1334,13 +1336,13 @@
((_) ((_)
(raise-stx-err "missing unit expression")))) (raise-stx-err "missing unit expression"))))
;; build-unit-from-context : syntax-object -> ;; build-unit-from-context : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
;; constructs the code for a unit-from-context expression. stx must be ;; constructs the code for a unit-from-context expression. stx must be
;; such that it passes check-ufc-syntax. ;; such that it passes check-ufc-syntax.
;; The two additional values are the identifiers of the unit's import and export ;; The two additional values are the identifiers of the unit's import and export
;; signatures ;; signatures
(define-for-syntax (build-unit-from-context stx) (define-for-syntax (build-unit-from-context stx)
(syntax-case stx () (syntax-case stx ()
((export-spec) ((export-spec)
(let* ((tagged-export-sig (process-tagged-export #'export-spec)) (let* ((tagged-export-sig (process-tagged-export #'export-spec))
@ -1355,7 +1357,7 @@
(list (cadr tagged-export-sig)) (list (cadr tagged-export-sig))
'())))))) '()))))))
(define-for-syntax (check-ufc-syntax stx) (define-for-syntax (check-ufc-syntax stx)
(syntax-case stx () (syntax-case stx ()
((export-spec) (void)) ((export-spec) (void))
(() (()
@ -1363,7 +1365,7 @@
(_ (_
(raise-stx-err "nothing is permitted after export-spec")))) (raise-stx-err "nothing is permitted after export-spec"))))
(define-syntax/err-param (unit-from-context stx) (define-syntax/err-param (unit-from-context stx)
(syntax-case stx () (syntax-case stx ()
((_ . x) ((_ . x)
(begin (begin
@ -1373,7 +1375,7 @@
(define-for-syntax (build-define-unit-helper contracted?) (define-for-syntax (build-define-unit-helper contracted?)
(lambda (stx build err-msg) (lambda (stx build err-msg)
(syntax-case stx () (syntax-case stx ()
((_ name . rest) ((_ name . rest)
@ -1399,14 +1401,14 @@
((_) ((_)
(raise-stx-err err-msg))))) (raise-stx-err err-msg)))))
;; build-define-unit : syntax-object ;; build-define-unit : syntax-object
;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier)) ;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier))
;; string -> ;; string ->
;; syntax-object ;; syntax-object
(define-for-syntax build-define-unit (build-define-unit-helper #f)) (define-for-syntax build-define-unit (build-define-unit-helper #f))
(define-for-syntax build-define-unit/contracted (build-define-unit-helper #t)) (define-for-syntax build-define-unit/contracted (build-define-unit-helper #t))
(define-for-syntax (build-define-unit-binding stx) (define-for-syntax (build-define-unit-binding stx)
(define (check-helper tagged-info) (define (check-helper tagged-info)
(cons (car (siginfo-names (cdr tagged-info))) (cons (car (siginfo-names (cdr tagged-info)))
@ -1450,33 +1452,33 @@
tagged-export-sigids tagged-export-sigids
tagged-dep-sigids)))))) tagged-dep-sigids))))))
(define-syntax/err-param (define-unit-binding stx) (define-syntax/err-param (define-unit-binding stx)
(build-define-unit stx (lambda (unit) (build-define-unit stx (lambda (unit)
(build-define-unit-binding (check-unit-body-syntax unit))) (build-define-unit-binding (check-unit-body-syntax unit)))
"missing unit name, unit expression, import clause, and export clause")) "missing unit name, unit expression, import clause, and export clause"))
(define-syntax/err-param (define-unit stx) (define-syntax/err-param (define-unit stx)
(build-define-unit stx (lambda (unit) (build-define-unit stx (lambda (unit)
(build-unit (check-unit-syntax unit))) (build-unit (check-unit-syntax unit)))
"missing unit name, import clause, and export clause")) "missing unit name, import clause, and export clause"))
(define-syntax/err-param (define-unit/new-import-export stx) (define-syntax/err-param (define-unit/new-import-export stx)
(build-define-unit stx (lambda (unit) (build-define-unit stx (lambda (unit)
(build-unit/new-import-export (check-unit-syntax unit))) (build-unit/new-import-export (check-unit-syntax unit)))
"missing unit name, import clause, and export clause")) "missing unit name, import clause, and export clause"))
(define-syntax/err-param (define-compound-unit stx) (define-syntax/err-param (define-compound-unit stx)
(build-define-unit stx (lambda (clauses) (build-define-unit stx (lambda (clauses)
(build-compound-unit (check-compound-syntax clauses))) (build-compound-unit (check-compound-syntax clauses)))
"missing unit name")) "missing unit name"))
(define-syntax/err-param (define-unit-from-context stx) (define-syntax/err-param (define-unit-from-context stx)
(build-define-unit stx (lambda (sig) (build-define-unit stx (lambda (sig)
(check-ufc-syntax sig) (check-ufc-syntax sig)
(build-unit-from-context sig)) (build-unit-from-context sig))
"missing unit name and signature")) "missing unit name and signature"))
(define-for-syntax (build-unit/contract stx) (define-for-syntax (build-unit/contract stx)
(syntax-parse stx (syntax-parse stx
[(:import-clause/contract :export-clause/contract dep:dep-clause . body) [(:import-clause/contract :export-clause/contract dep:dep-clause . body)
(let-values ([(exp isigs esigs deps) (let-values ([(exp isigs esigs deps)
@ -1512,24 +1514,24 @@
(syntax/loc stx (syntax/loc stx
(ic ec (init-depend) . body)))])) (ic ec (init-depend) . body)))]))
(define-syntax/err-param (define-unit/contract stx) (define-syntax/err-param (define-unit/contract stx)
(build-define-unit/contracted stx (λ (stx) (build-define-unit/contracted stx (λ (stx)
(build-unit/contract stx)) (build-unit/contract stx))
"missing unit name")) "missing unit name"))
(define-for-syntax (unprocess-tagged-id ti) (define-for-syntax (unprocess-tagged-id ti)
(if (car ti) (if (car ti)
#`(tag #,(car ti) #,(cdr ti)) #`(tag #,(car ti) #,(cdr ti))
(cdr ti))) (cdr ti)))
(define-for-syntax (temp-id-with-tags id i) (define-for-syntax (temp-id-with-tags id i)
(syntax-case i (tag) (syntax-case i (tag)
[(tag t sig) [(tag t sig)
(list id #`(tag t #,id) #'sig)] (list id #`(tag t #,id) #'sig)]
[_else [_else
(list id id i)])) (list id id i)]))
(define-syntax/err-param (define-values/invoke-unit stx) (define-syntax/err-param (define-values/invoke-unit stx)
(syntax-case stx (import export) (syntax-case stx (import export)
((_ u (import) (export e ...)) ((_ u (import) (export e ...))
(quasisyntax/loc stx (quasisyntax/loc stx
@ -1561,13 +1563,13 @@
(format "expected syntax matching (~a <unit-expression> (import <sig-expr> ...) (export <sig-expr> ...))" (format "expected syntax matching (~a <unit-expression> (import <sig-expr> ...) (export <sig-expr> ...))"
(syntax-e (stx-car stx))))))) (syntax-e (stx-car stx)))))))
;; build-compound-unit/infer : syntax-object -> ;; build-compound-unit/infer : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
;; constructs the code for a compound-unit/infer expression. stx match the return of ;; constructs the code for a compound-unit/infer expression. stx match the return of
;; check-compound-syntax ;; check-compound-syntax
;; The two additional values are the identifiers of the compound-unit's import and export ;; The two additional values are the identifiers of the compound-unit's import and export
;; signatures ;; signatures
(define-for-syntax (build-compound-unit/infer stx) (define-for-syntax (build-compound-unit/infer stx)
(define (lookup-tagged tid) (define (lookup-tagged tid)
(cons (car tid) (lookup-signature (cdr tid)))) (cons (car tid) (lookup-signature (cdr tid))))
@ -1623,7 +1625,7 @@
[link-defs (append import-sigs (apply append sub-outs))]) [link-defs (append import-sigs (apply append sub-outs))])
(define lnk-table (make-bound-identifier-mapping)) (define lnk-table (make-bound-identifier-mapping))
(define sig-table (make-hash-table)) (define sig-table (make-hasheq))
(let ([dup (check-duplicate-identifier (map link-record-linkid link-defs))]) (let ([dup (check-duplicate-identifier (map link-record-linkid link-defs))])
(when dup (when dup
@ -1638,8 +1640,8 @@
(lambda (b) (lambda (b)
(for-each (for-each
(lambda (cid) (lambda (cid)
(define there? (hash-table-get sig-table cid #f)) (define there? (hash-ref sig-table cid #f))
(hash-table-put! sig-table cid (if there? 'duplicate (link-record-linkid b)))) (hash-set! sig-table cid (if there? 'duplicate (link-record-linkid b))))
(siginfo-ctime-ids (link-record-siginfo b)))) (siginfo-ctime-ids (link-record-siginfo b))))
link-defs) link-defs)
@ -1687,7 +1689,7 @@
(cond (cond
[lookup (unprocess-tagged-id tid)] [lookup (unprocess-tagged-id tid)]
[else [else
(let ([lnkid (hash-table-get (let ([lnkid (hash-ref
sig-table sig-table
(car (siginfo-ctime-ids (signature-siginfo (lookup-signature (cdr tid))))) (car (siginfo-ctime-ids (signature-siginfo (lookup-signature (cdr tid)))))
#f)]) #f)])
@ -1723,7 +1725,7 @@
(for-each check-link-line-syntax (syntax->list #'(l ...)))))) (for-each check-link-line-syntax (syntax->list #'(l ...))))))
(define-for-syntax (check-compound/infer-syntax stx) (define-for-syntax (check-compound/infer-syntax stx)
(syntax-case (check-compound-syntax stx) () (syntax-case (check-compound-syntax stx) ()
((i e (b ...)) ((i e (b ...))
(with-syntax (((b ...) (with-syntax (((b ...)
@ -1735,24 +1737,24 @@
(syntax->list #'(b ...))))) (syntax->list #'(b ...)))))
#'(i e (b ...)))))) #'(i e (b ...))))))
(define-syntax/err-param (compound-unit/infer stx) (define-syntax/err-param (compound-unit/infer stx)
(let-values (((u i e d) (let-values (((u i e d)
(build-compound-unit/infer (build-compound-unit/infer
(check-compound/infer-syntax (check-compound/infer-syntax
(syntax-case stx () ((_ . x) #'x)))))) (syntax-case stx () ((_ . x) #'x))))))
u)) u))
(define-for-syntax (do-define-compound-unit/infer stx) (define-for-syntax (do-define-compound-unit/infer stx)
(build-define-unit stx (build-define-unit stx
(lambda (clause) (lambda (clause)
(build-compound-unit/infer (check-compound/infer-syntax clause))) (build-compound-unit/infer (check-compound/infer-syntax clause)))
"missing unit name")) "missing unit name"))
(define-syntax/err-param (define-compound-unit/infer stx) (define-syntax/err-param (define-compound-unit/infer stx)
(do-define-compound-unit/infer stx)) (do-define-compound-unit/infer stx))
;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax ;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax
(define-for-syntax (build-invoke-unit/infer units define? exports) (define-for-syntax (build-invoke-unit/infer units define? exports)
(define (imps/exps-from-unit u) (define (imps/exps-from-unit u)
(let* ([ui (lookup-def-unit u)] (let* ([ui (lookup-def-unit u)]
[unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))]) [unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))])
@ -1792,11 +1794,11 @@
(loop (cdr units) (append i imps) (append e exps)))))) (loop (cdr units) (append i imps) (append e exps))))))
(define-values (isig tagged-import-sigs import-tagged-infos (define-values (isig tagged-import-sigs import-tagged-infos
import-tagged-sigids import-sigs) import-tagged-sigids import-sigs)
(process-unit-import (datum->syntax-object #f isigs))) (process-unit-import (datum->syntax #f isigs)))
(define-values (esig tagged-export-sigs export-tagged-infos (define-values (esig tagged-export-sigs export-tagged-infos
export-tagged-sigids export-sigs) export-tagged-sigids export-sigs)
(process-unit-export (datum->syntax-object #f esigs))) (process-unit-export (datum->syntax #f esigs)))
(check-duplicate-subs export-tagged-infos esig) (check-duplicate-subs export-tagged-infos esig)
(let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)]) (let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)])
(values (drop-from-other-list export-tagged-infos itagged isources) (values (drop-from-other-list export-tagged-infos itagged isources)
@ -1804,7 +1806,7 @@
[(list? exports) [(list? exports)
(let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos (let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos
spec-export-tagged-sigids spec-export-sigs) spec-export-tagged-sigids spec-export-sigs)
(process-unit-export (datum->syntax-object #f exports))]) (process-unit-export (datum->syntax #f exports))])
(restrict-exports export-tagged-infos (restrict-exports export-tagged-infos
spec-esig spec-export-tagged-infos))] spec-esig spec-export-tagged-infos))]
[else esig])))) [else esig]))))
@ -1816,7 +1818,7 @@
(siginfo-subtype (cdr ute) (cdr ste)))) (siginfo-subtype (cdr ute) (cdr ste))))
unit-tagged-exports) unit-tagged-exports)
(raise-stx-err (format "no subunit exports signature ~a" (raise-stx-err (format "no subunit exports signature ~a"
(syntax-object->datum se)) (syntax->datum se))
se))) se)))
spec-exports spec-exports
spec-tagged-exports) spec-tagged-exports)
@ -1856,7 +1858,7 @@
;; just for error handling ;; just for error handling
[else (lookup-def-unit units)])) [else (lookup-def-unit units)]))
(define-syntax/err-param (define-values/invoke-unit/infer stx) (define-syntax/err-param (define-values/invoke-unit/infer stx)
(syntax-case stx (export link) (syntax-case stx (export link)
[(_ (link unit ...)) [(_ (link unit ...))
(build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)] (build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)]
@ -1873,7 +1875,7 @@
(format "expected syntax matching (~a [(export <define-signature-identifier>)] <define-unit-identifier>) or (~a [(export <define-signature-identifier>)] (link <define-unit-identifier> ...))" (format "expected syntax matching (~a [(export <define-signature-identifier>)] <define-unit-identifier>) or (~a [(export <define-signature-identifier>)] (link <define-unit-identifier> ...))"
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
(define-syntax/err-param (invoke-unit stx) (define-syntax/err-param (invoke-unit stx)
(syntax-case stx (import) (syntax-case stx (import)
((_ unit) ((_ unit)
(syntax/loc stx (syntax/loc stx
@ -1898,7 +1900,7 @@
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))
(syntax-e (stx-car stx))))))) (syntax-e (stx-car stx)))))))
(define-syntax/err-param (invoke-unit/infer stx) (define-syntax/err-param (invoke-unit/infer stx)
(syntax-case stx () (syntax-case stx ()
[(_ (link unit ...)) [(_ (link unit ...))
(build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)] (build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)]
@ -1910,7 +1912,7 @@
(format "expected syntax matching (~a <define-unit-identifier>) or (~a (link <define-unit-identifier> ...))" (format "expected syntax matching (~a <define-unit-identifier>) or (~a (link <define-unit-identifier> ...))"
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
(define-for-syntax (build-unit/s stx) (define-for-syntax (build-unit/s stx)
(syntax-case stx (import export init-depend) (syntax-case stx (import export init-depend)
[((import i ...) (export e ...) (init-depend d ...) u) [((import i ...) (export e ...) (init-depend d ...) u)
(let* ([ui (lookup-def-unit #'u)] (let* ([ui (lookup-def-unit #'u)]
@ -1923,15 +1925,12 @@
(syntax/loc stx (syntax/loc stx
((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))])) ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))]))
(define-syntax/err-param (define-unit/s stx) (define-syntax/err-param (define-unit/s stx)
(build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx))) (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx)))
"missing unit name")) "missing unit name"))
(define-syntax/err-param (unit/s stx) (define-syntax/err-param (unit/s stx)
(syntax-case stx () (syntax-case stx ()
[(_ . stx) [(_ . stx)
(let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))]) (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))])
u)])) u)]))
)
;(load "test-unit.ss")