suzanne.soy/compatibility
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

original commit: 73d68593af6b7c3a389013527f9b2a46618d1642
This commit is contained in:
Stevie Strickland 2010-01-08 21:44:42 +00:00
parent bb3d45340d
commit e19d7a7128
3 changed files with 1936 additions and 1937 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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