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) #'(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)
(make-set!-transformer
(let ([saved-id-table (make-hasheq)])

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

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