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

Now that we're in with-contract land, use the same syntax parameter for units

Browse Source 
as well as with-contract and define/contract.

svn: r13181
This commit is contained in:
Stevie Strickland 2009-01-16 20:41:51 +00:00
parent 0fcf609e2b
commit 39d9cfbb0a
1 changed files with 4 additions and 6 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,11 @@
#,(syntax-span id)) #,(syntax-span id))
#,(format "~s" (syntax-object->datum id)))) #,(format "~s" (syntax-object->datum id))))
(define-syntax-parameter current-unit-blame-stx (lambda (stx) #'(#%variable-reference)))
(define-for-syntax (make-import-unboxing var loc ctc) (define-for-syntax (make-import-unboxing var loc ctc)
(if ctc (if ctc
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen (quote-syntax (contract #,ctc (unbox #,loc) 'cant-happen
(current-unit-blame-stx) (current-contract-region)
#,(id->contract-src-info var)))) #,(id->contract-src-info var))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc))))) (quote-syntax (unbox #,loc)))))
@ -556,7 +554,7 @@
(vector-immutable (cons 'export-name (vector-immutable (cons 'export-name
(vector-immutable export-key ...)) ...) (vector-immutable export-key ...)) ...)
(list (cons 'dept depr) ...) (list (cons 'dept depr) ...)
(syntax-parameterize ([current-unit-blame-stx (lambda (stx) #'(quote (unit name)))]) (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(lambda () (lambda ()
(let ([eloc (box undefined)] ... ...) (let ([eloc (box undefined)] ... ...)
(values (values
@ -693,7 +691,7 @@
(set-var-info-add-ctc! (set-var-info-add-ctc!
v v
(λ (e) (λ (e)
#`(contract #,(cdr (syntax-e ctc)) #,e (current-unit-blame-stx) #`(contract #,(cdr (syntax-e ctc)) #,e (current-contract-region)
'cant-happen #,(id->contract-src-info e))))))) 'cant-happen #,(id->contract-src-info e)))))))
(syntax->list (localify #'evars def-ctx)) (syntax->list (localify #'evars def-ctx))
(syntax->list #'elocs) (syntax->list #'elocs)
@ -1219,7 +1217,7 @@
(lambda (i v c) (lambda (i v c)
(if c (if c
#`(contract #,c (unbox (vector-ref #,ov #,i)) #`(contract #,c (unbox (vector-ref #,ov #,i))
'cant-happen (current-unit-blame-stx) 'cant-happen (current-contract-region)
#,(id->contract-src-info v)) #,(id->contract-src-info v))
#`(unbox (vector-ref #,ov #,i)))) #`(unbox (vector-ref #,ov #,i))))
(iota (length (car os))) (iota (length (car os)))