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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.59.18.1.4.2 - (hide annotations)
Sat Jun 17 02:59:42 2006 UTC (7 years, 10 months ago) by rtoy
Branch: double-double-array-branch
Changes since 1.59.18.1.4.1: +2 -1 lines
Initial support for (complex double-double-float).

Use boot-2006-06-2-cross-dd* to cross compile this change (along with
the simple-array double-double-float change).
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 rtoy 1.59.18.1.4.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.59.18.1.4.2 2006/06/17 02:59:42 rtoy 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 rtoy 1.59.18.1 %typep class-cell-typep))
20    
21     #+double-double
22     (export '(double-double-float-p))
23 wlott 1.7
24     (in-package "SYSTEM")
25     (export '(system-area-pointer system-area-pointer-p))
26    
27 ram 1.33 (in-package "LISP")
28 wlott 1.7
29 ram 1.1 (export '(typep null symbolp atom consp listp numberp integerp rationalp
30     floatp complexp characterp stringp bit-vector-p vectorp
31     simple-vector-p simple-string-p simple-bit-vector-p arrayp
32 pw 1.36 functionp compiled-function-p eq eql equal equalp not
33 wlott 1.26 type-of upgraded-array-element-type realp
34 ram 1.1 ;; Names of types...
35 dtc 1.48 array atom bignum bit bit-vector character
36 ram 1.1 compiled-function complex cons double-float
37     fixnum float function integer keyword list long-float nil
38 wlott 1.7 null number ratio rational real sequence short-float signed-byte
39 ram 1.1 simple-array simple-bit-vector simple-string simple-vector
40 dtc 1.45 single-float standard-char base-char string symbol t
41 ram 1.29 unsigned-byte vector satisfies))
42 ram 1.1
43    
44 wlott 1.7
45     ;;;; Primitive predicates. These must be supported by the compiler.
46 ram 1.1
47 wlott 1.7 (eval-when (compile eval)
48     (defparameter primitive-predicates
49     '(array-header-p
50     arrayp
51     atom
52     base-char-p
53     bignump
54     bit-vector-p
55     characterp
56 wlott 1.18 code-component-p
57 wlott 1.7 consp
58     compiled-function-p
59     complexp
60 dtc 1.49 complex-double-float-p
61     complex-float-p
62     #+long-float complex-long-float-p
63 rtoy 1.59.18.1.4.2 #+double-double complex-double-double-float-p
64 dtc 1.49 complex-rational-p
65     complex-single-float-p
66 rtoy 1.59.18.1 #+double-double double-double-float-p
67 wlott 1.7 double-float-p
68 wlott 1.25 fdefn-p
69 wlott 1.7 fixnump
70     floatp
71     functionp
72     integerp
73     listp
74 wlott 1.10 long-float-p
75 wlott 1.18 lra-p
76 wlott 1.7 not
77     null
78     numberp
79     rationalp
80     ratiop
81     realp
82 wlott 1.18 scavenger-hook-p
83 wlott 1.10 short-float-p
84 wlott 1.7 simple-array-p
85     simple-bit-vector-p
86     simple-string-p
87     simple-vector-p
88     single-float-p
89     stringp
90 ram 1.29 %instancep
91 wlott 1.7 symbolp
92     system-area-pointer-p
93     weak-pointer-p
94     vectorp
95 ram 1.20 unsigned-byte-32-p
96     signed-byte-32-p
97     simple-array-unsigned-byte-2-p
98     simple-array-unsigned-byte-4-p
99     simple-array-unsigned-byte-8-p
100     simple-array-unsigned-byte-16-p
101     simple-array-unsigned-byte-32-p
102 dtc 1.49 simple-array-signed-byte-8-p
103     simple-array-signed-byte-16-p
104     simple-array-signed-byte-30-p
105     simple-array-signed-byte-32-p
106 ram 1.20 simple-array-single-float-p
107     simple-array-double-float-p
108 dtc 1.46 #+long-float simple-array-long-float-p
109 rtoy 1.59.18.1.4.1 #+double-double simple-array-double-double-float-p
110 dtc 1.49 simple-array-complex-single-float-p
111     simple-array-complex-double-float-p
112     #+long-float simple-array-complex-long-float-p
113 wlott 1.7 )))
114 ram 1.1
115 wlott 1.7 (macrolet
116     ((frob ()
117     `(progn
118     ,@(mapcar #'(lambda (pred)
119     `(defun ,pred (object)
120     ,(format nil
121     "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
122     and NIL otherwise."
123     (find (schar (string pred) 0) "AEIOUaeiou")
124     (string pred))
125     (,pred object)))
126     primitive-predicates))))
127     (frob))
128 ram 1.1
129    
130 wlott 1.7 ;;;; TYPE-OF -- public.
131     ;;;
132     ;;; Return the specifier for the type of object. This is not simply
133     ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
134 ram 1.29 ;;; than type-of. In particular, speed is more important than precision, and
135     ;;; it is not permitted to return member types.
136 wlott 1.7 ;;;
137 ram 1.1 (defun type-of (object)
138 wlott 1.7 "Return the type of OBJECT."
139 gerd 1.59 (typecase object
140     ((or array complex)
141     (type-specifier (ctype-of object)))
142     (integer
143     `(integer ,object ,object))
144     ((member t)
145     'boolean)
146     (keyword
147     'keyword)
148     (standard-char
149     'standard-char)
150     (t
151     (let* ((class (layout-class (layout-of object)))
152     (name (%class-name class)))
153     (if (%instancep object)
154     (if (eq name 'alien-internals:alien-value)
155     `(alien:alien ,(alien-internals:unparse-alien-type
156     (alien-internals:alien-value-type object)))
157     (let ((proper-name (class-proper-name class)))
158     (if (kernel::class-p proper-name)
159     (%class-pcl-class proper-name)
160     proper-name)))
161     name)))))
162 wlott 1.8
163 ram 1.22
164     ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
165     ;;;
166 toy 1.55 (defun upgraded-array-element-type (spec &optional environment)
167 ram 1.22 "Return the element type that will actually be used to implement an array
168     with the specifier :ELEMENT-TYPE Spec."
169 toy 1.55 ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
170     (declare (ignore environment))
171 ram 1.22 (type-specifier
172     (array-type-specialized-element-type
173     (specifier-type `(array ,spec)))))
174 wlott 1.7
175     ;;;; SUBTYPEP -- public.
176 ram 1.1 ;;;
177 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
178     ;;;
179 toy 1.55 (defun subtypep (type1 type2 &optional environment)
180 wlott 1.7 "Return two values indicating the relationship between type1 and type2:
181 ram 1.33 T and T: type1 definitely is a subtype of type2.
182     NIL and T: type1 definitely is not a subtype of type2.
183 wlott 1.7 NIL and NIL: who knows?"
184 toy 1.55 (declare (ignore environment))
185 wlott 1.7 (csubtypep (specifier-type type1) (specifier-type type2)))
186 ram 1.1
187    
188 ram 1.33 ;;;; TYPEP:
189    
190     (declaim (start-block typep %typep class-cell-typep))
191    
192     ;;; TYPEP -- public.
193 wlott 1.7 ;;;
194     ;;; Just call %typep
195     ;;;
196 toy 1.55 (defun typep (object type &optional environment)
197 wlott 1.7 "Return T iff OBJECT is of type TYPE."
198 toy 1.55 (declare (ignore environment))
199 wlott 1.7 (%typep object type))
200 ram 1.1
201 wlott 1.28
202 wlott 1.7 ;;; %TYPEP -- internal.
203 ram 1.1 ;;;
204 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
205     ;;; function when it can't figure out anything more intelligent to do.
206     ;;;
207     (defun %typep (object specifier)
208 wlott 1.13 (%%typep object
209     (if (ctype-p specifier)
210     specifier
211     (specifier-type specifier))))
212     ;;;
213     (defun %%typep (object type)
214     (declare (type ctype type))
215     (etypecase type
216     (named-type
217 ram 1.29 (ecase (named-type-name type)
218     ((* t) t)
219     ((nil) nil)))
220 wlott 1.13 (numeric-type
221     (and (numberp object)
222     (let ((num (if (complexp object) (realpart object) object)))
223     (ecase (numeric-type-class type)
224     (integer (integerp num))
225     (rational (rationalp num))
226     (float
227     (ecase (numeric-type-format type)
228 ram 1.35 (short-float (typep num 'short-float))
229     (single-float (typep num 'single-float))
230     (double-float (typep num 'double-float))
231     (long-float (typep num 'long-float))
232 rtoy 1.59.18.1 (double-double-float (typep num 'double-double-float))
233 wlott 1.13 ((nil) (floatp num))))
234 wlott 1.27 ((nil) t)))
235 wlott 1.13 (flet ((bound-test (val)
236 ram 1.33 (let ((low (numeric-type-low type))
237     (high (numeric-type-high type)))
238     (and (cond ((null low) t)
239     ((listp low) (> val (car low)))
240     (t (>= val low)))
241     (cond ((null high) t)
242     ((listp high) (< val (car high)))
243     (t (<= val high)))))))
244 wlott 1.13 (ecase (numeric-type-complexp type)
245     ((nil) t)
246     (:complex
247     (and (complexp object)
248 wlott 1.26 (bound-test (realpart object))
249     (bound-test (imagpart object))))
250 wlott 1.13 (:real
251     (and (not (complexp object))
252     (bound-test object)))))))
253     (array-type
254     (and (arrayp object)
255     (ecase (array-type-complexp type)
256     ((t) (not (typep object 'simple-array)))
257     ((nil) (typep object 'simple-array))
258 gerd 1.57 ((* :maybe) t))
259 wlott 1.13 (or (eq (array-type-dimensions type) '*)
260     (do ((want (array-type-dimensions type) (cdr want))
261     (got (array-dimensions object) (cdr got)))
262     ((and (null want) (null got)) t)
263     (unless (and want got
264     (or (eq (car want) '*)
265     (= (car want) (car got))))
266     (return nil))))
267 gerd 1.57 (if (unknown-type-p (array-type-element-type type))
268     ;; better to fail this way than to get bogosities like
269     ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
270     (error "~@<unknown element type in array type: ~2I~_~S~:>"
271     (type-specifier type))
272     t)
273 wlott 1.13 (or (eq (array-type-element-type type) *wild-type*)
274 gerd 1.57 (values (type= (array-type-specialized-element-type type)
275     (specifier-type (array-element-type
276     object)))))))
277 wlott 1.13 (member-type
278     (if (member object (member-type-members type)) t))
279 gerd 1.56 (kernel::class
280 pw 1.37 (class-typep (layout-of object) type object))
281 wlott 1.13 (union-type
282 gerd 1.57 (some (lambda (type) (%%typep object type))
283     (union-type-types type)))
284     (intersection-type
285     (every (lambda (type) (%%typep object type))
286     (intersection-type-types type)))
287 dtc 1.52 (cons-type
288     (and (consp object)
289     (%%typep (car object) (cons-type-car-type type))
290     (%%typep (cdr object) (cons-type-cdr-type type))))
291 wlott 1.13 (unknown-type
292 ram 1.29 ;; Parse it again to make sure it's really undefined.
293     (let ((reparse (specifier-type (unknown-type-specifier type))))
294     (if (typep reparse 'unknown-type)
295     (error "Unknown type specifier: ~S"
296     (unknown-type-specifier reparse))
297     (%%typep object reparse))))
298 gerd 1.57 (negation-type
299     (not (%%typep object (negation-type-type type))))
300 wlott 1.13 (hairy-type
301     ;; Now the tricky stuff.
302     (let* ((hairy-spec (hairy-type-specifier type))
303     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
304     (ecase symbol
305     (and
306 gerd 1.57 (every (lambda (spec) (%%typep object (specifier-type spec)))
307     (rest hairy-spec)))
308     ;; Note: it should be safe to skip OR here, because union
309     ;; types can always be represented as UNION-TYPE in general
310     ;; or other CTYPEs in special cases; we never need to use
311     ;; HAIRY-TYPE for them.
312 wlott 1.13 (not
313     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
314     (error "Invalid type specifier: ~S" hairy-spec))
315 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
316 wlott 1.13 (satisfies
317     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
318     (error "Invalid type specifier: ~S" hairy-spec))
319 wlott 1.17 (let ((fn (cadr hairy-spec)))
320     (if (funcall (typecase fn
321     (function fn)
322     (symbol (symbol-function fn))
323     (t
324     (coerce fn 'function)))
325     object)
326     t
327     nil))))))
328 wlott 1.23 (alien-type-type
329     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
330 wlott 1.13 (function-type
331     (error "Function types are not a legal argument to TYPEP:~% ~S"
332     (type-specifier type)))))
333    
334 ram 1.1
335 ram 1.33 ;;; CLASS-CELL-TYPEP -- Interface
336     ;;;
337     ;;; Do type test from a class cell, allowing forward reference and
338     ;;; redefinition.
339     ;;;
340 dtc 1.47 (defun class-cell-typep (obj-layout cell object)
341 ram 1.33 (let ((class (class-cell-class cell)))
342     (unless class
343     (error "Class has not yet been defined: ~S" (class-cell-name cell)))
344 pw 1.37 (class-typep obj-layout class object)))
345 ram 1.1
346 ram 1.33
347 ram 1.29 ;;; CLASS-TYPEP -- Internal
348 ram 1.1 ;;;
349 ram 1.29 ;;; Test whether Obj-Layout is from an instance of Class.
350 ram 1.1 ;;;
351 pw 1.37 (defun class-typep (obj-layout class object)
352 ram 1.1 (declare (optimize speed))
353 ram 1.29 (when (layout-invalid obj-layout)
354 gerd 1.56 (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)
355 pw 1.37 (setq obj-layout (pcl::check-wrapper-validity object))
356     (error "TYPEP on obsolete object (was class ~S)."
357     (class-proper-name (layout-class obj-layout)))))
358 gerd 1.56 (let ((layout (%class-layout class))
359 ram 1.33 (obj-inherits (layout-inherits obj-layout)))
360 ram 1.29 (when (layout-invalid layout)
361     (error "Class is currently invalid: ~S" class))
362 ram 1.33 (or (eq obj-layout layout)
363     (dotimes (i (length obj-inherits) nil)
364     (when (eq (svref obj-inherits i) layout)
365     (return t))))))
366    
367     (declaim (end-block))
368 ram 1.1
369    
370 wlott 1.7 ;;;; Equality predicates.
371 ram 1.1
372 wlott 1.7 ;;; EQ -- public.
373     ;;;
374     ;;; Real simple, 'cause the compiler takes care of it.
375     ;;;
376 ram 1.1
377 wlott 1.7 (defun eq (obj1 obj2)
378     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
379     (eq obj1 obj2))
380 ram 1.1
381    
382 wlott 1.7 ;;; EQUAL -- public.
383     ;;;
384 ram 1.1 (defun equal (x y)
385     "Returns T if X and Y are EQL or if they are structured components
386     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
387     are the same length and have indentical components. Other arrays must be
388     EQ to be EQUAL."
389     (cond ((eql x y) t)
390     ((consp x)
391     (and (consp y)
392     (equal (car x) (car y))
393     (equal (cdr x) (cdr y))))
394     ((stringp x)
395     (and (stringp y) (string= x y)))
396     ((pathnamep x)
397 ram 1.20 (and (pathnamep y) (pathname= x y)))
398 ram 1.1 ((bit-vector-p x)
399     (and (bit-vector-p y)
400     (= (the fixnum (length x))
401     (the fixnum (length y)))
402     (do ((i 0 (1+ i))
403     (length (length x)))
404     ((= i length) t)
405     (declare (fixnum i))
406     (or (= (the fixnum (bit x i))
407     (the fixnum (bit y i)))
408     (return nil)))))
409     (t nil)))
410    
411 wlott 1.7 ;;; EQUALP -- public.
412     ;;;
413 ram 1.1 (defun equalp (x y)
414     "Just like EQUAL, but more liberal in several respects.
415     Numbers may be of different types, as long as the values are identical
416     after coercion. Characters may differ in alphabetic case. Vectors and
417     arrays must have identical dimensions and EQUALP elements, but may differ
418     in their type restriction."
419 wlott 1.12 (cond ((eq x y) t)
420 dtc 1.51 ((characterp x) (and (characterp y) (char-equal x y)))
421 ram 1.1 ((numberp x) (and (numberp y) (= x y)))
422     ((consp x)
423     (and (consp y)
424     (equalp (car x) (car y))
425     (equalp (cdr x) (cdr y))))
426 ram 1.20 ((pathnamep x)
427     (and (pathnamep y) (pathname= x y)))
428 dtc 1.53 ((hash-table-p x)
429     (and (hash-table-p y)
430     (eql (hash-table-count x) (hash-table-count y))
431     (eql (hash-table-test x) (hash-table-test y))
432     (with-hash-table-iterator (next x)
433     (loop
434     (multiple-value-bind (more x-key x-value)
435     (next)
436     (cond (more
437     (multiple-value-bind (y-value foundp)
438     (gethash x-key y)
439     (unless (and foundp (equalp x-value y-value))
440     (return nil))))
441     (t
442     (return t))))))))
443 ram 1.29 ((%instancep x)
444     (let* ((layout-x (%instance-layout x))
445     (len (layout-length layout-x)))
446     (and (%instancep y)
447     (eq layout-x (%instance-layout y))
448     (structure-class-p (layout-class layout-x))
449     (do ((i 1 (1+ i)))
450     ((= i len) t)
451     (declare (fixnum i))
452     (let ((x-el (%instance-ref x i))
453     (y-el (%instance-ref y i)))
454     (unless (or (eq x-el y-el)
455     (equalp x-el y-el))
456     (return nil)))))))
457 ram 1.1 ((vectorp x)
458     (let ((length (length x)))
459     (and (vectorp y)
460 wlott 1.7 (= length (length y))
461 ram 1.1 (dotimes (i length t)
462     (let ((x-el (aref x i))
463     (y-el (aref y i)))
464 wlott 1.12 (unless (or (eq x-el y-el)
465 ram 1.1 (equalp x-el y-el))
466     (return nil)))))))
467     ((arrayp x)
468 wlott 1.7 (and (arrayp y)
469     (= (array-rank x) (array-rank y))
470     (dotimes (axis (array-rank x) t)
471     (unless (= (array-dimension x axis)
472     (array-dimension y axis))
473     (return nil)))
474     (dotimes (index (array-total-size x) t)
475 wlott 1.12 (let ((x-el (row-major-aref x index))
476     (y-el (row-major-aref y index)))
477     (unless (or (eq x-el y-el)
478     (equalp x-el y-el))
479     (return nil))))))
480 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5