/[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.5 - (show annotations) (vendor branch)
Sun Jun 3 18:59:49 1990 UTC (23 years, 10 months ago) by ch
Changes since 1.4.1.4: +4 -2 lines
Added weak pointer cruft.
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.5 1990/06/03 18:59:49 ch 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 (typecase 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 (ecase (numeric-type-complexp type)
202 ((nil) t)
203 (:complex
204 (complexp object))
205 (:real
206 (let ((low (numeric-type-low type))
207 (high (numeric-type-high type)))
208 (and (not (complexp object))
209 (cond ((null low) t)
210 ((listp low) (> object (car low)))
211 (t (>= object low)))
212 (cond ((null high) t)
213 ((listp high) (< object (car high)))
214 (t (<= object high)))))))))
215 (array-type
216 (and (arrayp object)
217 (ecase (array-type-complexp type)
218 ((t) (not (typep object 'simple-array)))
219 ((nil) (typep object 'simple-array))
220 (* t))
221 (or (eq (array-type-dimensions type) '*)
222 (do ((want (array-type-dimensions type) (cdr want))
223 (got (array-dimensions object) (cdr got)))
224 ((and (null want) (null got)) t)
225 (unless (and want got
226 (or (eq (car want) '*)
227 (= (car want) (car got))))
228 (return nil))))
229 (or (eq (array-type-element-type type) *wild-type*)
230 (type= (array-type-element-type type)
231 (specifier-type (array-element-type object))))))
232 (member-type
233 (if (member object (member-type-members type)) t))
234 (structure-type
235 (structure-typep object (structure-type-name type)))
236 (union-type
237 (dolist (type (union-type-types type))
238 (when (%typep object type)
239 (return t))))
240 (unknown-type
241 (let ((orig-spec (unknown-type-specifier type)))
242 (if (eq type specifier)
243 ;; The type was unknown at compile time. Therefore, we should
244 ;; try again at runtime, 'cause it might be known now.
245 (%typep object orig-spec)
246 (error "Unknown type specifier: ~S" orig-spec))))
247 (hairy-type
248 ;; Now the tricky stuff.
249 (let* ((hairy-spec (hairy-type-specifier type))
250 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
251 (ecase symbol
252 (and
253 (or (atom hairy-spec)
254 (dolist (spec (cdr hairy-spec))
255 (unless (%typep object spec)
256 (return nil)))))
257 (not
258 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
259 (error "Invalid type specifier: ~S" hairy-spec))
260 (not (%typep object (cadr hairy-spec))))
261 (satisfies
262 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
263 (error "Invalid type specifier: ~S" hairy-spec))
264 (if (funcall (cadr hairy-spec) object) t))))))))
265
266 ;;; Structure-Typep -- Internal
267 ;;;
268 ;;; This is called by %typep when it tries to match against a structure type,
269 ;;; and typep of types that are known to be structure types at compile time
270 ;;; are converted to this.
271 ;;;
272 (defun structure-typep (object type)
273 (declare (optimize speed))
274 (let ((info (info type defined-structure-info type)))
275 (if info
276 (and (structurep object)
277 (let ((obj-name (%primitive structure-ref object 0)))
278 (or (eq obj-name type)
279 (if (member obj-name (c::dd-included-by info)
280 :test #'eq)
281 t nil))))
282 (error "~S is an unknown structure type specifier." type))))
283
284
285 ;;;; Equality predicates.
286
287 ;;; EQ -- public.
288 ;;;
289 ;;; Real simple, 'cause the compiler takes care of it.
290 ;;;
291
292 (defun eq (obj1 obj2)
293 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
294 (eq obj1 obj2))
295
296 ;;; EQL -- public.
297 ;;;
298 ;;; More complicated, 'cause we have to pick off a few of the immediate types.
299 ;;;
300 (defun eql (obj1 obj2)
301 "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
302 (or (eq obj1 obj2)
303 (macrolet ((foo (&rest stuff)
304 `(typecase obj1
305 ,@(mapcar #'(lambda (foo)
306 (let ((type (car foo))
307 (fn (cadr foo)))
308 `(,type
309 (and (typep obj2 ',type)
310 (,fn (truly-the ,type obj1)
311 (truly-the ,type obj2))))))
312 stuff))))
313 (foo
314 (fixnum =)
315 (bignum =)
316 (character char=)))))
317
318 ;;; EQUAL -- public.
319 ;;;
320 (defun equal (x y)
321 "Returns T if X and Y are EQL or if they are structured components
322 whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
323 are the same length and have indentical components. Other arrays must be
324 EQ to be EQUAL."
325 (cond ((eql x y) t)
326 ((consp x)
327 (and (consp y)
328 (equal (car x) (car y))
329 (equal (cdr x) (cdr y))))
330 ((stringp x)
331 (and (stringp y) (string= x y)))
332 ((pathnamep x)
333 (and (pathnamep y)
334 (do* ((i 1 (1+ i))
335 (len (length x)))
336 ((>= i len) t)
337 (declare (fixnum i len))
338 (let ((x-el (svref x i))
339 (y-el (svref y i)))
340 (if (and (simple-vector-p x-el)
341 (simple-vector-p y-el))
342 (let ((lx (length x-el))
343 (ly (length y-el)))
344 (declare (fixnum lx ly))
345 (if (/= lx ly) (return nil))
346 (do ((i 0 (1+ i)))
347 ((>= i lx))
348 (declare (fixnum i))
349 (if (not (equal (svref x-el i) (svref y-el i)))
350 (return-from equal nil))))
351 (unless (equal x-el y-el)
352 (return nil)))))))
353 ((bit-vector-p x)
354 (and (bit-vector-p y)
355 (= (the fixnum (length x))
356 (the fixnum (length y)))
357 (do ((i 0 (1+ i))
358 (length (length x)))
359 ((= i length) t)
360 (declare (fixnum i))
361 (or (= (the fixnum (bit x i))
362 (the fixnum (bit y i)))
363 (return nil)))))
364 (t nil)))
365
366 ;;; EQUALP -- public.
367 ;;;
368 (defun equalp (x y)
369 "Just like EQUAL, but more liberal in several respects.
370 Numbers may be of different types, as long as the values are identical
371 after coercion. Characters may differ in alphabetic case. Vectors and
372 arrays must have identical dimensions and EQUALP elements, but may differ
373 in their type restriction."
374 (cond ((eql x y) t)
375 ((characterp x) (char-equal x y))
376 ((numberp x) (and (numberp y) (= x y)))
377 ((consp x)
378 (and (consp y)
379 (equalp (car x) (car y))
380 (equalp (cdr x) (cdr y))))
381 ((vectorp x)
382 (let ((length (length x)))
383 (and (vectorp y)
384 (= length (length y))
385 (dotimes (i length t)
386 (let ((x-el (aref x i))
387 (y-el (aref y i)))
388 (unless (or (eql x-el y-el)
389 (equalp x-el y-el))
390 (return nil)))))))
391 ((arrayp x)
392 (and (arrayp y)
393 (= (array-rank x) (array-rank y))
394 (dotimes (axis (array-rank x) t)
395 (unless (= (array-dimension x axis)
396 (array-dimension y axis))
397 (return nil)))
398 (dotimes (index (array-total-size x) t)
399 (unless (equalp (row-major-aref x index)
400 (row-major-aref y index))
401 (return nil)))))
402 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5