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 (provide contract
recursive-contract recursive-contract
current-module-path
current-contract-region) current-contract-region)
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
scheme/stxparam scheme/stxparam
unstable/srcloc unstable/srcloc
unstable/location
"guts.ss" "guts.ss"
"helpers.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 (define-syntax-parameter current-contract-region
(λ (stx) #'(current-module-path))) (λ (stx) #'(quote-module-path)))
(define-syntax (contract stx) (define-syntax (contract stx)
(syntax-case 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 "positive blame" pos)
(check-sexp! 'contract "negative blame" neg) (check-sexp! 'contract "negative blame" neg)
(check-sexp! 'contract "value name" name) (check-sexp! 'contract "value name" name)
(check-syntax/srcloc! 'contract "source location" loc) (check-srcloc! 'contract "source location" loc)
(((contract-projection c) (((contract-projection c)
(make-blame loc name (contract-name c) pos neg #f)) (make-blame loc name (contract-name c) pos neg #f))
v))) v)))
(define (check-syntax/srcloc! f-name v-name v) (define (check-srcloc! f-name v-name v)
(unless (or (syntax? v) (srcloc? v) (not v)) (unless (srcloc? v)
(error f-name "expected ~a to be syntax or srcloc or #f; got: ~e" v-name v)) (error f-name "expected ~a to be a srcloc structure; got: ~e" v-name v))
(check-sexp! f-name (check-sexp! f-name
(format "source file of ~a" v-name) (format "source file of ~a" v-name)
(source-location-source v))) (source-location-source v)))

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

@ -8,7 +8,8 @@
"arrow.ss" "arrow.ss"
"base.ss" "base.ss"
scheme/contract/exists scheme/contract/exists
"guts.ss") "guts.ss"
unstable/location)
(define-syntax (verify-contract stx) (define-syntax (verify-contract stx)
(syntax-case stx () (syntax-case stx ()
@ -52,9 +53,9 @@
#`(contract contract-id #`(contract contract-id
id id
pos-module-source pos-module-source
(current-module-path) (quote-module-path)
'id '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:
@ -653,7 +654,7 @@
(with-syntax ([code (with-syntax ([code
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define pos-module-source (current-module-path)) (define pos-module-source (quote-module-path))
#,@(if no-need-to-check-ctrct? #,@(if no-need-to-check-ctrct?
(list) (list)
@ -670,7 +671,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))))))]))