master: Improve SB-INTROSPECT:FIND-DEFINITION-SOURCES-BY-NAME error handling
melisgl via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via bfd25952d5caa8984811f60dba50420213cf502d (commit)
from 5249a30f980f1edb05741ad939b6399e8a54e22a (commit)
- Log -----------------------------------------------------------------
commit bfd25952d5caa8984811f60dba50420213cf502d
Author: Gabor Melis <[email protected]>
Date: Fri Mar 13 08:47:53 2026 +0100
Improve SB-INTROSPECT:FIND-DEFINITION-SOURCES-BY-NAME error handling
- Accept string designators names with :PACKAGE.
- Do not signal an error with :COMPILER-MACRO, :FUNCTION,
:GENERIC-FUNCTION and :METHOD if NAME is not a valid function name.
- Document that SB-INTROSPECT:FIND-DEFINITION-SOURCES-BY-NAME returns
NIL on invalid NAMEs.
- Document that definition types are disjoint.
- Remove stale TODO.
---
contrib/sb-introspect/introspect.lisp | 152 ++++++++++++++++++---------------
contrib/sb-introspect/test-driver.lisp | 89 +++++++++++++------
2 files changed, 148 insertions(+), 93 deletions(-)
diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 3ebdf1a2d..d2bc8a07a 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -20,8 +20,6 @@
;;; application programmer, and are not.
;;; TODO
-;;; 1) structs don't have within-file location info. problem for the
-;;; structure itself, accessors, the copier and the predicate
;;; 3) error handling. Signal random errors, or handle and resignal 'our'
;;; error, or return NIL?
;;; 4) FIXMEs
@@ -205,38 +203,54 @@ constant pool."
source))))
(defun find-definition-sources-by-name (name type)
- "Returns a list of DEFINITION-SOURCEs for the objects of type TYPE
-defined with name NAME. NAME may be a symbol or a extended function
-name. Type can currently be one of the following:
-
- (Public)
- :CLASS
- :COMPILER-MACRO
- :CONDITION
- :CONSTANT
- :FUNCTION
- :GENERIC-FUNCTION
- :MACRO
- :METHOD
- :METHOD-COMBINATION
- :PACKAGE
- :SETF-EXPANDER
- :STRUCTURE
- :SYMBOL-MACRO
- :TYPE
- :ALIEN-TYPE
- :VARIABLE
- :DECLARATION
-
- (Internal)
- :OPTIMIZER
- :SOURCE-TRANSFORM
- :TRANSFORM
- :VOP
- :IR1-CONVERT
-
-If an unsupported TYPE is requested, the function will return NIL.
-"
+ "Returns a list of DEFINITION-SOURCEs for definitions of NAME with
+the given definition TYPE. TYPE can currently be one of the following.
+
+Public definition TYPEs:
+
+ :CLASS
+ :COMPILER-MACRO
+ :CONDITION
+ :CONSTANT
+ :FUNCTION
+ :GENERIC-FUNCTION
+ :MACRO
+ :METHOD
+ :METHOD-COMBINATION
+ :PACKAGE
+ :SETF-EXPANDER
+ :STRUCTURE
+ :SYMBOL-MACRO
+ :TYPE
+ :ALIEN-TYPE
+ :VARIABLE
+ :DECLARATION
+
+Internal definition TYPEs:
+
+ :OPTIMIZER
+ :SOURCE-TRANSFORM
+ :TRANSFORM
+ :VOP
+ :IR1-CONVERT
+
+Definition types are disjoint. For example, :TYPE refers to DEFTYPEs
+but not CLASSes or SB-ALIEN:DEFINE-ALIEN-TYPE, as those are of
+definition type :CLASS and :ALIEN-TYPE, respectively. :FUNCTION does
+not include :GENERIC-FUNCTION, :CLASS does not include :STRUCTURE,
+etc. :VARIABLE refers to non-constant dynamic variables (e.g. those
+defined with DEFVAR, DEFPARAMETER, SB-EXT:DEFGLOBAL or
+SB-ALIEN:DEFINE-ALIEN-VARIABLE but not with DEFCONSTANT).
+
+Valid NAMEs are generally SYMBOLs with the following exceptions:
+
+- For :COMPILER-MACRO, :FUNCTION, :GENERIC-FUNCTION and :METHOD,
+ anything that's VALID-FUNCTION-NAME-P is valid.
+
+- For :PACKAGE, string designators are valid.
+
+If an unsupported TYPE is requested or NAME is invalid, the function
+will return NIL."
(flet ((get-class (name)
(and (symbolp name)
(find-class name nil)))
@@ -267,25 +281,28 @@ If an unsupported TYPE is requested, the function will return NIL.
(macro-function name))
(find-definition-source (macro-function name))))
((:compiler-macro)
- (when (compiler-macro-function name)
+ (when (and (valid-function-name-p name)
+ (compiler-macro-function name))
(find-definition-source (compiler-macro-function name))))
(:ir1-convert
(let ((converter (info :function :ir1-convert name)))
(and converter
- (find-definition-source converter))))
+ (find-definition-source converter))))
((:function :generic-function)
- (if (fboundp name)
- (when (and (or (consp name)
- (and
- (not (macro-function name))
- (not (special-operator-p name)))))
- (let ((fun (real-fdefinition name)))
- (when (eq (not (typep fun 'generic-function))
- (not (eq type :generic-function)))
- (find-definition-source fun))))
- (let ((dd (info :function :source-transform name)))
- (when (typep dd '(cons defstruct-description))
- (find-definition-sources-by-name (dd-name (car dd)) :structure)))))
+ (when (valid-function-name-p name)
+ (if (fboundp name)
+ (when (and (or (consp name)
+ (and
+ (not (macro-function name))
+ (not (special-operator-p name)))))
+ (let ((fun (real-fdefinition name)))
+ (when (eq (not (typep fun 'generic-function))
+ (not (eq type :generic-function)))
+ (find-definition-source fun))))
+ (let ((dd (info :function :source-transform name)))
+ (when (typep dd '(cons defstruct-description))
+ (find-definition-sources-by-name (dd-name (car dd))
+ :structure))))))
((:type)
;; Source locations for types are saved separately when the expander
;; is a closure without a good source-location.
@@ -296,7 +313,7 @@ If an unsupported TYPE is requested, the function will return NIL.
(when (functionp expander-fun)
(find-definition-source expander-fun))))))
((:method)
- (when (fboundp name)
+ (when (and (valid-function-name-p name) (fboundp name))
(let ((fun (real-fdefinition name)))
(when (typep fun 'generic-function)
(loop for method in (sb-mop::generic-function-methods
@@ -334,10 +351,9 @@ If an unsupported TYPE is requested, the function will return NIL.
(translate-source-location
(sb-pcl::method-combination-info-source-location info)))))
((:package)
- (when (symbolp name)
- (let ((package (find-package name)))
- (when package
- (find-definition-source package)))))
+ (let ((package (ignore-errors (find-package name))))
+ (when package
+ (find-definition-source package))))
;; TRANSFORM and OPTIMIZER handling from swank-sbcl
((:transform)
(let ((fun-info (info :function :info name)))
@@ -379,11 +395,11 @@ If an unsupported TYPE is requested, the function will return NIL.
(sb-c::fun-info-flushable . sb-c::flushable))))
(loop for (reader . name) in otypes
for fn = (funcall reader fun-info)
- when (functionp fn) collect
- (let ((source (find-definition-source fn)))
- (setf (definition-source-description source)
- (list name))
- source))))))
+ when (functionp fn)
+ collect (let ((source (find-definition-source fn)))
+ (setf (definition-source-description source)
+ (list name))
+ source))))))
(:vop
(find-vop-source name))
(:alien-type
@@ -392,10 +408,10 @@ If an unsupported TYPE is requested, the function will return NIL.
(translate-source-location loc))))
((:source-transform)
(let* ((transform-fun
- (or (info :function :source-transform name)
- (and (typep name '(cons (eql setf) (cons symbol null)))
- (info :function :source-transform
- (second name)))))
+ (or (info :function :source-transform name)
+ (and (typep name '(cons (eql setf) (cons symbol null)))
+ (info :function :source-transform
+ (second name)))))
;; A cons for the :source-transform is essentially the same
;; info that was formerly in :structure-accessor.
(accessor (and (consp transform-fun) (cdr transform-fun))))
@@ -409,12 +425,12 @@ If an unsupported TYPE is requested, the function will return NIL.
(let ((locations (info :source-location :declaration name)))
(loop for (kind loc) on locations by #'cddr
when loc
- collect (let ((loc (translate-source-location loc)))
- (setf (definition-source-description loc)
- ;; Copy list to ensure that user code
- ;; cannot mutate the original.
- (copy-list (ensure-list kind)))
- loc))))
+ collect (let ((loc (translate-source-location loc)))
+ (setf (definition-source-description loc)
+ ;; Copy list to ensure that user code
+ ;; cannot mutate the original.
+ (copy-list (ensure-list kind)))
+ loc))))
(t
nil)))))
diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index 5f099cbab..9da19a249 100644
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -8,7 +8,7 @@
;;;; files for more information.
(defpackage :sb-introspect-test
- (:import-from #:test-util #:deftest)
+ (:import-from #:test-util #:deftest #:with-test)
(:use "SB-INTROSPECT" "CL"))
(in-package :sb-introspect-test)
@@ -75,7 +75,7 @@
'(x &key (b "abc")))
t)
-(test-util:with-test (:name definition-source.1 :skipped-on :no-source-locs)
+(with-test (:name definition-source.1 :skipped-on :no-source-locs)
#+sb-devel
(assert (consp (find-definition-sources-by-name 'vectorp :vop)))
(assert (consp (find-definition-sources-by-name 'check-type :macro))))
@@ -97,7 +97,7 @@
;;; The behavior of :SOURCE-PLIST on nested WITH-COMPILATION-UNIT
;;; is to append. This is documented in source/compiler/main
-(test-util:with-test (:name :definition-source-plist.2)
+(with-test (:name :definition-source-plist.2)
(let ((plist (definition-source-plist
(find-definition-source #'cl-user::four))))
(assert (equal (getf plist :test-outer) "OUT"))
@@ -127,25 +127,25 @@
(matchp #'cl-user::one 2)
t)
-(test-util:with-test (:name find-source-stuff.3 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.3 :skipped-on :no-source-locs)
(assert (matchp-name :generic-function 'cl-user::two 3)))
-(test-util:with-test (:name find-source-stuff.4 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.4 :skipped-on :no-source-locs)
(assert (matchp (car (sb-mop:generic-function-methods #'cl-user::two)) 4)))
-(test-util:with-test (:name find-source-stuff.5 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.5 :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::*a* 8)))
-(test-util:with-test (:name find-source-stuff.6 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.6 :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::*b* 9)))
-(test-util:with-test (:name find-source-stuff.7 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.7 :skipped-on :no-source-locs)
(assert (matchp-name :class 'cl-user::a 10)))
-(test-util:with-test (:name find-source-stuff.8 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.8 :skipped-on :no-source-locs)
(assert (matchp-name :condition 'cl-user::b 11)))
-(test-util:with-test (:name find-source-stuff.9 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.9 :skipped-on :no-source-locs)
(assert (matchp-name :structure 'cl-user::c 12)))
(deftest find-source-stuff.10
@@ -156,7 +156,7 @@
(matchp-name :function 'cl-user::c-e 12)
t)
-(test-util:with-test (:name find-source-stuff.12 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.12 :skipped-on :no-source-locs)
(assert (matchp-name :structure 'cl-user::d 13)))
(deftest find-source-stuff.13
@@ -167,16 +167,16 @@
(matchp-name :function 'cl-user::d-e 13)
t)
-(test-util:with-test (:name find-source-stuff.15 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.15 :skipped-on :no-source-locs)
(assert (matchp-name :package 'cl-user::e 14)))
-(test-util:with-test (:name find-source-stuff.16 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.16 :skipped-on :no-source-locs)
(assert (matchp-name :symbol-macro 'cl-user::f 15)))
-(test-util:with-test (:name find-source-stuff.17 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.17 :skipped-on :no-source-locs)
(assert (matchp-name :type 'cl-user::g 16)))
-(test-util:with-test (:name find-source-stuff.18 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.18 :skipped-on :no-source-locs)
(assert (matchp-name :constant 'cl-user::+h+ 17)))
(deftest find-source-stuff.19
@@ -199,7 +199,7 @@
(matchp-name :function '(setf cl-user::o) 23)
t)
-(test-util:with-test (:name find-source-stuff.24 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.24 :skipped-on :no-source-locs)
(assert (matchp-name :method '(setf cl-user::p) 24)))
(deftest find-source-stuff.25
@@ -207,7 +207,7 @@
t)
-(test-util:with-test (:name find-source-stuff.26 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.26 :skipped-on :no-source-locs)
(assert (matchp-name :method-combination 'cl-user::r 26)))
@@ -243,7 +243,7 @@
(matchp-name :function 'cl-user::loaded-as-source-fun 3)
t)
-(test-util:with-test (:name find-source-stuff.33 :skipped-on :no-source-locs)
+(with-test (:name find-source-stuff.33 :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::**global** 29)))
;;; Check wrt. interplay of generic functions and their methods.
@@ -371,7 +371,7 @@
(tai 42s0 :immediate nil)
t)
-(test-util:with-test (:name :allocation-information.4
+(with-test (:name :allocation-information.4
;; Ignored as per the comment above, even though it seems
;; unlikely that this is the right condition.
:fails-on (or :ppc64 (and :sparc :gencgc)))
@@ -388,7 +388,7 @@
(setq *large-obj* (make-array (* sb-vm:gencgc-page-bytes 4)
:element-type '(unsigned-byte 8)))
(sb-ext:gc :gen 1) ; Array won't move to a large unboxed page until GC'd
- (test-util:with-test (:name allocation-information.5
+ (with-test (:name allocation-information.5
:skipped-on :mark-region-gc) ; doesn't move to an unboxed page
(tai *large-obj* :heap
`(:space :dynamic :generation 1 :boxed nil :pinned nil :large t)
@@ -736,19 +736,19 @@
t
t)
-(test-util:with-test (:name alien-type.1 :skipped-on :no-source-locs)
+(with-test (:name alien-type.1 :skipped-on :no-source-locs)
(assert (matchp-name :alien-type 'cl-user::test-alien-type 30)))
-(test-util:with-test (:name alien-type.2 :skipped-on :no-source-locs)
+(with-test (:name alien-type.2 :skipped-on :no-source-locs)
(assert (matchp-name :alien-type 'cl-user::test-alien-struct 31)))
-(test-util:with-test (:name alien-variable :skipped-on :no-source-locs)
+(with-test (:name alien-variable :skipped-on :no-source-locs)
(assert (matchp-name :variable 'cl-user::test-alien-var 32)))
-(test-util:with-test (:name condition-slot-reader :skipped-on :no-source-locs)
+(with-test (:name condition-slot-reader :skipped-on :no-source-locs)
(matchp-name :method 'cl-user::condition-slot-reader 33))
-(test-util:with-test (:name condition-slot-writer :skipped-on :no-source-locs)
+(with-test (:name condition-slot-writer :skipped-on :no-source-locs)
(matchp-name :method 'cl-user::condition-slot-writer 33))
(deftest function-with-a-local-function
@@ -808,3 +808,42 @@
(and (>= (length callers) 5)
(not (null (member #'sb-c::find-dominators callers)))))
t)
+
+(defparameter *definition-types*
+ '(:class
+ :compiler-macro
+ :condition
+ :constant
+ :function
+ :generic-function
+ :macro
+ :method
+ :method-combination
+ :package
+ :setf-expander
+ :structure
+ :symbol-macro
+ :type
+ :alien-type
+ :variable
+ :declaration
+ :optimizer
+ :source-transform
+ :transform
+ :vop
+ :ir1-convert))
+
+(with-test (:name :find-definition-sources-by-name-error-handling)
+ (dolist (definition-type *definition-types*)
+ (assert (null (sb-introspect:find-definition-sources-by-name
+ 7 definition-type)))
+ (assert (null (sb-introspect:find-definition-sources-by-name
+ "xxx" definition-type)))
+ (assert (null (sb-introspect:find-definition-sources-by-name
+ '(setf (setf xxx)) definition-type))))
+ (assert (null (sb-introspect:find-definition-sources-by-name 'print :junk))))
+
+(with-test (:name (:find-definition-sources-by-name :package))
+ (assert (sb-introspect:find-definition-sources-by-name "CL" :package))
+ (assert (sb-introspect:find-definition-sources-by-name :cl :package))
+ (assert (null (sb-introspect:find-definition-sources-by-name #\a :package))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL