1.0.24.5: SB-INTROSPECT: rename FUNCTION-ARGLIST to FUNCTION-LAMBDA-LIST

[sbcl.git] / contrib / sb-introspect / sb-introspect.lisp

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index e54f5c4..d962f6c 100644 (file)
--- 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)