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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5