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

Fix open so that it respects contracts.

Browse Source 
svn: r14902

original commit: 732e93b9dc5a1e589af6355228ff47313682d0f4
This commit is contained in:
Stevie Strickland 2009-05-21 16:36:36 +00:00
parent 329482216f
commit 1e2e38be43
1 changed files with 8 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mzlib/unit.ss
View File

@ -234,17 +234,23 @@
(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)))
(car sig)
(cadddr sig)))
(parameterize ([error-syntax stx]) (parameterize ([error-syntax stx])
(syntax-case stx () (syntax-case stx ()
((_ export-spec) ((_ export-spec)
(let ([sig (process-spec #'export-spec)]) (let ([sig (process-spec #'export-spec)])
(with-syntax ((((int . ext) ...) (car sig)) (with-syntax (((sig-elem ...)
(build-sig-elems sig))
((renames ((renames
(((mac-name ...) mac-body) ...) (((mac-name ...) mac-body) ...)
(((val-name ...) val-body) ...)) (((val-name ...) val-body) ...))
(build-val+macro-defs sig))) (build-val+macro-defs sig)))
(syntax->list (syntax->list
#'(int ... #'(sig-elem ...
(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) ...)))))