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

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

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

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

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

@ -1,21 +1,21 @@
(module unit-compiletime mzscheme #lang scheme/base
(require syntax/boundmap
mzlib/list (require scheme/list
"unit-syntax.ss" syntax/boundmap
(only scheme/base define-struct struct-out) "unit-syntax.ss")
(rename scheme/base provide* provide)) (require (for-syntax scheme/base))
(require-for-template mzscheme (require (for-template scheme/base
"unit-keywords.ss" "unit-keywords.ss"
"unit-runtime.ss") "unit-runtime.ss"))
(require scheme/private/define-struct) (require scheme/private/define-struct)
(provide* (struct-out var-info) (provide (struct-out var-info)
(struct-out signature) (struct-out signature)
(struct-out signature-form) (struct-out signature-form)
(struct-out unit-info) (struct-out unit-info)
(struct-out link-record)) (struct-out link-record)
(provide (rename build-siginfo make-siginfo) (rename-out [build-siginfo make-siginfo])
siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype siginfo-names siginfo-ctime-ids siginfo-rtime-ids siginfo-subtype
unprocess-link-record-bind unprocess-link-record-use unprocess-link-record-bind unprocess-link-record-use
set!-trans-extract set!-trans-extract
@ -38,7 +38,7 @@
(else (else
(syntax-case (car l) () (syntax-case (car l) ()
((r . x) ((r . x)
(ormap (lambda (req) (module-identifier=? #'r req)) (ormap (lambda (req) (free-identifier=? #'r req))
req-forms) req-forms)
(loop (cdr l) (cons (car l) requires))) (loop (cdr l) (cons (car l) requires)))
(_ (_
@ -89,11 +89,11 @@
(make-siginfo names (make-siginfo names
ctime-ids ctime-ids
rtime-ids rtime-ids
(make-immutable-hash-table (map (λ (x) `(,x . #t)) ctime-ids)))) (make-immutable-hasheq (map (λ (x) `(,x . #t)) ctime-ids))))
;; siginfo-subtype : siginfo siginfo -> bool ;; siginfo-subtype : siginfo siginfo -> bool
(define (siginfo-subtype s1 s2) (define (siginfo-subtype s1 s2)
(hash-table-get (siginfo-super-table s1) (hash-ref (siginfo-super-table s1)
(car (siginfo-ctime-ids s2)) (car (siginfo-ctime-ids s2))
(λ () #f))) (λ () #f)))
@ -204,7 +204,7 @@
;; ensures that pid is an identifier ;; ensures that pid is an identifier
(define (do-prefix stx pid) (define (do-prefix stx pid)
(if (identifier? stx) (if (identifier? stx)
(datum->syntax-object (datum->syntax
stx stx
(string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx))) (string->symbol (format "~a~a" (syntax-e pid) (syntax-e stx)))
stx) stx)
@ -361,7 +361,7 @@
(let* ((sig-res (let* ((sig-res
(do-rename (process-import/export #'sub-spec res bind? add-prefix) (do-rename (process-import/export #'sub-spec res bind? add-prefix)
#'(internal ...) #'(internal ...)
(datum->syntax-object #f (add-prefixes add-prefix #'(external ...))))) (datum->syntax #f (add-prefixes add-prefix #'(external ...)))))
(dup (check-duplicate-identifier (sig-int-names sig-res)))) (dup (check-duplicate-identifier (sig-int-names sig-res))))
(when dup (when dup
(raise-stx-err (raise-stx-err
@ -406,7 +406,7 @@
(when (and (eq? (car tinfo1) (car tinfo2)) (when (and (eq? (car tinfo1) (car tinfo2))
(siginfo-subtype (cdr tinfo1) (cdr tinfo2))) (siginfo-subtype (cdr tinfo1) (cdr tinfo2)))
(raise-stx-err (format "the signature of ~a extends this signature" (raise-stx-err (format "the signature of ~a extends this signature"
(syntax-object->datum s1)) (syntax->datum s1))
s2)))) s2))))
tagged-siginfos tagged-siginfos
sources)) sources))
@ -421,8 +421,8 @@
;; complete-exports : (listof link-record) (listof link-record) -> (listof link-record) ;; complete-exports : (listof link-record) (listof link-record) -> (listof link-record)
;; The export-bindings should not contain two bindings that are related as subsignatures. ;; The export-bindings should not contain two bindings that are related as subsignatures.
(define (complete-exports unit-exports given-bindings) (define (complete-exports unit-exports given-bindings)
(define binding-table (make-hash-table 'equal)) (define binding-table (make-hash))
(define used-binding-table (make-hash-table 'equal)) (define used-binding-table (make-hash))
(check-duplicate-subs (check-duplicate-subs
(map (λ (ts) (cons (link-record-tag ts) (link-record-siginfo ts))) given-bindings) (map (λ (ts) (cons (link-record-tag ts) (link-record-siginfo ts))) given-bindings)
@ -430,7 +430,7 @@
(for-each (for-each
(λ (b) (λ (b)
(hash-table-put! binding-table (hash-set! binding-table
(cons (link-record-tag b) (cons (link-record-tag b)
(car (siginfo-ctime-ids (link-record-siginfo b)))) (car (siginfo-ctime-ids (link-record-siginfo b))))
(link-record-linkid b))) (link-record-linkid b)))
@ -443,12 +443,12 @@
(ormap (ormap
(λ (ctime-id) (λ (ctime-id)
(define key (cons (link-record-tag export) ctime-id)) (define key (cons (link-record-tag export) ctime-id))
(define used (hash-table-get used-binding-table key (λ () #f))) (define used (hash-ref used-binding-table key (λ () #f)))
(when used (when used
(raise-stx-err "this export is supplied multiple times by the given unit" used)) (raise-stx-err "this export is supplied multiple times by the given unit" used))
(let ([r (hash-table-get binding-table key (λ () #f))]) (let ([r (hash-ref binding-table key (λ () #f))])
(when r (when r
(hash-table-put! used-binding-table key r)) (hash-set! used-binding-table key r))
r)) r))
(siginfo-ctime-ids (link-record-siginfo export)))) (siginfo-ctime-ids (link-record-siginfo export))))
(make-link-record (make-link-record
@ -460,27 +460,27 @@
(link-record-siginfo export))) (link-record-siginfo export)))
unit-exports) unit-exports)
(hash-table-for-each (hash-for-each
binding-table binding-table
(λ (k v) (λ (k v)
(unless (hash-table-get used-binding-table k (λ () #f)) (unless (hash-ref used-binding-table k (λ () #f))
(raise-stx-err "this export is not supplied by the given unit" v)))))) (raise-stx-err "this export is not supplied by the given unit" v))))))
(define (name-form n) (syntax-object->datum n)) (define (name-form n) (syntax->datum n))
;; complete-imports : (hash-tableof symbol (or identifier 'duplicate)) ;; complete-imports : (hash-tableof symbol (or identifier 'duplicate))
;; (listof link-record) ;; (listof link-record)
;; (listof (list symbol identifier siginfo)) -> ;; (listof (list symbol identifier siginfo)) ->
;; (listof (cons symbol identifier)) ;; (listof (cons symbol identifier))
(define (complete-imports sig-table given-links unit-imports src) (define (complete-imports sig-table given-links unit-imports src)
(define linked-sigs-table (make-hash-table 'equal)) (define linked-sigs-table (make-hash))
(for-each (for-each
(λ (link) (λ (link)
(define tag (link-record-tag link)) (define tag (link-record-tag link))
(for-each (for-each
(λ (cid) (λ (cid)
(define there? (hash-table-get linked-sigs-table (cons tag cid) (λ () #f))) (define there? (hash-ref linked-sigs-table (cons tag cid) (λ () #f)))
(hash-table-put! linked-sigs-table (cons tag cid) (if there? 'duplicate #t))) (hash-set! linked-sigs-table (cons tag cid) (if there? 'duplicate #t)))
(siginfo-ctime-ids (link-record-siginfo link)))) (siginfo-ctime-ids (link-record-siginfo link))))
given-links) given-links)
@ -494,7 +494,7 @@
[ctime-ids (siginfo-ctime-ids (link-record-siginfo import))] [ctime-ids (siginfo-ctime-ids (link-record-siginfo import))]
[tag (link-record-tag import)] [tag (link-record-tag import)]
[there? [there?
(hash-table-get linked-sigs-table (hash-ref linked-sigs-table
(cons tag (car ctime-ids)) (cons tag (car ctime-ids))
(λ () #f))]) (λ () #f))])
(cond (cond
@ -509,7 +509,7 @@
[there? [there?
(loop (cdr unit-imports))] (loop (cdr unit-imports))]
[else [else
(let ([there?2 (hash-table-get sig-table (let ([there?2 (hash-ref sig-table
(car ctime-ids) (car ctime-ids)
(λ () #f))]) (λ () #f))])
(cond (cond
@ -524,7 +524,7 @@
[there?2 [there?2
(for-each (for-each
(λ (cid) (λ (cid)
(hash-table-put! linked-sigs-table (hash-set! linked-sigs-table
(cons tag cid) (cons tag cid)
#t)) #t))
ctime-ids) ctime-ids)
@ -568,7 +568,7 @@
"cannot set! imported or exported variables" "cannot set! imported or exported variables"
sstx)] sstx)]
[(_ . x) [(_ . x)
(datum->syntax-object (datum->syntax
sstx sstx
(cons unbox-stx #'x) (cons unbox-stx #'x)
sstx)]))))) sstx)]))))

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

@ -1,7 +1,8 @@
(module unit-runtime mzscheme #lang scheme/base
(require-for-syntax "unit-syntax.ss")
(require (for-syntax "unit-syntax.ss" scheme/base))
(provide define-syntax/err-param (provide define-syntax/err-param
undefined (rename make-a-unit make-unit) unit-import-sigs unit-export-sigs unit-go unit? unit-deps undefined (rename-out [make-a-unit make-unit]) unit-import-sigs unit-export-sigs unit-go unit? unit-deps
check-unit check-no-imports check-sigs check-deps check-helper) check-unit check-no-imports check-sigs check-deps check-helper)
(define-syntax define-syntax/err-param (define-syntax define-syntax/err-param
@ -50,15 +51,15 @@
;; symbol symbol -> ;; symbol symbol ->
;; ensure that the unit's signatures match the expected signatures. ;; ensure that the unit's signatures match the expected signatures.
(define (check-helper sub-sig super-sig name import?) (define (check-helper sub-sig super-sig name import?)
(define t (make-hash-table 'equal)) (define t (make-hash))
(let loop ([i (sub1 (vector-length sub-sig))]) (let loop ([i (sub1 (vector-length sub-sig))])
(when (>= i 0) (when (>= i 0)
(let ([v (cdr (vector-ref sub-sig i))]) (let ([v (cdr (vector-ref sub-sig i))])
(let loop ([j (sub1 (vector-length v))]) (let loop ([j (sub1 (vector-length v))])
(when (>= j 0) (when (>= j 0)
(let ([vj (vector-ref v j)]) (let ([vj (vector-ref v j)])
(hash-table-put! t vj (hash-set! t vj
(if (hash-table-get t vj #f) (if (hash-ref t vj #f)
'amb 'amb
#t))) #t)))
(loop (sub1 j))))) (loop (sub1 j)))))
@ -66,7 +67,7 @@
(let loop ([i (sub1 (vector-length super-sig))]) (let loop ([i (sub1 (vector-length super-sig))])
(when (>= i 0) (when (>= i 0)
(let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)] (let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)]
[r (hash-table-get t v0 #f)]) [r (hash-ref t v0 #f)])
(when (or (eq? r 'amb) (not r)) (when (or (eq? r 'amb) (not r))
(let ([tag (if (pair? v0) (car v0) #f)] (let ([tag (if (pair? v0) (car v0) #f)]
[sub-name (car (vector-ref super-sig i))] [sub-name (car (vector-ref super-sig i))]
@ -107,7 +108,7 @@
(define (check-deps dep-table unit name) (define (check-deps dep-table unit name)
(for-each (for-each
(λ (dep) (λ (dep)
(let ([r (hash-table-get dep-table dep #f)]) (let ([r (hash-ref dep-table dep #f)])
(when r (when r
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
@ -131,6 +132,4 @@
;; ensures that unit has the given signatures ;; ensures that unit has the given signatures
(define (check-sigs unit expected-imports expected-exports name) (define (check-sigs unit expected-imports expected-exports name)
(check-helper expected-imports (unit-import-sigs unit) name #t) (check-helper expected-imports (unit-import-sigs unit) name #t)
(check-helper (unit-export-sigs unit) expected-exports name #f))) (check-helper (unit-export-sigs unit) expected-exports name #f))

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

@ -1,8 +1,9 @@
(module unit-syntax mzscheme #lang scheme/base
(require syntax/stx)
(require-for-template "unit-keywords.ss")
(provide (all-defined)) (require syntax/stx)
(require (for-template "unit-keywords.ss"))
(provide (all-defined-out))
(define error-syntax (make-parameter #f)) (define error-syntax (make-parameter #f))
(define raise-stx-err (define raise-stx-err
@ -75,8 +76,8 @@
(checked-syntax->list s) (checked-syntax->list s)
(syntax-case s (prefix rename) (syntax-case s (prefix rename)
((key . x) ((key . x)
(or (module-identifier=? #'key #'only) (or (free-identifier=? #'key #'only)
(module-identifier=? #'key #'except)) (free-identifier=? #'key #'except))
(begin (begin
(unless import? (unless import?
(raise-stx-err (raise-stx-err
@ -281,6 +282,3 @@
(format "bad syntax (has ~a parts after keyword)" (format "bad syntax (has ~a parts after keyword)"
(sub1 (length (syntax->list d)))) (sub1 (length (syntax->list d))))
d)))) d))))
)
;(load "test-unit-syntax.ss")

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

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

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

@ -1,5 +1,4 @@
#lang scheme/base
(module unitidmap mzscheme
;; Help Desk binding info: ;; Help Desk binding info:
(define (binding binder bound stx) (define (binding binder bound stx)
@ -12,14 +11,14 @@
(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)

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

@ -1,4 +1,5 @@
(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")
@ -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))))))))

87
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,11 +11,11 @@
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"
@ -23,7 +25,7 @@
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
@ -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
@ -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
@ -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)
@ -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))
@ -482,7 +484,7 @@
(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)))))
@ -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
@ -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)))
@ -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
@ -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
@ -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 ... ...)
@ -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)])
@ -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)
@ -1932,6 +1934,3 @@
[(_ . 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")