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

Fixed a bug in provide/contract that caused it to lose the source location of the original contract, when .zo files were compiled

Browse Source
This commit is contained in:
Robby Findler 2010-08-19 23:12:33 -05:00
parent 3637073f7f
commit 22f2e18a99
3 changed files with 123 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/racket/contract/private/helpers.rkt
View File

@ -6,12 +6,16 @@
nums-up-to nums-up-to
add-name-prop add-name-prop
all-but-last all-but-last
known-good-contract?) known-good-contract?
update-loc)
(require setup/main-collects (require setup/main-collects
racket/struct-info racket/struct-info
(for-template racket/base)) (for-template racket/base))
(define (update-loc stx loc)
(datum->syntax stx (syntax-e stx) loc))
;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) ;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
(define (lookup-struct-info stx provide-stx) (define (lookup-struct-info stx provide-stx)
(let ([id (syntax-case stx () (let ([id (syntax-case stx ()

100
collects/racket/contract/private/provide.rkt
View File

@ -11,6 +11,7 @@
"base.rkt" "base.rkt"
racket/contract/exists racket/contract/exists
"guts.rkt" "guts.rkt"
(for-syntax unstable/dirs)
unstable/location unstable/location
unstable/srcloc) unstable/srcloc)
@ -80,14 +81,28 @@
[external-id external-id] [external-id external-id]
[pos-module-source pos-module-source] [pos-module-source pos-module-source]
[loc-id (identifier-prune-to-source-module id)]) [loc-id (identifier-prune-to-source-module id)])
(syntax-local-introduce (let ([srcloc-code
(syntax-local-lift-expression (with-syntax ([src
#`(contract contract-id (cond
id [(and
pos-module-source (path-string? (syntax-source #'id))
(first-requiring-module (quote-syntax loc-id) (quote-module-path)) (path->directory-relative-string (syntax-source #'id) #:default #f))
'external-id =>
(quote-srcloc id))))))]) (lambda (rel) rel)]
[else (syntax-source #'id)])]
[line (syntax-line #'id)]
[col (syntax-column #'id)]
[pos (syntax-position #'id)]
[span (syntax-span #'id)])
#'(make-srcloc 'src 'line 'col 'pos 'span))])
(syntax-local-introduce
(syntax-local-lift-expression
#`(contract contract-id
id
pos-module-source
(first-requiring-module (quote-syntax loc-id) (quote-module-path))
'external-id
#,srcloc-code))))))])
(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:
@ -696,37 +711,44 @@
#`(and (procedure? id) #`(and (procedure? id)
(procedure-arity-includes? id #,(length (syntax->list #'(dom ...)))))] (procedure-arity-includes? id #,(length (syntax->list #'(dom ...)))))]
[_ #f])]) [_ #f])])
(with-syntax ([code (with-syntax ([code
(syntax-property (syntax-property
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define pos-module-source (quote-module-path)) (define pos-module-source (quote-module-path))
#,@(if no-need-to-check-ctrct? #,@(if no-need-to-check-ctrct?
(list) (list)
(list #'(define contract-id (list #'(define contract-id
(let ([ex-id ctrct]) ;; let is here to give the right name. (let ([ex-id ctrct]) ;; let is here to give the right name.
(verify-contract 'provide/contract ex-id))))) (verify-contract 'provide/contract ex-id)))))
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-provide/contract-transformer (quote-syntax contract-id)
(quote-syntax id) (a:update-loc
(quote-syntax reflect-external-name) (quote-syntax id)
(quote-syntax pos-module-source))) (vector
#,(syntax-source #'id)
#,@(if provide? #,(syntax-line #'id)
(list #`(provide (rename-out [id-rename external-name]))) #,(syntax-column #'id)
null))) #,(syntax-position #'id)
'provide/contract-original-contract #,(syntax-span #'id)))
(vector #'external-name #'ctrct))]) (quote-syntax reflect-external-name)
(quote-syntax pos-module-source)))
(syntax-local-lift-module-end-declaration
#`(begin #,@(if provide?
(unless extra-test (list #`(provide (rename-out [id-rename external-name])))
(contract contract-id id pos-module-source 'ignored 'id null)))
(quote-srcloc id))) 'provide/contract-original-contract
(void))) (vector #'external-name #'ctrct))])
(syntax (code id-rename))))))])) (syntax-local-lift-module-end-declaration
#`(begin
(unless extra-test
(contract contract-id id pos-module-source 'ignored 'id
(quote-srcloc id)))
(void)))
(syntax (code id-rename))))))]))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(signal-dup-syntax-error) (signal-dup-syntax-error)

57
collects/tests/racket/contract-test.rktl
View File

@ -21,6 +21,10 @@
(parameterize ([current-namespace contract-namespace]) (parameterize ([current-namespace contract-namespace])
(eval x))) (eval x)))
(define (contract-compile x)
(parameterize ([current-namespace contract-namespace])
(compile x)))
(define-syntax (ctest stx) (define-syntax (ctest stx)
(syntax-case stx () (syntax-case stx ()
[(_ a ...) [(_ a ...)
@ -10174,6 +10178,59 @@ so that propagation occurs.
(eval 'provide/contract34-x)) (eval 'provide/contract34-x))
10) 10)
;; The following test is designed to test that source locations for contracts
;; survive compilation and being saved to disk (and thus aren't recorded by
;; quoted syntax object constant embedded in the expansion).
(let ()
;; compile/wash : like compile, but reads and writes the data
;; so that source locations (and other things presumably) get dumped.
(define (compile/wash x)
(let-values ([(in out) (make-pipe)])
(thread
(λ () (write (contract-compile x) out)))
(parameterize ([read-accept-compiled #t])
(read in))))
;; drop-var-info : syntax -> syntax
;; strips the lexical content from the syntax object, but preserves the source locations
(define (drop-var-info stx)
(let loop ([stx stx])
(cond
[(syntax? stx)
(datum->syntax #f (loop (syntax-e stx)) stx)]
[(pair? stx)
(cons (loop (car stx))
(loop (cdr stx)))]
[else stx])))
;; WARNING: do not add or remove lines between here-line and the two modules
;; below it, unless you also revise the expected result of the test case.
(define here-line (syntax-line #'here))
(contract-eval
(compile/wash
(drop-var-info
#'(module provide/contract-35/m racket/base
(require racket/contract)
(define (f x) x)
(provide/contract [f (-> integer? integer?)])))))
(contract-eval
(compile/wash
(drop-var-info
#'(module provide/contract-35/n racket/base
(require 'provide/contract-35/m)
(f #f)))))
(test (format "/contract-test.rktl:~a.30: "
(+ here-line 8))
'provide/contract-compiled-source-locs
(with-handlers ((exn:fail? (λ (x)
(let ([m (regexp-match #rx"/contract-test.rktl[^ ]* " (exn-message x))])
(and m (car m))))))
(contract-eval '(require 'provide/contract-35/n)))))
(contract-error-test (contract-error-test
#'(begin #'(begin