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

Tag the contracts so we know what are truly contracts and which are just

Browse Source 
placeholder #fs.

svn: r13048

original commit: af69c0bbeccf2fab5e11b104cd8bb3a686f343f9
This commit is contained in:
Stevie Strickland 2009-01-09 19:50:28 +00:00
parent ea41bc867d
commit 4d8f6fdeb0
1 changed files with 12 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/mzlib/unit.ss
View File

@ -514,7 +514,12 @@
[((eloc ...) ...) [((eloc ...) ...)
(map (lambda (x) (generate-temporaries (car x))) export-sigs)] (map (lambda (x) (generate-temporaries (car x))) export-sigs)]
[((ectc ...) ...) [((ectc ...) ...)
(map cadddr export-sigs)] (map (λ (sig)
(map (λ (ctc)
(if ctc
(cons 'contract ctc)
#f))
(cadddr sig))) export-sigs)]
[((import-key import-super-keys ...) ...) [((import-key import-super-keys ...) ...)
(map tagged-info->keys import-tagged-infos)] (map tagged-info->keys import-tagged-infos)]
[((export-key ...) ...) [((export-key ...) ...)
@ -673,10 +678,12 @@
(when (var-info-syntax? v) (when (var-info-syntax? v)
(raise-stx-err "cannot export syntax from a unit" name)) (raise-stx-err "cannot export syntax from a unit" name))
(set-var-info-exported?! v loc) (set-var-info-exported?! v loc)
(set-var-info-add-ctc! v (lambda (e) (when (pair? (syntax-e ctc))
#`(if #,ctc (set-var-info-add-ctc!
(contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var)) v
#,e))))) (λ (e)
#`(contract #,(cdr (syntax-e ctc)) #,e '#,unit-name
'cant-happen #,(id->contract-src-info var)))))))
(syntax->list (localify #'evars def-ctx)) (syntax->list (localify #'evars def-ctx))
(syntax->list #'elocs) (syntax->list #'elocs)
(syntax->list #'ext-evars) (syntax->list #'ext-evars)