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

Suppress #A mostly like #C in SB-COVER source mapping reader

Browse source 
Fixes SB-COVER in the presence of #A(dim type . contents) syntax,
lp#2134290.
This commit is contained in:
Christophe Rhodes 2025-12-07 10:06:55 +00:00
parent 0b8038d3d3
commit ea206da2d4
3 changed files with 48 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
NEWS
View file

@ -1,5 +1,10 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-2.5.11:
* bug fix: the SB-COVER reporting utilities can now annotate source files
containing array literals using #A(<dims> <eltype> . <contents>) syntax.
(lp#2134290)
changes in sbcl-2.5.11 relative to sbcl-2.5.10:
* incompatible change: the compiler's internal representation of "source
paths" for unquoted forms within backquotes has changed. Other developer

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

@ -693,6 +693,7 @@ The source locations are stored in SOURCE-MAP."
;; Portability concerns aside, it doesn't work in the latest code,
;; but first changing the function for #. and then # in that order works.
(suppress-sharp-dot tab)
(suppress-sharp-a tab)
(suppress-sharp-c tab)
(dotimes (code 128)
(let ((char (code-char code)))
@ -820,10 +821,27 @@ The source locations are stored in SOURCE-MAP."
(let ((thing (read stream t nil t)))
(cond
(*read-suppress* nil)
((and (listp thing) (= (length thing) 2)) #c(0 0))
((and (listp thing) (= (length thing) 2)) #c(1 1))
(t (sb-int:simple-reader-error stream "illegal complex number format: #C~S" thing))))))
(set-dispatch-macro-character #\# #\c #'sharp-c-replacement readtable))))))
(defun suppress-sharp-a (readtable)
(when (get-macro-character #\# readtable)
(let ((sharp-a (get-dispatch-macro-character #\# #\a readtable)))
(when sharp-a
(flet ((sharp-a-replacement (stream subchar numarg)
(declare (ignore subchar))
(let ((thing (read stream t nil t)))
(cond
(*read-suppress* nil)
;; regular #2A(...) syntax
((and numarg (typep thing 'sequence)) #())
;; extended #A(dims element-type &rest contents) syntax
((not numarg) #())
(t (sb-int:simple-reader-error stream "illegal literal array format: #~DA~S"
numarg thing))))))
(set-dispatch-macro-character #\# #\a #'sharp-a-replacement readtable))))))
;;; The detection logic for "IN-PACKAGE" is stolen from swank's
;;; source-path-parser.lisp.
;;;

28
tests/sb-cover.impure.lisp
View file

@ -4,7 +4,8 @@
(defpackage "SB-COVER-TEST"
(:export
"*OUTPUT-DIRECTORY*" "*SOURCE-DIRECTORY*"
"COMPILE-LOAD" "GET-STATES" "REPORT" "REPORT-EXPECT-FAILURE" "SOURCE-PATHNAME")
"COMPILE-LOAD" "GET-STATES" "REPORT" "REPORT-EXPECT-FAILURE" "SOURCE-PATHNAME"
"SOURCE-RECORDING-READTABLE")
(:use "CL"))
(defvar sb-cover-test:*output-directory*)
@ -38,6 +39,9 @@
(warning (condition)
(error "Unexpected warning: ~A" condition))))
(defun sb-cover-test:source-recording-readtable ()
(sb-cover::make-source-recording-readtable (copy-readtable nil) (make-hash-table :test 'eq)))
(defglobal *new-code* nil)
(defun preserve-code (underlying-fun object reason)
(declare (ignore underlying-fun reason))
@ -49,11 +53,27 @@
(with-test (:name :sb-cover)
(test-util:with-test-directory (sb-cover-test:*output-directory*)
(load (merge-pathnames "tests.lisp" sb-cover-test:*source-directory*))
(load (merge-pathnames "file-info-tests.lisp" sb-cover-test:*source-directory*))
(load (merge-pathnames "save-restore-tests.lisp" sb-cover-test:*source-directory*)))
(load (merge-pathnames "tests.lisp" sb-cover-test:*source-directory*))
(load (merge-pathnames "file-info-tests.lisp" sb-cover-test:*source-directory*))
(load (merge-pathnames "save-restore-tests.lisp" sb-cover-test:*source-directory*)))
(assert (> (length *new-code*) 40)))
;;; the return values tested here don't actually need to be as
;;; specific as COMPLEX, ARRAY (etc.): probably ATOM would do (though
;;; we might as well test for the slightly stronger consistency that
;;; we happen to have implemented). In case of future conflict,
;;; probably weaken these tests rather than contort the
;;; implementation.
(with-test (:name (:sb-cover read :sharp-c))
(let ((*readtable* (sb-cover-test:source-recording-readtable)))
(assert (typep (read-from-string "#c(0 0)") 'complex))
(assert (typep (read-from-string "#C(0d0 1/2)") 'complex))))
(with-test (:name (:sb-cover read :sharp-a))
(let ((*readtable* (sb-cover-test:source-recording-readtable)))
(assert (typep (read-from-string "#2A((1 2) (3 4))") 'array))
(assert (typep (read-from-string "#a(4 base-char . \"abcd\")") 'array))))
(with-test (:name :no-redundant-form-paths)
(dolist (c *new-code*)
(let ((map (sb-cover::%find-coverage-map c)))