X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=1e28bc88b5daaa0585bcc9ff85066a86e9139ec8;hb=7c75cd363da90afe334e936aad2b63437ea5905d;hp=f0312845f06e4500542c0b9b8893661de15679ed;hpb=c000ff1b6d3dbfc0c0b993cfb36f80ec301bda71;p=sbcl.git

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index f031284..1e28bc8 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"
@@ -358,7 +359,7 @@ If an unsupported TYPE is requested, the function will return NIL.
     ((or condition standard-object structure-object)
      (find-definition-source (class-of object)))
     (t
-     (error "Don't know how to retrieve 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)
@@ -451,7 +452,46 @@ function designator."
   "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))
+  (check-type typespec-operator symbol)
+  (case (sb-int:info :type :kind typespec-operator)
+    (:defined
+     (sb-int:info :type :lambda-list typespec-operator))
+    (:primitive
+     (let ((translator-fun (sb-int:info :type :translator typespec-operator)))
+       (if translator-fun
+           (values (sb-kernel:%fun-lambda-list translator-fun) t)
+           ;; Some builtin types (e.g. STRING) do not have a
+           ;; translator, but they were actually defined via DEFTYPE
+           ;; in src/code/deftypes-for-target.lisp.
+           (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)))