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

Ported mzlib units to new contract system.

Browse Source 
svn: r17718

original commit: 7763a4079ad4db29c3c42d7278e779e6ff604f90
This commit is contained in:
Carl Eastlund 2010-01-18 18:26:02 +00:00
parent f56868d873
commit 62f745be71
1 changed files with 8 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/mzlib/unit.ss
View File

@ -482,7 +482,7 @@
(if (pair? v/c)
(contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info var))
(quote #,var) (quote-syntax #,var))
(error 'unit "contracted import ~a used before definition"
(quote #,(syntax->datum var))))))))
(quasisyntax/loc (error-syntax)
@ -747,7 +747,8 @@
(contract #,ctc #,tmp
(current-contract-region)
'cant-happen
#,(id->contract-src-info id))
(quote #,id)
(quote-syntax #,id))
(set-box! #,export-loc
(cons #,tmp (current-contract-region)))))
(quasisyntax/loc defn-or-expr
@ -824,7 +825,7 @@
#`(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))
(quote #,var) (quote-syntax #,var)))
#`(#,vref))
(current-contract-region)))
(if ctc
@ -832,7 +833,7 @@
(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var))))
(quote #,var) (quote-syntax #,var))))
vref)))))
(car target-sig)
(cadddr target-sig)))
@ -1303,7 +1304,7 @@
#`(let ([v/c (#,tb)])
(contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info v))))
(quote #,v) (quote-syntax #,v))))
#`(#,tb)))
tbs
(iota (length (car os)))
@ -1503,11 +1504,10 @@
#'name
(syntax/loc stx
((import (import-tagged-sig-id [i.x i.c] ...) ...)
(export (export-tagged-sig-id [e.x e.c] ...) ...))))]
[src-info (id->contract-src-info #'name)])
(export (export-tagged-sig-id [e.x e.c] ...) ...))))])
(values
(syntax/loc stx
(contract unit-contract new-unit '(unit name) (current-contract-region) src-info))
(contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name)))
isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body)
(build-unit/contract