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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5