From e5334bc7f2c88a5819e45e2d6e1cfe18af355169 Mon Sep 17 00:00:00 2001 From: trittweiler Date: Fri, 30 Oct 2009 18:10:38 +0000 Subject: [PATCH] 1.0.32.6: WHO-SPECIALIZES-DIRECTLY & WHO-SPECIALIZES-GENERALLY * Add two new Xref functions to SB-INTROSPECT: WHO-SPECIALIZES-DIRECTLY returns method definitions which specialize one the designated class itself. WHO-SPECIALIZES-GENERALLY returns methods definitions which specialize on the designated class, or subclasses of it. Both take CLASS-EQ, and EQL specializers into account. * Refactor xref tests, and add tests for the two new functions. * Fix sb-introspect.asd to perform the test-op with a *D-P-D* bound to contrib/sb-introspect/. --- NEWS | 5 + contrib/sb-introspect/introspect.lisp | 84 ++++++++++++++- contrib/sb-introspect/sb-introspect.asd | 12 ++- contrib/sb-introspect/xref-test-data.lisp | 24 +++++ contrib/sb-introspect/xref-test.lisp | 167 +++++++++++++++++++++-------- version.lisp-expr | 2 +- 6 files changed, 248 insertions(+), 46 deletions(-) diff --git a/NEWS b/NEWS index eb79254..4ab65d9 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,11 @@ changes relative to sbcl-1.0.32: * 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 diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index 5f46ae6..735d92f 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -48,7 +48,9 @@ "WHO-CALLS" "WHO-REFERENCES" "WHO-SETS" - "WHO-MACROEXPANDS")) + "WHO-MACROEXPANDS" + "WHO-SPECIALIZES-DIRECTLY" + "WHO-SPECIALIZES-GENERALLY")) (in-package :sb-introspect) @@ -624,6 +626,86 @@ macro MACRO-NAME is expanded. Returns a list of function name, 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) diff --git a/contrib/sb-introspect/sb-introspect.asd b/contrib/sb-introspect/sb-introspect.asd index b484c23..bb1cbaa 100644 --- a/contrib/sb-introspect/sb-introspect.asd +++ b/contrib/sb-introspect/sb-introspect.asd @@ -46,5 +46,13 @@ (: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)))) diff --git a/contrib/sb-introspect/xref-test-data.lisp b/contrib/sb-introspect/xref-test-data.lisp index a839a44..ff44e10 100644 --- a/contrib/sb-introspect/xref-test-data.lisp +++ b/contrib/sb-introspect/xref-test-data.lisp @@ -195,3 +195,27 @@ (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*)))) diff --git a/contrib/sb-introspect/xref-test.lisp b/contrib/sb-introspect/xref-test.lisp index ee445a5..923ce81 100644 --- a/contrib/sb-introspect/xref-test.lisp +++ b/contrib/sb-introspect/xref-test.lisp @@ -9,46 +9,129 @@ (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 diff --git a/version.lisp-expr b/version.lisp-expr index 7212c30..6752b04 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4