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

Actually make this used specifically for blame, not the unit name.

Browse Source 
We might end up collapsing this and what's introduced in with-contract.

svn: r13140

original commit: 6e86da95e60f9d2aaef92c73226c9f99f374c3ae
This commit is contained in:
Stevie Strickland 2009-01-15 05:17:27 +00:00
commit f5961b496a
1 changed files with 5 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mzlib/unit.ss
View File

@ -469,13 +469,13 @@
#,(syntax-span id))
#,(format "~s" (syntax-object->datum id))))
(define-syntax-parameter current-unit-name-stx (lambda (stx) #'(#%variable-reference)))
(define-syntax-parameter current-unit-blame-stx (lambda (stx) #'(#%variable-reference)))
(define-for-syntax (make-import-unboxing ext-var loc ctc)
(if ctc
(quasisyntax/loc (error-syntax)
(quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen
(current-unit-name-stx)
(current-unit-blame-stx)
#,(id->contract-src-info ext-var))))
(quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc)))))
@ -556,7 +556,7 @@
(vector-immutable (cons 'export-name
(vector-immutable export-key ...)) ...)
(list (cons 'dept depr) ...)
(syntax-parameterize ([current-unit-name-stx (lambda (stx) #'(quote name))])
(syntax-parameterize ([current-unit-blame-stx (lambda (stx) #'(quote (unit name)))])
(lambda ()
(let ([eloc (box undefined)] ... ...)
(values
@ -695,7 +695,7 @@
(set-var-info-add-ctc!
v
(λ (e)
#`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-name-stx)
#`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-blame-stx)
'cant-happen #,(id->contract-src-info var)))))))
(syntax->list (localify #'evars def-ctx))
(syntax->list #'elocs)
@ -1222,7 +1222,7 @@
(lambda (i iv c)
(if c
#`(contract #,c (unbox (vector-ref #,ov #,i))
'cant-happen (current-unit-name-stx)
'cant-happen (current-unit-blame-stx)
#,(id->contract-src-info iv))
#`(unbox (vector-ref #,ov #,i))))
(iota (length (car os)))