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

Handle this similarly to scheme/private/contract.

Browse Source 
svn: r12869

original commit: f7c37571ce844987fcb1bbfc8c20580b70e25864
This commit is contained in:
Stevie Strickland 2008-12-16 19:42:06 +00:00
commit 3db841f79a
1 changed files with 13 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/mzlib/unit.ss
View File

@ -451,10 +451,20 @@
(define-for-syntax process-unit-export (define-for-syntax process-unit-export
(process-unit-import/export process-tagged-export)) (process-unit-import/export process-tagged-export))
;; 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 int-var ext-var loc ctc name) (define-for-syntax (make-import-unboxing int-var ext-var loc ctc name)
(if ctc (if ctc
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name (quote-syntax #,ext-var)))) (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen '#,name #,(id->contract-src-info ext-var))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc))))) (quote-syntax (unbox #,loc)))))
@ -675,7 +685,7 @@
(set-var-info-exported?! v loc) (set-var-info-exported?! v loc)
(set-var-info-add-ctc! v (lambda (e) (set-var-info-add-ctc! v (lambda (e)
#`(if #,ctc #`(if #,ctc
(contract #,ctc #,e '#,unit-name 'cant-happen (quote-syntax #,var)) (contract #,ctc #,e '#,unit-name 'cant-happen #,(id->contract-src-info var))
#,e))))) #,e)))))
local-evars local-evars
(syntax->list #'elocs) (syntax->list #'elocs)
@ -1246,7 +1256,7 @@
(if c (if c
#`(contract #,c (unbox (vector-ref #,ov #,i)) #`(contract #,c (unbox (vector-ref #,ov #,i))
'cant-happen (#%variable-reference) 'cant-happen (#%variable-reference)
(quote-syntax #,iv)) #,(id->contract-src-info iv))
#`(unbox (vector-ref #,ov #,i)))) #`(unbox (vector-ref #,ov #,i))))
(iota (length (car os))) (iota (length (car os)))
(map cdr (car os)) (map cdr (car os))