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

Try to set up the inferred-name property appropriately.

Browse Source 
svn: r13805
This commit is contained in:
Stevie Strickland 2009-02-23 21:46:22 +00:00
parent a303b781cc
commit 78dbc22598
3 changed files with 41 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -60,13 +60,15 @@ 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.
#`(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)))])
(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))))])
(if ctc
#`(cons
#,(if import?

14
collects/mzlib/private/unit-utils.ss
View File

@ -43,13 +43,13 @@
(for/list ([i (in-list (map car (car sig)))]
[c (in-list (cadddr sig))])
(let ([add-ctc
(λ (v stx)
(if c
#`(let ([v/c ((car #,stx))])
(contract (let ([#,v #,c]) #,v)
(car v/c) (cdr v/c) #,blame
#,(id->contract-src-info v)))
#`((car #,stx))))])
(λ (v stx)
(if c
(with-syntax ([c-stx (syntax-property c 'inferred-name v)])
#`(let ([v/c ((car #,stx))])
(contract c-stx (car v/c) (cdr v/c) #,blame
#,(id->contract-src-info v))))
#`((car #,stx))))])
#`[#,i
(make-set!-transformer
(λ (stx)

49
collects/mzlib/unit.ss
View File

@ -790,30 +790,31 @@
[rename-bindings (get-member-bindings def-table
(bound-identifier-mapping-get sig-table var)
#'(current-contract-region))])
(if (or target-ctc ctc)
#`(cons
(λ ()
(let ([old-v #,(if ctc
#`(let ([old-v/c ((car #,vref))])
(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
(car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))
#`((car #,vref)))])
#,(if target-ctc
#'(cons old-v (current-contract-region))
#'old-v)))
(λ (v) (let ([new-v #,(if ctc
#`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var)
(car v)
(current-contract-region)
(cdr v)
#,(id->contract-src-info var))
#'v)])
#,(if target-ctc
#`((cdr #,vref) (cons new-v (current-contract-region)))
#`((cdr #,vref) new-v)))))
vref)))
(with-syntax ([ctc-stx (if ctc (syntax-property
#`(letrec-syntax #,rename-bindings #,ctc)
'inferred-name var)
ctc)])
(if (or target-ctc ctc)
#`(cons
(λ ()
(let ([old-v #,(if ctc
#`(let ([old-v/c ((car #,vref))])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))
#`((car #,vref)))])
#,(if target-ctc
#'(cons old-v (current-contract-region))
#'old-v)))
(λ (v) (let ([new-v #,(if ctc
#`(contract ctc-stx (car v)
(current-contract-region) (cdr v)
#,(id->contract-src-info var))
#'v)])
#,(if target-ctc
#`((cdr #,vref) (cons new-v (current-contract-region)))
#`((cdr #,vref) new-v)))))
vref))))
(car target-sig)
(cadddr target-sig)))
target-import-sigs))