diff --git a/collects/racket/contract/private/helpers.rkt b/collects/racket/contract/private/helpers.rkt index 0c5789113a..84ad6340a0 100644 --- a/collects/racket/contract/private/helpers.rkt +++ b/collects/racket/contract/private/helpers.rkt @@ -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 () diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index 9fb5ebabf1..d08f8c0500 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -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) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 7582513e22..6784f65060 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -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