X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=bc406b322e9d0c75134bd9a9fe2a1dcd7d424880;hb=0e5c6a3b77adf6bcd2e7f7c7ac5bbfc684602274;hp=1b97c67742eb50316cd0055e3c4443685a4d0d66;hpb=e63e13ad45816c530f89da13415f4ed0129c9d1c;p=sbcl.git

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 1b97c67..bc406b3 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -31,6 +31,7 @@
   (:export "ALLOCATION-INFORMATION"
            "FUNCTION-ARGLIST"
            "FUNCTION-LAMBDA-LIST"
+           "FUNCTION-TYPE"
            "DEFTYPE-LAMBDA-LIST"
            "VALID-FUNCTION-NAME-P"
            "FIND-DEFINITION-SOURCE"
@@ -95,7 +96,8 @@ include the pathname of the file and the position of the definition."
   (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
 
 (defun valid-function-name-p (name)
-  "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION "
+  "True if NAME denotes a valid function name, ie. one that can be passed to
+FBOUNDP."
   (and (sb-int:valid-function-name-p name) t))
 
 ;;;; Finding definitions
@@ -422,14 +424,10 @@ If an unsupported TYPE is requested, the function will return NIL.
     ;; FIXME there may be other structure predicate functions
     (member self (list *struct-predicate*))))
 
-(defun function-arglist (function)
-  "Deprecated alias for FUNCTION-LAMBDA-LIST."
+(sb-int:define-deprecated-function :late "1.0.24.5" function-arglist function-lambda-list
+    (function)
   (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,
@@ -465,6 +463,33 @@ value."
            (sb-int:info :type :lambda-list typespec-operator))))
     (t (values nil nil))))
 
+(defun function-type (function-designator)
+  "Returns the ftype of FUNCTION-DESIGNATOR, or NIL."
+  (flet ((ftype-of (function-designator)
+           (sb-kernel:type-specifier
+            (sb-int:info :function :type function-designator))))
+    (etypecase function-designator
+      (symbol
+       (when (and (fboundp function-designator)
+                  (not (macro-function function-designator))
+                  (not (special-operator-p function-designator)))
+         (ftype-of function-designator)))
+      (cons
+       (when (and (sb-int:legal-fun-name-p function-designator)
+                  (fboundp function-designator))
+         (ftype-of function-designator)))
+      (generic-function
+       (function-type (sb-pcl:generic-function-name function-designator)))
+      (function
+       ;; Give declared type in globaldb priority over derived type
+       ;; because it contains more accurate information e.g. for
+       ;; struct-accessors.
+       (let ((type (function-type (sb-kernel:%fun-name
+                                   (sb-impl::%fun-fun function-designator)))))
+         (if type
+             type
+             (sb-impl::%fun-type function-designator)))))))
+
 (defun struct-accessor-structure-class (function)
   (let ((self (sb-vm::%simple-fun-self function)))
     (cond
@@ -758,6 +783,15 @@ For :HEAP objects the secondary value is a plist:
     even if :PINNED in NIL if the GC has not had the need to mark the the page
     as pinned. (GENCGC and :SPACE :DYNAMIC only.)
 
+  :WRITE-PROTECTED
+    Indicates that the page on which the object starts is write-protected,
+    which indicates for :BOXED objects that it hasn't been written to since
+    the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)
+
+  :PAGE
+    The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC
+    only.)
+
 For :STACK objects secondary value is the thread on whose stack the object is
 allocated.
 
@@ -805,7 +839,8 @@ Experimental: interface subject to change."
                                    :write-protected (logbitp 0 flags)
                                    :boxed (logbitp 2 flags)
                                    :pinned (logbitp 5 flags)
-                                   :large (logbitp 6 flags)))))
+                                   :large (logbitp 6 flags)
+                                   :page index))))
                        (list :space space))
                    #-gencgc
                    (list :space space))))))