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
add-name-prop
all-but-last
known-good-contract?)
known-good-contract?
update-loc)
(require setup/main-collects
racket/struct-info
(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) ...))
(define (lookup-struct-info stx provide-stx)
(let ([id (syntax-case stx ()

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

@ -11,6 +11,7 @@
"base.rkt"
racket/contract/exists
"guts.rkt"
(for-syntax unstable/dirs)
unstable/location
unstable/srcloc)
@ -80,6 +81,20 @@
[external-id external-id]
[pos-module-source pos-module-source]
[loc-id (identifier-prune-to-source-module id)])
(let ([srcloc-code
(with-syntax ([src
(cond
[(and
(path-string? (syntax-source #'id))
(path->directory-relative-string (syntax-source #'id) #:default #f))
=>
(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
@ -87,7 +102,7 @@
pos-module-source
(first-requiring-module (quote-syntax loc-id) (quote-module-path))
'external-id
(quote-srcloc id))))))])
#,srcloc-code))))))])
(when key
(hash-set! saved-id-table key lifted-id))
;; Expand to a use of the lifted expression:
@ -709,7 +724,14 @@
(verify-contract 'provide/contract ex-id)))))
(define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id)
(a:update-loc
(quote-syntax id)
(vector
#,(syntax-source #'id)
#,(syntax-line #'id)
#,(syntax-column #'id)
#,(syntax-position #'id)
#,(syntax-span #'id)))
(quote-syntax reflect-external-name)
(quote-syntax pos-module-source)))

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

@ -21,6 +21,10 @@
(parameterize ([current-namespace contract-namespace])
(eval x)))
(define (contract-compile x)
(parameterize ([current-namespace contract-namespace])
(compile x)))
(define-syntax (ctest stx)
(syntax-case stx ()
[(_ a ...)
@ -10175,6 +10179,59 @@ so that propagation occurs.
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
#'(begin
(eval '(module pce1-bug scheme/base