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

Clean up some bindings, moving them from defines to letrec-syntax.

Browse Source 
svn: r13599
This commit is contained in:
Stevie Strickland 2009-02-15 05:20:30 +00:00
parent 154cb8d1fd
commit 62d82ca9be
2 changed files with 22 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/mzlib/unit.ss
View File

@ -1151,10 +1151,19 @@
(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)) (tmarker (make-syntax-introducer))
(vmarker (make-syntax-introducer)) (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs))
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs))) (def-table (make-bound-identifier-mapping)))
(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))))
(for-each
(λ (sig new-xs)
(for-each
(λ (old new)
(bound-identifier-mapping-put! def-table old new))
(map car (car sig))
new-xs))
out-sigs
tmp-bindings)
(with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags)) (with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags))
((((int-binding . ext-binding) ...) ...) (map car out-sigs)) ((((int-binding . ext-binding) ...) ...) (map car out-sigs))
((out-vec ...) out-vec) ((out-vec ...) out-vec)
@ -1167,34 +1176,26 @@
(map (lambda (info) (car (siginfo-names (cdr info)))) (map (lambda (info) (car (siginfo-names (cdr info))))
out-tags)) out-tags))
(((tmp-binding ...) ...) tmp-bindings) (((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) (lambda (i)
#`((car (vector-ref #,ov #,i)))) #`(vector-ref #,ov #,i))
(iota (length (car os))))) (iota (length (car os)))))
out-sigs out-sigs
out-vec)) out-vec))
(((val-code ...) ...)
(map (λ (tbs os)
(map (λ (tb c)
(if c
#`(car #,tb)
tb))
tbs
(cadddr os)))
tmp-bindings
out-sigs))
(((wrap-code ...) ...) (((wrap-code ...) ...)
(map (λ (os ov tbs) (map (λ (os ov tbs)
(define rename-bindings
(get-member-bindings def-table os #'(#%variable-reference)))
(map (λ (tb i v c) (map (λ (tb i v c)
(if c #`(let ([v/c ((car #,tb))])
#`(contract #,(vmarker c) (car #,tb) (cdr #,tb) #,(if c
(current-contract-region) #`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c)
#,(id->contract-src-info v)) (current-contract-region)
tb)) #,(id->contract-src-info v))
#'v/c)))
tbs tbs
(iota (length (car os))) (iota (length (car os)))
(map car (car os)) (map car (car os))
@ -1218,8 +1219,6 @@
(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 ... ...) (define-values (int-binding ... ...)
(values wrap-code ... ...)) (values wrap-code ... ...))
(define-syntaxes . renames) ... (define-syntaxes . renames) ...

3
collects/tests/units/test-unit-contracts.ss
View File

@ -1,5 +1,6 @@
(require "test-harness.ss" (require "test-harness.ss"
scheme/unit) scheme/unit
scheme/contract)
(define-signature sig1 (define-signature sig1
((contracted [x number?]))) ((contracted [x number?])))