* bug fix: restore buildability on the MIPS platform. (regression from
1.0.30.38, reported by Samium Gromoff)
* bug fix: inspecting closures is less likely to fail with a type error.
+ * new feature: SB-INTROSPECT:WHO-SPECIALIZES-DIRECTLY to get a list of
+ definitions for methods specializing on the passed class itself.
+ * new feature: SB-INTROSPECT:WHO-SPECIALIZES-GENERALLY to get a list of
+ definitions for methods specializing on the passed class itself, or on
+ subclasses of it.
changes in sbcl-1.0.32 relative to sbcl-1.0.31:
* optimization: faster FIND and POSITION on strings of unknown element type
"WHO-CALLS"
"WHO-REFERENCES"
"WHO-SETS"
- "WHO-MACROEXPANDS"))
+ "WHO-MACROEXPANDS"
+ "WHO-SPECIALIZES-DIRECTLY"
+ "WHO-SPECIALIZES-GENERALLY"))
(in-package :sb-introspect)
definition-source pairs."
(collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
+(defun who-specializes-directly (class-designator)
+ "Search for source locations of methods directly specializing on
+CLASS-DESIGNATOR. Returns an alist of method name, definition-source
+pairs.
+
+A method matches the criterion either if it specializes on the same
+class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
+specializers), or if it eql-specializes on an instance of the
+designated class.
+
+Experimental.
+"
+ (let ((class (canonicalize-class-designator class-designator)))
+ (let ((result (collect-specializing-methods
+ #'(lambda (specl)
+ ;; Does SPECL specialize on CLASS directly?
+ (typecase specl
+ (sb-pcl::class-eq-specializer
+ (eq (sb-pcl::specializer-object specl) class))
+ (sb-pcl::eql-specializer
+ (let ((obj (sb-mop:eql-specializer-object specl)))
+ (eq (class-of obj) class)))
+ ((not sb-pcl::standard-specializer)
+ nil)
+ (t
+ (eq specl class)))))))
+ (map-into result #'(lambda (m)
+ (cons `(method ,(method-generic-function-name m))
+ (find-definition-source m)))
+ result))))
+
+(defun who-specializes-generally (class-designator)
+ "Search for source locations of methods specializing on
+CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
+name, definition-source pairs.
+
+A method matches the criterion either if it specializes on the
+designated class itself or a subclass of it (this includes CLASS-EQ
+specializers), or if it eql-specializes on an instance of the
+designated class or a subclass of it.
+
+Experimental.
+"
+ (let ((class (canonicalize-class-designator class-designator)))
+ (let ((result (collect-specializing-methods
+ #'(lambda (specl)
+ ;; Does SPECL specialize on CLASS or a subclass
+ ;; of it?
+ (typecase specl
+ (sb-pcl::class-eq-specializer
+ (subtypep (sb-pcl::specializer-object specl) class))
+ (sb-pcl::eql-specializer
+ (typep (sb-mop:eql-specializer-object specl) class))
+ ((not sb-pcl::standard-specializer)
+ nil)
+ (t
+ (subtypep specl class)))))))
+ (map-into result #'(lambda (m)
+ (cons `(method ,(method-generic-function-name m))
+ (find-definition-source m)))
+ result))))
+
+(defun canonicalize-class-designator (class-designator)
+ (etypecase class-designator
+ (symbol (find-class class-designator))
+ (class class-designator)))
+
+(defun method-generic-function-name (method)
+ (sb-mop:generic-function-name (sb-mop:method-generic-function method)))
+
+(defun collect-specializing-methods (predicate)
+ (let ((result '()))
+ (sb-pcl::map-specializers
+ #'(lambda (specl)
+ (when (funcall predicate specl)
+ (let ((methods (sb-mop:specializer-direct-methods specl)))
+ (setf result (append methods result))))))
+ (delete-duplicates result)))
+
+
;;;; ALLOCATION INTROSPECTION
(defun allocation-information (object)
(:file "test-driver" :depends-on ("test"))))
(defmethod perform ((op test-op) (com (eql (find-system :sb-introspect-tests))))
- (or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
- (error "~S failed" 'test-op)))
+ ;; N.b. At least DEFINITION-SOURCE-PLIST.1 assumes that CWD is the
+ ;; contrib/sb-introspect directory which is true for when this is
+ ;; implicitly run via make-target-contribs.sh -- but not when this
+ ;; is executed manually.
+ (let ((*default-pathname-defaults*
+ (make-pathname :directory (pathname-directory
+ '#.(or *compile-file-pathname*
+ *load-pathname*)))))
+ (or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
+ (error "~S failed" 'test-op))))
(inline/4 :a :b :c))
;;; Test references to / from compiler-macros
+
+
+;;; Test specialization
+
+(defclass a-class () ())
+(defclass a-subclass (a-class) ())
+
+(defstruct a-structure)
+(defstruct (a-substructure (:include a-structure)))
+
+(defvar *an-instance-of-a-class* (make-instance 'a-class))
+(defvar *an-instance-of-a-subclass* (make-instance 'a-subclass))
+
+(defvar *an-instance-of-a-structure* (make-a-structure))
+(defvar *an-instance-of-a-substructure* (make-a-substructure))
+
+(defmethod a-gf-1 ((x a-class)))
+(defmethod a-gf-1 ((x a-structure)))
+
+(defmethod a-gf-2 ((x (eql *an-instance-of-a-class*))))
+(defmethod a-gf-2 ((x (eql *an-instance-of-a-structure*))))
+
+(defmethod a-gf-3 ((x (eql *an-instance-of-a-subclass*))))
+(defmethod a-gf-3 ((x (eql *an-instance-of-a-substructure*))))
(in-package :sb-introspect-test/xref)
-(deftest xrefs
- (labels ((natural< (a b)
- (string< (princ-to-string a) (princ-to-string b))))
- (let ((tests '(((sb-introspect::who-calls 'foo) ())
- ((sb-introspect::who-calls 'bar) (xref/1 xref/3))
- ((sb-introspect::who-calls 'xref/1) (xref/2))
- ((sb-introspect::who-calls 'xref/2)
- (xref/5 xref/6 xref/8 xref/8 xref/12
- (sb-pcl::fast-method xref/10
- (t t t t t t t t fixnum))
- (sb-pcl::fast-method xref/11 (fixnum))))
- ((sb-introspect::who-calls 'xref/3)
- (inline/1 (sb-pcl::fast-method xref/11 (float))))
- ((sb-introspect::who-calls 'xref/4) ())
- ((sb-introspect::who-calls 'xref/5) ())
- ((sb-introspect::who-calls 'xref/6) (xref/7))
- ((sb-introspect::who-calls 'xref/7) ())
- ((sb-introspect::who-calls 'xref/8) ())
- ((sb-introspect::who-calls 'xref/10) ())
- ((sb-introspect::who-calls 'xref/11) ())
- ((sb-introspect::who-calls 'inline/1) (xref/12))
- ((sb-introspect::who-calls 'xref/12) (macro/1))
- ((sb-introspect::who-calls 'inline/3)
- (inline/3-user/1 inline/3-user/2 inline/3-user/3 inline/3-user/4))
- ((sb-introspect::who-calls 'inline/4) (inline/4-user))
- ((sb-introspect::who-macroexpands 'macro/1)
- (macro-use/1 macro-use/2 macro-use/3 macro-use/4 inline/2))
- ((sb-introspect::who-binds '*a*) (xref/2))
- ((sb-introspect::who-sets '*a*) (xref/2 xref/13))
- ((sb-introspect::who-references '*a*)
- (xref/1 xref/2 xref/4 inline/1 xref/14))
- ((sb-introspect::who-references '+z+)
- (inline/1)))))
- (loop for x in tests
- for form = (first x)
- for wanted = (sort (second x) #'natural<)
- for result = (sort (loop for name in (eval form)
- collect (car name))
- #'natural<)
- do (unless (equalp wanted result)
- (return (format nil "form=~a~%wanted=~a~%result=~a~%"
- form wanted result))))))
+(defmacro define-xref-test (name form result)
+ `(deftest ,name
+ (sort (mapcar #'first ,form) #'string< :key #'princ-to-string)
+ ,(sort (copy-list result) #'string< :key #'princ-to-string)))
+
+(define-xref-test who-calls.1
+ (who-calls 'foo)
nil)
+(define-xref-test who-calls.2
+ (who-calls 'bar)
+ (xref/1 xref/3))
+
+(define-xref-test who-calls.3
+ (who-calls 'xref/1)
+ (xref/2))
+
+(define-xref-test who-calls.4
+ (who-calls 'xref/2)
+ (xref/5
+ xref/6
+ xref/8
+ xref/8
+ xref/12
+ (sb-pcl::fast-method xref/10 (t t t t t t t t fixnum))
+ (sb-pcl::fast-method xref/11 (fixnum))))
+
+(define-xref-test who-calls.5
+ (who-calls 'xref/3)
+ (inline/1 (sb-pcl::fast-method xref/11 (float))))
+
+(define-xref-test who-calls.6
+ (who-calls 'xref/4)
+ nil)
+
+(define-xref-test who-calls.7
+ (who-calls 'xref/5)
+ nil)
+
+(define-xref-test who-calls.8
+ (who-calls 'xref/6)
+ (xref/7))
+
+(define-xref-test who-calls.9
+ (who-calls 'xref/7)
+ nil)
+
+(define-xref-test who-calls.10
+ (who-calls 'xref/8)
+ nil)
+
+(define-xref-test who-calls.11
+ (who-calls 'xref/10)
+ nil)
+(define-xref-test who-calls.12
+ (who-calls 'xref/11)
+ nil)
+
+(define-xref-test who-calls.13
+ (who-calls 'inline/1)
+ (xref/12))
+
+(define-xref-test who-calls.14
+ (who-calls 'xref/12)
+ (macro/1))
+
+(define-xref-test who-calls.15
+ (who-calls 'inline/3)
+ (inline/3-user/1
+ inline/3-user/2
+ inline/3-user/3
+ inline/3-user/4))
+
+(define-xref-test who-calls.16
+ (who-calls 'inline/4)
+ (inline/4-user))
+
+
+(define-xref-test who-macroexpands.1
+ (who-macroexpands 'macro/1)
+ (macro-use/1
+ macro-use/2
+ macro-use/3
+ macro-use/4
+ inline/2))
+
+
+(define-xref-test who-binds.1
+ (who-binds '*a*)
+ (xref/2))
+
+
+(define-xref-test who-sets.1
+ (who-sets '*a*)
+ (xref/2 xref/13))
+
+
+(define-xref-test who-references.1
+ (who-references '*a*)
+ (xref/1 xref/2 xref/4 inline/1 xref/14))
+
+(define-xref-test who-references.2
+ (who-references '+z+)
+ (inline/1))
+
+
+(define-xref-test who-specializes-directly.1
+ (who-specializes-directly 'a-class)
+ ((method a-gf-1)
+ (method a-gf-2)))
+
+(define-xref-test who-specializes-directly.2
+ (who-specializes-directly 'a-structure)
+ ((method a-gf-1)
+ (method a-gf-2)))
+
+(define-xref-test who-specializes-generally.1
+ (who-specializes-generally 'a-class)
+ ((method a-gf-1)
+ (method a-gf-2)
+ (method a-gf-3)))
+
+(define-xref-test who-specializes-generally.2
+ (who-specializes-generally 'a-structure)
+ ((method a-gf-1)
+ (method a-gf-2)
+ (method a-gf-3)))
\ No newline at end of file
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.32.5"
+"1.0.32.6"
projects / sbcl.git / commitdiff