common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Handle read-eval more robustly in SB-COVER.

Browse source 
READ-EVAL can be used to inline source code using the reader.  This is
distinct from macro-based inlining (or compiler-macro, or compiler
transform...) because it happens independently of the compiler
processing the source code, and so to the source path processor there
is no distinction between the code as inserted by READ-EVAL and the
code written out long-hand.

For reporting on the state of the source code, however, there is a
significant difference: we do not want to (and indeed cannot) descend
into source code inserted by read-eval.  Define a marker struct to
denote an element read by sharp-dot, and do not attempt to descend
into it when mapping source forms to character positions.  If asked to
descend, discard that source path for state annotation
purposes (rather than returning an outer form) to avoid annotating
anything with conditional states that are irrelevant to the actual
source form.

Don't use *READ-SUPPRESS* in the replaced sharp-dot reader to avoid
having the READ-EVAL'd form annotated as having suppressed state.

Delete some unused source-mapping utilities inherited from the initial
implementation.
This commit is contained in:
Christophe Rhodes 2025-11-08 21:30:53 +00:00
parent 00eabf5a58
commit 8d94fb9013
4 changed files with 69 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
contrib/sb-cover/cover.lisp
View file

@ -494,9 +494,10 @@ report, otherwise ignored. The default value is CL:IDENTITY.
(handler-case
(multiple-value-bind (start end)
(source-path-source-position (cons 0 source-path) source-form source-map)
(push (list start end state) locations))
(error ()
(warn "Error finding source location for source path ~A in file ~A~%" source-path file)))
(when (and start end)
(push (list start end state) locations)))
(error (e)
(warn "~@<Error finding source location for source path ~A in file ~A: ~2I~_~A~@:>" source-path file e)))
(warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file)))))))
(defun fill-states-from-locations (source states locations)
@ -694,6 +695,8 @@ The source locations are stored in SOURCE-MAP."
(let ((*backquote-level* (1- *backquote-level*)))
(list 'comma (read stream t nil t)))))
(defstruct read-eval-marker)
;;; Ripped from SB-IMPL, since location recording on a cons-cell level
;;; can't be done just by simple read-table tricks.
(defun make-recording-read-list (source-map)
@ -732,8 +735,8 @@ The source locations are stored in SOURCE-MAP."
(end (file-position stream)))
;; allows the possibility that a comment was read
(when listobj
(unless (consp (car listobj))
(setf (car listobj) (gensym))
(unless (or (consp (car listobj)) (read-eval-marker-p (car listobj)))
(setf (car listobj) (gensym))
(push (list start end *read-suppress*)
(gethash (car listobj) source-map)))
(rplacd listtail listobj)
@ -742,11 +745,14 @@ The source locations are stored in SOURCE-MAP."
(defun suppress-sharp-dot (readtable)
(when (get-macro-character #\# readtable)
(let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable)))
(set-dispatch-macro-character #\# #\.
(lambda (&rest args)
(let ((*read-suppress* t))
(apply sharp-dot args)))
readtable))))
(when sharp-dot
(set-dispatch-macro-character #\# #\.
(lambda (stream &rest args)
(declare (ignore args))
(let ((*backquote-level* 0))
(read stream t nil t)
(make-read-eval-marker))))
readtable))))
(defun suppress-sharp-c (readtable)
(when (get-macro-character #\# readtable)
@ -832,34 +838,17 @@ Return the form and the source-map."
(error 'end-of-file :stream stream)
(values form source-map)))))
(defun source-path-stream-position (path stream)
"Search the source-path PATH in STREAM and return its position."
(check-source-path path)
(destructuring-bind (tlf-number . path) path
(multiple-value-bind (form source-map) (read-source-form tlf-number stream)
(source-path-source-position (cons 0 path) form source-map))))
(defun check-source-path (path)
(unless (and (consp path)
(every #'integerp path))
(error "The source-path ~S is not valid." path)))
(defun source-path-string-position (path string)
(with-input-from-string (s string)
(source-path-stream-position path s)))
(defun source-path-file-position (path filename)
(with-open-file (file filename)
(source-path-stream-position path file)))
(defun source-path-source-position (path form source-map)
"Return the start position of PATH from FORM and SOURCE-MAP. All
subforms along the path are considered and the start and end position
of the deepest (i.e. smallest) possible form is returned."
;; compute all subforms along path
(let ((forms (loop for n in path
(let ((forms (loop for ns on path
for n = (car ns)
for f = form then (nth n f)
collect f into forms
if (read-eval-marker-p f)
do (return-from source-path-source-position (values nil nil))
finally (return forms))))
;; select the first subform present in source-map
(loop for real-form in (reverse forms)

28
contrib/sb-cover/file-info-tests.lisp
View file

@ -194,3 +194,31 @@
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
;; ( 1 + * p r i n t - l e v e l * ) ) )
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(sb-cover:clear-coverage)
(defun generate-code (x y)
`(if (evenp ,x) (1+ ,y) (1- ,y)))
(compile-load "test-data-read-eval")
;; It's a bit difficult to decide what the state of the READ-EVAL'd
;; code should be without ever running the function; if something
;; changes this test, that might be OK.
(assert (equalp (get-states "test-data-read-eval")
;;( i n - p a c k a g e s b - c o v e r - t e s t )
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
0
;;( d e f u n r e a d - e v a l ( z w )
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
;; # . ( g e n e r a t e c o d e ' z ' w ) )
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))
(read-eval 2 3)
;; ... but probably the main thing is that this shouldn't show any
;; conditional-related states (or indeed read-suppressed states).
(assert (equalp (get-states "test-data-read-eval")
;;( i n - p a c k a g e s b - c o v e r - t e s t )
#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
0
;;( d e f u n r e a d - e v a l ( z w )
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
;; # . ( g e n e r a t e c o d e ' z ' w ) )
0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))

4
contrib/sb-cover/test-data-read-eval.lisp Normal file
View file

@ -0,0 +1,4 @@
(in-package sb-cover-test)
(defun read-eval (z w)
#.(generate-code 'z 'w))

17
contrib/sb-cover/tests.lisp
View file

@ -148,3 +148,20 @@
(assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
(assert (= 7 (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
(assert (= 7 (sb-cover::all-of (getf sb-cover::*counts* :expression))))
(sb-cover:clear-coverage)
(defun generate-code (x y)
`(if (evenp ,x) (1+ ,y) (1- ,y)))
(compile-load "test-data-read-eval")
(report)
(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
(assert (= 2 (sb-cover::all-of (getf sb-cover::*counts* :branch))))
(assert (= 2 (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
(assert (= 6 (sb-cover::all-of (getf sb-cover::*counts* :expression))))
(read-eval 3 4)
(report)
(assert (= 1 (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
(assert (= 2 (sb-cover::all-of (getf sb-cover::*counts* :branch))))
(assert (= 5 (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
(assert (= 6 (sb-cover::all-of (getf sb-cover::*counts* :expression))))