0.6.11.13:
[sbcl.git] / src / code / target-type.lisp
1 ;;;; type-related stuff which exists only in the target SBCL runtime
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!KERNEL")
13
14 (!begin-collecting-cold-init-forms)
15 \f
16 ;;; Just call %TYPEP.
17 ;;;
18 ;;; Note that when cross-compiling, SB!XC:TYPEP is interpreted as
19 ;;; a test that the host Lisp object OBJECT translates to a target SBCL
20 ;;; type TYPE. (This behavior is needed e.g. to test for the validity of
21 ;;; numeric subtype bounds read when cross-compiling.)
22 (defun typep (object type)
23   #!+sb-doc
24   "Return T iff OBJECT is of type TYPE."
25   (%typep object type))
26
27 ;;; If TYPE is a type that we can do a compile-time test on, then
28 ;;; return whether the object is of that type as the first value and
29 ;;; second value true. Otherwise return NIL, NIL.
30 ;;;
31 ;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
32 ;;; types. For STRUCTURE- types, we require that the type be defined
33 ;;; in both the current and compiler environments, and that the
34 ;;; INCLUDES be the same.
35 (defun ctypep (obj type)
36   (declare (type ctype type))
37   (etypecase type
38     ((or numeric-type
39          named-type
40          member-type
41          array-type
42          sb!xc:built-in-class
43          cons-type)
44      (values (%typep obj type) t))
45     (sb!xc:class
46      (if (if (csubtypep type (specifier-type 'funcallable-instance))
47              (funcallable-instance-p obj)
48              (typep obj 'instance))
49          (if (eq (class-layout type)
50                  (info :type :compiler-layout (sb!xc:class-name type)))
51              (values (sb!xc:typep obj type) t)
52              (values nil nil))
53          (values nil t)))
54     (compound-type
55      (let ((certain? t))
56        (etypecase type
57          ;; FIXME: The cases here are very similar to #'EVERY/TYPE and
58          ;; #'ANY/TYPE. It would be good to fix them so that they
59          ;; share the same code. (That will require making sure that
60          ;; the two-value return convention for CTYPEP really is
61          ;; exactly compatible with the two-value convention the
62          ;; quantifier/TYPE functions operate on, and probably also
63          ;; making sure that things are inlined and defined early
64          ;; enough that consing can be avoided.)
65          (union-type
66           (dolist (mem (union-type-types type) (values nil certain?))
67             (multiple-value-bind (val win) (ctypep obj mem)
68               (if win
69                   (when val (return (values t t)))
70                   (setf certain? nil)))))
71          (intersection-type
72           (dolist (mem (intersection-type-types type)
73                        (if certain? (values t t) (values nil nil)))
74             (multiple-value-bind (val win) (ctypep obj mem)
75               (if win
76                   (unless val (return (values nil t)))
77                   (setf certain? nil))))))))
78     (function-type
79      (values (functionp obj) t))
80     (unknown-type
81      (values nil nil))
82     (alien-type-type
83      (values (alien-typep obj (alien-type-type-alien-type type)) t))
84     (hairy-type
85      ;; Now the tricky stuff.
86      (let* ((hairy-spec (hairy-type-specifier type))
87             (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
88        (ecase symbol
89          (and
90           (if (atom hairy-spec)
91               (values t t)
92               (dolist (spec (cdr hairy-spec) (values t t))
93                 (multiple-value-bind (res win)
94                     (ctypep obj (specifier-type spec))
95                   (unless win (return (values nil nil)))
96                   (unless res (return (values nil t)))))))
97          (not
98           (multiple-value-bind (res win)
99               (ctypep obj (specifier-type (cadr hairy-spec)))
100             (if win
101                 (values (not res) t)
102                 (values nil nil))))
103          (satisfies
104           ;; KLUDGE: This stuff might well blow up if we tried to execute it
105           ;; when cross-compiling. But since for the foreseeable future the
106           ;; only code we'll try to cross-compile is SBCL itself, and SBCL is
107           ;; built without using SATISFIES types, it's arguably not important
108           ;; to worry about this. -- WHN 19990210.
109           (let ((fun (second hairy-spec)))
110             (cond ((and (consp fun)
111                         (eq (car fun) 'lambda))
112                    (values (not (null (funcall (coerce fun 'function) obj)))
113                            t))
114                   ((and (symbolp fun) (fboundp fun))
115                    (values (not (null (funcall fun obj))) t))
116                   (t
117                    (values nil nil))))))))))
118 \f
119 ;;; LAYOUT-OF  --  Exported
120 ;;;
121 ;;;    Return the layout for an object. This is the basic operation for
122 ;;; finding out the "type" of an object, and is used for generic function
123 ;;; dispatch. The standard doesn't seem to say as much as it should about what
124 ;;; this returns for built-in objects. For example, it seems that we must
125 ;;; return NULL rather than LIST when X is NIL so that GF's can specialize on
126 ;;; NULL.
127 #!-sb-fluid (declaim (inline layout-of))
128 (defun layout-of (x)
129   (declare (optimize (speed 3) (safety 0)))
130   (cond ((typep x 'instance) (%instance-layout x))
131         ((funcallable-instance-p x) (%funcallable-instance-layout x))
132         ((null x)
133          ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))).
134          ;; I (WHN 19990209) replaced this with an expression evaluated at
135          ;; run time in order to make it easier to build the cross-compiler.
136          ;; If it doesn't work, something else will be needed..
137          (locally
138            ;; KLUDGE: In order to really make it run at run time (instead of
139            ;; doing some weird broken thing at cold load time),
140            ;; we need to suppress a DEFTRANSFORM.. -- WHN 19991004
141            (declare (notinline sb!xc:find-class))
142            (class-layout (sb!xc:find-class 'null))))
143         (t (svref *built-in-class-codes* (get-type x)))))
144
145 #!-sb-fluid (declaim (inline sb!xc:class-of))
146 (defun sb!xc:class-of (object)
147   #!+sb-doc
148   "Return the class of the supplied object, which may be any Lisp object, not
149    just a CLOS STANDARD-OBJECT."
150   (layout-class (layout-of object)))
151
152 ;;; Pull the type specifier out of a function object.
153 (defun extract-function-type (fun)
154   (if (sb!eval:interpreted-function-p fun)
155       (sb!eval:interpreted-function-type fun)
156       (typecase fun
157         (byte-function (byte-function-type fun))
158         (byte-closure (byte-function-type (byte-closure-function fun)))
159         (t
160          (specifier-type (%function-type (%closure-function fun)))))))
161 \f
162 ;;;; miscellaneous interfaces
163
164 ;;; Clear memoization of all type system operations that can be
165 ;;; altered by type definition/redefinition.
166 (defun clear-type-caches ()
167   (when *type-system-initialized*
168     (dolist (sym '(values-specifier-type-cache-clear
169                    values-type-union-cache-clear
170                    type-union-cache-clear
171                    values-subtypep-cache-clear
172                    csubtypep-cache-clear
173                    type-intersection2-cache-clear
174                    values-type-intersection-cache-clear))
175       (funcall (symbol-function sym))))
176   (values))
177
178 ;;; Like TYPE-OF, only we return a CTYPE structure instead of a type
179 ;;; specifier, and we try to return the type most useful for type
180 ;;; checking, rather than trying to come up with the one that the user
181 ;;; might find most informative.
182 (declaim (ftype (function (t) ctype) ctype-of))
183 (defun-cached (ctype-of
184                :hash-function (lambda (x) (logand (sxhash x) #x1FF))
185                :hash-bits 9
186                :init-wrapper !cold-init-forms)
187               ((x eq))
188   (typecase x
189     (function
190      (if (funcallable-instance-p x)
191          (sb!xc:class-of x)
192          (extract-function-type x)))
193     (symbol
194      (make-member-type :members (list x)))
195     (number
196      (let* ((num (if (complexp x) (realpart x) x))
197             (res (make-numeric-type
198                   :class (etypecase num
199                            (integer 'integer)
200                            (rational 'rational)
201                            (float 'float))
202                   :format (if (floatp num)
203                               (float-format-name num)
204                               nil))))
205        (cond ((complexp x)
206               (setf (numeric-type-complexp res) :complex)
207               (let ((imag (imagpart x)))
208                 (setf (numeric-type-low res) (min num imag))
209                 (setf (numeric-type-high res) (max num imag))))
210              (t
211               (setf (numeric-type-low res) num)
212               (setf (numeric-type-high res) num)))
213        res))
214     (array
215      (let ((etype (specifier-type (array-element-type x))))
216        (make-array-type :dimensions (array-dimensions x)
217                         :complexp (not (typep x 'simple-array))
218                         :element-type etype
219                         :specialized-element-type etype)))
220     (cons
221      (make-cons-type *universal-type* *universal-type*))
222     (t
223      (sb!xc:class-of x))))
224
225 ;;; Clear this cache on GC so that we don't hold onto too much garbage.
226 (pushnew 'ctype-of-cache-clear *before-gc-hooks*)
227 \f
228 (!defun-from-collected-cold-init-forms !target-type-cold-init)