suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #177 from mflatt/filepos

Browse Source 
add file-position-object and eager source-line counting
original commit: 75107ee73f3619e1afcf043822cf5fbf675522e3
This commit is contained in:
R. Kent Dybvig 2017-08-01 09:00:22 -04:00 committed by GitHub
commit f09043b073
21 changed files with 566 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
LOG
View File

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

1
c/gc.c
View File

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

9
csug/debug.stex
View File

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

102
csug/syntax.stex
View File

@ -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),
a beginning file position (bfp), and an ending file position (efp).
The sfd identifies the file from which an expression is read and the
bfp identify the range of character positions occupied by the object
also have three or five components: a \emph{source-file descriptor} (sfd),
a beginning file position (bfp), an ending file position (efp),
an optional beginning line, and an optional beginning
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
greater than the third.
third must be nonnegative exact integers, the second must not be
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})}
\returns the sfd component of \var{source-object}
\formdef{source-object-line}{\categoryprocedure}{(source-object-line \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}.

210
mats/8.ms
View File

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

2
mats/mat.ss
View File

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

20
mats/root-experr-compile-0-f-f-f
View File

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

20
mats/root-experr-compile-2-f-f-f
View File

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

17
release_notes/release_notes.stex
View File

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

2
s/7.ss
View File

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

1
s/cmacros.ss
View File

@ -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]

3
s/compile.ss
View File

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

1
s/cpnanopass.ss
View File

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

18
s/exceptions.ss
View File

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

10
s/inspect.ss
View File

@ -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)]
[(path line char) (values path line char)])))
[() (let ([sfd (source-sfd src)] [fp (source-bfp src)])
(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)]

13
s/primdata.ss
View File

@ -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-object [sig [(sfd uint uint) -> (source-object)]] [flags pure true mifoldable discard])
(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) (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])

1
s/prims.ss
View File

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

6
s/print.ss
View File

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

65
s/read.ss
View File

@ -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))))))))))
(set! $locate-source
(lambda (sfd fp)
(let ([source-lines-cache (make-weak-eq-hashtable)])
(set! $locate-source
(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])
(if (= fp 0)
(begin
(define name (port-name ip))
(define table
;; 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))
(if (eqv? (read-char ip) #\newline)
(loop (- fp 1) (fx+ line 1) 1)
(loop (- fp 1) line (fx+ char 1))))))]
(list->vector (reverse accum))]
[(eqv? ch #\newline)
(let ([fp (fx+ fp 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

80
s/syntax.ss
View File

@ -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))
($locate-source sfd fp)))
(unless (if (fixnum? fp) (fx>= fp 0) (and (bignum? fp) ($bigpositive? 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

7
s/types.ss
View File

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