diff --git a/code/type.lisp b/code/type.lisp index 378f26a20deba9bcb4c9099f91bad4d34154995b..75c460bcd8ce920b07067d2078a0566963448fcf 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.8 1993/03/13 17:07:45 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.9 1993/03/14 17:16:15 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -33,6 +33,8 @@ (in-package "KERNEL") +(export '(extract-function-type)) + (with-cold-load-init-forms) ;;; ### Remaining incorrectnesses: @@ -2153,6 +2155,16 @@ (values nil nil)))))))))) +;;; EXTRACT-FUNCTION-TYPE -- Interface +;;; +;;; Pull the type specifier out of a function object. +;;; +(defun extract-function-type (fun) + (if (eval:interpreted-function-p fun) + (eval:interpreted-function-type fun) + (specifier-type (%function-type (%closure-function fun))))) + + ;;; Ctype-Of -- Interface ;;; ;;; Like Type-Of, only returns a Type structure instead of a type @@ -2170,9 +2182,10 @@ :init-form cold-load-init) ((x eq)) (typecase x - (base-char (specifier-type 'base-char)) - (function (specifier-type 'function)) - (cons (specifier-type 'cons)) + (function + (if (funcallable-instance-p x) + (class-of x) + (extract-function-type x))) (symbol (make-member-type :members (list x))) (number @@ -2194,8 +2207,6 @@ (setf (numeric-type-low res) num) (setf (numeric-type-high res) num))) res)) - (instance - (layout-class (%instance-layout x))) (array (let ((etype (specifier-type (array-element-type x)))) (make-array-type :dimensions (array-dimensions x) @@ -2203,7 +2214,8 @@ :element-type etype :specialized-element-type etype))) (t - *universal-type*))) + (class-of x)))) + ;;; Clear this cache on GC so that we don't hold onto too much garbage. ;;;