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

Fixing some more inferred-name placements.

Browse Source 
svn: r13806

original commit: e727f4fd083b3728d9531486f26d2be42e2bd882
This commit is contained in:
Stevie Strickland 2009-02-23 22:05:09 +00:00
parent 5074111cf3
commit 5d478c9aa1
1 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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)))