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

Changed contract source locations to perform module resolution in advance.

Browse Source 
svn: r17723
This commit is contained in:
Carl Eastlund 2010-01-18 23:11:12 +00:00
parent f346bc7f1a
commit 167c9cb1a8
2 changed files with 12 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scheme/contract/private/base.ss
View File

@ -11,28 +11,17 @@ improve method arity mismatch contract violation error messages?
(provide contract
recursive-contract
current-module-path
current-contract-region)
(require (for-syntax scheme/base)
scheme/stxparam
unstable/srcloc
unstable/location
"guts.ss"
"helpers.ss")
(define-syntax-rule (current-module-path)
(variable-reference->module-path (#%variable-reference)))
(define (variable-reference->module-path var)
(let* ([path (variable-reference->resolved-module-path var)]
[name (and path (resolved-module-path-name path))])
(cond
[(path? name) `(file ,(path->string name))]
[(symbol? name) `(quote ,name)]
[else 'top-level])))
(define-syntax-parameter current-contract-region
(λ (stx) #'(current-module-path)))
(λ (stx) #'(quote-module-path)))
(define-syntax (contract stx)
(syntax-case stx ()
@ -68,14 +57,14 @@ improve method arity mismatch contract violation error messages?
(check-sexp! 'contract "positive blame" pos)
(check-sexp! 'contract "negative blame" neg)
(check-sexp! 'contract "value name" name)
(check-syntax/srcloc! 'contract "source location" loc)
(check-srcloc! 'contract "source location" loc)
(((contract-projection c)
(make-blame loc name (contract-name c) pos neg #f))
v)))
(define (check-syntax/srcloc! f-name v-name v)
(unless (or (syntax? v) (srcloc? v) (not v))
(error f-name "expected ~a to be syntax or srcloc or #f; got: ~e" v-name v))
(define (check-srcloc! f-name v-name v)
(unless (srcloc? v)
(error f-name "expected ~a to be a srcloc structure; got: ~e" v-name v))
(check-sexp! f-name
(format "source file of ~a" v-name)
(source-location-source v)))

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

@ -8,7 +8,8 @@
"arrow.ss"
"base.ss"
scheme/contract/exists
"guts.ss")
"guts.ss"
unstable/location)
(define-syntax (verify-contract stx)
(syntax-case stx ()
@ -52,9 +53,9 @@
#`(contract contract-id
id
pos-module-source
(current-module-path)
(quote-module-path)
'id
(quote-syntax id))))))])
(quote-srcloc id))))))])
(when key
(hash-set! saved-id-table key lifted-id))
;; Expand to a use of the lifted expression:
@ -653,7 +654,7 @@
(with-syntax ([code
(quasisyntax/loc stx
(begin
(define pos-module-source (current-module-path))
(define pos-module-source (quote-module-path))
#,@(if no-need-to-check-ctrct?
(list)
@ -670,7 +671,7 @@
(syntax-local-lift-module-end-declaration
#`(begin
(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)))
(syntax (code id-rename))))))]))