X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=d962f6cf7fb68a4b5221240c9d046f9b6e0b2587;hb=d56803388a0a0a35e1889596f928b367c650c15b;hp=e54f5c4be8c6f58cafbd9edf7ed9ef6cc2af8921;hpb=79709834471d14949535d30ef05fdd2d1c80adac;p=sbcl.git diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index e54f5c4..d962f6c 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -25,6 +25,8 @@ (defpackage :sb-introspect (:use "CL") (:export "FUNCTION-ARGLIST" + "FUNCTION-LAMBDA-LIST" + "DEFTYPE-LAMBDA-LIST" "VALID-FUNCTION-NAME-P" "FIND-DEFINITION-SOURCE" "FIND-DEFINITION-SOURCES-BY-NAME" @@ -186,9 +188,14 @@ If an unsupported TYPE is requested, the function will return NIL. (not (eq type :generic-function))) (find-definition-source fun))))) ((:type) - (let ((expander-fun (sb-int:info :type :expander name))) - (when expander-fun - (find-definition-source expander-fun)))) + ;; Source locations for types are saved separately when the expander + ;; is a closure without a good source-location. + (let ((loc (sb-int:info :type :source-location name))) + (if loc + (translate-source-location loc) + (let ((expander-fun (sb-int:info :type :expander name))) + (when expander-fun + (find-definition-source expander-fun)))))) ((:method) (when (fboundp name) (let ((fun (real-fdefinition name))) @@ -224,11 +231,12 @@ If an unsupported TYPE is requested, the function will return NIL. (find-definition-source class))))) ((:method-combination) (let ((combination-fun - (ignore-errors (find-method #'sb-mop:find-method-combination - nil - (list (find-class 'generic-function) - (list 'eql name) - t))))) + (find-method #'sb-mop:find-method-combination + nil + (list (find-class 'generic-function) + (list 'eql name) + t) + nil))) (when combination-fun (find-definition-source combination-fun)))) ((:package) @@ -320,8 +328,11 @@ If an unsupported TYPE is requested, the function will return NIL. (when source (setf (definition-source-description source) (append (method-qualifiers object) - (sb-pcl::unparse-specializers - (sb-mop:method-specializers object))))) + (if (sb-mop:method-generic-function object) + (sb-pcl::unparse-specializers + (sb-mop:method-generic-function object) + (sb-mop:method-specializers object)) + (sb-mop:method-specializers object))))) source)) #+sb-eval (sb-eval:interpreted-function @@ -337,8 +348,10 @@ If an unsupported TYPE is requested, the function will return NIL. (struct-predicate-structure-class object))) (t (find-function-definition-source object)))) + ((or condition standard-object structure-object) + (find-definition-source (class-of object))) (t - (error "Don't know how to retrive source location for a ~S~%" + (error "Don't know how to retrieve source location for a ~S~%" (type-of object))))) (defun find-function-definition-source (function) @@ -348,8 +361,14 @@ If an unsupported TYPE is requested, the function will return NIL. (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) (make-definition-source :pathname - (if (eql (sb-c::debug-source-from debug-source) :file) - (parse-namestring (sb-c::debug-source-name debug-source))) + ;; KLUDGE: at the moment, we don't record the correct toplevel + ;; form number for forms processed by EVAL (including EVAL-WHEN + ;; :COMPILE-TOPLEVEL). Until that's fixed, don't return a + ;; DEFINITION-SOURCE with a pathname. (When that's fixed, take + ;; out the (not (debug-source-form ...)) test. + (if (and (sb-c::debug-source-namestring debug-source) + (not (sb-c::debug-source-form debug-source))) + (parse-namestring (sb-c::debug-source-namestring debug-source))) :character-offset (if tlf (elt (sb-c::debug-source-start-positions debug-source) tlf)) @@ -396,22 +415,36 @@ If an unsupported TYPE is requested, the function will return NIL. ;; FIXME there may be other structure predicate functions (member self (list *struct-predicate*)))) -;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST? (defun function-arglist (function) + "Deprecated alias for FUNCTION-LAMBDA-LIST." + (function-lambda-list function)) + +(define-compiler-macro function-arglist (function) + (sb-int:deprecation-warning 'function-arglist 'function-lambda-list) + `(function-lambda-list ,function)) + +(defun function-lambda-list (function) "Describe the lambda list for the extended function designator FUNCTION. -Works for special-operators, macros, simple functions, -interpreted functions, and generic functions. Signals error if -not found" +Works for special-operators, macros, simple functions, interpreted functions, +and generic functions. Signals an error if FUNCTION is not a valid extended +function designator." (cond ((valid-function-name-p function) - (function-arglist (or (and (symbolp function) - (macro-function function)) - (fdefinition function)))) + (function-lambda-list (or (and (symbolp function) + (macro-function function)) + (fdefinition function)))) ((typep function 'generic-function) (sb-pcl::generic-function-pretty-arglist function)) #+sb-eval ((typep function 'sb-eval:interpreted-function) (sb-eval:interpreted-function-lambda-list function)) - (t (sb-kernel:%simple-fun-arglist (sb-kernel:%fun-fun function))))) + (t + (sb-kernel:%simple-fun-arglist (sb-kernel:%fun-fun function))))) + +(defun deftype-lambda-list (typespec-operator) + "Returns the lambda list of TYPESPEC-OPERATOR as first return +value, and a flag whether the arglist could be found as second +value." + (sb-int:info :type :lambda-list typespec-operator)) (defun struct-accessor-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) @@ -494,7 +527,8 @@ list of the symbols :dynamic, :static, or :read-only." (lambda (obj header size) (when (= sb-vm:code-header-widetag header) (funcall fn obj size))) - space))) + space + t))) (declaim (inline map-caller-code-components)) (defun map-caller-code-components (function spaces fn)