Fixed a bug in provide/contract that caused it to lose the source location of the original contract, when .zo files were compiled
This commit is contained in:
Robby Findler
parent
3637073f7f
commit
22f2e18a99
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
"base.rkt"
|
||||
racket/contract/exists
|
||||
"guts.rkt"
|
||||
(for-syntax unstable/dirs)
|
||||
unstable/location
|
||||
unstable/srcloc)
|
||||
|
||||
|
|
@ -80,14 +81,28 @@
|
|||
[external-id external-id]
|
||||
[pos-module-source pos-module-source]
|
||||
[loc-id (identifier-prune-to-source-module id)])
|
||||
(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
|
||||
(quote-srcloc 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
|
||||
id
|
||||
pos-module-source
|
||||
(first-requiring-module (quote-syntax loc-id) (quote-module-path))
|
||||
'external-id
|
||||
#,srcloc-code))))))])
|
||||
(when key
|
||||
(hash-set! saved-id-table key lifted-id))
|
||||
;; Expand to a use of the lifted expression:
|
||||
|
|
@ -696,37 +711,44 @@
|
|||
#`(and (procedure? id)
|
||||
(procedure-arity-includes? id #,(length (syntax->list #'(dom ...)))))]
|
||||
[_ #f])])
|
||||
(with-syntax ([code
|
||||
(syntax-property
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(define pos-module-source (quote-module-path))
|
||||
|
||||
#,@(if no-need-to-check-ctrct?
|
||||
(list)
|
||||
(list #'(define contract-id
|
||||
(let ([ex-id ctrct]) ;; let is here to give the right name.
|
||||
(verify-contract 'provide/contract ex-id)))))
|
||||
(define-syntax id-rename
|
||||
(make-provide/contract-transformer (quote-syntax contract-id)
|
||||
(quote-syntax id)
|
||||
(quote-syntax reflect-external-name)
|
||||
(quote-syntax pos-module-source)))
|
||||
|
||||
#,@(if provide?
|
||||
(list #`(provide (rename-out [id-rename external-name])))
|
||||
null)))
|
||||
'provide/contract-original-contract
|
||||
(vector #'external-name #'ctrct))])
|
||||
|
||||
(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 ([code
|
||||
(syntax-property
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(define pos-module-source (quote-module-path))
|
||||
|
||||
#,@(if no-need-to-check-ctrct?
|
||||
(list)
|
||||
(list #'(define contract-id
|
||||
(let ([ex-id ctrct]) ;; let is here to give the right name.
|
||||
(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)))
|
||||
|
||||
#,@(if provide?
|
||||
(list #`(provide (rename-out [id-rename external-name])))
|
||||
null)))
|
||||
'provide/contract-original-contract
|
||||
(vector #'external-name #'ctrct))])
|
||||
|
||||
(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 ...))))])
|
||||
(signal-dup-syntax-error)
|
||||
|
|
|
|||
|
|
@ -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 ...)
|
||||
|
|
@ -10174,6 +10178,59 @@ so that propagation occurs.
|
|||
(eval 'provide/contract34-x))
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user