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

Replaced uses of quote-srcloc with quote-syntax.

Browse Source 
svn: r17757
This commit is contained in:
Carl Eastlund 2010-01-19 23:25:07 +00:00
parent 87645ebd11
commit 7f58c26709
8 changed files with 24 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drscheme/private/tools.ss
View File

@ -4,7 +4,6 @@
scheme/list scheme/list
scheme/runtime-path scheme/runtime-path
scheme/contract scheme/contract
unstable/location
setup/getinfo setup/getinfo
mred mred
framework framework
@ -328,7 +327,7 @@
'drscheme 'drscheme
tool-name tool-name
(quote name) (quote name)
(quote-srcloc name))])) (quote-syntax name))]))
name name
ctc) ctc)
body)] body)]

7
collects/mzlib/private/contract-define.ss
View File

@ -5,8 +5,7 @@
(require (for-syntax scheme/base (require (for-syntax scheme/base
unstable/srcloc unstable/srcloc
(prefix-in a: scheme/contract/private/helpers)) (prefix-in a: scheme/contract/private/helpers))
(only-in scheme/contract contract) (only-in scheme/contract contract))
unstable/location)
;; First, we have the old define/contract implementation, which ;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract. ;; is still used in mzlib/contract.
@ -30,7 +29,7 @@
(syntax->datum (quote-syntax f)) (syntax->datum (quote-syntax f))
neg-blame-str neg-blame-str
(quote f) (quote f)
(quote-srcloc f)) (quote-syntax f))
arg arg
...))] ...))]
[ident [ident
@ -41,7 +40,7 @@
(syntax->datum (quote-syntax ident)) (syntax->datum (quote-syntax ident))
neg-blame-str neg-blame-str
(quote ident) (quote ident)
(quote-srcloc ident)))]))))) (quote-syntax ident)))])))))
;; (define/contract id contract expr) ;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding ;; defines `id' with `contract'; initially binding

13
collects/mzlib/unit.ss
View File

@ -16,7 +16,6 @@
(require mzlib/etc (require mzlib/etc
scheme/contract/base scheme/contract/base
scheme/stxparam scheme/stxparam
unstable/location
"private/unit-contract.ss" "private/unit-contract.ss"
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.ss" "private/unit-runtime.ss"
@ -483,7 +482,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-srcloc #,var)) (quote #,var) (quote-syntax #,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 +748,7 @@
(current-contract-region) (current-contract-region)
'cant-happen 'cant-happen
(quote #,id) (quote #,id)
(quote-srcloc #,id)) (quote-syntax #,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 +825,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-srcloc #,var))) (quote #,var) (quote-syntax #,var)))
#`(#,vref)) #`(#,vref))
(current-contract-region))) (current-contract-region)))
(if ctc (if ctc
@ -834,7 +833,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-srcloc #,var)))) (quote #,var) (quote-syntax #,var))))
vref))))) vref)))))
(car target-sig) (car target-sig)
(cadddr target-sig))) (cadddr target-sig)))
@ -1305,7 +1304,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-srcloc #,v)))) (quote #,v) (quote-syntax #,v))))
#`(#,tb))) #`(#,tb)))
tbs tbs
(iota (length (car os))) (iota (length (car os)))
@ -1508,7 +1507,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-srcloc name))) (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax 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/base.ss
View File

@ -56,9 +56,9 @@ improve method arity mismatch contract violation error messages?
v))) v)))
(define (check-srcloc! f-name v-name v args) (define (check-srcloc! f-name v-name v args)
(unless (srcloc? v) (unless (source-location? v)
(error f-name (error f-name
"expected ~a to be a srcloc structure, got: ~e; all arguments: ~e" "expected ~a to be a source location, got: ~e; all arguments: ~e"
v-name v args)) v-name v args))
(check-sexp! f-name (check-sexp! f-name
(format "source file of ~a" v-name) (format "source file of ~a" v-name)

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

@ -46,7 +46,7 @@
pos-module-source pos-module-source
(quote-module-path) (quote-module-path)
'id 'id
(quote-srcloc id))))))]) (quote-syntax 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:
@ -662,7 +662,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-srcloc id))) (contract contract-id id pos-module-source 'ignored 'id (quote-syntax id)))
(void))) (void)))
(syntax (code id-rename))))))])) (syntax (code id-rename))))))]))

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

@ -11,7 +11,6 @@
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")
@ -314,7 +313,7 @@
'(struct name) '(struct name)
'cant-happen 'cant-happen
(quote #,av-id) (quote #,av-id)
(quote-srcloc #,av-id)))))] (quote-syntax #,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
@ -346,7 +345,7 @@
guard guard
(current-contract-region) blame-id (current-contract-region) blame-id
(quote maker) (quote maker)
(quote-srcloc maker))))))))))] (quote-syntax 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"
@ -385,7 +384,7 @@
#,neg-blame-id #,neg-blame-id
#,pos-blame-id #,pos-blame-id
(quote #,id) (quote #,id)
(quote-srcloc #,id))))] (quote-syntax #,id))))]
[(f arg ...) [(f arg ...)
(quasisyntax/loc stx (quasisyntax/loc stx
((contract #,contract-stx ((contract #,contract-stx
@ -393,7 +392,7 @@
#,pos-blame-id #,pos-blame-id
#,neg-blame-id #,neg-blame-id
(quote #,id) (quote #,id)
(quote-srcloc #,id)) (quote-syntax #,id))
arg ...))] arg ...))]
[ident [ident
(identifier? (syntax ident)) (identifier? (syntax ident))
@ -403,7 +402,7 @@
#,pos-blame-id #,pos-blame-id
#,neg-blame-id #,neg-blame-id
(quote #,id) (quote #,id)
(quote-srcloc #,id)))])))) (quote-syntax #,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]
@ -551,7 +550,7 @@
blame-id blame-id
'cant-happen 'cant-happen
(quote free-var) (quote free-var)
(quote-srcloc free-var)) (quote-syntax free-var))
... ...
(values))) (values)))
(define-syntaxes (free-var-id ...) (define-syntaxes (free-var-id ...)
@ -569,7 +568,7 @@
blame-stx blame-stx
'cant-happen 'cant-happen
(quote marked-p) (quote marked-p)
(quote-srcloc marked-p)) (quote-syntax marked-p))
... ...
(values))) (values)))
(define-syntaxes (p ...) (define-syntaxes (p ...)

3
collects/syntax/private/stxparse/lib.ss
View File

@ -6,7 +6,6 @@
syntax/kerncase syntax/kerncase
scheme/struct-info scheme/struct-info
unstable/srcloc unstable/srcloc
unstable/location
(for-syntax scheme/base (for-syntax scheme/base
syntax/kerncase syntax/kerncase
"rep.ss" "rep.ss"
@ -115,7 +114,7 @@
(quote #,(source-location->string #'x "<<unknown>>")) (quote #,(source-location->string #'x "<<unknown>>"))
'<this-macro> '<this-macro>
#f #f
(quote-srcloc x)))) (quote-syntax x))))
;; Literal sets ;; Literal sets

5
collects/typed-scheme/utils/require-contract.ss
View File

@ -1,7 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/contract (require scheme/contract
unstable/location
(for-syntax scheme/base (for-syntax scheme/base
syntax/kerncase syntax/kerncase
syntax/parse syntax/parse
@ -46,7 +45,7 @@
'(interface for #,(syntax->datum #'nm)) '(interface for #,(syntax->datum #'nm))
'never-happen 'never-happen
(quote nm) (quote nm)
(quote-srcloc nm))))] (quote-syntax nm))))]
[(require/contract (orig-nm:renameable nm:id) cnt lib) [(require/contract (orig-nm:renameable nm:id) cnt lib)
#`(begin (require (only-in lib [orig-nm orig-nm.r])) #`(begin (require (only-in lib [orig-nm orig-nm.r]))
(define-ignored nm (define-ignored nm
@ -55,4 +54,4 @@
'#,(syntax->datum #'nm) '#,(syntax->datum #'nm)
'never-happen 'never-happen
(quote nm) (quote nm)
(quote-srcloc nm))))])) (quote-syntax nm))))]))