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

  ViewVC Help
Powered by ViewVC 1.1.5