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

Fixing some more inferred-name placements.

Browse Source 
svn: r13806
This commit is contained in:
Stevie Strickland 2009-02-23 22:05:09 +00:00
parent 78dbc22598
commit e727f4fd08
2 changed files with 34 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/mzlib/private/unit-contract.ss
View File

@ -60,15 +60,13 @@ packed with the neg blame.
;; If contract coersion ends up being a large overhead, we can ;; If contract coersion ends up being a large overhead, we can
;; store the result in a local box, then just check the box to ;; store the result in a local box, then just check the box to
;; see if we need to coerce. ;; see if we need to coerce.
(with-syntax ([ctc-stx (syntax-property #`(letrec-syntax #,rename-bindings #,ctc) #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))])
'inferred-name var)])
#`(let ([ctc (coerce-contract 'unit/c ctc-stx)])
((((proj-get ctc) ctc) ((((proj-get ctc) ctc)
#,(if import? neg pos) #,(if import? neg pos)
#,(if import? pos neg) #,(if import? pos neg)
#,src-info #,src-info
#,name) #,name)
#,stx))))]) #,stx)))])
(if ctc (if ctc
#`(cons #`(cons
#,(if import? #,(if import?
@ -79,9 +77,13 @@ packed with the neg blame.
#`(let ([old-v/c ((car #,vref))]) #`(let ([old-v/c ((car #,vref))])
(cons #,(wrap-with-proj (cons #,(wrap-with-proj
ctc ctc
#`(contract #,sig-ctc (car old-v/c) (with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(contract sig-ctc-stx (car old-v/c)
(cdr old-v/c) #,pos (cdr old-v/c) #,pos
#,(id->contract-src-info var))) #,(id->contract-src-info var))))
#,neg)) #,neg))
(wrap-with-proj ctc #`((car #,vref))))]) (wrap-with-proj ctc #`((car #,vref))))])
old-v))) old-v)))
@ -91,9 +93,13 @@ packed with the neg blame.
#,(if sig-ctc #,(if sig-ctc
#`(cons #,(wrap-with-proj #`(cons #,(wrap-with-proj
ctc ctc
#`(contract #,sig-ctc (car v) (with-syntax ([sig-ctc-stx
(syntax-property sig-ctc
'inferred-name
var)])
#`(contract sig-ctc-stx (car v)
(cdr v) #,neg (cdr v) #,neg
#,(id->contract-src-info var))) #,(id->contract-src-info var))))
#,pos) #,pos)
(wrap-with-proj ctc #'v))]) (wrap-with-proj ctc #'v))])
((cdr #,vref) new-v))) ((cdr #,vref) new-v)))

13
collects/mzlib/unit.ss
View File

@ -459,11 +459,12 @@
(define-for-syntax (make-import-unboxing var loc ctc) (define-for-syntax (make-import-unboxing var loc ctc)
(if ctc (if ctc
(with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (let ([v/c ((car #,loc))]) (quote-syntax (let ([v/c ((car #,loc))])
(contract #,ctc (car v/c) (cdr v/c) (contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info var))))) #,(id->contract-src-info var))))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax ((car #,loc)))))) (quote-syntax ((car #,loc))))))
@ -1278,9 +1279,13 @@
(map (λ (tb i v c) (map (λ (tb i v c)
#`(let ([v/c ((car #,tb))]) #`(let ([v/c ((car #,tb))])
#,(if c #,(if c
#`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c) (with-syntax ([ctc-stx
(syntax-property
#`(letrec-syntax #,rename-bindings #,c)
'inferred-name v)])
#`(contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info v)) #,(id->contract-src-info v)))
#'v/c))) #'v/c)))
tbs tbs
(iota (length (car os))) (iota (length (car os)))