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

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 ()

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,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)))
                                       

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 ...)
@@ -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