/[cmucl]/src/code/pred.lisp
ViewVC logotype

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Sat Nov 1 22:58:19 1997 UTC (16 years, 5 months ago) by dtc
Branch: MAIN
Changes since 1.39: +5 -1 lines
Improved support for (complex single-float) and (complex double-float)
types. Adds storage classes to the backend for these so they can be
stored in registers or on the stack without consing; new primitive
types etc. Also adds (simple-array (complex {single,double}-float))
array types to avoid consing and speed vectors operations.  All
these changes are conditional on the :complex-float feature. More work
is needed to exploit these changes: improving the type dispatch in the
various function; maybe compiler transforms or more VOPs to handle
common functions inline.
1 wlott 1.7 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ram 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.16 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 dtc 1.40 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.40 1997/11/01 22:58:19 dtc Exp $")
9 ram 1.16 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12 wlott 1.7 ;;; Predicate functions for CMU Common Lisp.
13 ram 1.1 ;;;
14 wlott 1.7 ;;; Written by William Lott.
15     ;;;
16    
17 ram 1.29 (in-package "KERNEL")
18     (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
19 ram 1.33 %typep class-cell-typep))
20 wlott 1.7
21     (in-package "SYSTEM")
22     (export '(system-area-pointer system-area-pointer-p))
23    
24 ram 1.33 (in-package "LISP")
25 wlott 1.7
26 ram 1.1 (export '(typep null symbolp atom consp listp numberp integerp rationalp
27     floatp complexp characterp stringp bit-vector-p vectorp
28     simple-vector-p simple-string-p simple-bit-vector-p arrayp
29 pw 1.36 functionp compiled-function-p eq eql equal equalp not
30 wlott 1.26 type-of upgraded-array-element-type realp
31 ram 1.1 ;; Names of types...
32     array atom bignum bit bit-vector character common
33     compiled-function complex cons double-float
34     fixnum float function integer keyword list long-float nil
35 wlott 1.7 null number ratio rational real sequence short-float signed-byte
36 ram 1.1 simple-array simple-bit-vector simple-string simple-vector
37     single-float standard-char string string-char symbol t
38 ram 1.29 unsigned-byte vector satisfies))
39 ram 1.1
40    
41 wlott 1.7
42     ;;;; Primitive predicates. These must be supported by the compiler.
43 ram 1.1
44 wlott 1.7 (eval-when (compile eval)
45     (defparameter primitive-predicates
46     '(array-header-p
47     arrayp
48     atom
49     base-char-p
50     bignump
51     bit-vector-p
52     characterp
53 wlott 1.18 code-component-p
54 wlott 1.7 consp
55     compiled-function-p
56     complexp
57 dtc 1.40 #+complex-float complex-single-float-p
58     #+complex-float complex-double-float-p
59 wlott 1.7 double-float-p
60 wlott 1.25 fdefn-p
61 wlott 1.7 fixnump
62     floatp
63     functionp
64     integerp
65     listp
66 wlott 1.10 long-float-p
67 wlott 1.18 lra-p
68 wlott 1.7 not
69     null
70     numberp
71     rationalp
72     ratiop
73     realp
74 wlott 1.18 scavenger-hook-p
75 wlott 1.10 short-float-p
76 wlott 1.7 simple-array-p
77     simple-bit-vector-p
78     simple-string-p
79     simple-vector-p
80     single-float-p
81     stringp
82 ram 1.29 %instancep
83 wlott 1.7 symbolp
84     system-area-pointer-p
85     weak-pointer-p
86     vectorp
87 ram 1.20 unsigned-byte-32-p
88     signed-byte-32-p
89     simple-array-unsigned-byte-2-p
90     simple-array-unsigned-byte-4-p
91     simple-array-unsigned-byte-8-p
92     simple-array-unsigned-byte-16-p
93     simple-array-unsigned-byte-32-p
94 dtc 1.39 #+signed-array simple-array-signed-byte-8-p
95     #+signed-array simple-array-signed-byte-16-p
96     #+signed-array simple-array-signed-byte-30-p
97     #+signed-array simple-array-signed-byte-32-p
98 ram 1.20 simple-array-single-float-p
99     simple-array-double-float-p
100 dtc 1.40 #+complex-float simple-array-complex-single-float-p
101     #+complex-float simple-array-complex-double-float-p
102 wlott 1.28 dylan::dylan-function-p
103 wlott 1.7 )))
104 ram 1.1
105 wlott 1.7 (macrolet
106     ((frob ()
107     `(progn
108     ,@(mapcar #'(lambda (pred)
109     `(defun ,pred (object)
110     ,(format nil
111     "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
112     and NIL otherwise."
113     (find (schar (string pred) 0) "AEIOUaeiou")
114     (string pred))
115     (,pred object)))
116     primitive-predicates))))
117     (frob))
118 ram 1.1
119    
120 wlott 1.7 ;;;; TYPE-OF -- public.
121     ;;;
122     ;;; Return the specifier for the type of object. This is not simply
123     ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
124 ram 1.29 ;;; than type-of. In particular, speed is more important than precision, and
125     ;;; it is not permitted to return member types.
126 wlott 1.7 ;;;
127 ram 1.1 (defun type-of (object)
128 wlott 1.7 "Return the type of OBJECT."
129 ram 1.29 (if (typep object '(or function array))
130     (type-specifier (ctype-of object))
131     (let* ((class (layout-class (layout-of object)))
132     (name (class-name class)))
133 ram 1.30 (if (%instancep object)
134 ram 1.29 (case name
135     (alien-internals:alien-value
136     `(alien:alien
137     ,(alien-internals:unparse-alien-type
138     (alien-internals:alien-value-type object))))
139     (t
140     (class-proper-name class)))
141     name))))
142 wlott 1.8
143 ram 1.22
144     ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
145     ;;;
146     (defun upgraded-array-element-type (spec)
147     "Return the element type that will actually be used to implement an array
148     with the specifier :ELEMENT-TYPE Spec."
149     (type-specifier
150     (array-type-specialized-element-type
151     (specifier-type `(array ,spec)))))
152 wlott 1.7
153     ;;;; SUBTYPEP -- public.
154 ram 1.1 ;;;
155 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
156     ;;;
157     (defun subtypep (type1 type2)
158     "Return two values indicating the relationship between type1 and type2:
159 ram 1.33 T and T: type1 definitely is a subtype of type2.
160     NIL and T: type1 definitely is not a subtype of type2.
161 wlott 1.7 NIL and NIL: who knows?"
162     (csubtypep (specifier-type type1) (specifier-type type2)))
163 ram 1.1
164    
165 ram 1.33 ;;;; TYPEP:
166    
167     (declaim (start-block typep %typep class-cell-typep))
168    
169     ;;; TYPEP -- public.
170 wlott 1.7 ;;;
171     ;;; Just call %typep
172     ;;;
173     (defun typep (object type)
174     "Return T iff OBJECT is of type TYPE."
175     (%typep object type))
176 ram 1.1
177 wlott 1.28
178 wlott 1.7 ;;; %TYPEP -- internal.
179 ram 1.1 ;;;
180 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
181     ;;; function when it can't figure out anything more intelligent to do.
182     ;;;
183     (defun %typep (object specifier)
184 wlott 1.13 (%%typep object
185     (if (ctype-p specifier)
186     specifier
187     (specifier-type specifier))))
188     ;;;
189     (defun %%typep (object type)
190     (declare (type ctype type))
191     (etypecase type
192     (named-type
193 ram 1.29 (ecase (named-type-name type)
194     ((* t) t)
195     ((nil) nil)))
196 wlott 1.13 (numeric-type
197     (and (numberp object)
198     (let ((num (if (complexp object) (realpart object) object)))
199     (ecase (numeric-type-class type)
200     (integer (integerp num))
201     (rational (rationalp num))
202     (float
203     (ecase (numeric-type-format type)
204 ram 1.35 (short-float (typep num 'short-float))
205     (single-float (typep num 'single-float))
206     (double-float (typep num 'double-float))
207     (long-float (typep num 'long-float))
208 wlott 1.13 ((nil) (floatp num))))
209 wlott 1.27 ((nil) t)))
210 wlott 1.13 (flet ((bound-test (val)
211 ram 1.33 (let ((low (numeric-type-low type))
212     (high (numeric-type-high type)))
213     (and (cond ((null low) t)
214     ((listp low) (> val (car low)))
215     (t (>= val low)))
216     (cond ((null high) t)
217     ((listp high) (< val (car high)))
218     (t (<= val high)))))))
219 wlott 1.13 (ecase (numeric-type-complexp type)
220     ((nil) t)
221     (:complex
222     (and (complexp object)
223 wlott 1.26 (bound-test (realpart object))
224     (bound-test (imagpart object))))
225 wlott 1.13 (:real
226     (and (not (complexp object))
227     (bound-test object)))))))
228     (array-type
229     (and (arrayp object)
230     (ecase (array-type-complexp type)
231     ((t) (not (typep object 'simple-array)))
232     ((nil) (typep object 'simple-array))
233     (* t))
234     (or (eq (array-type-dimensions type) '*)
235     (do ((want (array-type-dimensions type) (cdr want))
236     (got (array-dimensions object) (cdr got)))
237     ((and (null want) (null got)) t)
238     (unless (and want got
239     (or (eq (car want) '*)
240     (= (car want) (car got))))
241     (return nil))))
242     (or (eq (array-type-element-type type) *wild-type*)
243     (type= (array-type-specialized-element-type type)
244     (specifier-type (array-element-type object))))))
245     (member-type
246     (if (member object (member-type-members type)) t))
247 ram 1.29 (class
248 pw 1.37 (class-typep (layout-of object) type object))
249 wlott 1.13 (union-type
250     (dolist (type (union-type-types type))
251     (when (%%typep object type)
252     (return t))))
253     (unknown-type
254 ram 1.29 ;; Parse it again to make sure it's really undefined.
255     (let ((reparse (specifier-type (unknown-type-specifier type))))
256     (if (typep reparse 'unknown-type)
257     (error "Unknown type specifier: ~S"
258     (unknown-type-specifier reparse))
259     (%%typep object reparse))))
260 wlott 1.13 (hairy-type
261     ;; Now the tricky stuff.
262     (let* ((hairy-spec (hairy-type-specifier type))
263     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
264     (ecase symbol
265     (and
266     (or (atom hairy-spec)
267 ram 1.21 (dolist (spec (cdr hairy-spec) t)
268 wlott 1.14 (unless (%%typep object (specifier-type spec))
269 wlott 1.13 (return nil)))))
270     (not
271     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
272     (error "Invalid type specifier: ~S" hairy-spec))
273 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
274 wlott 1.13 (satisfies
275     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
276     (error "Invalid type specifier: ~S" hairy-spec))
277 wlott 1.17 (let ((fn (cadr hairy-spec)))
278     (if (funcall (typecase fn
279     (function fn)
280     (symbol (symbol-function fn))
281     (t
282     (coerce fn 'function)))
283     object)
284     t
285     nil))))))
286 wlott 1.23 (alien-type-type
287     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
288 wlott 1.13 (function-type
289     (error "Function types are not a legal argument to TYPEP:~% ~S"
290     (type-specifier type)))))
291    
292 ram 1.1
293 ram 1.33 ;;; CLASS-CELL-TYPEP -- Interface
294     ;;;
295     ;;; Do type test from a class cell, allowing forward reference and
296     ;;; redefinition.
297     ;;;
298 pw 1.37 ;;; 2-Feb-97 add third arg optional for back compatibility and boot
299     (defun class-cell-typep (obj-layout cell &optional object)
300 ram 1.33 (let ((class (class-cell-class cell)))
301     (unless class
302     (error "Class has not yet been defined: ~S" (class-cell-name cell)))
303 pw 1.37 (class-typep obj-layout class object)))
304 ram 1.1
305 ram 1.33
306 ram 1.29 ;;; CLASS-TYPEP -- Internal
307 ram 1.1 ;;;
308 ram 1.29 ;;; Test whether Obj-Layout is from an instance of Class.
309 ram 1.1 ;;;
310 pw 1.37 (defun class-typep (obj-layout class object)
311 ram 1.1 (declare (optimize speed))
312 ram 1.29 (when (layout-invalid obj-layout)
313 pw 1.38 (if (and (typep (class-of object) 'standard-class) object)
314 pw 1.37 (setq obj-layout (pcl::check-wrapper-validity object))
315     (error "TYPEP on obsolete object (was class ~S)."
316     (class-proper-name (layout-class obj-layout)))))
317 ram 1.33 (let ((layout (class-layout class))
318     (obj-inherits (layout-inherits obj-layout)))
319 ram 1.29 (when (layout-invalid layout)
320     (error "Class is currently invalid: ~S" class))
321 ram 1.33 (or (eq obj-layout layout)
322     (dotimes (i (length obj-inherits) nil)
323     (when (eq (svref obj-inherits i) layout)
324     (return t))))))
325    
326     (declaim (end-block))
327 ram 1.1
328    
329 wlott 1.7 ;;;; Equality predicates.
330 ram 1.1
331 wlott 1.7 ;;; EQ -- public.
332     ;;;
333     ;;; Real simple, 'cause the compiler takes care of it.
334     ;;;
335 ram 1.1
336 wlott 1.7 (defun eq (obj1 obj2)
337     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
338     (eq obj1 obj2))
339 ram 1.1
340    
341 wlott 1.7 ;;; EQUAL -- public.
342     ;;;
343 ram 1.1 (defun equal (x y)
344     "Returns T if X and Y are EQL or if they are structured components
345     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
346     are the same length and have indentical components. Other arrays must be
347     EQ to be EQUAL."
348     (cond ((eql x y) t)
349     ((consp x)
350     (and (consp y)
351     (equal (car x) (car y))
352     (equal (cdr x) (cdr y))))
353     ((stringp x)
354     (and (stringp y) (string= x y)))
355     ((pathnamep x)
356 ram 1.20 (and (pathnamep y) (pathname= x y)))
357 ram 1.1 ((bit-vector-p x)
358     (and (bit-vector-p y)
359     (= (the fixnum (length x))
360     (the fixnum (length y)))
361     (do ((i 0 (1+ i))
362     (length (length x)))
363     ((= i length) t)
364     (declare (fixnum i))
365     (or (= (the fixnum (bit x i))
366     (the fixnum (bit y i)))
367     (return nil)))))
368     (t nil)))
369    
370 wlott 1.7 ;;; EQUALP -- public.
371     ;;;
372 ram 1.1 (defun equalp (x y)
373     "Just like EQUAL, but more liberal in several respects.
374     Numbers may be of different types, as long as the values are identical
375     after coercion. Characters may differ in alphabetic case. Vectors and
376     arrays must have identical dimensions and EQUALP elements, but may differ
377     in their type restriction."
378 wlott 1.12 (cond ((eq x y) t)
379 ram 1.1 ((characterp x) (char-equal x y))
380     ((numberp x) (and (numberp y) (= x y)))
381     ((consp x)
382     (and (consp y)
383     (equalp (car x) (car y))
384     (equalp (cdr x) (cdr y))))
385 ram 1.20 ((pathnamep x)
386     (and (pathnamep y) (pathname= x y)))
387 ram 1.29 ((%instancep x)
388     (let* ((layout-x (%instance-layout x))
389     (len (layout-length layout-x)))
390     (and (%instancep y)
391     (eq layout-x (%instance-layout y))
392     (structure-class-p (layout-class layout-x))
393     (do ((i 1 (1+ i)))
394     ((= i len) t)
395     (declare (fixnum i))
396     (let ((x-el (%instance-ref x i))
397     (y-el (%instance-ref y i)))
398     (unless (or (eq x-el y-el)
399     (equalp x-el y-el))
400     (return nil)))))))
401 ram 1.1 ((vectorp x)
402     (let ((length (length x)))
403     (and (vectorp y)
404 wlott 1.7 (= length (length y))
405 ram 1.1 (dotimes (i length t)
406     (let ((x-el (aref x i))
407     (y-el (aref y i)))
408 wlott 1.12 (unless (or (eq x-el y-el)
409 ram 1.1 (equalp x-el y-el))
410     (return nil)))))))
411     ((arrayp x)
412 wlott 1.7 (and (arrayp y)
413     (= (array-rank x) (array-rank y))
414     (dotimes (axis (array-rank x) t)
415     (unless (= (array-dimension x axis)
416     (array-dimension y axis))
417     (return nil)))
418     (dotimes (index (array-total-size x) t)
419 wlott 1.12 (let ((x-el (row-major-aref x index))
420     (y-el (row-major-aref y index)))
421     (unless (or (eq x-el y-el)
422     (equalp x-el y-el))
423     (return nil))))))
424 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5