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

Maintain source locations appropriately.

Browse Source 
svn: r18422
This commit is contained in:
Stevie Strickland 2010-03-01 23:47:31 +00:00
parent 65b12a2af3
commit f37f81cdb2
3 changed files with 18 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/mzlib/unit.ss
View File

@ -9,6 +9,7 @@
syntax/parse syntax/parse
syntax/struct syntax/struct
syntax/stx syntax/stx
unstable/location
"private/unit-contract-syntax.ss" "private/unit-contract-syntax.ss"
"private/unit-compiletime.ss" "private/unit-compiletime.ss"
"private/unit-syntax.ss")) "private/unit-syntax.ss"))
@ -483,7 +484,7 @@
(if (pair? v/c) (if (pair? v/c)
(contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
(quote #,var) (quote-syntax #,var)) (quote #,var) (quote-srcloc #,var))
(error 'unit "contracted import ~a used before definition" (error 'unit "contracted import ~a used before definition"
(quote #,(syntax->datum var)))))))) (quote #,(syntax->datum var))))))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
@ -749,7 +750,7 @@
(current-contract-region) (current-contract-region)
'cant-happen 'cant-happen
(quote #,id) (quote #,id)
(quote-syntax #,id)) (quote-srcloc #,id))
(set-box! #,export-loc (set-box! #,export-loc
(cons #,tmp (current-contract-region))))) (cons #,tmp (current-contract-region)))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
@ -826,7 +827,7 @@
#`(let ([old-v/c (#,vref)]) #`(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c) (contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region) (cdr old-v/c) (current-contract-region)
(quote #,var) (quote-syntax #,var))) (quote #,var) (quote-srcloc #,var)))
#`(#,vref)) #`(#,vref))
(current-contract-region))) (current-contract-region)))
(if ctc (if ctc
@ -834,7 +835,7 @@
(let ([old-v/c (#,vref)]) (let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c) (contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region) (cdr old-v/c) (current-contract-region)
(quote #,var) (quote-syntax #,var)))) (quote #,var) (quote-srcloc #,var))))
vref))))) vref)))))
(car target-sig) (car target-sig)
(cadddr target-sig))) (cadddr target-sig)))
@ -1305,7 +1306,7 @@
#`(let ([v/c (#,tb)]) #`(let ([v/c (#,tb)])
(contract ctc-stx (car v/c) (cdr v/c) (contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
(quote #,v) (quote-syntax #,v)))) (quote #,v) (quote-srcloc #,v))))
#`(#,tb))) #`(#,tb)))
tbs tbs
(iota (length (car os))) (iota (length (car os)))
@ -1508,7 +1509,7 @@
(export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (export (export-tagged-sig-id [e.x e.c] ...) ...))))])
(values (values
(syntax/loc stx (syntax/loc stx
(contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name)))
isigs esigs deps))))] isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body) [(ic:import-clause/contract ec:export-clause/contract . body)
(build-unit/contract (build-unit/contract

4
collects/scheme/contract/private/provide.ss
View File

@ -47,7 +47,7 @@
pos-module-source pos-module-source
(quote-module-path) (quote-module-path)
'external-id 'external-id
(quote-syntax id))))))]) (quote-srcloc id))))))])
(when key (when key
(hash-set! saved-id-table key lifted-id)) (hash-set! saved-id-table key lifted-id))
;; Expand to a use of the lifted expression: ;; Expand to a use of the lifted expression:
@ -664,7 +664,7 @@
(syntax-local-lift-module-end-declaration (syntax-local-lift-module-end-declaration
#`(begin #`(begin
(unless extra-test (unless extra-test
(contract contract-id id pos-module-source 'ignored 'id (quote-syntax id))) (contract contract-id id pos-module-source 'ignored 'id (quote-srcloc id)))
(void))) (void)))
(syntax (code id-rename))))))])) (syntax (code id-rename))))))]))

17
collects/scheme/contract/regions.ss
View File

@ -14,6 +14,7 @@
(prefix-in a: "private/helpers.ss")) (prefix-in a: "private/helpers.ss"))
scheme/splicing scheme/splicing
scheme/stxparam scheme/stxparam
unstable/location
"private/arrow.ss" "private/arrow.ss"
"private/base.ss" "private/base.ss"
"private/guts.ss") "private/guts.ss")
@ -311,7 +312,7 @@
'(struct name) '(struct name)
'cant-happen 'cant-happen
(quote #,av-id) (quote #,av-id)
(quote-syntax #,av-id)))))] (quote-srcloc #,av-id)))))]
;; a list of variables, one for each super field ;; a list of variables, one for each super field
[(super-fields ...) (generate-temporaries super-fields)] [(super-fields ...) (generate-temporaries super-fields)]
;; the contract for a super field is any/c becuase the ;; the contract for a super field is any/c becuase the
@ -343,7 +344,7 @@
guard guard
(current-contract-region) blame-id (current-contract-region) blame-id
(quote maker) (quote maker)
(quote-syntax maker))))))))))] (quote-srcloc maker))))))))))]
[(_ name . bad-fields) [(_ name . bad-fields)
(identifier? #'name) (identifier? #'name)
(syntax-error "expected a list of field name/contract pairs" (syntax-error "expected a list of field name/contract pairs"
@ -380,15 +381,15 @@
(syntax-case stx (set!) (syntax-case stx (set!)
[(set! i arg) [(set! i arg)
(quasisyntax/loc stx (quasisyntax/loc stx
(set! id (contract ctc arg neg pos (quote id) (quote-syntax id))))] (set! id (contract ctc arg neg pos (quote id) (quote-srcloc id))))]
[(f arg ...) [(f arg ...)
(quasisyntax/loc stx (quasisyntax/loc stx
((contract ctc id pos neg (quote id) (quote-syntax id)) ((contract ctc id pos neg (quote id) (quote-srcloc id))
arg ...))] arg ...))]
[ident [ident
(identifier? (syntax ident)) (identifier? (syntax ident))
(quasisyntax/loc stx (quasisyntax/loc stx
(contract ctc id pos neg (quote id) (quote-syntax id)))]))))) (contract ctc id pos neg (quote id) (quote-srcloc id)))])))))
(define-syntax (with-contract-helper stx) (define-syntax (with-contract-helper stx)
(syntax-case stx () (syntax-case stx ()
@ -511,7 +512,7 @@
blame-id blame-id
'cant-happen 'cant-happen
(quote free-var) (quote free-var)
(quote-syntax free-var)) (quote-srcloc free-var))
... ...
(values))) (values)))
(define-syntaxes (free-var-id ...) (define-syntaxes (free-var-id ...)
@ -576,7 +577,7 @@
blame-id blame-id
'cant-happen 'cant-happen
(quote free-var) (quote free-var)
(quote-syntax free-var)) (quote-srcloc free-var))
... ...
(values))) (values)))
(define-syntaxes (free-var-id ...) (define-syntaxes (free-var-id ...)
@ -594,7 +595,7 @@
blame-stx blame-stx
'cant-happen 'cant-happen
(quote marked-p) (quote marked-p)
(quote-syntax marked-p)) (quote-srcloc marked-p))
... ...
(values))) (values)))
(define-syntaxes (p ...) (define-syntaxes (p ...)