Moving unit system from mzscheme->scheme/base, reformatting and small changes
as necessary. Ran the quiet testsuite, unit tests, and setup-plt, all good. svn: r17582
This commit is contained in:
Stevie Strickland
parent
d846d22b9e
commit
73d68593af
|
|
@ -1,21 +1,21 @@
|
|||
(module unit-compiletime mzscheme
|
||||
(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)
|
||||
#lang scheme/base
|
||||
|
||||
(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-form)
|
||||
(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
|
||||
unprocess-link-record-bind unprocess-link-record-use
|
||||
set!-trans-extract
|
||||
|
|
@ -24,13 +24,13 @@
|
|||
map-sig split-requires split-requires* apply-mac complete-exports complete-imports check-duplicate-subs
|
||||
process-spec)
|
||||
|
||||
(define-syntax (apply-mac stx)
|
||||
(define-syntax (apply-mac stx)
|
||||
(syntax-case stx ()
|
||||
((_ f x) ((syntax-e #'f) #'x))))
|
||||
|
||||
;; split-requires* : (listof identifier) -> (listof syntax) -> (values (listof syntax) (listof syntax))
|
||||
;; Parameterized over identifiers for require forms.
|
||||
(define ((split-requires* req-forms) l)
|
||||
;; split-requires* : (listof identifier) -> (listof syntax) -> (values (listof syntax) (listof syntax))
|
||||
;; Parameterized over identifiers for require forms.
|
||||
(define ((split-requires* req-forms) l)
|
||||
(let loop ((l l)
|
||||
(requires null))
|
||||
(cond
|
||||
|
|
@ -38,47 +38,47 @@
|
|||
(else
|
||||
(syntax-case (car l) ()
|
||||
((r . x)
|
||||
(ormap (lambda (req) (module-identifier=? #'r req))
|
||||
(ormap (lambda (req) (free-identifier=? #'r req))
|
||||
req-forms)
|
||||
(loop (cdr l) (cons (car l) requires)))
|
||||
(_
|
||||
(cons (reverse requires) l)))))))
|
||||
|
||||
;; split-requires : (listof syntax) -> (values (listof syntax) (listof syntax))
|
||||
;; Recognizes mzscheme require forms.
|
||||
(define split-requires
|
||||
;; split-requires : (listof syntax) -> (values (listof syntax) (listof syntax))
|
||||
;; Recognizes mzscheme require forms.
|
||||
(define split-requires
|
||||
(split-requires*
|
||||
(list #'require #'require-for-syntax #'require-for-template)))
|
||||
|
||||
;; (make-var-info bool bool identifier (U #f syntax-object))
|
||||
(define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable]))
|
||||
;; (make-var-info bool bool identifier (U #f syntax-object))
|
||||
(define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable]))
|
||||
|
||||
(define-syntax define-struct/proc
|
||||
(define-syntax define-struct/proc
|
||||
(syntax-rules ()
|
||||
((_ name (field ...) p)
|
||||
(define-struct name (field ...) #:property prop:procedure p))))
|
||||
|
||||
;; An int/ext is
|
||||
;; - (cons identifier identifier)
|
||||
;; A def is
|
||||
;; - (listof (cons (listof int/ext) syntax-object))
|
||||
;; A ctc is
|
||||
;; - syntax-object
|
||||
;; - #f
|
||||
;; A sig is
|
||||
;; - (list (listof int/ext) (listof def) (listof def) (listof ctc))
|
||||
;; A tagged-sig is
|
||||
;; - (listof (cons #f siginfo) (cons #f identifier) sig)
|
||||
;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
|
||||
;; An int/ext is
|
||||
;; - (cons identifier identifier)
|
||||
;; A def is
|
||||
;; - (listof (cons (listof int/ext) syntax-object))
|
||||
;; A ctc is
|
||||
;; - syntax-object
|
||||
;; - #f
|
||||
;; A sig is
|
||||
;; - (list (listof int/ext) (listof def) (listof def) (listof ctc))
|
||||
;; A tagged-sig is
|
||||
;; - (listof (cons #f siginfo) (cons #f identifier) sig)
|
||||
;; - (listof (cons symbol siginfo) (cons symbol identifier) sig)
|
||||
|
||||
;; A siginfo is
|
||||
;; - (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
|
||||
;; its super signatures. All lists are non-empty and the same length.
|
||||
(define-struct siginfo (names ctime-ids rtime-ids super-table))
|
||||
;; A siginfo is
|
||||
;; - (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
|
||||
;; its super signatures. All lists are non-empty and the same length.
|
||||
(define-struct siginfo (names ctime-ids rtime-ids super-table))
|
||||
|
||||
;; build-siginfo : (listof symbol) (listof symbol) (listof identifier) -> siginfo
|
||||
(define (build-siginfo names rtime-ids)
|
||||
;; build-siginfo : (listof symbol) (listof symbol) (listof identifier) -> siginfo
|
||||
(define (build-siginfo names rtime-ids)
|
||||
(define ctime-ids
|
||||
(cons (gensym)
|
||||
(if (null? (cdr names))
|
||||
|
|
@ -89,35 +89,35 @@
|
|||
(make-siginfo names
|
||||
ctime-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
|
||||
(define (siginfo-subtype s1 s2)
|
||||
(hash-table-get (siginfo-super-table s1)
|
||||
;; siginfo-subtype : siginfo siginfo -> bool
|
||||
(define (siginfo-subtype s1 s2)
|
||||
(hash-ref (siginfo-super-table s1)
|
||||
(car (siginfo-ctime-ids s2))
|
||||
(λ () #f)))
|
||||
|
||||
|
||||
;; A signature is
|
||||
;; (make-signature siginfo
|
||||
;; (listof identifier)
|
||||
;; (listof (cons (listof identifier) syntax-object))
|
||||
;; (listof (cons (listof identifier) syntax-object))
|
||||
;; (listof (U syntax-object #f))
|
||||
;; identifier)
|
||||
(define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder)
|
||||
;; A signature is
|
||||
;; (make-signature siginfo
|
||||
;; (listof identifier)
|
||||
;; (listof (cons (listof identifier) syntax-object))
|
||||
;; (listof (cons (listof identifier) syntax-object))
|
||||
;; (listof (U syntax-object #f))
|
||||
;; identifier)
|
||||
(define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder)
|
||||
(lambda (_ stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(raise-stx-err "illegal use of signature name"))))
|
||||
|
||||
;; (make-signature-form (syntax-object -> any))
|
||||
(define-struct/proc signature-form (f)
|
||||
;; (make-signature-form (syntax-object -> any))
|
||||
(define-struct/proc signature-form (f)
|
||||
(lambda (_ stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(raise-stx-err "illegal use of signature form"))))
|
||||
|
||||
;; (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?)
|
||||
;; (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?)
|
||||
(lambda (struct stx)
|
||||
(with-syntax ((u (unit-info-unit-id struct)))
|
||||
(syntax-case stx (set!)
|
||||
|
|
@ -136,9 +136,9 @@
|
|||
(x
|
||||
(identifier? #'x)
|
||||
(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)
|
||||
(let ((s (set!-trans-extract
|
||||
(syntax-local-value
|
||||
|
|
@ -147,27 +147,27 @@
|
|||
(raise-stx-err err-msg id))))))
|
||||
s))
|
||||
|
||||
;; lookup-signature : syntax-object -> signature
|
||||
(define (lookup-signature id)
|
||||
;; lookup-signature : syntax-object -> signature
|
||||
(define (lookup-signature id)
|
||||
(let ((s (lookup id "unknown signature")))
|
||||
(unless (signature? s)
|
||||
(raise-stx-err "not a signature" id))
|
||||
s))
|
||||
|
||||
(define (set!-trans-extract x)
|
||||
(define (set!-trans-extract x)
|
||||
(if (set!-transformer? x)
|
||||
(set!-transformer-procedure x)
|
||||
x))
|
||||
|
||||
(define (lookup-def-unit id)
|
||||
(define (lookup-def-unit id)
|
||||
(let ((u (lookup id "unknown unit definition")))
|
||||
(unless (unit-info? u)
|
||||
(raise-stx-err "not a unit definition" id))
|
||||
u))
|
||||
|
||||
;; 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
|
||||
(define (check-bound-id-subset i1 i2)
|
||||
;; 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
|
||||
(define (check-bound-id-subset i1 i2)
|
||||
(let ((ht (make-bound-identifier-mapping)))
|
||||
(for-each (lambda (id)
|
||||
(bound-identifier-mapping-put! ht id #t))
|
||||
|
|
@ -179,10 +179,10 @@
|
|||
(raise-stx-err "listed identifier not present in signature specification" id)))
|
||||
i1)))
|
||||
|
||||
;; do-rename : sig syntax-object syntax-object -> sig
|
||||
;; internals and externals must both be of the form (x ...)
|
||||
;; ensures that each x above is an identifier
|
||||
(define (do-rename sig internals externals)
|
||||
;; do-rename : sig syntax-object syntax-object -> sig
|
||||
;; internals and externals must both be of the form (x ...)
|
||||
;; ensures that each x above is an identifier
|
||||
(define (do-rename sig internals externals)
|
||||
(check-bound-id-subset (syntax->list externals)
|
||||
(sig-int-names sig))
|
||||
(let ((ht (make-bound-identifier-mapping)))
|
||||
|
|
@ -200,19 +200,19 @@
|
|||
(lambda (x) x)
|
||||
sig)))
|
||||
|
||||
;; do-prefix : id id -> id
|
||||
;; ensures that pid is an identifier
|
||||
(define (do-prefix stx pid)
|
||||
;; do-prefix : id id -> id
|
||||
;; ensures that pid is an identifier
|
||||
(define (do-prefix stx pid)
|
||||
(if (identifier? stx)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
stx
|
||||
(string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx)))
|
||||
stx)
|
||||
stx))
|
||||
|
||||
;; do-only/except : sig (listof identifier) -> sig
|
||||
;; ensures that only-ids are identifiers and are mentioned in the signature
|
||||
(define (do-only/except sig only/except-ids put get)
|
||||
;; do-only/except : sig (listof identifier) -> sig
|
||||
;; ensures that only-ids are identifiers and are mentioned in the signature
|
||||
(define (do-only/except sig only/except-ids put get)
|
||||
(check-bound-id-subset only/except-ids
|
||||
(sig-int-names sig))
|
||||
(let ((ht (make-bound-identifier-mapping)))
|
||||
|
|
@ -227,8 +227,8 @@
|
|||
(lambda (x) x)
|
||||
sig)))
|
||||
|
||||
;; do-identifier : identifier (box (cons identifier siginfo)) -> sig
|
||||
(define (do-identifier spec res bind? add-prefix)
|
||||
;; do-identifier : identifier (box (cons identifier siginfo)) -> sig
|
||||
(define (do-identifier spec res bind? add-prefix)
|
||||
(let* ((sig (lookup-signature spec))
|
||||
(vars (signature-vars sig))
|
||||
(vals (signature-val-defs sig))
|
||||
|
|
@ -261,62 +261,62 @@
|
|||
stxs)
|
||||
ctcs))))
|
||||
|
||||
(define (sig-names sig)
|
||||
(define (sig-names sig)
|
||||
(append (car sig)
|
||||
(apply append (map car (cadr sig)))
|
||||
(apply append (map car (caddr sig)))))
|
||||
|
||||
|
||||
(define (sig-int-names sig)
|
||||
(define (sig-int-names sig)
|
||||
(map car (sig-names sig)))
|
||||
|
||||
(define (sig-ext-names sig)
|
||||
(define (sig-ext-names sig)
|
||||
(map cdr (sig-names sig)))
|
||||
|
||||
;; map-def : (identifier -> identifier) (syntax-object -> syntax-object) def -> def
|
||||
(define (map-def f g def)
|
||||
;; map-def : (identifier -> identifier) (syntax-object -> syntax-object) def -> def
|
||||
(define (map-def f g def)
|
||||
(cons (map (lambda (x)
|
||||
(cons (f (car x)) (g (cdr x))))
|
||||
(car def))
|
||||
(g (cdr def))))
|
||||
|
||||
;; map-ctc : (identifier -> identifier) (syntax-object -> syntax-object) ctc -> ctc
|
||||
(define (map-ctc f g ctc)
|
||||
;; map-ctc : (identifier -> identifier) (syntax-object -> syntax-object) ctc -> ctc
|
||||
(define (map-ctc f g ctc)
|
||||
(if ctc
|
||||
(g ctc)
|
||||
ctc))
|
||||
|
||||
;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig
|
||||
;; applies f to the internal parts, and g to the external parts.
|
||||
(define (map-sig f g sig)
|
||||
;; map-sig : (identifier -> identifier) (sytnax-object -> syntax-object) sig -> sig
|
||||
;; applies f to the internal parts, and g to the external parts.
|
||||
(define (map-sig f g 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)) (caddr sig))
|
||||
(map (lambda (x) (map-ctc f g x)) (cadddr sig))))
|
||||
|
||||
;; An import-spec is one of
|
||||
;; - signature-name
|
||||
;; - (only import-spec identifier ...)
|
||||
;; - (except import-spec identifier ...)
|
||||
;; - (prefix prefix-identifier import-spec)
|
||||
;; - (rename import-spec (local-identifier signature-identifier) ...)
|
||||
;; An import-spec is one of
|
||||
;; - signature-name
|
||||
;; - (only import-spec identifier ...)
|
||||
;; - (except import-spec identifier ...)
|
||||
;; - (prefix prefix-identifier import-spec)
|
||||
;; - (rename import-spec (local-identifier signature-identifier) ...)
|
||||
|
||||
;; An export-spec is one of
|
||||
;; - signature-name
|
||||
;; - (prefix prefix-identifier export-spec)
|
||||
;; - (rename export-spec (local-identifier signature-identifier) ...)
|
||||
;; An export-spec is one of
|
||||
;; - signature-name
|
||||
;; - (prefix prefix-identifier export-spec)
|
||||
;; - (rename export-spec (local-identifier signature-identifier) ...)
|
||||
|
||||
;; A tagged-import-spec is one of
|
||||
;; - import-spec
|
||||
;; - (tag symbol import-spec)
|
||||
;; A tagged-import-spec is one of
|
||||
;; - import-spec
|
||||
;; - (tag symbol import-spec)
|
||||
|
||||
;; A tagged-export-spec is one of
|
||||
;; - export-spec
|
||||
;; - (tag symbol export-spec)
|
||||
;; A tagged-export-spec is one of
|
||||
;; - export-spec
|
||||
;; - (tag symbol export-spec)
|
||||
|
||||
|
||||
;; process-tagged-import/export : syntax-object boolean -> tagged-sig
|
||||
(define (process-tagged-import/export spec import? bind?)
|
||||
;; process-tagged-import/export : syntax-object boolean -> tagged-sig
|
||||
(define (process-tagged-import/export spec import? bind?)
|
||||
(define res (box #f))
|
||||
(check-tagged-spec-syntax spec import? identifier?)
|
||||
(syntax-case spec (tag)
|
||||
|
|
@ -332,11 +332,11 @@
|
|||
(cons #f (car (unbox res)))
|
||||
s)))))
|
||||
|
||||
(define (add-prefixes add-prefix l)
|
||||
(define (add-prefixes add-prefix l)
|
||||
(map add-prefix (syntax->list l)))
|
||||
|
||||
;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig
|
||||
(define (process-import/export spec res bind? add-prefix)
|
||||
;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig
|
||||
(define (process-import/export spec res bind? add-prefix)
|
||||
(syntax-case spec (only except prefix rename)
|
||||
(_
|
||||
(identifier? spec)
|
||||
|
|
@ -361,7 +361,7 @@
|
|||
(let* ((sig-res
|
||||
(do-rename (process-import/export #'sub-spec res bind? add-prefix)
|
||||
#'(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))))
|
||||
(when dup
|
||||
(raise-stx-err
|
||||
|
|
@ -369,13 +369,13 @@
|
|||
spec))
|
||||
sig-res))))
|
||||
|
||||
(define (process-tagged-import spec)
|
||||
(define (process-tagged-import spec)
|
||||
(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-spec : syntax-object -> sig
|
||||
(define (process-spec spec)
|
||||
;; process-spec : syntax-object -> sig
|
||||
(define (process-spec spec)
|
||||
(check-tagged-spec-syntax spec #f identifier?)
|
||||
(process-import/export spec (box #f) #t values))
|
||||
|
||||
|
|
@ -396,8 +396,8 @@
|
|||
|
||||
|
||||
|
||||
;; check-duplicate-subs : (listof (cons symbol siginfo)) (listof syntax-object) ->
|
||||
(define (check-duplicate-subs tagged-siginfos sources)
|
||||
;; check-duplicate-subs : (listof (cons symbol siginfo)) (listof syntax-object) ->
|
||||
(define (check-duplicate-subs tagged-siginfos sources)
|
||||
(for-each
|
||||
(λ (tinfo1 s1)
|
||||
(for-each
|
||||
|
|
@ -406,7 +406,7 @@
|
|||
(when (and (eq? (car tinfo1) (car tinfo2))
|
||||
(siginfo-subtype (cdr tinfo1) (cdr tinfo2)))
|
||||
(raise-stx-err (format "the signature of ~a extends this signature"
|
||||
(syntax-object->datum s1))
|
||||
(syntax->datum s1))
|
||||
s2))))
|
||||
tagged-siginfos
|
||||
sources))
|
||||
|
|
@ -414,15 +414,15 @@
|
|||
sources))
|
||||
|
||||
|
||||
;; A link-record is
|
||||
;; (make-link-record (or symbol #f) (or identifier #f) identifier siginfo)
|
||||
(define-struct link-record (tag linkid sigid siginfo))
|
||||
;; A link-record is
|
||||
;; (make-link-record (or symbol #f) (or identifier #f) identifier siginfo)
|
||||
(define-struct link-record (tag linkid sigid siginfo))
|
||||
|
||||
;; complete-exports : (listof link-record) (listof link-record) -> (listof link-record)
|
||||
;; The export-bindings should not contain two bindings that are related as subsignatures.
|
||||
(define (complete-exports unit-exports given-bindings)
|
||||
(define binding-table (make-hash-table 'equal))
|
||||
(define used-binding-table (make-hash-table 'equal))
|
||||
;; complete-exports : (listof link-record) (listof link-record) -> (listof link-record)
|
||||
;; The export-bindings should not contain two bindings that are related as subsignatures.
|
||||
(define (complete-exports unit-exports given-bindings)
|
||||
(define binding-table (make-hash))
|
||||
(define used-binding-table (make-hash))
|
||||
|
||||
(check-duplicate-subs
|
||||
(map (λ (ts) (cons (link-record-tag ts) (link-record-siginfo ts))) given-bindings)
|
||||
|
|
@ -430,7 +430,7 @@
|
|||
|
||||
(for-each
|
||||
(λ (b)
|
||||
(hash-table-put! binding-table
|
||||
(hash-set! binding-table
|
||||
(cons (link-record-tag b)
|
||||
(car (siginfo-ctime-ids (link-record-siginfo b))))
|
||||
(link-record-linkid b)))
|
||||
|
|
@ -443,12 +443,12 @@
|
|||
(ormap
|
||||
(λ (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
|
||||
(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
|
||||
(hash-table-put! used-binding-table key r))
|
||||
(hash-set! used-binding-table key r))
|
||||
r))
|
||||
(siginfo-ctime-ids (link-record-siginfo export))))
|
||||
(make-link-record
|
||||
|
|
@ -460,27 +460,27 @@
|
|||
(link-record-siginfo export)))
|
||||
unit-exports)
|
||||
|
||||
(hash-table-for-each
|
||||
(hash-for-each
|
||||
binding-table
|
||||
(λ (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))))))
|
||||
|
||||
(define (name-form n) (syntax-object->datum n))
|
||||
(define (name-form n) (syntax->datum n))
|
||||
|
||||
;; complete-imports : (hash-tableof symbol (or identifier 'duplicate))
|
||||
;; (listof link-record)
|
||||
;; (listof (list symbol identifier siginfo)) ->
|
||||
;; (listof (cons symbol identifier))
|
||||
(define (complete-imports sig-table given-links unit-imports src)
|
||||
(define linked-sigs-table (make-hash-table 'equal))
|
||||
;; complete-imports : (hash-tableof symbol (or identifier 'duplicate))
|
||||
;; (listof link-record)
|
||||
;; (listof (list symbol identifier siginfo)) ->
|
||||
;; (listof (cons symbol identifier))
|
||||
(define (complete-imports sig-table given-links unit-imports src)
|
||||
(define linked-sigs-table (make-hash))
|
||||
(for-each
|
||||
(λ (link)
|
||||
(define tag (link-record-tag link))
|
||||
(for-each
|
||||
(λ (cid)
|
||||
(define there? (hash-table-get linked-sigs-table (cons tag cid) (λ () #f)))
|
||||
(hash-table-put! linked-sigs-table (cons tag cid) (if there? 'duplicate #t)))
|
||||
(define there? (hash-ref linked-sigs-table (cons tag cid) (λ () #f)))
|
||||
(hash-set! linked-sigs-table (cons tag cid) (if there? 'duplicate #t)))
|
||||
(siginfo-ctime-ids (link-record-siginfo link))))
|
||||
given-links)
|
||||
|
||||
|
|
@ -494,7 +494,7 @@
|
|||
[ctime-ids (siginfo-ctime-ids (link-record-siginfo import))]
|
||||
[tag (link-record-tag import)]
|
||||
[there?
|
||||
(hash-table-get linked-sigs-table
|
||||
(hash-ref linked-sigs-table
|
||||
(cons tag (car ctime-ids))
|
||||
(λ () #f))])
|
||||
(cond
|
||||
|
|
@ -509,7 +509,7 @@
|
|||
[there?
|
||||
(loop (cdr unit-imports))]
|
||||
[else
|
||||
(let ([there?2 (hash-table-get sig-table
|
||||
(let ([there?2 (hash-ref sig-table
|
||||
(car ctime-ids)
|
||||
(λ () #f))])
|
||||
(cond
|
||||
|
|
@ -524,7 +524,7 @@
|
|||
[there?2
|
||||
(for-each
|
||||
(λ (cid)
|
||||
(hash-table-put! linked-sigs-table
|
||||
(hash-set! linked-sigs-table
|
||||
(cons tag cid)
|
||||
#t))
|
||||
ctime-ids)
|
||||
|
|
@ -542,20 +542,20 @@
|
|||
(name-form (car (siginfo-names (link-record-siginfo import))))))
|
||||
src)]))]))]))))
|
||||
|
||||
(define (unprocess-link-record-bind lr)
|
||||
(define (unprocess-link-record-bind lr)
|
||||
(if (link-record-tag lr)
|
||||
#`(#,(link-record-linkid lr) : (tag #,(link-record-tag 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)
|
||||
#`(tag #,(link-record-tag 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)))
|
||||
|
||||
(define (make-id-mapper unbox-stx)
|
||||
(define (make-id-mapper unbox-stx)
|
||||
(make-set!-transformer
|
||||
(lambda (sstx)
|
||||
(syntax-case sstx (set!)
|
||||
|
|
@ -568,7 +568,7 @@
|
|||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[(_ . x)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
sstx
|
||||
(cons unbox-stx #'x)
|
||||
sstx)])))))
|
||||
sstx)]))))
|
||||
|
|
|
|||
|
|
@ -1,34 +1,35 @@
|
|||
(module unit-runtime mzscheme
|
||||
(require-for-syntax "unit-syntax.ss")
|
||||
(provide define-syntax/err-param
|
||||
undefined (rename make-a-unit make-unit) unit-import-sigs unit-export-sigs unit-go unit? unit-deps
|
||||
#lang scheme/base
|
||||
|
||||
(require (for-syntax "unit-syntax.ss" scheme/base))
|
||||
(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)
|
||||
|
||||
(define-syntax define-syntax/err-param
|
||||
(define-syntax define-syntax/err-param
|
||||
(syntax-rules ()
|
||||
((_ (name arg) body)
|
||||
(define-syntax (name arg)
|
||||
(parameterize ((error-syntax arg))
|
||||
body)))))
|
||||
|
||||
;; initial value
|
||||
(define undefined (letrec ([x x]) x))
|
||||
;; initial value
|
||||
(define undefined (letrec ([x x]) x))
|
||||
|
||||
;; for named structures
|
||||
(define insp (current-inspector))
|
||||
;; for named structures
|
||||
(define insp (current-inspector))
|
||||
|
||||
;; (make-unit (listof (cons symbol symbol)) (listof (cons symbol symbol)) (listof nat) thunk)
|
||||
;; Runtime representation of a unit
|
||||
(define-struct unit (import-sigs export-sigs deps go))
|
||||
;; (make-unit (listof (cons symbol symbol)) (listof (cons symbol symbol)) (listof nat) thunk)
|
||||
;; Runtime representation of a unit
|
||||
(define-struct unit (import-sigs export-sigs deps go))
|
||||
|
||||
;; For units with inferred names, generate a struct that prints using the name:
|
||||
(define (make-naming-constructor type name)
|
||||
;; For units with inferred names, generate a struct that prints using the name:
|
||||
(define (make-naming-constructor type name)
|
||||
(let-values ([(struct: make- ? -accessor -mutator)
|
||||
(make-struct-type name type 0 0 #f null insp)])
|
||||
make-))
|
||||
|
||||
;; Make a unit value (call by the macro expansion of `unit')
|
||||
(define (make-a-unit name num-imports exports deps go)
|
||||
;; Make a unit value (call by the macro expansion of `unit')
|
||||
(define (make-a-unit name num-imports exports deps go)
|
||||
((if name
|
||||
(make-naming-constructor
|
||||
struct:unit
|
||||
|
|
@ -36,29 +37,29 @@
|
|||
make-unit)
|
||||
num-imports exports deps go))
|
||||
|
||||
;; check-unit : X symbol ->
|
||||
;; ensure that u is a unit value
|
||||
(define (check-unit u name)
|
||||
;; check-unit : X symbol ->
|
||||
;; ensure that u is a unit value
|
||||
(define (check-unit u name)
|
||||
(unless (unit? u)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(format "~a: result of unit expression was not a unit: ~e" name u)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol symbol ->
|
||||
;; ensure that the unit's signatures match the expected signatures.
|
||||
(define (check-helper sub-sig super-sig name import?)
|
||||
(define t (make-hash-table 'equal))
|
||||
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol symbol ->
|
||||
;; ensure that the unit's signatures match the expected signatures.
|
||||
(define (check-helper sub-sig super-sig name import?)
|
||||
(define t (make-hash))
|
||||
(let loop ([i (sub1 (vector-length sub-sig))])
|
||||
(when (>= i 0)
|
||||
(let ([v (cdr (vector-ref sub-sig i))])
|
||||
(let loop ([j (sub1 (vector-length v))])
|
||||
(when (>= j 0)
|
||||
(let ([vj (vector-ref v j)])
|
||||
(hash-table-put! t vj
|
||||
(if (hash-table-get t vj #f)
|
||||
(hash-set! t vj
|
||||
(if (hash-ref t vj #f)
|
||||
'amb
|
||||
#t)))
|
||||
(loop (sub1 j)))))
|
||||
|
|
@ -66,7 +67,7 @@
|
|||
(let loop ([i (sub1 (vector-length super-sig))])
|
||||
(when (>= 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))
|
||||
(let ([tag (if (pair? v0) (car v0) #f)]
|
||||
[sub-name (car (vector-ref super-sig i))]
|
||||
|
|
@ -101,13 +102,13 @@
|
|||
(current-continuation-marks))))))
|
||||
(loop (sub1 i)))))
|
||||
|
||||
;; 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 values are the name of the signature and the linkage
|
||||
(define (check-deps dep-table unit name)
|
||||
;; 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 values are the name of the signature and the linkage
|
||||
(define (check-deps dep-table unit name)
|
||||
(for-each
|
||||
(λ (dep)
|
||||
(let ([r (hash-table-get dep-table dep #f)])
|
||||
(let ([r (hash-ref dep-table dep #f)])
|
||||
(when r
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
|
|
@ -119,18 +120,16 @@
|
|||
(current-continuation-marks))))))
|
||||
(unit-deps unit)))
|
||||
|
||||
;; check-no-imports : unit symbol ->
|
||||
;; ensures that the unit has no imports
|
||||
(define (check-no-imports unit name)
|
||||
;; check-no-imports : unit symbol ->
|
||||
;; ensures that the unit has no imports
|
||||
(define (check-no-imports unit name)
|
||||
(check-helper (vector) (unit-import-sigs unit) name #t))
|
||||
|
||||
;; check-sigs : unit
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol ->
|
||||
;; ensures that unit has the given signatures
|
||||
(define (check-sigs unit expected-imports expected-exports name)
|
||||
;; check-sigs : unit
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol ->
|
||||
;; ensures that unit has the given signatures
|
||||
(define (check-sigs unit expected-imports expected-exports name)
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -1,23 +1,24 @@
|
|||
(module unit-syntax mzscheme
|
||||
(require syntax/stx)
|
||||
(require-for-template "unit-keywords.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(provide (all-defined))
|
||||
(require syntax/stx)
|
||||
(require (for-template "unit-keywords.ss"))
|
||||
|
||||
(define error-syntax (make-parameter #f))
|
||||
(define raise-stx-err
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define error-syntax (make-parameter #f))
|
||||
(define raise-stx-err
|
||||
(case-lambda
|
||||
((msg) (raise-syntax-error #f msg (error-syntax)))
|
||||
((msg stx) (raise-syntax-error #f msg (error-syntax) stx))))
|
||||
|
||||
;; check-id: syntax-object -> identifier
|
||||
(define (check-id id)
|
||||
;; check-id: syntax-object -> identifier
|
||||
(define (check-id id)
|
||||
(unless (identifier? id)
|
||||
(raise-stx-err "not an identifier" id))
|
||||
id)
|
||||
|
||||
;; checked-syntax->list : syntax-object -> (listof syntax-object)
|
||||
(define (checked-syntax->list s)
|
||||
;; checked-syntax->list : syntax-object -> (listof syntax-object)
|
||||
(define (checked-syntax->list s)
|
||||
(define l (syntax->list s))
|
||||
(unless (or (stx-pair? s) (stx-null? s))
|
||||
(raise-stx-err "bad syntax (not a list)" s))
|
||||
|
|
@ -25,8 +26,8 @@
|
|||
(raise-stx-err "bad syntax (illegal use of `.')" s))
|
||||
l)
|
||||
|
||||
;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
|
||||
(define (check-tagged check)
|
||||
;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
|
||||
(define (check-tagged check)
|
||||
(λ (o)
|
||||
(syntax-case o (tag)
|
||||
((tag . s)
|
||||
|
|
@ -40,9 +41,9 @@
|
|||
(_
|
||||
(cons #f (check o))))))
|
||||
|
||||
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
|
||||
;; ensures that clause matches (a : b) or (a : (tag t b))
|
||||
(define (check-tagged-:-clause clause)
|
||||
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
|
||||
;; ensures that clause matches (a : b) or (a : (tag t b))
|
||||
(define (check-tagged-:-clause clause)
|
||||
(checked-syntax->list clause)
|
||||
(syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
((a : b)
|
||||
|
|
@ -53,21 +54,21 @@
|
|||
"expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))"
|
||||
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) ->
|
||||
;; ensures that s matches spec.
|
||||
;; tag-spec ::= spec
|
||||
;; | (tag symbol spec)
|
||||
;; spec ::= prim-spec
|
||||
;; | (prefix identifier spec)
|
||||
;; | (rename spec (identifier identifier) ...)
|
||||
;; | (only spec identifier ...) only if import? is true
|
||||
;; | (except spec identifier ...) only if import? is true
|
||||
(define (check-tagged-spec-syntax s import? prim-spec?)
|
||||
;; check-spec-syntax : syntax-object boolean (syntax-object -> boolean) ->
|
||||
;; ensures that s matches spec.
|
||||
;; tag-spec ::= spec
|
||||
;; | (tag symbol spec)
|
||||
;; spec ::= prim-spec
|
||||
;; | (prefix identifier spec)
|
||||
;; | (rename spec (identifier identifier) ...)
|
||||
;; | (only spec identifier ...) only if import? is true
|
||||
;; | (except spec identifier ...) only if import? is true
|
||||
(define (check-tagged-spec-syntax s import? prim-spec?)
|
||||
((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)
|
||||
(let ((ie (if import? 'import 'export)))
|
||||
(unless (stx-pair? s)
|
||||
|
|
@ -75,8 +76,8 @@
|
|||
(checked-syntax->list s)
|
||||
(syntax-case s (prefix rename)
|
||||
((key . x)
|
||||
(or (module-identifier=? #'key #'only)
|
||||
(module-identifier=? #'key #'except))
|
||||
(or (free-identifier=? #'key #'only)
|
||||
(free-identifier=? #'key #'except))
|
||||
(begin
|
||||
(unless import?
|
||||
(raise-stx-err
|
||||
|
|
@ -125,11 +126,11 @@
|
|||
((k . x)
|
||||
(raise-stx-err (format "bad ~a-spec keyword" ie) #'k))))))
|
||||
|
||||
;; check-unit-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches ((import i ...) (export e ...) b ...)
|
||||
;; or ((import i ...) (export e ...) (init-depend id ...) b ...)
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-syntax stx)
|
||||
;; check-unit-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches ((import i ...) (export e ...) b ...)
|
||||
;; or ((import i ...) (export e ...) (init-depend id ...) b ...)
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-syntax stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
(((import . isig) (export . esig) (init-depend . id) . body)
|
||||
(begin
|
||||
|
|
@ -155,11 +156,11 @@
|
|||
(raise-stx-err "import clause must start with keyword \"import\"" #'i))))
|
||||
|
||||
|
||||
;; check-unit-body-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches (exp (import i ...) (export e ...))
|
||||
;; or (exp (import i ...) (export e ...) (init-depend id ...))
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-body-syntax stx)
|
||||
;; check-unit-body-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches (exp (import i ...) (export e ...))
|
||||
;; or (exp (import i ...) (export e ...) (init-depend id ...))
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-body-syntax stx)
|
||||
(checked-syntax->list stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
((exp (import . isig) (export . esig) (init-depend . id))
|
||||
|
|
@ -192,9 +193,9 @@
|
|||
|
||||
|
||||
|
||||
;; check-link-line-syntax : syntax-object ->
|
||||
;; ensures that l matches ((x ...) u y ...)
|
||||
(define (check-link-line-syntax l)
|
||||
;; check-link-line-syntax : syntax-object ->
|
||||
;; ensures that l matches ((x ...) u y ...)
|
||||
(define (check-link-line-syntax l)
|
||||
(unless (stx-pair? l)
|
||||
(raise-stx-err "bad linking line" l))
|
||||
(checked-syntax->list l)
|
||||
|
|
@ -208,11 +209,11 @@
|
|||
(raise-stx-err "bad export list" #'x))
|
||||
(checked-syntax->list #'x)))))
|
||||
|
||||
;; check-compound-syntax : syntax-object -> syntax-object
|
||||
;; ensures that clauses has exactly one clause matching each of
|
||||
;; (import i ...), (export e ...), and (link i ...), in any order.
|
||||
;; returns #'((i ...) (e ...) (l ...))
|
||||
(define (check-compound-syntax c)
|
||||
;; check-compound-syntax : syntax-object -> syntax-object
|
||||
;; ensures that clauses has exactly one clause matching each of
|
||||
;; (import i ...), (export e ...), and (link i ...), in any order.
|
||||
;; returns #'((i ...) (e ...) (l ...))
|
||||
(define (check-compound-syntax c)
|
||||
(define clauses (checked-syntax->list c))
|
||||
(define im #f)
|
||||
(define ex #f)
|
||||
|
|
@ -250,10 +251,10 @@
|
|||
(raise-stx-err "missing link clause" ))
|
||||
#`(#,im #,ex #,li))
|
||||
|
||||
;; check-def-syntax : syntax-object ->
|
||||
;; d must be a syntax-pair
|
||||
;; ensures that d matches (_ (x ...) e)
|
||||
(define (check-def-syntax d)
|
||||
;; check-def-syntax : syntax-object ->
|
||||
;; d must be a syntax-pair
|
||||
;; ensures that d matches (_ (x ...) e)
|
||||
(define (check-def-syntax d)
|
||||
(unless (syntax->list d)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
|
|
@ -281,6 +282,3 @@
|
|||
(format "bad syntax (has ~a parts after keyword)"
|
||||
(sub1 (length (syntax->list d))))
|
||||
d))))
|
||||
)
|
||||
|
||||
;(load "test-unit-syntax.ss")
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
syntax/boundmap
|
||||
"unit-compiletime.ss"
|
||||
"unit-syntax.ss")
|
||||
mzlib/contract)
|
||||
scheme/contract/base)
|
||||
|
||||
(provide (for-syntax build-key
|
||||
check-duplicate-sigs
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;; This 'bound-in-source is no longer needed
|
||||
#;
|
||||
|
|
@ -11,15 +10,15 @@
|
|||
'bound-in-source
|
||||
(cons binder (syntax-local-introduce bound))))
|
||||
|
||||
(define (make-id-mapper unbox-stx the-binder)
|
||||
(let ([set!-stx (datum->syntax-object unbox-stx 'set! #f)])
|
||||
(define (make-id-mapper unbox-stx the-binder)
|
||||
(let ([set!-stx (datum->syntax unbox-stx 'set! #f)])
|
||||
(make-set!-transformer
|
||||
(lambda (sstx)
|
||||
(cond
|
||||
[(identifier? sstx)
|
||||
(binding the-binder sstx
|
||||
unbox-stx)]
|
||||
[(module-identifier=? set!-stx (car (syntax-e sstx)))
|
||||
[(free-identifier=? set!-stx (car (syntax-e sstx)))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
|
|
@ -27,10 +26,10 @@
|
|||
[else
|
||||
(binding
|
||||
the-binder (car (syntax-e sstx))
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
sstx
|
||||
(cons unbox-stx (cdr (syntax-e sstx)))
|
||||
sstx))])))))
|
||||
|
||||
(provide make-id-mapper))
|
||||
(provide make-id-mapper)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,17 +1,18 @@
|
|||
(module unit-exptime mzscheme
|
||||
(require "private/unit-syntax.ss"
|
||||
#lang scheme/base
|
||||
|
||||
(require "private/unit-syntax.ss"
|
||||
"private/unit-compiletime.ss")
|
||||
|
||||
(provide unit-static-signatures
|
||||
(provide unit-static-signatures
|
||||
signature-members)
|
||||
|
||||
(define (unit-static-signatures name err-stx)
|
||||
(define (unit-static-signatures name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ((ui (lookup-def-unit name)))
|
||||
(values (apply list (unit-info-import-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))
|
||||
(let ([s (lookup-signature name)])
|
||||
(values
|
||||
|
|
@ -23,4 +24,4 @@
|
|||
;; defined vars
|
||||
(apply list (apply append (map car (signature-val-defs s))))
|
||||
;; defined stxs
|
||||
(apply list (apply append (map car (signature-stx-defs s)))))))))
|
||||
(apply list (apply append (map car (signature-stx-defs s))))))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
(module unit mzscheme
|
||||
(require-for-syntax mzlib/list
|
||||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/list
|
||||
syntax/boundmap
|
||||
syntax/context
|
||||
syntax/kerncase
|
||||
|
|
@ -9,21 +11,21 @@
|
|||
syntax/stx
|
||||
"private/unit-contract-syntax.ss"
|
||||
"private/unit-compiletime.ss"
|
||||
"private/unit-syntax.ss")
|
||||
"private/unit-syntax.ss"))
|
||||
|
||||
(require mzlib/etc
|
||||
mzlib/contract
|
||||
mzlib/stxparam
|
||||
(require mzlib/etc
|
||||
scheme/contract/base
|
||||
scheme/stxparam
|
||||
"private/unit-contract.ss"
|
||||
"private/unit-keywords.ss"
|
||||
"private/unit-runtime.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
|
||||
only except rename import export prefix link tag init-depend extends contracted
|
||||
unit?
|
||||
(rename :unit unit) define-unit
|
||||
(rename-out [:unit unit]) define-unit
|
||||
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
|
||||
invoke-unit define-values/invoke-unit
|
||||
invoke-unit/infer define-values/invoke-unit/infer
|
||||
|
|
@ -33,7 +35,7 @@
|
|||
unit/s define-unit/s
|
||||
unit/c define-unit/contract)
|
||||
|
||||
(define-syntax/err-param (define-signature-form stx)
|
||||
(define-syntax/err-param (define-signature-form stx)
|
||||
(syntax-case stx ()
|
||||
((_ (name arg) . val)
|
||||
(begin
|
||||
|
|
@ -53,7 +55,7 @@
|
|||
"expected syntax matching (identifier identifier)"
|
||||
(car l)))))))
|
||||
|
||||
(define-signature-form (struct stx)
|
||||
(define-signature-form (struct stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
((_ name (field ...) . omissions)
|
||||
|
|
@ -90,16 +92,16 @@
|
|||
(lambda (omission)
|
||||
(cond
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-selectors))
|
||||
(free-identifier=? omission #'-selectors))
|
||||
(set! omit-selectors #t))
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-setters))
|
||||
(free-identifier=? omission #'-setters))
|
||||
(set! omit-setters #t))
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-constructor))
|
||||
(free-identifier=? omission #'-constructor))
|
||||
(set! omit-constructor #t))
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-type))
|
||||
(free-identifier=? omission #'-type))
|
||||
(set! omit-type #t))
|
||||
(else
|
||||
(raise-stx-err
|
||||
|
|
@ -126,7 +128,7 @@
|
|||
((_)
|
||||
(raise-stx-err "missing name and fields")))))
|
||||
|
||||
(define-signature-form (struct/ctc stx)
|
||||
(define-signature-form (struct/ctc stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
((_ name ([field ctc] ...) . omissions)
|
||||
|
|
@ -170,16 +172,16 @@
|
|||
(lambda (omission)
|
||||
(cond
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-selectors))
|
||||
(free-identifier=? omission #'-selectors))
|
||||
(set! omit-selectors #t))
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-setters))
|
||||
(free-identifier=? omission #'-setters))
|
||||
(set! omit-setters #t))
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-constructor))
|
||||
(free-identifier=? omission #'-constructor))
|
||||
(set! omit-constructor #t))
|
||||
((and (identifier? omission)
|
||||
(module-identifier=? omission #'-type))
|
||||
(free-identifier=? omission #'-type))
|
||||
(set! omit-type #t))
|
||||
(else
|
||||
(raise-stx-err
|
||||
|
|
@ -211,8 +213,8 @@
|
|||
(raise-stx-err "missing name and fields")))))
|
||||
|
||||
|
||||
;; build-val+macro-defs : sig -> (list syntax-object^3)
|
||||
(define-for-syntax (build-val+macro-defs sig)
|
||||
;; build-val+macro-defs : sig -> (list syntax-object^3)
|
||||
(define-for-syntax (build-val+macro-defs sig)
|
||||
(with-syntax ([(((int-ivar . ext-ivar) ...)
|
||||
((((int-vid . ext-vid) ...) . vbody) ...)
|
||||
((((int-sid . ext-sid) ...) . sbody) ...)
|
||||
|
|
@ -233,7 +235,7 @@
|
|||
#'(((int-vid ...) vbody) ...))))
|
||||
|
||||
|
||||
(define-signature-form (open stx)
|
||||
(define-signature-form (open stx)
|
||||
(define (build-sig-elems sig)
|
||||
(map (λ (p c)
|
||||
(if c #`(contracted [#,(car p) #,c]) (car p)))
|
||||
|
|
@ -259,12 +261,12 @@
|
|||
(syntax-e (stx-car stx))))))))
|
||||
|
||||
|
||||
(define-for-syntax (introduce-def d)
|
||||
(define-for-syntax (introduce-def d)
|
||||
(cons (map syntax-local-introduce (car d))
|
||||
(syntax-local-introduce (cdr d))))
|
||||
|
||||
;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
|
||||
(define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
|
||||
;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
|
||||
(define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
|
||||
(unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
|
||||
(raise-stx-err "expected syntax matching (sig-expr ...)" 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)))
|
||||
((x (y z) ...)
|
||||
(and (identifier? #'x)
|
||||
(module-identifier=? #'x #'contracted)
|
||||
(free-identifier=? #'x #'contracted)
|
||||
(andmap identifier? (syntax->list #'(y ...))))
|
||||
(loop (cdr sig-exprs)
|
||||
(append (syntax->list #'(y ...)) bindings)
|
||||
|
|
@ -359,15 +361,15 @@
|
|||
(append (syntax->list #'(z ...)) ctcs)))
|
||||
((x . z)
|
||||
(and (identifier? #'x)
|
||||
(module-identifier=? #'x #'contracted))
|
||||
(free-identifier=? #'x #'contracted))
|
||||
(raise-syntax-error
|
||||
'define-signature
|
||||
"expected a list of [id contract] pairs after the contracted keyword"
|
||||
(car sig-exprs)))
|
||||
((x . y)
|
||||
(and (identifier? #'x)
|
||||
(or (module-identifier=? #'x #'define-values)
|
||||
(module-identifier=? #'x #'define-syntaxes)))
|
||||
(or (free-identifier=? #'x #'define-values)
|
||||
(free-identifier=? #'x #'define-syntaxes)))
|
||||
(begin
|
||||
(check-def-syntax (car sig-exprs))
|
||||
(syntax-case #'y ()
|
||||
|
|
@ -378,11 +380,11 @@
|
|||
(let ((b #'body))
|
||||
(loop (cdr sig-exprs)
|
||||
bindings
|
||||
(if (module-identifier=? #'x #'define-values)
|
||||
(if (free-identifier=? #'x #'define-values)
|
||||
(cons (cons (syntax->list #'(name ...)) b)
|
||||
val-defs)
|
||||
val-defs)
|
||||
(if (module-identifier=? #'x #'define-syntaxes)
|
||||
(if (free-identifier=? #'x #'define-syntaxes)
|
||||
(cons (cons (syntax->list #'(name ...)) b)
|
||||
stx-defs)
|
||||
stx-defs)
|
||||
|
|
@ -411,7 +413,7 @@
|
|||
#'x))))))))
|
||||
|
||||
|
||||
(define-syntax/err-param (define-signature stx)
|
||||
(define-syntax/err-param (define-signature stx)
|
||||
(syntax-case stx (extends)
|
||||
((_ sig-name sig-exprs)
|
||||
(begin
|
||||
|
|
@ -429,12 +431,12 @@
|
|||
(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))))))))
|
||||
|
||||
(define-for-syntax (signature->identifiers sigids)
|
||||
(define-for-syntax (signature->identifiers sigids)
|
||||
(define provide-tagged-sigs (map process-tagged-import sigids))
|
||||
(define provide-sigs (map caddr provide-tagged-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 ()
|
||||
((_ . p)
|
||||
(let* ((sigs (checked-syntax->list #'p))
|
||||
|
|
@ -448,7 +450,7 @@
|
|||
(filter (lambda (name)
|
||||
(bound-identifier=?
|
||||
name
|
||||
(datum->syntax-object sig (syntax-e name))))
|
||||
(datum->syntax sig (syntax-e name))))
|
||||
names))
|
||||
sigs nameses))
|
||||
(names (apply append nameses))
|
||||
|
|
@ -458,21 +460,21 @@
|
|||
(quasisyntax/loc stx
|
||||
(provide #,@names))))))
|
||||
|
||||
;; A unit is
|
||||
;; - (unit (import import-spec ...) (export export-spec ...) unit-body-expr ...)
|
||||
;; A unit is
|
||||
;; - (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
|
||||
(local-expand #`(stop #,exp)
|
||||
'expression
|
||||
(list #'stop)
|
||||
def-ctx))))
|
||||
|
||||
(define-for-syntax (tagged-sigid->tagged-siginfo x)
|
||||
(define-for-syntax (tagged-sigid->tagged-siginfo x)
|
||||
(cons (car 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
|
||||
(with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
|
||||
(quasisyntax/loc (error-syntax)
|
||||
|
|
@ -482,17 +484,17 @@
|
|||
(current-contract-region)
|
||||
#,(id->contract-src-info var))
|
||||
(error 'unit "contracted import ~a used before definition"
|
||||
(quote #,(syntax-object->datum var))))))))
|
||||
(quote #,(syntax->datum var))))))))
|
||||
(quasisyntax/loc (error-syntax)
|
||||
(quote-syntax (#,loc)))))
|
||||
|
||||
;; build-unit : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a unit expression. stx must be
|
||||
;; such that it passes check-unit-syntax.
|
||||
;; The two additional values are the identifiers of the unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-unit stx)
|
||||
;; build-unit : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a unit expression. stx must be
|
||||
;; such that it passes check-unit-syntax.
|
||||
;; The two additional values are the identifiers of the unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-unit stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
(((import i ...)
|
||||
(export e ...)
|
||||
|
|
@ -568,7 +570,7 @@
|
|||
(values
|
||||
(lambda (import-table)
|
||||
(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)
|
||||
(with-syntax ([renamings
|
||||
|
|
@ -604,14 +606,14 @@
|
|||
export-tagged-sigids
|
||||
dep-tagged-sigids))))))
|
||||
|
||||
(define-syntax/err-param (:unit stx)
|
||||
(define-syntax/err-param (:unit stx)
|
||||
(syntax-case stx ()
|
||||
((_ . x)
|
||||
(begin
|
||||
(let-values (((u x y z) (build-unit (check-unit-syntax #'x))))
|
||||
u)))))
|
||||
|
||||
(define-syntax (unit-body stx)
|
||||
(define-syntax (unit-body stx)
|
||||
(syntax-case stx ()
|
||||
((_ err-stx ivars evars elocs ectcs body ...)
|
||||
(parameterize ((error-syntax #'err-stx))
|
||||
|
|
@ -624,8 +626,8 @@
|
|||
[definition?
|
||||
(lambda (id)
|
||||
(and (identifier? id)
|
||||
(or (module-identifier=? id (quote-syntax define-values))
|
||||
(module-identifier=? id (quote-syntax define-syntaxes)))))]
|
||||
(or (free-identifier=? id (quote-syntax define-values))
|
||||
(free-identifier=? id (quote-syntax define-syntaxes)))))]
|
||||
[expanded-body
|
||||
(let expand-all ((defns&exprs (syntax->list #'(body ...))))
|
||||
;; Also lifted from Matthew, to expand the body enough
|
||||
|
|
@ -680,7 +682,7 @@
|
|||
(raise-stx-err "variable defined twice" id))
|
||||
(bound-identifier-mapping-put!
|
||||
table id
|
||||
(make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes))
|
||||
(make-var-info (free-identifier=? #'dv (quote-syntax define-syntaxes))
|
||||
#f
|
||||
id
|
||||
#f)))
|
||||
|
|
@ -763,7 +765,7 @@
|
|||
expanded-body))])
|
||||
#'(begin-with-definitions defn-or-expr ...))))))))
|
||||
|
||||
(define-for-syntax (redirect-imports/exports import?)
|
||||
(define-for-syntax (redirect-imports/exports import?)
|
||||
(lambda (table-stx
|
||||
import-tagged-infos
|
||||
import-sigs
|
||||
|
|
@ -775,7 +777,7 @@
|
|||
(for-each
|
||||
(lambda (tagged-info sig)
|
||||
(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
|
||||
(lambda (int/ext-name index ctc)
|
||||
(bound-identifier-mapping-put! def-table
|
||||
|
|
@ -840,17 +842,17 @@
|
|||
#`(unit-export ((export-keys ...)
|
||||
(vector-immutable eloc ...)) ...))))
|
||||
|
||||
(define-for-syntax redirect-imports (redirect-imports/exports #t))
|
||||
(define-for-syntax redirect-exports (redirect-imports/exports #f))
|
||||
(define-for-syntax redirect-imports (redirect-imports/exports #t))
|
||||
(define-for-syntax redirect-exports (redirect-imports/exports #f))
|
||||
|
||||
|
||||
;; build-unit/new-import-export : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; 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.
|
||||
;; The two additional values are the identifiers of the unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-unit/new-import-export stx)
|
||||
;; build-unit/new-import-export : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; 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.
|
||||
;; The two additional values are the identifiers of the unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-unit/new-import-export stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
(((import i ...)
|
||||
(export e ...)
|
||||
|
|
@ -954,20 +956,20 @@
|
|||
dep-tagged-sigids)))))))
|
||||
|
||||
|
||||
(define-syntax/err-param (unit/new-import-export stx)
|
||||
(define-syntax/err-param (unit/new-import-export stx)
|
||||
(syntax-case stx ()
|
||||
((_ . x)
|
||||
(begin
|
||||
(let-values (((u x y z) (build-unit/new-import-export (check-unit-syntax #'x))))
|
||||
u)))))
|
||||
|
||||
;; build-compound-unit : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a compound-unit expression. stx match the return of
|
||||
;; check-compound-syntax
|
||||
;; The two additional values are the identifiers of the compound-unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-compound-unit stx)
|
||||
;; build-compound-unit : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a compound-unit expression. stx match the return of
|
||||
;; check-compound-syntax
|
||||
;; The two additional values are the identifiers of the compound-unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-compound-unit stx)
|
||||
(define-struct lnkid-record (access-code names ctime-ids rtime-ids source-idx sigid siginfo))
|
||||
(define (lnkid-rec->keys t rec)
|
||||
(map (lambda (rid) (build-key t rid))
|
||||
|
|
@ -1021,7 +1023,7 @@
|
|||
bt
|
||||
lnkid
|
||||
(make-lnkid-record
|
||||
#`(hash-table-get
|
||||
#`(hash-ref
|
||||
#,tableid
|
||||
#,(build-key (syntax-e tag) (car rtime-ids)))
|
||||
(siginfo-names siginfo)
|
||||
|
|
@ -1047,7 +1049,7 @@
|
|||
[link-deps
|
||||
(map
|
||||
(lambda (tags lnkids i)
|
||||
(define ht (make-hash-table 'equal))
|
||||
(define ht (make-hash))
|
||||
(for-each
|
||||
(lambda (t l)
|
||||
(define et (syntax-e t))
|
||||
|
|
@ -1057,7 +1059,7 @@
|
|||
(define import-dep (= 0 (lnkid-record-source-idx rec)))
|
||||
(for-each
|
||||
(lambda (ctime-id rtime-id name)
|
||||
(hash-table-put! ht
|
||||
(hash-set! ht
|
||||
(build-key et ctime-id)
|
||||
(list forward-dep import-dep et rtime-id name el)))
|
||||
(lnkid-record-ctime-ids rec)
|
||||
|
|
@ -1065,7 +1067,7 @@
|
|||
(lnkid-record-names rec)))
|
||||
(syntax->list tags)
|
||||
(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-lnkid ...) ...))
|
||||
(cdr idxs))])
|
||||
|
|
@ -1182,7 +1184,7 @@
|
|||
#,(syntax/loc #'sub-exp (check-deps fht sub-tmp 'form))
|
||||
(for-each
|
||||
(lambda (dep)
|
||||
(when (hash-table-get rht dep #f)
|
||||
(when (hash-ref rht dep #f)
|
||||
(set! deps (cons dep deps))))
|
||||
(unit-deps sub-tmp)))))))
|
||||
(syntax->list #'((sub-exp
|
||||
|
|
@ -1231,20 +1233,20 @@
|
|||
(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)
|
||||
(build-compound-unit
|
||||
(check-compound-syntax (syntax-case stx () ((_ . x) #'x))))))
|
||||
u))
|
||||
|
||||
|
||||
(define (invoke-unit/core unit)
|
||||
(define (invoke-unit/core unit)
|
||||
(check-unit unit 'invoke-unit)
|
||||
(check-no-imports unit 'invoke-unit)
|
||||
(let-values ([(f exports) ((unit-go unit))])
|
||||
(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 ()
|
||||
((_ unit-expr . unit-out)
|
||||
(let* ((unit-out (checked-syntax->list #'unit-out))
|
||||
|
|
@ -1323,7 +1325,7 @@
|
|||
'define-values/invoke-unit)
|
||||
(let-values (((unit-fn export-table)
|
||||
((unit-go unit-tmp))))
|
||||
(let ([out-vec (hash-table-get export-table key1)] ...)
|
||||
(let ([out-vec (hash-ref export-table key1)] ...)
|
||||
(unit-fn #f)
|
||||
(values out-code ... ...))))))
|
||||
(define-values (int-binding ... ...)
|
||||
|
|
@ -1334,13 +1336,13 @@
|
|||
((_)
|
||||
(raise-stx-err "missing unit expression"))))
|
||||
|
||||
;; build-unit-from-context : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a unit-from-context expression. stx must be
|
||||
;; such that it passes check-ufc-syntax.
|
||||
;; The two additional values are the identifiers of the unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-unit-from-context stx)
|
||||
;; build-unit-from-context : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a unit-from-context expression. stx must be
|
||||
;; such that it passes check-ufc-syntax.
|
||||
;; The two additional values are the identifiers of the unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-unit-from-context stx)
|
||||
(syntax-case stx ()
|
||||
((export-spec)
|
||||
(let* ((tagged-export-sig (process-tagged-export #'export-spec))
|
||||
|
|
@ -1355,7 +1357,7 @@
|
|||
(list (cadr tagged-export-sig))
|
||||
'()))))))
|
||||
|
||||
(define-for-syntax (check-ufc-syntax stx)
|
||||
(define-for-syntax (check-ufc-syntax stx)
|
||||
(syntax-case stx ()
|
||||
((export-spec) (void))
|
||||
(()
|
||||
|
|
@ -1363,7 +1365,7 @@
|
|||
(_
|
||||
(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 ()
|
||||
((_ . x)
|
||||
(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)
|
||||
(syntax-case stx ()
|
||||
((_ name . rest)
|
||||
|
|
@ -1399,14 +1401,14 @@
|
|||
((_)
|
||||
(raise-stx-err err-msg)))))
|
||||
|
||||
;; build-define-unit : syntax-object
|
||||
;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier))
|
||||
;; string ->
|
||||
;; syntax-object
|
||||
(define-for-syntax build-define-unit (build-define-unit-helper #f))
|
||||
(define-for-syntax build-define-unit/contracted (build-define-unit-helper #t))
|
||||
;; build-define-unit : syntax-object
|
||||
;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier))
|
||||
;; string ->
|
||||
;; syntax-object
|
||||
(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-binding stx)
|
||||
(define-for-syntax (build-define-unit-binding stx)
|
||||
|
||||
(define (check-helper tagged-info)
|
||||
(cons (car (siginfo-names (cdr tagged-info)))
|
||||
|
|
@ -1450,33 +1452,33 @@
|
|||
tagged-export-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-binding (check-unit-body-syntax unit)))
|
||||
"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-unit (check-unit-syntax unit)))
|
||||
"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-unit/new-import-export (check-unit-syntax unit)))
|
||||
"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-compound-unit (check-compound-syntax clauses)))
|
||||
"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)
|
||||
(check-ufc-syntax sig)
|
||||
(build-unit-from-context sig))
|
||||
"missing unit name and signature"))
|
||||
|
||||
(define-for-syntax (build-unit/contract stx)
|
||||
(define-for-syntax (build-unit/contract stx)
|
||||
(syntax-parse stx
|
||||
[(:import-clause/contract :export-clause/contract dep:dep-clause . body)
|
||||
(let-values ([(exp isigs esigs deps)
|
||||
|
|
@ -1512,24 +1514,24 @@
|
|||
(syntax/loc stx
|
||||
(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-unit/contract stx))
|
||||
"missing unit name"))
|
||||
|
||||
(define-for-syntax (unprocess-tagged-id ti)
|
||||
(define-for-syntax (unprocess-tagged-id ti)
|
||||
(if (car ti)
|
||||
#`(tag #,(car 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)
|
||||
[(tag t sig)
|
||||
(list id #`(tag t #,id) #'sig)]
|
||||
[_else
|
||||
(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)
|
||||
((_ u (import) (export e ...))
|
||||
(quasisyntax/loc stx
|
||||
|
|
@ -1561,13 +1563,13 @@
|
|||
(format "expected syntax matching (~a <unit-expression> (import <sig-expr> ...) (export <sig-expr> ...))"
|
||||
(syntax-e (stx-car stx)))))))
|
||||
|
||||
;; build-compound-unit/infer : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a compound-unit/infer expression. stx match the return of
|
||||
;; check-compound-syntax
|
||||
;; The two additional values are the identifiers of the compound-unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-compound-unit/infer stx)
|
||||
;; build-compound-unit/infer : syntax-object ->
|
||||
;; (values syntax-object (listof identifier) (listof identifier))
|
||||
;; constructs the code for a compound-unit/infer expression. stx match the return of
|
||||
;; check-compound-syntax
|
||||
;; The two additional values are the identifiers of the compound-unit's import and export
|
||||
;; signatures
|
||||
(define-for-syntax (build-compound-unit/infer stx)
|
||||
|
||||
(define (lookup-tagged tid)
|
||||
(cons (car tid) (lookup-signature (cdr tid))))
|
||||
|
|
@ -1623,7 +1625,7 @@
|
|||
[link-defs (append import-sigs (apply append sub-outs))])
|
||||
|
||||
(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))])
|
||||
(when dup
|
||||
|
|
@ -1638,8 +1640,8 @@
|
|||
(lambda (b)
|
||||
(for-each
|
||||
(lambda (cid)
|
||||
(define there? (hash-table-get sig-table cid #f))
|
||||
(hash-table-put! sig-table cid (if there? 'duplicate (link-record-linkid b))))
|
||||
(define there? (hash-ref sig-table cid #f))
|
||||
(hash-set! sig-table cid (if there? 'duplicate (link-record-linkid b))))
|
||||
(siginfo-ctime-ids (link-record-siginfo b))))
|
||||
link-defs)
|
||||
|
||||
|
|
@ -1687,7 +1689,7 @@
|
|||
(cond
|
||||
[lookup (unprocess-tagged-id tid)]
|
||||
[else
|
||||
(let ([lnkid (hash-table-get
|
||||
(let ([lnkid (hash-ref
|
||||
sig-table
|
||||
(car (siginfo-ctime-ids (signature-siginfo (lookup-signature (cdr tid)))))
|
||||
#f)])
|
||||
|
|
@ -1723,7 +1725,7 @@
|
|||
(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) ()
|
||||
((i e (b ...))
|
||||
(with-syntax (((b ...)
|
||||
|
|
@ -1735,24 +1737,24 @@
|
|||
(syntax->list #'(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)
|
||||
(build-compound-unit/infer
|
||||
(check-compound/infer-syntax
|
||||
(syntax-case stx () ((_ . x) #'x))))))
|
||||
u))
|
||||
|
||||
(define-for-syntax (do-define-compound-unit/infer stx)
|
||||
(define-for-syntax (do-define-compound-unit/infer stx)
|
||||
(build-define-unit stx
|
||||
(lambda (clause)
|
||||
(build-compound-unit/infer (check-compound/infer-syntax clause)))
|
||||
"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))
|
||||
|
||||
;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax
|
||||
(define-for-syntax (build-invoke-unit/infer units define? exports)
|
||||
;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax
|
||||
(define-for-syntax (build-invoke-unit/infer units define? exports)
|
||||
(define (imps/exps-from-unit u)
|
||||
(let* ([ui (lookup-def-unit u)]
|
||||
[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))))))
|
||||
(define-values (isig tagged-import-sigs import-tagged-infos
|
||||
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
|
||||
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)
|
||||
(let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)])
|
||||
(values (drop-from-other-list export-tagged-infos itagged isources)
|
||||
|
|
@ -1804,7 +1806,7 @@
|
|||
[(list? exports)
|
||||
(let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos
|
||||
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
|
||||
spec-esig spec-export-tagged-infos))]
|
||||
[else esig]))))
|
||||
|
|
@ -1816,7 +1818,7 @@
|
|||
(siginfo-subtype (cdr ute) (cdr ste))))
|
||||
unit-tagged-exports)
|
||||
(raise-stx-err (format "no subunit exports signature ~a"
|
||||
(syntax-object->datum se))
|
||||
(syntax->datum se))
|
||||
se)))
|
||||
spec-exports
|
||||
spec-tagged-exports)
|
||||
|
|
@ -1856,7 +1858,7 @@
|
|||
;; just for error handling
|
||||
[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)
|
||||
[(_ (link unit ...))
|
||||
(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> ...))"
|
||||
(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)
|
||||
((_ unit)
|
||||
(syntax/loc stx
|
||||
|
|
@ -1898,7 +1900,7 @@
|
|||
(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 ()
|
||||
[(_ (link unit ...))
|
||||
(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> ...))"
|
||||
(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)
|
||||
[((import i ...) (export e ...) (init-depend d ...) u)
|
||||
(let* ([ui (lookup-def-unit #'u)]
|
||||
|
|
@ -1923,15 +1925,12 @@
|
|||
(syntax/loc stx
|
||||
((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)))
|
||||
"missing unit name"))
|
||||
|
||||
(define-syntax/err-param (unit/s stx)
|
||||
(define-syntax/err-param (unit/s stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . stx)
|
||||
(let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))])
|
||||
u)]))
|
||||
|
||||
)
|
||||
;(load "test-unit.ss")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user