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

* Fix unit/c so that less unnecessary code is generated.

Browse Source 
* Fix contracts for signatures and units so that references to
   other signature members work appropriately.
 * Add text about signature and unit contracts to the Guide.

svn: r13562

original commit: 387c8b210f6d8361238fa9416e96eff225d7d6d3
This commit is contained in:
Stevie Strickland 2009-02-13 22:50:49 +00:00
commit eb8a57c182
1 changed files with 83 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
collects/mzlib/unit.ss
View File

@ -369,16 +369,6 @@
(cons (car x) (cons (car x)
(signature-siginfo (lookup-signature (cdr x))))) (signature-siginfo (lookup-signature (cdr x)))))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the contract, given an identifier
(define-for-syntax (id->contract-src-info id)
#`(list (make-srcloc (quote-syntax #,id)
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax-object->datum id))))
(define-for-syntax (make-import-unboxing var loc ctc) (define-for-syntax (make-import-unboxing var loc ctc)
(if ctc (if ctc
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
@ -670,6 +660,12 @@
target-import-tagged-infos target-import-tagged-infos
target-import-sigs) target-import-sigs)
(define def-table (make-bound-identifier-mapping)) (define def-table (make-bound-identifier-mapping))
(define ctc-table (make-bound-identifier-mapping))
(define sig-of-all-import-sigs
(list (apply append (map car import-sigs))
(apply append (map cadr import-sigs))
(apply append (map caddr import-sigs))
(apply append (map cadddr import-sigs))))
(for-each (for-each
(lambda (tagged-info sig) (lambda (tagged-info sig)
(define v (define v
@ -678,7 +674,10 @@
(lambda (int/ext-name index ctc) (lambda (int/ext-name index ctc)
(bound-identifier-mapping-put! def-table (bound-identifier-mapping-put! def-table
(car int/ext-name) (car int/ext-name)
(cons #`(vector-ref #,v #,index) ctc))) #`(vector-ref #,v #,index))
(bound-identifier-mapping-put! ctc-table
(car int/ext-name)
ctc))
(car sig) (car sig)
(iota (length (car sig))) (iota (length (car sig)))
(cadddr sig))) (cadddr sig)))
@ -687,38 +686,48 @@
(with-syntax ((((eloc ...) ...) (with-syntax ((((eloc ...) ...)
(map (map
(lambda (target-sig) (lambda (target-sig)
(define rename-bindings
(get-member-bindings def-table
sig-of-all-import-sigs
#'(current-contract-region)))
(map (map
(lambda (target-int/ext-name target-ctc) (lambda (target-int/ext-name target-ctc)
(let ([vref/ctc (let* ([var (car target-int/ext-name)]
[vref
(bound-identifier-mapping-get (bound-identifier-mapping-get
def-table def-table
(car target-int/ext-name) var
(lambda () (lambda ()
(raise-stx-err (raise-stx-err
(format (if import? (format (if import?
"identifier ~a is not present in new imports" "identifier ~a is not present in new imports"
"identifier ~a is not present in old exports") "identifier ~a is not present in old exports")
(syntax-e (car target-int/ext-name))))))]) (syntax-e (car target-int/ext-name))))))]
(let ([old-cl (car vref/ctc)]) [ctc (bound-identifier-mapping-get ctc-table var)])
(if (or target-ctc ctc)
#`(cons #`(cons
(λ () (λ ()
(let ([old-v #,(if (cdr vref/ctc) (let ([old-v #,(if ctc
#`(let ([old-v/c ((car #,old-cl))]) #`(let ([old-v/c ((car #,vref))])
(contract #,(cdr vref/ctc) (car old-v/c) (contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
(car old-v/c)
(cdr old-v/c) (current-contract-region) (cdr old-v/c) (current-contract-region)
#,(id->contract-src-info (car target-int/ext-name)))) #,(id->contract-src-info var)))
#`((car #,old-cl)))]) #`((car #,vref)))])
#,(if target-ctc #,(if target-ctc
#'(cons old-v (current-contract-region)) #'(cons old-v (current-contract-region))
#'old-v))) #'old-v)))
(λ (v) (let ([new-v #,(if (cdr vref/ctc) (λ (v) (let ([new-v #,(if ctc
#`(contract #,(cdr vref/ctc) (car v) #`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
(current-contract-region) (cdr v) (car v)
#,(id->contract-src-info (car target-int/ext-name))) (current-contract-region)
(cdr v)
#,(id->contract-src-info var))
#'v)]) #'v)])
#,(if target-ctc #,(if target-ctc
#`((cdr #,old-cl) (cons new-v (current-contract-region))) #`((cdr #,vref) (cons new-v (current-contract-region)))
#`((cdr #,old-cl) new-v)))))))) #`((cdr #,vref) new-v)))))
vref)))
(car target-sig) (car target-sig)
(cadddr target-sig))) (cadddr target-sig)))
target-import-sigs)) target-import-sigs))
@ -1139,7 +1148,10 @@
(out-tags (map car tagged-out)) (out-tags (map car tagged-out))
(out-sigs (map caddr tagged-out)) (out-sigs (map caddr tagged-out))
(dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs)))) (dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs))))
(out-vec (generate-temporaries out-sigs))) (out-vec (generate-temporaries out-sigs))
(tmarker (make-syntax-introducer))
(vmarker (make-syntax-introducer))
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)))
(when dup (when dup
(raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup))))
(with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags)) (with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags))
@ -1153,25 +1165,45 @@
((out-names ...) ((out-names ...)
(map (lambda (info) (car (siginfo-names (cdr info)))) (map (lambda (info) (car (siginfo-names (cdr info))))
out-tags)) out-tags))
(((tmp-binding ...) ...) tmp-bindings)
(((val-binding ...) ...) (map (λ (s) (map vmarker (map car (car s)))) out-sigs))
(((out-code ...) ...) (((out-code ...) ...)
(map (map
(lambda (os ov) (lambda (os ov)
(map (map
(lambda (i v c) (lambda (i)
#`((car (vector-ref #,ov #,i))))
(iota (length (car os)))))
out-sigs
out-vec))
(((val-code ...) ...)
(map (λ (tbs os)
(map (λ (tb c)
(if c (if c
#`(let ([v/c ((car (vector-ref #,ov #,i)))]) #`(car #,tb)
(contract #,c (car v/c) (cdr v/c) tb))
tbs
(cadddr os)))
tmp-bindings
out-sigs))
(((wrap-code ...) ...)
(map (λ (os ov tbs)
(map (λ (tb i v c)
(if c
#`(contract #,(vmarker c) (car #,tb) (cdr #,tb)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info v))) #,(id->contract-src-info v))
#`((car (vector-ref #,ov #,i))))) tb))
tbs
(iota (length (car os))) (iota (length (car os)))
(map car (car os)) (map car (car os))
(cadddr os))) (cadddr os)))
out-sigs out-sigs
out-vec))) out-vec
tmp-bindings)))
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define-values (int-binding ... ...) (define-values (tmp-binding ... ...)
#,(syntax/loc #'unit-expr #,(syntax/loc #'unit-expr
(let ((unit-tmp unit-expr)) (let ((unit-tmp unit-expr))
(check-unit unit-tmp 'define-values/invoke-unit) (check-unit unit-tmp 'define-values/invoke-unit)
@ -1185,6 +1217,10 @@
(let ([out-vec (hash-table-get export-table key1)] ...) (let ([out-vec (hash-table-get export-table key1)] ...)
(unit-fn #f) (unit-fn #f)
(values out-code ... ...)))))) (values out-code ... ...))))))
(define-values (val-binding ... ...)
(values val-code ... ...))
(define-values (int-binding ... ...)
(values wrap-code ... ...))
(define-syntaxes . renames) ... (define-syntaxes . renames) ...
(define-syntaxes (mac-name ...) mac-body) ... ... (define-syntaxes (mac-name ...) mac-body) ... ...
(define-values (val-name ...) val-body) ... ...))))) (define-values (val-name ...) val-body) ... ...)))))