Merge pull request #177 from mflatt/filepos

add file-position-object and eager source-line counting
original commit: 75107ee73f3619e1afcf043822cf5fbf675522e3

LOG

@@ -543,3 +543,14 @@
     objects.stex, system.stex
 - fix (define-values () ....) to expand to a definition
     syntax.ss, 3.ms
+- added optional line and column components to a source object, a
+  locate-source-object-source function that uses the new components,
+  a current-locate-source-object-source parameter to control looking up
+  line and column information, a current-make-source-object parameter to
+  control loation recording, an optional use-cache argument to
+  locate-source, and a 'source-object message for code and continuation
+  inspectors
+    read.ss, syntax.ss, 7.ss, compile.ss, cpnanopass.ss, exceptions.ss,
+    inspect.ss, primdata.ss, prims.ss, print.ss, cmacros.ss, types.ss,
+    mat.ss, 8.ms, root-experr*,
+    syntax.stex, debug.stex, system.stex, release_notes.stex

c/gc.c

@@ -1487,6 +1487,7 @@ static void sweep_thread(p) ptr p; {
     relocate(&CURRENTERROR(tc))
     /* immediate BLOCKCOUNTER */
     relocate(&SFD(tc))
+    relocate(&CURRENTMSO(tc))
     relocate(&TARGETMACHINE(tc))
     relocate(&FXLENGTHBV(tc))
     relocate(&FXFIRSTBITSETBV(tc))

csug/debug.stex

@@ -1181,6 +1181,11 @@ to the continuation (representing the source for the application that
 resulted in the formation of the continuation)
 or \scheme{#f} if no source information is attached.
 
+\insmsg{continuation}{\scheme{'source-object}}
+returns an inspector object containing the source object for the
+procedure application that resulted in the formation of the continuation
+or \scheme{#f} if no source object is attached.
+
 \insmsg{continuation}{\scheme{'source-path}}
 attempts to find the pathname of the file containing the source for
 the procedure application that resulted in the formation of the continuation.
@@ -1216,6 +1221,10 @@ procedure.
 returns an inspector object containing the source information attached
 to the code object or \scheme{#f} if no source information is attached.
 
+\insmsg{continuation}{\scheme{'source-object}}
+returns an inspector object containing the source object for the
+code object or \scheme{#f} if no source object is attached.
+
 \insmsg{code}{\scheme{'source-path}}
 attempts to find the pathname of the file containing the source for
 the lambda expression that produced the code object.

csug/syntax.stex

@@ -1559,17 +1559,20 @@ locations to be profiled.
 
 \index{source objects}%
 Source objects are also values of a type distinct from other types and
-also have three components: a \emph{source-file descriptor} (sfd),
+also have three or five components: a \emph{source-file descriptor} (sfd),
-a beginning file position (bfp), and an ending file position (efp).
+a beginning file position (bfp), an ending file position (efp),
-The sfd identifies the file from which an expression is read and the
+an optional beginning line, and an optional beginning
-bfp identify the range of character positions occupied by the object
+column. The sfd identifies the file from which an expression is read and the
+bfp and efp identify the range of character positions occupied by the object
 in the file, with the bfp being inclusive and the efp being exclusive.
+The line and column are either both numbers or both not present.
 A source object can be created via
 \index{\scheme{make-source-object}}\scheme{make-source-object}, which
-takes three arguments corresponding to these components.
+takes either three or five arguments corresponding to these components.
 The first argument must be a source-file descriptor, the second and
-third must be nonnegative exact integers, and the second must not be
+third must be nonnegative exact integers, the second must not be
-greater than the third.
+greater than the third, and the fourth and fifth (if provided) must
+be positive exact integers.
 
 \index{source-file descriptors}%
 Source-file descriptors are also values of a type distinct
@@ -1605,10 +1608,13 @@ and described in more detail later in this section.
 (annotation-stripped \var{annotation}) ;-> \var{obj}
 
 (make-source-object \var{sfd} \var{uint} \var{uint}) ;-> \var{source-object}
+(make-source-object \var{sfd} \var{uint} \var{uint} \var{uint} \var{uint}) ;-> \var{source-object}
 (source-object? \var{obj}) ;-> \var{boolean}
+(source-object-sfd \var{source-object}) ;-> \var{sfd}
 (source-object-bfp \var{source-object}) ;-> \var{uint}
 (source-object-efp \var{source-object}) ;-> \var{uint}
-(source-object-sfd \var{source-object}) ;-> \var{sfd}
+(source-object-line \var{source-object}) ;-> \var{uint} or #f
+(source-object-column \var{source-object}) ;-> \var{uint} or #f
 
 (make-source-file-descriptor \var{string} \var{binary-input-port}) ;-> \var{sfd}
 (make-source-file-descriptor \var{string} \var{binary-input-port} \var{reset?}) ;-> \var{sfd}
@@ -1734,6 +1740,7 @@ marked \scheme{profile} are used for profiling.
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{make-source-object}{\categoryprocedure}{(make-source-object \var{sfd} \var{bfp} \var{efp})}
+\formdef{make-source-object}{\categoryprocedure}{(make-source-object \var{sfd} \var{bfp} \var{efp} \var{line} \var{column})}
 \returns a source-object
 \listlibraries
 \endentryheader
@@ -1741,6 +1748,7 @@ marked \scheme{profile} are used for profiling.
 \var{sfd} must be a source-file descriptor.
 \var{bfp} and \var{efp} must be exact nonnegative integers, and \var{bfp}
 should not be greater than \var{efp}.
+\var{line} and \var{column} must be exact positive integers.
 
 %----------------------------------------------------------------------------
 \entryheader
@@ -1749,6 +1757,13 @@ should not be greater than \var{efp}.
 \listlibraries
 \endentryheader
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-object-sfd}{\categoryprocedure}{(source-object-sfd \var{source-object})}
+\returns the sfd component of \var{source-object}
+\listlibraries
+\endentryheader
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{source-object-bfp}{\categoryprocedure}{(source-object-bfp \var{source-object})}
@@ -1765,11 +1780,34 @@ should not be greater than \var{efp}.
 
 %----------------------------------------------------------------------------
 \entryheader
-\formdef{source-object-sfd}{\categoryprocedure}{(source-object-sfd \var{source-object})}
+\formdef{source-object-line}{\categoryprocedure}{(source-object-line \var{source-object})}
-\returns the sfd component of \var{source-object}
+\returns the line component of \var{source-object} if present, otherwise \scheme{#f}
 \listlibraries
 \endentryheader
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{source-object-column}{\categoryprocedure}{(source-object-column \var{source-object})}
+\returns the column component of \var{source-object} if present, otherwise \scheme{#f}
+\listlibraries
+\endentryheader
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{current-make-source-object}{\categorythreadparameter}{current-make-source-object}
+\listlibraries
+\endentryheader
+
+\noindent
+\scheme{current-make-source-object} is used by the reader to construct
+a source object for an annotation. \scheme{current-make-source-object}
+is initially bound to \scheme{make-source-object}, and the reader always
+calls the function bound to the paramater with three arguments.
+
+Adjust this parameter to, for example, eagerly convert a position integer
+to a file-position object, instead of delaying the conversion to
+\scheme{locate-source}.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{make-source-file-descriptor}{\categoryprocedure}{(make-source-file-descriptor \var{string} \var{binary-input-port})}
@@ -1883,6 +1921,7 @@ checksum recorded in \var{sfd}.
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{locate-source}{\categoryprocedure}{(locate-source \var{sfd} \var{pos})}
+\formdef{locate-source}{\categoryprocedure}{(locate-source \var{sfd} \var{pos} \var{use-cache?})}
 \returns see below
 \listlibraries
 \endentryheader
@@ -1890,7 +1929,9 @@ checksum recorded in \var{sfd}.
 \var{sfd} must be a source-file descriptor, and \var{pos} must be an
 exact nonnegative integer.
 
-This procedure attempts to locate and open the source file identified
+This procedure either uses cached information from a previous
+request for \var{sfd} (only when \var{use-cache?} is provided as true)
+or attempts to locate and open the source file identified
 by \var{sfd}.
 If successful, it returns three values: a string \var{path}, an exact
 nonnegative integer \var{line}, and an exact nonnegative integer \var{char}
@@ -1901,3 +1942,42 @@ If unsuccessful, it returns zero values.
 It can fail even if a file with the correct name exists in one of
 the source directories when the file's checksum does not match the
 checksum recorded in \var{sfd}.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{locate-source-object-source}{\categoryprocedure}{(locate-source-object-source \var{source-object} \var{get-start?} \var{use-cache?})}
+\returns see below
+\listlibraries
+\endentryheader
+
+This procedure is similar to \scheme{locate-source}, but instead of
+taking an sfd and a position, it takes a source object plus a request
+for either the start or end location.
+
+If \var{get-start?} is true and \var{source-object} has a line and column,
+\scheme{locate-source-object-source} returns the path in
+\var{source-objects}'s sfd, \var{source-object}'s line, and
+\var{source-objects}'s column.
+
+If \var{source-object} has no line and column, then
+\scheme{locate-source-object-source} calls \scheme{locate-source} on
+\var{source-object}'s sfd, either \var{source-object}'s bfp or efp
+depending on \var{get-start?}, and \var{use-cache?}.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{current-locate-source-object-source}{\categorythreadparameter}{current-locate-source-object-source}
+\listlibraries
+\endentryheader
+
+\noindent
+
+\scheme{current-locate-source-object-source} determines the
+source-location lookup function that is used by the system to report
+errors based on source objects. This parameter is initially bound to
+\scheme{locate-source-object-object}.
+
+Adjust this parameter to control the way that source locations are
+extracted from source objects, possibly using recorded information,
+caches, and the filesystem in a way different from
+\scheme{locate-source-object-object}.

mats/8.ms

@@ -10726,18 +10726,33 @@
     (make-source-object sfd -7 -3))
   (error? ; bfp -7 is not between 0 and efp 3
     (make-source-object sfd -7 3))
+  (error? ; bfp -7 is not between 0 and efp 3
+    (make-source-object sfd -7 3 2 1))
+  (error? ; one is not an exact integer
+    (make-source-object sfd 1 2 'one 1))
+  (error? ; one is not an exact integer
+    (make-source-object sfd 1 2 1 'one))
+  (error? ; zero is not an exact positive integer
+    (make-source-object sfd 1 2 0 1))
+  (error? ; zero is not an exact positive integer
+    (make-source-object sfd 1 2 1 0))
+  (error? ; bfp 3 is not between 0 and efp 2
+    (make-source-object sfd 3 2 1 1))
   (begin
     (define source (make-source-object sfd 2 3))
+    (define source-at-line-two (make-source-object sfd 3 5 2 1))
     #t)
   (error? ; source is not a source object
     (make-annotation #f 'source #f))
   (begin
     (define a (make-annotation '(if 3) source '(if I were a rich man)))
+    (define a-at-line-two (make-annotation '(if 3) source-at-line-two '(if I were a rich man)))
     (define x (datum->syntax #'* a))
     #t)
   (source-file-descriptor? sfd)
   (not (source-file-descriptor? source))
   (source-object? source)
+  (source-object? source-at-line-two)
   (not (source-object? sfd))
   (not (source-object? a))
   (annotation? a)
@@ -10752,6 +10767,10 @@
     (source-object-bfp a))
   (error? ; 3 is not a source object
     (source-object-efp 3))
+  (error? ; 3 is not a source object
+    (source-object-line 3))
+  (error? ; 3 is not a source object
+    (source-object-column 3))
   (error? ; 3 is not an annotation
     (annotation-expression 3))
   (error? ; #<source> is not an annotation
@@ -10777,6 +10796,13 @@
   (eq? (source-object-sfd source) sfd)
   (eq? (source-object-bfp source) 2)
   (eq? (source-object-efp source) 3)
+  (eq? (source-object-line source) #f)
+  (eq? (source-object-column source) #f)
+  (eq? (source-object-sfd source) sfd)
+  (eq? (source-object-bfp source-at-line-two) 3)
+  (eq? (source-object-efp source-at-line-two) 5)
+  (eq? (source-object-line source-at-line-two) 2)
+  (eq? (source-object-column source-at-line-two) 1)
   (equal? (annotation-expression a) '(if 3))
   (eq? (annotation-source a) source)
   (equal? (annotation-stripped a) '(if I were a rich man))
@@ -10802,12 +10828,20 @@
   (not (syntax->annotation #f))
   (error? ; invalid syntax (if I were a rich man) at char 2 of foo
     (expand a))
+  (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo
+    (expand a-at-line-two))
   (error? ; invalid syntax (if I were a rich man) at char 2 of foo
     (eval a))
+  (error? ; invalid syntax (if I were a rich man) at char 2, char 1 of foo
+    (eval a-at-line-two))
   (error? ; invalid syntax (if I were a rich man) at char 2 of foo
     (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* a))) foo)))
+  (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* a-at-line-two))) foo)))
   (error? ; invalid syntax (if I were a rich man) at char 2 of foo
     (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug profile))))) foo)))
+  (error? ; invalid syntax (if I were a rich man) at line 2, char 1 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source-at-line-two '(if I were a rich man) (annotation-options debug profile))))) foo)))
   (error? ; invalid syntax (if I were a rich man) at char 2 of foo
     (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options debug))))) foo)))
   (error? ; invalid syntax (if I were a rich man)
@@ -10816,6 +10850,8 @@
     (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* (make-annotation '(if 3) source '(if I were a rich man) (annotation-options))))) foo)))
   (error? ; invalid argument count in call (f) at char 2 of foo
     (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options debug profile)))))) foo)))
+  (error? ; invalid argument count in call (f) at line 2, char 1 of foo
+    (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source-at-line-two '(f) (annotation-options debug profile)))))) foo)))
   (error? ; invalid argument count in call (f) at char 2 of foo
     (eval '(let () (define-syntax foo (lambda (z) (datum->syntax #'* `(let ([f (lambda (x) x)]) ,(make-annotation '(f) source '(f) (annotation-options debug)))))) foo)))
   (error? ; invalid argument count in call (f)
@@ -10939,6 +10975,180 @@
                        (call-with-values (lambda () (locate-source (source-object-sfd source) (source-object-efp source))) vector)))])
           (load "testfile.ss"))))
     '(#("testfile.ss" 2 12) . #("testfile.ss" 2 13)))
+
+  (error? ; not a source object
+   (locate-source-object-source "spam" #t #t))
+  (error?
+   (current-locate-source-object-source 7))
+  (error?
+   (current-locate-source-object-source "string"))
+  (error? ; not a source object
+   ((current-locate-source-object-source) "spam" #t #t))
+  (error? ; invalid syntax (if I were a rich man) at line 200, char 17 of foo
+   (parameterize ([current-locate-source-object-source
+                   (lambda (src start? cache?)
+                     (values (source-file-descriptor-path (source-object-sfd src)) 200 17))])
+     (expand a)))
+ )
+
+(mat annotations-via-recorded-lines
+  (error?
+   (current-make-source-object 7))
+  (error?
+   (current-make-source-object "string"))
+  (begin
+    (define sfd-with-lines
+      (let ((op (open-output-file "testfile.ss" 'replace)))
+        (display "apple\n  banana\ncoconut" op)
+        (close-port op)
+        (let* ([ip (open-file-input-port "testfile.ss")]
+               [sfd (make-source-file-descriptor "testfile.ss" ip)])
+          (close-port ip)
+          sfd)))
+    (define input-string-with-lines "Apple\n  Banana\nCoconut\nMore")
+    (define input-port-with-lines (open-string-input-port input-string-with-lines))
+    (define input-port-with-line-pos 0)
+    (define (make-make-source-object/get-lines expected-sfd)
+      (lambda (sfd bfp efp)
+        (if (eq? sfd expected-sfd)
+            ;; Gather line and column now:
+            (let-values ([(path line col) (locate-source sfd bfp #t)])
+              (make-source-object sfd bfp efp line col))
+            (error 'recording-make-source-object "reading some other file?"))))
+    (define (read-with-lines)
+      (parameterize ([current-make-source-object (make-make-source-object/get-lines sfd-with-lines)])
+        (let-values ([(v pos) (get-datum/annotations input-port-with-lines sfd-with-lines input-port-with-line-pos)])
+          (set! input-port-with-line-pos pos)
+          v)))
+    #t)
+  (begin
+    (define line-one (read-with-lines))
+    (annotation? line-one))
+  (equal? (annotation-stripped line-one) 'Apple)
+  (equal? (source-object-bfp (annotation-source line-one)) 0)
+  (equal? (source-object-line (annotation-source line-one)) 1)
+  (equal? (source-object-column (annotation-source line-one)) 1)
+  (begin
+    (define line-two (read-with-lines))
+    (annotation? line-two))
+  (equal? (source-object-bfp (annotation-source line-two)) 8)
+  (equal? (source-object-line (annotation-source line-two)) 2)
+  (equal? (source-object-column (annotation-source line-two)) 3)
+  (begin
+    (define line-three (read-with-lines))
+    (annotation? line-three))
+  (equal? (source-object-bfp (annotation-source line-three)) 15)
+  (equal? (source-object-line (annotation-source line-three)) 3)
+  (equal? (source-object-column (annotation-source line-three)) 1)
+  (annotation? (read-with-lines)) ; 'More
+  (eof-object? (read-with-lines))
+
+  ;; Make sure lines are calculated right with input that is longer than
+  ;; the file buffer size:
+  (begin
+    (define input-string-with-lines (string-append
+                                     "\""
+                                     (make-string (* 2 (file-buffer-size)) #\a)
+                                     "\""
+                                     "\nend"))
+    
+    (define input-port-with-lines (open-string-input-port input-string-with-lines))
+    (define sfd-with-lines
+      (let ((op (open-output-file "testfile.ss" 'replace)))
+        (display input-string-with-lines op)
+        (close-port op)
+        (let* ([ip (open-file-input-port "testfile.ss")]
+               [sfd (make-source-file-descriptor "testfile.ss" ip)])
+          (close-port ip)
+          sfd)))
+    (define input-port-with-line-pos 0)
+    (define (read-with-lines)
+      (parameterize ([current-make-source-object (make-make-source-object/get-lines sfd-with-lines)])
+        (let-values ([(v pos) (get-datum/annotations input-port-with-lines sfd-with-lines input-port-with-line-pos)])
+          (set! input-port-with-line-pos pos)
+          v)))
+    (define line-one (read-with-lines))
+    (annotation? line-one))
+  (string? (annotation-stripped line-one))
+  (begin
+    (define line-two (read-with-lines))
+    (annotation? line-two))
+  (equal? (source-object-line (annotation-source line-two)) 2)
+  (equal? (source-object-column (annotation-source line-two)) 1)
+  )
+
+(mat locate-source-caching
+  (begin
+   (define (make-expr n)
+     `(let ()
+        ,@(let loop ([i n])
+            (if (zero? i)
+                '(#t)
+                (cons
+                 `(let-values ([(x y z) (values 1 2 3)]) x)
+                 (loop (sub1 i)))))))
+
+   (define (time-expr n)
+     (with-output-to-file "testfile.ss"
+       (lambda ()
+         (pretty-print (make-expr n)))
+       'truncate)
+     (let ([start (current-time)])
+       (load "testfile.ss")
+       (let ([delta (time-difference (current-time) start)])
+         (+ (time-second delta)
+            (* 1e-9 (time-nanosecond delta))))))
+
+   (let loop ([tries 3])
+     (when (zero? tries)
+       (error 'source-cache-test "loading lots of `let-values` forms seems to take too long"))
+     (or (> (* 20 (time-expr 100))
+            (time-expr 1000))
+         (loop (sub1 tries)))))
+
+  (begin
+    (define sfd-to-cache
+      (let ((op (open-output-file "testfile.ss" 'replace)))
+        (display "apple\n  banana\ncoconut" op)
+        (close-port op)
+        (let* ([ip (open-file-input-port "testfile.ss")]
+               [sfd (make-source-file-descriptor "testfile.ss" ip)])
+          (close-port ip)
+          sfd)))
+
+    (equal? (call-with-values
+             (lambda () (locate-source sfd-to-cache 8 #t))
+             (case-lambda
+              [(name line col) (list line col)]))
+            '(2 3)))
+
+  (begin
+    (let ((op (open-output-file "testfile.ss" 'replace)))
+      (display "1\n2\n3\n4\n5\n6789" op)
+      (close-port op))
+    ;; Cache may report the old source line,
+    ;; or uncached should report no line:
+    (equal? (call-with-values
+             (lambda () (locate-source sfd-to-cache 8 #t))
+             (case-lambda
+              [() '(2 3)] ; report no line same as expected cache
+              [(name line col) (list line col)]))
+            '(2 3)))
+
+  ;; An uncached lookup defniitely reports no line:
+  (equal? (call-with-values
+            (lambda () (locate-source sfd-to-cache 8 #f))
+            (lambda () 'none))
+          'none)
+
+  (begin
+    (collect (collect-maximum-generation))
+    ;; After collecting the maximum generation, the
+    ;; cached information shoould definitely be gone:
+    (equal? (call-with-values
+             (lambda () (locate-source sfd-to-cache 8 #t))
+             (lambda () 'gone))
+            'gone))
   )
 
 (mat include

mats/mat.ss

@@ -162,7 +162,7 @@
           (let ()
             (let ([sfd (source-object-sfd src)] [fp (source-object-bfp src)])
               (call-with-values
-                (lambda () (#%$locate-source sfd fp))
+                (lambda () (#%$locate-source sfd fp #t))
                 (case-lambda
                   [() (fprintf *mat-output* "~a at char ~a of ~a~%" msg fp (source-file-descriptor-path sfd))]
                   [(path line char) (fprintf *mat-output* "~a at line ~a, char ~a of ~a~%" msg line char path)]))))

mats/root-experr-compile-0-f-f-f

@@ -8375,12 +8375,20 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
 8.mo:Expected error in mat annotations: "make-source-object: ending file position 2 is less than beginning file position 3".
 8.mo:Expected error in mat annotations: "make-source-object: -7 is not an exact nonnegative integer".
 8.mo:Expected error in mat annotations: "make-source-object: -7 is not an exact nonnegative integer".
+8.mo:Expected error in mat annotations: "make-source-object: -7 is not an exact nonnegative integer".
+8.mo:Expected error in mat annotations: "make-source-object: one is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: one is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: 0 is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: 0 is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: ending file position 2 is less than beginning file position 3".
 8.mo:Expected error in mat annotations: "make-annotation: source is not a source object".
 8.mo:Expected error in mat annotations: "source-file-descriptor-path: #<source foo[2:3]> is not a source-file descriptor".
 8.mo:Expected error in mat annotations: "source-file-descriptor-checksum: #<annotation foo[2:3] (if I were a rich man)> is not a source-file descriptor".
 8.mo:Expected error in mat annotations: "source-object-sfd: #<sfd foo> is not a source object".
 8.mo:Expected error in mat annotations: "source-object-bfp: #<annotation foo[2:3] (if I were a rich man)> is not a source object".
 8.mo:Expected error in mat annotations: "source-object-efp: 3 is not a source object".
+8.mo:Expected error in mat annotations: "source-object-line: 3 is not a source object".
+8.mo:Expected error in mat annotations: "source-object-column: 3 is not a source object".
 8.mo:Expected error in mat annotations: "annotation-expression: 3 is not an annotation".
 8.mo:Expected error in mat annotations: "annotation-stripped: #<source foo[2:3]> is not an annotation".
 8.mo:Expected error in mat annotations: "annotation-source: #<sfd foo> is not an annotation".
@@ -8391,13 +8399,18 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
 8.mo:Expected error in mat annotations: "invalid fasl strip option fig".
 8.mo:Expected error in mat annotations: "invalid fasl strip option fig".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man)".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man)".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f) at char 2 of foo".
+8.mo:Expected error in mat annotations: "incorrect argument count in call (f) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f) at char 2 of foo".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f)".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f)".
@@ -8412,6 +8425,13 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
 8.mo:Expected error in mat annotations: "locate-source: "spam" is not a source-file descriptor".
 8.mo:Expected error in mat annotations: "locate-source: -1 is not an exact nonnegative integer".
 8.mo:Expected error in mat annotations: "locate-source: a is not an exact nonnegative integer".
+8.mo:Expected error in mat annotations: "locate-source-object-source: "spam" is not a source object".
+8.mo:Expected error in mat annotations: "current-locate-source-object-source: 7 is not a procedure".
+8.mo:Expected error in mat annotations: "current-locate-source-object-source: "string" is not a procedure".
+8.mo:Expected error in mat annotations: "locate-source-object-source: "spam" is not a source object".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 200, char 17 of foo".
+8.mo:Expected error in mat annotations-via-recorded-lines: "current-make-source-object: 7 is not a procedure".
+8.mo:Expected error in mat annotations-via-recorded-lines: "current-make-source-object: "string" is not a procedure".
 8.mo:Expected error in mat include: "invalid syntax (include spam)".
 8.mo:Expected error in mat include: "invalid syntax (include spam)".
 8.mo:Expected error in mat extend-syntax: "extend-syntax: invalid keyword ... in keyword list (foo ...)".

mats/root-experr-compile-2-f-f-f

@@ -8375,12 +8375,20 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
 8.mo:Expected error in mat annotations: "make-source-object: ending file position 2 is less than beginning file position 3".
 8.mo:Expected error in mat annotations: "make-source-object: -7 is not an exact nonnegative integer".
 8.mo:Expected error in mat annotations: "make-source-object: -7 is not an exact nonnegative integer".
+8.mo:Expected error in mat annotations: "make-source-object: -7 is not an exact nonnegative integer".
+8.mo:Expected error in mat annotations: "make-source-object: one is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: one is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: 0 is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: 0 is not an exact positive integer".
+8.mo:Expected error in mat annotations: "make-source-object: ending file position 2 is less than beginning file position 3".
 8.mo:Expected error in mat annotations: "make-annotation: source is not a source object".
 8.mo:Expected error in mat annotations: "source-file-descriptor-path: #<source foo[2:3]> is not a source-file descriptor".
 8.mo:Expected error in mat annotations: "source-file-descriptor-checksum: #<annotation foo[2:3] (if I were a rich man)> is not a source-file descriptor".
 8.mo:Expected error in mat annotations: "source-object-sfd: #<sfd foo> is not a source object".
 8.mo:Expected error in mat annotations: "source-object-bfp: #<annotation foo[2:3] (if I were a rich man)> is not a source object".
 8.mo:Expected error in mat annotations: "source-object-efp: 3 is not a source object".
+8.mo:Expected error in mat annotations: "source-object-line: 3 is not a source object".
+8.mo:Expected error in mat annotations: "source-object-column: 3 is not a source object".
 8.mo:Expected error in mat annotations: "annotation-expression: 3 is not an annotation".
 8.mo:Expected error in mat annotations: "annotation-stripped: #<source foo[2:3]> is not an annotation".
 8.mo:Expected error in mat annotations: "annotation-source: #<sfd foo> is not an annotation".
@@ -8391,13 +8399,18 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
 8.mo:Expected error in mat annotations: "invalid fasl strip option fig".
 8.mo:Expected error in mat annotations: "invalid fasl strip option fig".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at char 2 of foo".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man)".
 8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man)".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f) at char 2 of foo".
+8.mo:Expected error in mat annotations: "incorrect argument count in call (f) at line 2, char 1 of foo".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f) at char 2 of foo".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f)".
 8.mo:Expected error in mat annotations: "incorrect argument count in call (f)".
@@ -8412,6 +8425,13 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
 8.mo:Expected error in mat annotations: "locate-source: "spam" is not a source-file descriptor".
 8.mo:Expected error in mat annotations: "locate-source: -1 is not an exact nonnegative integer".
 8.mo:Expected error in mat annotations: "locate-source: a is not an exact nonnegative integer".
+8.mo:Expected error in mat annotations: "locate-source-object-source: "spam" is not a source object".
+8.mo:Expected error in mat annotations: "current-locate-source-object-source: 7 is not a procedure".
+8.mo:Expected error in mat annotations: "current-locate-source-object-source: "string" is not a procedure".
+8.mo:Expected error in mat annotations: "locate-source-object-source: "spam" is not a source object".
+8.mo:Expected error in mat annotations: "invalid syntax (if I were a rich man) at line 200, char 17 of foo".
+8.mo:Expected error in mat annotations-via-recorded-lines: "current-make-source-object: 7 is not a procedure".
+8.mo:Expected error in mat annotations-via-recorded-lines: "current-make-source-object: "string" is not a procedure".
 8.mo:Expected error in mat include: "invalid syntax (include spam)".
 8.mo:Expected error in mat include: "invalid syntax (include spam)".
 8.mo:Expected error in mat extend-syntax: "extend-syntax: invalid keyword ... in keyword list (foo ...)".

release_notes/release_notes.stex

@@ -125,6 +125,23 @@ The new primitive procedures \scheme{bytevector-compress} and
 compression functionality that is used for files with the
 \scheme{compressed} option.
 
+\subsection{Line caching and source objects (9.4.1)}
+
+The \scheme{locate-source} function accepts an optional argument that
+enables the use of a cache for line information, so that a source file
+does not have to be consulted each time to compute line information.
+To further avoid file and caching issues, a source object has optional
+beginning-line and beginning-column components. Source objects with line
+and column components take more space, but they allow reporting of line and column
+information even if a source file is later modified or becomes unavailable.
+The value of the \scheme{current-make-source-object} parameter is used by the
+reader to construct source objects for programs, and the parameter can be
+modified to collect line and column information eagerly. The value of the
+\scheme{current-locate-source-object-source} parameter is used for
+error reporting, instead of calling \scheme{locate-source} or
+\scheme{locate-source-object-source} directly, so that just-in-time
+source-location lookup can be adjusted, too.
+
 \subsection{High-precision clock time in Windows 8 and up (9.4.1)}
 
 When running on Windows 8 and up, Chez Scheme uses the high-precision

s/7.ss

@@ -669,6 +669,8 @@
                   "~%[collecting generation ~s into generation ~s..."
                   g gtarget)
                 (flush-output-port (console-output-port)))
+              (when (eqv? g (collect-maximum-generation))
+                ($clear-source-lines-cache))
               (do-gc g gtarget)
               ($close-resurrected-files)
               (when-feature pthreads

s/cmacros.ss

@@ -1351,6 +1351,7 @@
    [ptr current-error]
    [ptr block-counter]
    [ptr sfd]
+   [ptr current-mso]
    [ptr target-machine]
    [ptr fxlength-bv]
    [ptr fxfirst-bit-set-bv]

s/compile.ss

@@ -550,6 +550,7 @@
     (include "types.ss")
     (parameterize ([$target-machine machine]
                    [$sfd sfd]
+                   [$current-mso ($current-mso)]
                    [$block-counter 0]
                    [optimize-level (optimize-level)]
                    [debug-level (debug-level)]
@@ -577,7 +578,7 @@
                          (when (and (annotation? x0) (fxlogtest (annotation-flags x0) (constant annotation-debug)))
                            (let ((s (annotation-source x0)))
                              (call-with-values
-                               (lambda () ($locate-source (source-sfd s) (source-bfp s)))
+                               (lambda () ((current-locate-source-object-source) s #t #t))
                                (case-lambda
                                  [() (void)]
                                  [(path line char) (printf " on line ~s" line)]))))))))

s/cpnanopass.ss

@@ -5275,6 +5275,7 @@
           (define-tc-parameter $suppress-primitive-inlining suppress-primitive-inlining)
           (define-tc-parameter $block-counter block-counter)
           (define-tc-parameter $sfd sfd)
+          (define-tc-parameter $current-mso current-mso)
           (define-tc-parameter $target-machine target-machine)
           (define-tc-parameter $current-stack-link stack-link)
           (define-tc-parameter $current-winders winders)

s/exceptions.ss

@@ -35,23 +35,23 @@ TODO:
 
   (let ()
     (define $display-condition
-      (lambda (c op prefix?)
+      (lambda (c op prefix? use-cache?)
         (module (print-source)
           (include "types.ss")
           (define (print-position op prefix src start?)
-            (let ([sfd (source-sfd src)]
-                  [fp (if start? (source-bfp src) (source-efp src))])
             (call-with-values
-                (lambda () ($locate-source sfd fp))
+              (lambda () ((current-locate-source-object-source) src start? use-cache?))
               (case-lambda
                 [()
+                 (let ([sfd (source-sfd src)]
+                       [fp (if start? (source-bfp src) (source-efp src))])
                    (fprintf op "~a~a char ~a of ~a" prefix
                      (if (eq? start? 'near) "near" "at")
-                     fp (source-file-descriptor-name sfd))]
+                     fp (source-file-descriptor-name sfd)))]
                 [(path line char)
                  (fprintf op "~a~a line ~a, char ~a of ~a" prefix
                    (if (eq? start? 'near) "near" "at")
-                     line char path)]))))
+                   line char path)])))
           (define (print-source op prefix c)
             (cond
               [($src-condition? c)
@@ -145,11 +145,11 @@ TODO:
 
     (set-who! display-condition
       (case-lambda
-        [(c) ($display-condition c (current-output-port) #t)]
+        [(c) ($display-condition c (current-output-port) #t #f)]
         [(c op)
          (unless (and (output-port? op) (textual-port? op))
            ($oops who "~s is not a textual output port" op))
-         ($display-condition c op #t)]))
+         ($display-condition c op #t #f)]))
 
     (set! $make-source-oops
       (lambda (who msg expr)
@@ -159,7 +159,7 @@ TODO:
                   ($display-condition (condition
                                         (make-syntax-violation expr #f)
                                         (make-message-condition msg))
-                    p #f)))))))
+                    p #f #t)))))))
 
   (set! default-exception-handler
     (lambda (c)

s/inspect.ss

@@ -2148,6 +2148,7 @@
             [(get-code-sexpr x) => make-object]
             [else #f])]
         [source-path () (return-source (get-code-src x))]
+        [source-object () (get-code-src x)]
         [reloc () (make-object (get-reloc-objs x))]
         [size (g) (compute-size x g)]
         [write (p) (write x p)]
@@ -2157,12 +2158,12 @@
       (lambda (src)
         (include "types.ss")
         (if src
-            (let ([sfd (source-sfd src)] [fp (source-bfp src)])
             (call-with-values
-                (lambda () ($locate-source sfd fp))
+              (lambda () ((current-locate-source-object-source) src #t #f))
               (case-lambda
-                  [() (values (source-file-descriptor-name sfd) fp)]
+                [() (let ([sfd (source-sfd src)] [fp (source-bfp src)])
-                  [(path line char) (values path line char)])))
+                      (values (source-file-descriptor-name sfd) fp))]
+                [(path line char) (values path line char)]))
             (values))))
 
     (define-who make-continuation-object
@@ -2290,6 +2291,7 @@
           [eval (x) (frame-eval vars x)]
           [code () (make-object ($continuation-return-code x))]
           [source () (and sexpr (make-object sexpr))]
+          [source-object () src]
           [source-path () (return-source src)]
           [size (g) (compute-size x g)]
           [write (p) (write x p)]

s/primdata.ss

@@ -936,6 +936,8 @@
   (current-exception-state [sig [() -> (exception-state)] [(exception-state) -> (void)]] [flags])
   (current-expand [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (current-input-port [sig [() -> (textual-input-port)] [(textual-input-port) -> (void)]] [flags])   ; not restricted to 1 argument
+  (current-locate-source-object-source [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
+  (current-make-source-object [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (current-output-port [sig [() -> (textual-output-port)] [(textual-output-port) -> (void)]] [flags])  ; not restricted to 1 argument
   (current-transcoder [sig [() -> (transcoder)] [(transcoder) -> (void)]] [flags])
   (custom-port-buffer-size [sig [() -> (ufixnum)] [(sub-fixnum) -> (void)]] [flags])
@@ -1394,7 +1396,8 @@
   (profile-load-data [sig [(pathname) -> (void)]] [flags true])
   (load-program [sig [(pathname) (pathname procedure) -> (void)]] [flags true])
   (load-shared-object [sig [(maybe-pathname) -> (void)]] [flags true])
-  (locate-source [sig [(sfd uint) -> ()] [(sfd uint) -> (string uint uint)]] [flags])
+  (locate-source [sig [(sfd uint) (sfd uint ptr) -> ()] [(sfd uint) (sfd uint ptr) -> (string uint uint)]] [flags])
+  (locate-source-object-source [sig [(source-object ptr ptr) -> ()] [(source-object ptr ptr) -> (string uint uint)]] [flags])
   (lock-object [sig [(ptr) -> (void)]] [flags unrestricted true])
   (locked-object? [sig [(ptr) -> (boolean)]] [flags unrestricted discard])
   (logand [sig [(sint ...) -> (sint)]] [flags arith-op partial-folder])
@@ -1430,8 +1433,8 @@
   (make-parameter [sig [(ptr) (ptr procedure) -> (procedure)]] [flags true cp02 cp03])
   (make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02])
   (make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
-  (make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) -> (sfd)]] [flags true])
+  (make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) (string binary-input-port ptr ptr) -> (sfd)]] [flags true])
-  (make-source-object [sig [(sfd uint uint) -> (source-object)]] [flags pure true mifoldable discard])
+  (make-source-object [sig [(sfd uint uint) (sfd uint uint uint uint) -> (source-object)]] [flags pure true mifoldable discard])
   (make-sstats [sig [(time time exact-integer exact-integer time time exact-integer) -> (sstats)]] [flags alloc])
   (make-thread-parameter [feature pthreads] [sig [(ptr) (ptr procedure) -> (ptr)]] [flags true cp02 cp03])
   (make-weak-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc])
@@ -1594,7 +1597,9 @@
   (source-file-descriptor-path [sig [(sfd) -> (ptr)]] [flags pure mifoldable discard true])
   (source-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (source-object-bfp [sig [(source-object) -> (uint)]] [flags pure mifoldable discard])
+  (source-object-column [sig [(source-object) -> (ptr)]] [flags pure mifoldable discard])
   (source-object-efp [sig [(source-object) -> (uint)]] [flags pure mifoldable discard])
+  (source-object-line [sig [(source-object) -> (ptr)]] [flags pure mifoldable discard])
   (source-object-sfd [sig [(source-object) -> (sfd)]] [flags pure mifoldable discard])
   (sstats-bytes [sig [(sstats) -> (exact-integer)]] [flags mifoldable discard])
   (sstats-cpu [sig [(sstats) -> (time)]] [flags mifoldable discard])
@@ -1720,6 +1725,7 @@
   ($check-heap-errors [flags])
   ($clear-dynamic-closure-counts [flags])  ; added for closure instrumentation
   ($clear-pass-stats [flags])
+  ($clear-source-lines-cache [flags])
   ($close-files [flags])
   ($close-resurrected-files [flags])
   ($close-resurrected-mutexes&conditions [feature pthreads] [flags])
@@ -2232,6 +2238,7 @@
   ($compile-profile [flags])
   ($cp0-inner-unroll-limit #;[sig [() -> (ufixnum)] [(ufixnum) -> (void)]] [flags])
   ($cp0-polyvariant #;[sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
+  ($current-mso [flags])
   ($enable-check-heap [flags])
   ($enable-expeditor [feature expeditor] [flags])
   ($enable-pass-timing [flags])

s/prims.ss

@@ -1642,6 +1642,7 @@
   (define-tc-parameter current-error-port (lambda (x) (and (output-port? x) (textual-port? x))) "a textual output port")
   (define-tc-parameter $block-counter (lambda (x) (and (fixnum? x) (fx<= x 0))) "a nonpositive fixnum" 0)
   (define-tc-parameter $sfd (lambda (x) (or (eq? x #f) (source-file-descriptor? x))) "a source-file descriptor or #f" #f)
+  (define-tc-parameter $current-mso (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
   (define-tc-parameter $target-machine symbol? "a symbol")
   (define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "valid optimize level" 0)
   (define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "valid compile-profile flag" #f)

s/print.ss

@@ -709,9 +709,11 @@ floating point returns with (1 0 -1 ...).
         [(let ([info ($code-info x)])
            (and (code-info? info) (code-info-src info))) =>
          (lambda (src)
-           (fprintf p " at ~a:~s"
+           (fprintf p " at ~a:~a"
              (path-last (source-file-descriptor-name (source-sfd src)))
-             (source-bfp src)))])))
+             (if (source-2d? src)
+                 (format "~a.~a" (source-2d-line src) (source-2d-column src))
+                 (source-bfp src))))])))
 
   (define wrprocedure
     (lambda (x p)

s/read.ss

@@ -255,11 +255,22 @@
                 ((fx= i n) new)
               (string-set! new i (string-ref old i))))))))
 
+(define-syntax $make-source-object
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ sfd-expr bfp-expr efp-expr)
+       #'(let ([sfd sfd-expr]
+               [bfp bfp-expr]
+               [efp efp-expr])
+           (if ($current-mso)
+               (($current-mso) sfd bfp efp)
+               (make-source sfd bfp efp)))])))
+
 (xdefine (rd-error ir? start? msg . args)
   (cond
     [(eq? ip (console-input-port)) ($lexical-error who msg args ip ir?)]
     [(not fp) ($lexical-error who "~? on ~s" (list msg args ip) ip ir?)]
-    [sfd ($lexical-error who msg args ip (make-source sfd bfp fp) start? ir?)]
+    [sfd ($lexical-error who msg args ip ($make-source-object sfd bfp fp) start? ir?)]
     [else ($lexical-error who "~? at char ~a of ~s" (list msg args (if start? bfp fp) ip) ip ir?)]))
 
 (xdefine (rd-eof-error s)
@@ -1132,7 +1143,7 @@
   (xmvlet ((x stripped) (xcall rd-help type value))
     (xvalues
       (if (and a? (not (procedure? x))) ; don't annotate code
-          (make-annotation x (make-source sfd bfp fp) stripped)
+          (make-annotation x ($make-source-object sfd bfp fp) stripped)
           x)
       stripped)))
 
@@ -1612,21 +1623,53 @@
                     (and (not (string=? rest name))
                          (pathloop rest))))))))))
 
+(let ([source-lines-cache (make-weak-eq-hashtable)])
+
   (set! $locate-source
-  (lambda (sfd fp)
+    (lambda (sfd fp use-cache?)
+      (define (binary-search table name)
+        (let loop ([lo 0] [hi (vector-length table)])
+          (if (fx= (fx+ 1 lo) hi)
+              (values name
+                      hi
+                      (fx+ 1 (fx- fp (vector-ref table lo))))
+              (let ([mid (fxsra (fx+ lo hi) 1)])
+                (if (< fp (vector-ref table mid))
+                    (loop lo mid)
+                    (loop mid hi))))))
       (cond
+       [(and use-cache?
+             (with-tc-mutex (hashtable-ref source-lines-cache sfd #f))) =>
+        (lambda (name+table)
+          (binary-search (cdr name+table) (car name+table)))]
        [($open-source-file sfd) =>
         (lambda (ip)
-         (let loop ([fp fp] [line 1] [char 1])
+          (define name (port-name ip))
-           (if (= fp 0)
+          (define table
-               (begin
+            ;; Make a vector for the position (counting from zero)
+            ;; that starts each line (= vector index + 1)
+            (let loop ([fp 0] [accum '(0)])
+              (let ([ch (read-char ip)])
+                (cond
+                 [(eof-object? ch)
                   (close-input-port ip)
-                 (values (port-name ip) line char))
+                  (list->vector (reverse accum))]
-               (if (eqv? (read-char ip) #\newline)
+                 [(eqv? ch #\newline)
-                   (loop (- fp 1) (fx+ line 1) 1)
+                  (let ([fp (fx+ fp 1)])
-                   (loop (- fp 1) line (fx+ char 1))))))]
+                    (loop fp (cons fp accum)))]
+                 [else
+                  (loop (fx+ fp 1) accum)]))))
+          (when use-cache?
+            (with-tc-mutex
+             (hashtable-set! source-lines-cache sfd (cons name table))))
+          (binary-search table name))]
        [else (values)])))
 
+  (set! $clear-source-lines-cache
+   ; called from single-threaded docollect
+    (lambda ()
+      (hashtable-clear! source-lines-cache))))
+
 (set! $source-file-descriptor
   (let ()
     (define crc16

s/syntax.ss

@@ -6416,15 +6416,15 @@
   (lambda (x p wr)
     (define get-source
       (lambda (src)
-        (let ([sfd (source-sfd src)] [fp (source-bfp src)])
         (call-with-values
-            (lambda () ($locate-source sfd fp))
+          (lambda () ((current-locate-source-object-source) src #t #t))
           (case-lambda
-              [() (format "[char ~a of ~a]"
+            [() (let ([sfd (source-sfd src)] [fp (source-bfp src)])
+                  (format "[char ~a of ~a]"
                           fp
-                    (source-file-descriptor-name sfd))]
+                          (source-file-descriptor-name sfd)))]
             [(path line char)
-               (format "[line ~a, char ~a of ~a]" line char path)])))))
+             (format "[line ~a, char ~a of ~a]" line char path)]))))
     (display "#<syntax " p)
     (wr (syntax->datum x) p)
     (let f ([x x])
@@ -9635,6 +9635,7 @@
 
 (let ()
   (module types (source make-source source? source-sfd source-bfp source-efp
+                 source-2d? make-source-2d source-2d-line source-2d-column
                  annotation make-annotation annotation? annotation-expression annotation-source annotation-stripped annotation-flags
                  make-source-file-descriptor source-file-descriptor source-file-descriptor? source-file-descriptor-name
                  source-file-descriptor-length source-file-descriptor-crc
@@ -9665,7 +9666,8 @@
         (wr (%annotation-stripped x) p)
         (display-string ">" p))))
   (set-who! make-source-object
-    (lambda (sfd bfp efp)
+    (case-lambda
+     [(sfd bfp efp)
       (unless (%source-file-descriptor? sfd)
         ($oops who "~s is not a source file descriptor" sfd))
       (unless (if (fixnum? bfp) (fx>= bfp 0) (and (bignum? bfp) ($bigpositive? bfp)))
@@ -9674,7 +9676,27 @@
         ($oops who "~s is not an exact nonnegative integer" efp))
       (unless (<= bfp efp)
         ($oops who "ending file position ~s is less than beginning file position ~s" efp bfp))
-      (%make-source sfd bfp efp)))
+      (%make-source sfd bfp efp)]
+     [(sfd bfp efp line column)
+      (unless (%source-file-descriptor? sfd)
+        ($oops who "~s is not a source file descriptor" sfd))
+      (unless (if (fixnum? bfp) (fx>= bfp 0) (and (bignum? bfp) ($bigpositive? bfp)))
+        ($oops who "~s is not an exact nonnegative integer" bfp))
+      (unless (if (fixnum? efp) (fx>= efp 0) (and (bignum? efp) ($bigpositive? efp)))
+        ($oops who "~s is not an exact nonnegative integer" efp))
+      (unless (if (fixnum? line) (fx>= line 1) (and (bignum? line) ($bigpositive? line)))
+        ($oops who "~s is not an exact positive integer" line))
+      (unless (if (fixnum? column) (fx>= column 1) (and (bignum? column) ($bigpositive? column)))
+        ($oops who "~s is not an exact positive integer" column))
+      (unless (<= bfp efp)
+        ($oops who "ending file position ~s is less than beginning file position ~s" efp bfp))
+      (%make-source-2d sfd bfp efp line column)]))
+  (set-who! current-make-source-object
+    (case-lambda
+     [() (or ($current-mso) make-source-object)]
+     [(x)
+      (unless (procedure? x) ($oops who "~s is not a procedure" x))
+      ($current-mso (if (eq? x make-source-object) #f x))]))
   (set-who! source-object?
     (lambda (x)
       (%source? x)))
@@ -9690,6 +9712,18 @@
     (lambda (x)
       (unless (%source? x) ($oops who "~s is not a source object" x))
       (%source-efp x)))
+  (set-who! source-object-line
+    (lambda (x)
+      (cond
+       [(%source-2d? x) (%source-2d-line x)]
+       [(%source? x) #f]
+       [else ($oops who "~s is not a source object" x)])))
+  (set-who! source-object-column
+    (lambda (x)
+      (cond
+       [(%source-2d? x) (%source-2d-column x)]
+       [(%source? x) #f]
+       [else ($oops who "~s is not a source object" x)])))
   (set-who! make-annotation
     (case-lambda
       [(expression source stripped)
@@ -9769,10 +9803,36 @@
       (unless (%source-file-descriptor? sfd) ($oops who "~s is not a source-file descriptor" sfd))
       ($open-source-file sfd)))
   (set-who! locate-source
-    (lambda (sfd fp)
+    (rec locate-source
+      (case-lambda
+       [(sfd fp) (locate-source sfd fp #f)]
+       [(sfd fp use-cache?)
         (unless (%source-file-descriptor? sfd) ($oops who "~s is not a source-file descriptor" sfd))
-      (unless (if (fixnum? fp) (fx>= fp 0) (and (bignum? fp) ($bigpositive? fp))) ($oops who "~s is not an exact nonnegative integer" fp))
+        (unless (if (fixnum? fp) (fx>= fp 0) (and (bignum? fp) ($bigpositive? fp)))
-      ($locate-source sfd fp)))
+          ($oops who "~s is not an exact nonnegative integer" fp))
+        ($locate-source sfd fp use-cache?)])))
+  (set-who! locate-source-object-source
+    (lambda (src start? cache?)
+      (cond
+       [(and start?
+             (%source-2d? src))
+        (values (%source-file-descriptor-name (%source-sfd src))
+                (%source-2d-line src)
+                (%source-2d-column src))]
+       [(%source? src)
+        ($locate-source (%source-sfd src)
+                        (if start?
+                            (%source-bfp src)
+                            (%source-efp src))
+                        cache?)]
+       [else
+        ($oops who "~s is not a source object" src)])))
+  (set-who! current-locate-source-object-source
+    ($make-thread-parameter
+     locate-source-object-source
+     (lambda (x)
+       (unless (procedure? x) ($oops who "~s is not a procedure" x))
+       x)))
   (set-who! syntax->annotation
     (lambda (x)
       (cond

s/types.ss

@@ -27,7 +27,12 @@
 
 (define-record-type source
   (fields (immutable sfd) (immutable bfp) (immutable efp))
-  (nongenerative #{source bc9ao7qsvpf38krv-a})
+  (nongenerative #{source gbwctw0mahurbuiegp7uq3-0}))
+
+(define-record-type source-2d
+  (parent source)
+  (fields (immutable line) (immutable column))
+  (nongenerative #{source-2d gbwctw0mahurbuiegp7uq3-2})
   (sealed #t))
 
 (define-record-type source-file-descriptor