From 4e77726ecbe2bb33d3208610266db3b8c9cb2719 Mon Sep 17 00:00:00 2001 From: "Tobias C. Rittweiler" Date: Thu, 11 Feb 2010 22:04:03 +0000 Subject: [PATCH] 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. --- NEWS | 2 + contrib/sb-introspect/introspect.lisp | 28 +++++ contrib/sb-introspect/test-driver.lisp | 182 +++++++++++++++++++++++++++++++- version.lisp-expr | 2 +- 4 files changed, 211 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index ac7a6a6..e81b62b 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4