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

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

21
collects/mzlib/unit.ss
View File

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