1.0.35.12: Add SB-INTROSPECT:FUNCTION-TYPE.

  * New function which takes a function designator and returns the
    function's declared, or derived FTYPE.

diff --git a/NEWS b/NEWS
index ac7a6a6..e81b62b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.0.35:
+  * new feature: SB-INTROSPECT:FUNCTION-TYPE takes a function-designator and
+    returns the function's declared, or derived FTYPE.
   * new feature: SB-POSIX now supports accessing the d_ino member of
     dirent structures.  (Thanks to Philipp Marek and Pierre THEIRRY)
   * new feature: MAKE-RANDOM-STATE has been extended to accept octet vectors,

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 1b97c67..1e28bc8 100644 (file)
--- 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"
@@ -465,6 +466,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

diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index f482b8d..f1c896b 100644 (file)
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -151,12 +151,10 @@
     (matchp-name :function  '(setf cl-user::o) 23)
   t)
 
-
 (deftest find-source-stuff.24
     (matchp-name :method  '(setf cl-user::p) 24)
   t)
 
-
 (deftest find-source-stuff.25
     (matchp-name :macro  'cl-user::q 25)
   t)
@@ -344,3 +342,183 @@
    (deftest allocation-information.thread.3
        (thread-tai2)
      t))
+
+;;;; Test FUNCTION-TYPE
+
+(defun type-equal (typespec1 typespec2)
+  (or (equal typespec1 typespec2)   ; TYPE= punts on &keywords in FTYPEs.
+      (sb-kernel:type= (sb-kernel:values-specifier-type typespec1)
+                       (sb-kernel:values-specifier-type typespec2))))
+
+(defmacro interpret (form)
+  `(let ((sb-ext:*evaluator-mode* :interpret))
+     (eval ',form)))
+
+;; Functions
+
+(declaim (ftype (function (integer &optional string) string) moon))
+(defun moon (int &optional suffix)
+  (concatenate 'string (princ-to-string int) suffix))
+
+(deftest function-type.1
+    (values (type-equal (function-type 'moon) (function-type #'moon))
+            (type-equal (function-type #'moon)
+                        '(function (integer &optional string)
+                          (values string &rest t))))
+  t t)
+
+(defun sun (x y &key k1)
+  (declare (fixnum x y))
+  (declare (boolean k1))
+  (declare (ignore x y k1))
+  t)
+
+(deftest function-type.2
+    (values (type-equal (function-type 'sun) (function-type #'sun))
+            ;; Does not currently work due to Bug #384892. (1.0.31.26)
+            #+nil
+            (type-equal (function-type #'sun)
+                        '(function (fixnum fixnum &key (:k1 (member nil t)))
+                          (values (member t) &optional))))
+  t #+nil t)
+
+;; Local functions
+
+(deftest function-type.5
+    (flet ((f (s)
+             (declare (symbol s))
+             (values (symbol-name s))))
+      (type-equal (function-type #'f)
+                  '(function (symbol) (values simple-string &optional))))
+  t)
+
+;; Closures
+
+(deftest function-type.6
+    (let ((x 10))
+      (declare (fixnum x))
+      (flet ((closure (y)
+               (declare (fixnum y))
+               (setq x (+ x y))))
+        (type-equal (function-type #'closure)
+                    '(function (fixnum) (values fixnum &optional)))))
+  t)
+
+;; Anonymous functions
+
+(deftest function-type.7
+    (type-equal (function-type #'(lambda (x) (declare (fixnum x)) x))
+                '(function (fixnum) (values fixnum &optional)))
+  t)
+
+;; Interpreted functions
+
+(deftest function-type.8
+    (type-equal (function-type (interpret (lambda (x) (declare (fixnum x)) x)))
+                '(function (&rest t) *))
+  t)
+
+;; Generic functions
+
+(defgeneric earth (x y))
+
+(deftest function-type+gfs.1
+    (values (type-equal (function-type 'earth) (function-type #'earth))
+            (type-equal (function-type 'earth) '(function (t t) *)))
+  t t)
+
+;; Implicitly created generic functions.
+
+;; (FUNCTION-TYPE 'MARS) => FUNCTION at the moment. (1.0.31.26)
+
+;; See LP #520695.
+
+(defmethod mars (x y) (+ x y))
+
+#+ nil
+(deftest function-type+gfs.2
+    (values (type-equal (function-type 'mars) (function-type #'mars))
+            (type-equal (function-type 'mars) '(function (t t) *)))
+  t t)
+
+;; DEFSTRUCT created functions
+
+;; These do not yet work because SB-KERNEL:%FUN-NAME does not work on
+;; functions defined by DEFSTRUCT. (1.0.35.x)
+
+;; See LP #520692.
+
+#+nil
+(progn
+  
+  (defstruct (struct (:predicate our-struct-p)
+                     (:copier copy-our-struct))
+    (a 42 :type fixnum))
+
+  (deftest function-type+defstruct.1
+      (values (type-equal (function-type 'struct-a)
+                          (function-type #'struct-a))
+              (type-equal (function-type 'struct-a)
+                          '(function (struct) (values fixnum &optional))))
+    t t)
+
+  (deftest function-type+defstruct.2
+      (values (type-equal (function-type 'our-struct-p)
+                          (function-type #'our-struct-p))
+              (type-equal (function-type 'our-struct-p)
+                          '(function (t) (values (member t nil) &optional))))
+    t t)
+
+  (deftest function-type+defstruct.3
+      (values (type-equal (function-type 'copy-our-struct)
+                          (function-type #'copy-our-struct))
+              (type-equal (function-type 'copy-our-struct)
+                          '(function (struct) (values struct &optional))))
+    t t)
+
+  (defstruct (typed-struct :named (:type list)
+                           (:predicate typed-struct-p))
+    (a 42 :type fixnum))
+
+  (deftest function-type+defstruct.4
+      (values (type-equal (function-type 'typed-struct-a)
+                          (function-type #'typed-struct-a))
+              (type-equal (function-type 'typed-struct-a)
+                          '(function (list) (values fixnum &optional))))
+    t t)
+
+  (deftest function-type+defstruct.5
+      (values (type-equal (function-type 'typed-struct-p)
+                          (function-type #'typed-struct-p))
+              (type-equal (function-type 'typed-struct-p)
+                          '(function (t) (values (member t nil) &optional))))
+    t t)
+
+  ) ; #+nil (progn ...
+
+;; SETF functions
+
+(defun (setf sun) (value x y &key k1)
+  (declare (boolean value))
+  (declare (fixnum x y))
+  (declare (boolean k1))
+  (declare (ignore x y k1))
+  value)
+
+(deftest function-type+setf.1
+    (values (type-equal (function-type '(setf sun))
+                        (function-type #'(setf sun)))
+            (type-equal (function-type '(setf sun))
+                        '(function ((member nil t)
+                                    fixnum fixnum
+                                    &key (:k1 (member nil t)))
+                          *)))
+  t t)
+
+;; Misc
+
+(deftest function-type+misc.1
+    (flet ((nullary ()))
+      (type-equal (function-type #'nullary)
+                  '(function () (values null &optional))))
+  t)

diff --git a/version.lisp-expr b/version.lisp-expr
index 3b50987..dbcf2e2 100644 (file)
--- 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.35.11"
+"1.0.35.12"