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

Removed more occurrences of old source info representation.

Browse Source 
svn: r17724
This commit is contained in:
Carl Eastlund 2010-01-18 23:24:34 +00:00
parent 167c9cb1a8
commit 0edd786361
2 changed files with 14 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,16 +16,6 @@
[(_ name x) (a:known-good-contract? #'x) #'x] [(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)])) [(_ name x) #'(coerce-contract name x)]))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the -contract, given an identifier
(define-for-syntax (id->contract-src-info id)
#`(list (make-srcloc #,id
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
(make-set!-transformer (make-set!-transformer
(let ([saved-id-table (make-hasheq)]) (let ([saved-id-table (make-hasheq)])

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

@ -11,6 +11,7 @@
syntax/kerncase syntax/kerncase
(prefix-in a: "private/helpers.ss")) (prefix-in a: "private/helpers.ss"))
scheme/splicing scheme/splicing
unstable/location
"private/arrow.ss" "private/arrow.ss"
"private/base.ss" "private/base.ss"
"private/guts.ss") "private/guts.ss")
@ -22,16 +23,6 @@
[(_ name x) (a:known-good-contract? #'x) #'x] [(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)])) [(_ name x) #'(coerce-contract name x)]))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the -contract, given an identifier
(define-for-syntax (id->contract-src-info id)
#`(list (make-srcloc #,id
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
; ;
@ -322,7 +313,8 @@
#,av-id #,av-id
'(struct name) '(struct name)
'cant-happen 'cant-happen
#,(id->contract-src-info av-id)))))] (quote #,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
@ -391,14 +383,16 @@
arg arg
#,neg-blame-id #,neg-blame-id
#,pos-blame-id #,pos-blame-id
#,(id->contract-src-info id))))] (quote #,id)
(quote-srcloc #,id))))]
[(f arg ...) [(f arg ...)
(quasisyntax/loc stx (quasisyntax/loc stx
((contract #,contract-stx ((contract #,contract-stx
#,id #,id
#,pos-blame-id #,pos-blame-id
#,neg-blame-id #,neg-blame-id
#,(id->contract-src-info id)) (quote #,id)
(quote-srcloc #,id))
arg ...))] arg ...))]
[ident [ident
(identifier? (syntax ident)) (identifier? (syntax ident))
@ -407,7 +401,8 @@
#,id #,id
#,pos-blame-id #,pos-blame-id
#,neg-blame-id #,neg-blame-id
#,(id->contract-src-info id)))])))) (quote #,id)
(quote-srcloc #,id)))]))))
(define-for-syntax (check-and-split-with-contracts args) (define-for-syntax (check-and-split-with-contracts args)
(let loop ([args args] (let loop ([args args]
@ -533,15 +528,13 @@
(syntax-property c 'inferred-name v)) (syntax-property c 'inferred-name v))
free-ctcs free-ctcs
free-vars)] free-vars)]
[(free-src-info ...) (map id->contract-src-info free-vars)]
[(ctc-id ...) (map cid-marker protected)] [(ctc-id ...) (map cid-marker protected)]
[(ctc ...) (map (λ (c v) [(ctc ...) (map (λ (c v)
(syntax-property (add-context c) 'inferred-name v)) (syntax-property (add-context c) 'inferred-name v))
protections protections
protected)] protected)]
[(p ...) protected] [(p ...) protected]
[(marked-p ...) (add-context #`#,protected)] [(marked-p ...) (add-context #`#,protected)])
[(src-info ...) (map (compose id->contract-src-info add-context) protected)])
(with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize (with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)]) ([current-contract-region (λ (stx) #'blame-stx)])
. body))]) . body))])
@ -556,7 +549,8 @@
free-var free-var
blame-id blame-id
'cant-happen 'cant-happen
free-src-info) (quote free-var)
(quote-srcloc free-var))
... ...
(values))) (values)))
(define-syntaxes (free-var-id ...) (define-syntaxes (free-var-id ...)
@ -573,7 +567,8 @@
marked-p marked-p
blame-stx blame-stx
'cant-happen 'cant-happen
src-info) (quote marked-p)
(quote-srcloc marked-p))
... ...
(values))) (values)))
(define-syntaxes (p ...) (define-syntaxes (p ...)