/[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.1 - (show annotations) (vendor branch)
Fri Jan 15 15:29:10 1993 UTC (21 years, 3 months ago) by ram
Branch: new_struct
Changes since 1.28: +39 -75 lines
new structure hakcs
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.1 1993/01/15 15:29:10 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 ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
286 ;; a defined structure in the core.
287 (let ((orig-spec (unknown-type-specifier type)))
288 (if (and (symbolp orig-spec)
289 (info type defined-structure-info orig-spec))
290 (structure-typep object orig-spec)
291 (error "Unknown type specifier: ~S" orig-spec))))
292 (hairy-type
293 ;; Now the tricky stuff.
294 (let* ((hairy-spec (hairy-type-specifier type))
295 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
296 (ecase symbol
297 (and
298 (or (atom hairy-spec)
299 (dolist (spec (cdr hairy-spec) t)
300 (unless (%%typep object (specifier-type spec))
301 (return nil)))))
302 (not
303 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
304 (error "Invalid type specifier: ~S" hairy-spec))
305 (not (%%typep object (specifier-type (cadr hairy-spec)))))
306 (satisfies
307 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
308 (error "Invalid type specifier: ~S" hairy-spec))
309 (let ((fn (cadr hairy-spec)))
310 (if (funcall (typecase fn
311 (function fn)
312 (symbol (symbol-function fn))
313 (t
314 (coerce fn 'function)))
315 object)
316 t
317 nil))))))
318 (alien-type-type
319 (alien-internals:alien-typep object (alien-type-type-alien-type type)))
320 (function-type
321 (error "Function types are not a legal argument to TYPEP:~% ~S"
322 (type-specifier type)))))
323
324
325
326 ;;; CLASS-TYPEP -- Internal
327 ;;;
328 ;;; Test whether Obj-Layout is from an instance of Class.
329 ;;;
330 (defun class-typep (obj-layout class)
331 (declare (optimize speed))
332 (when (layout-invalid obj-layout)
333 (error "TYPEP on obsolete object (was class ~S)."
334 (class-proper-name (layout-class obj-layout))))
335 (let* ((layout (class-layout class))
336 (subclasses (class-subclasses layout)))
337 (when (layout-invalid layout)
338 (error "Class is currently invalid: ~S" class))
339 (if (or (eq obj-layout layout)
340 (and subclasses
341 (gethash (layout-class obj-layout) subclasses)))
342 t
343 nil)))
344
345
346 ;;;; Equality predicates.
347
348 ;;; EQ -- public.
349 ;;;
350 ;;; Real simple, 'cause the compiler takes care of it.
351 ;;;
352
353 (defun eq (obj1 obj2)
354 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
355 (eq obj1 obj2))
356
357
358 ;;; EQUAL -- public.
359 ;;;
360 (defun equal (x y)
361 "Returns T if X and Y are EQL or if they are structured components
362 whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
363 are the same length and have indentical components. Other arrays must be
364 EQ to be EQUAL."
365 (cond ((eql x y) t)
366 ((consp x)
367 (and (consp y)
368 (equal (car x) (car y))
369 (equal (cdr x) (cdr y))))
370 ((stringp x)
371 (and (stringp y) (string= x y)))
372 ((pathnamep x)
373 (and (pathnamep y) (pathname= x y)))
374 ((bit-vector-p x)
375 (and (bit-vector-p y)
376 (= (the fixnum (length x))
377 (the fixnum (length y)))
378 (do ((i 0 (1+ i))
379 (length (length x)))
380 ((= i length) t)
381 (declare (fixnum i))
382 (or (= (the fixnum (bit x i))
383 (the fixnum (bit y i)))
384 (return nil)))))
385 (t nil)))
386
387 ;;; EQUALP -- public.
388 ;;;
389 (defun equalp (x y)
390 "Just like EQUAL, but more liberal in several respects.
391 Numbers may be of different types, as long as the values are identical
392 after coercion. Characters may differ in alphabetic case. Vectors and
393 arrays must have identical dimensions and EQUALP elements, but may differ
394 in their type restriction."
395 (cond ((eq x y) t)
396 ((characterp x) (char-equal x y))
397 ((numberp x) (and (numberp y) (= x y)))
398 ((consp x)
399 (and (consp y)
400 (equalp (car x) (car y))
401 (equalp (cdr x) (cdr y))))
402 ((pathnamep x)
403 (and (pathnamep y) (pathname= x y)))
404 ((%instancep x)
405 (let* ((layout-x (%instance-layout x))
406 (length (layout-length layout-x)))
407 (and (%instancep y)
408 (eq layout-x (%instance-layout y))
409 (structure-class-p (layout-class layout-x))
410 (do ((i 1 (1+ i)))
411 ((= i len) t)
412 (declare (fixnum i))
413 (let ((x-el (%instance-ref x i))
414 (y-el (%instance-ref y i)))
415 (unless (or (eq x-el y-el)
416 (equalp x-el y-el))
417 (return nil)))))))
418 ((vectorp x)
419 (let ((length (length x)))
420 (and (vectorp y)
421 (= length (length y))
422 (dotimes (i length t)
423 (let ((x-el (aref x i))
424 (y-el (aref y i)))
425 (unless (or (eq x-el y-el)
426 (equalp x-el y-el))
427 (return nil)))))))
428 ((arrayp x)
429 (and (arrayp y)
430 (= (array-rank x) (array-rank y))
431 (dotimes (axis (array-rank x) t)
432 (unless (= (array-dimension x axis)
433 (array-dimension y axis))
434 (return nil)))
435 (dotimes (index (array-total-size x) t)
436 (let ((x-el (row-major-aref x index))
437 (y-el (row-major-aref y index)))
438 (unless (or (eq x-el y-el)
439 (equalp x-el y-el))
440 (return nil))))))
441 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5