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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Wed Oct 3 09:58:48 1990 UTC (23 years, 6 months ago) by wlott
Branch: MAIN
Changes since 1.9: +3 -1 lines
Added interpreter stubs for long-float-p and short-float-p.
1 wlott 1.7 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ram 1.1 ;;;
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 wlott 1.10 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.10 1990/10/03 09:58:48 wlott Exp $
11 ram 1.1 ;;;
12 wlott 1.7 ;;; Predicate functions for CMU Common Lisp.
13 ram 1.1 ;;;
14 wlott 1.7 ;;; 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 ram 1.1 (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 wlott 1.7 null number ratio rational real sequence short-float signed-byte
35 ram 1.1 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 wlott 1.7
41     ;;;; Primitive predicates. These must be supported by the compiler.
42 ram 1.1
43 wlott 1.7 (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 wlott 1.10 long-float-p
62 wlott 1.7 not
63     null
64     numberp
65     rationalp
66     ratiop
67     realp
68 wlott 1.10 short-float-p
69 wlott 1.7 simple-array-p
70     simple-bit-vector-p
71     simple-string-p
72     simple-vector-p
73     single-float-p
74     stringp
75 wlott 1.9 structurep
76 wlott 1.7 symbolp
77     system-area-pointer-p
78     weak-pointer-p
79     vectorp
80     c::unsigned-byte-32-p
81     c::signed-byte-32-p
82     c::simple-array-unsigned-byte-2-p
83     c::simple-array-unsigned-byte-4-p
84     c::simple-array-unsigned-byte-8-p
85     c::simple-array-unsigned-byte-16-p
86     c::simple-array-unsigned-byte-32-p
87     c::simple-array-single-float-p
88     c::simple-array-double-float-p
89     )))
90 ram 1.1
91 wlott 1.7 (macrolet
92     ((frob ()
93     `(progn
94     ,@(mapcar #'(lambda (pred)
95     `(defun ,pred (object)
96     ,(format nil
97     "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
98     and NIL otherwise."
99     (find (schar (string pred) 0) "AEIOUaeiou")
100     (string pred))
101     (,pred object)))
102     primitive-predicates))))
103     (frob))
104 ram 1.1
105    
106 wlott 1.7 ;;;; TYPE-OF -- public.
107     ;;;
108     ;;; Return the specifier for the type of object. This is not simply
109     ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
110     ;;; than type-of.
111     ;;;
112 ram 1.1 (defun type-of (object)
113 wlott 1.7 "Return the type of OBJECT."
114     (typecase object
115 wlott 1.8 ;; First the ones that we can tell by testing the lowtag
116     (fixnum 'fixnum)
117     (function (type-specifier (ctype-of object)))
118 wlott 1.7 (null 'null)
119 wlott 1.8 (list 'cons)
120    
121     ;; Any other immediates.
122 wlott 1.7 (character
123     (typecase object
124     (standard-char 'standard-char)
125     (base-character 'base-character)
126     (t 'character)))
127 wlott 1.8
128     ;; And now for the complicated ones.
129 wlott 1.7 (number
130     (etypecase object
131     (fixnum 'fixnum)
132     (bignum 'bignum)
133     (float
134     (etypecase object
135     (double-float 'double-float)
136     (single-float 'single-float)
137     (short-float 'short-float)
138     (long-float 'long-float)))
139     (ratio 'ratio)
140     (complex 'complex)))
141 wlott 1.8 (symbol
142     (if (eq (symbol-package object)
143     (symbol-package :foo))
144     'keyword
145     'symbol))
146     (structure (%primitive c::structure-ref object 0))
147     (array (type-specifier (ctype-of object)))
148     (system-area-pointer 'system-area-pointer)
149     (weak-pointer 'weak-pointer)
150 wlott 1.7 (t
151     (warn "Can't figure out the type of ~S" object)
152     t)))
153 ram 1.1
154 wlott 1.7
155     ;;;; SUBTYPEP -- public.
156 ram 1.1 ;;;
157 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
158     ;;;
159     (defun subtypep (type1 type2)
160     "Return two values indicating the relationship between type1 and type2:
161     T and T: type1 definatly is a subtype of type2.
162     NIL and T: type1 definatly is not a subtype of type2.
163     NIL and NIL: who knows?"
164     (csubtypep (specifier-type type1) (specifier-type type2)))
165 ram 1.1
166    
167 wlott 1.7 ;;;; TYPEP -- public.
168     ;;;
169     ;;; Just call %typep
170     ;;;
171     (defun typep (object type)
172     "Return T iff OBJECT is of type TYPE."
173     (declare (type (or list symbol) type))
174     (%typep object type))
175 ram 1.1
176 wlott 1.7 ;;; %TYPEP -- internal.
177 ram 1.1 ;;;
178 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
179     ;;; function when it can't figure out anything more intelligent to do.
180     ;;;
181     (defun %typep (object specifier)
182     (declare (type (or list symbol ctype) specifier))
183     (let ((type (if (ctype-p specifier)
184     specifier
185     (specifier-type specifier))))
186     (etypecase type
187     (named-type
188     (ecase (named-type-name type)
189     ((* t)
190     t)
191     ((nil)
192     nil)
193     (character (characterp object))
194     (base-character (base-char-p object))
195     (standard-char (and (characterp object) (standard-char-p object)))
196     (extended-character
197     (and (characterp object) (not (base-char-p object))))
198     (function (functionp object))
199     (cons (consp object))
200     (symbol (symbolp object))
201     (keyword
202     (and (symbolp object)
203     (eq (symbol-package object)
204     (symbol-package :foo))))
205     (system-area-pointer (system-area-pointer-p object))
206     (weak-pointer (weak-pointer-p object))
207     (structure (structurep object))))
208     (numeric-type
209     (and (numberp object)
210     (let ((num (if (complexp object) (realpart object) object)))
211     (ecase (numeric-type-class type)
212     (integer (integerp num))
213     (rational (rationalp num))
214     (float
215     (ecase (numeric-type-format type)
216     (short-float (typep object 'short-float))
217     (single-float (typep object 'single-float))
218     (double-float (typep object 'double-float))
219     (long-float (typep object 'long-float))
220     ((nil) (floatp num))))
221     ((nil) t)))
222     (flet ((bound-test (val)
223     (let ((low (numeric-type-low type))
224     (high (numeric-type-high type)))
225     (and (cond ((null low) t)
226     ((listp low) (> val (car low)))
227     (t (>= val low)))
228     (cond ((null high) t)
229     ((listp high) (< val (car high)))
230     (t (<= val high)))))))
231     (ecase (numeric-type-complexp type)
232     ((nil) t)
233     (:complex
234     (and (complexp object)
235     (let ((re (realpart object))
236     (im (imagpart object)))
237     (and (bound-test (min re im))
238     (bound-test (max re im))))))
239     (:real
240     (and (not (complexp object))
241     (bound-test object)))))))
242     (array-type
243     (and (arrayp object)
244     (ecase (array-type-complexp type)
245     ((t) (not (typep object 'simple-array)))
246     ((nil) (typep object 'simple-array))
247     (* t))
248     (or (eq (array-type-dimensions type) '*)
249     (do ((want (array-type-dimensions type) (cdr want))
250     (got (array-dimensions object) (cdr got)))
251     ((and (null want) (null got)) t)
252     (unless (and want got
253     (or (eq (car want) '*)
254     (= (car want) (car got))))
255     (return nil))))
256     (or (eq (array-type-element-type type) *wild-type*)
257     (type= (array-type-specialized-element-type type)
258     (specifier-type (array-element-type object))))))
259     (member-type
260     (if (member object (member-type-members type)) t))
261     (structure-type
262     (structure-typep object (structure-type-name type)))
263     (union-type
264     (dolist (type (union-type-types type))
265     (when (%typep object type)
266     (return t))))
267     (unknown-type
268     (let ((orig-spec (unknown-type-specifier type)))
269     (if (eq type specifier)
270     ;; The type was unknown at compile time. Therefore, we should
271     ;; try again at runtime, 'cause it might be known now.
272     (%typep object orig-spec)
273     (error "Unknown type specifier: ~S" orig-spec))))
274     (hairy-type
275     ;; Now the tricky stuff.
276     (let* ((hairy-spec (hairy-type-specifier type))
277     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
278     (ecase symbol
279     (and
280     (or (atom hairy-spec)
281     (dolist (spec (cdr hairy-spec))
282     (unless (%typep object spec)
283     (return nil)))))
284     (not
285     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
286     (error "Invalid type specifier: ~S" hairy-spec))
287     (not (%typep object (cadr hairy-spec))))
288     (satisfies
289     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
290     (error "Invalid type specifier: ~S" hairy-spec))
291     (if (funcall (cadr hairy-spec) object) t)))))
292     (function-type
293     (error "Function types are not a legal argument to TYPEP:~% ~S"
294     specifier)))))
295 ram 1.1
296    
297     ;;; Structure-Typep -- Internal
298     ;;;
299 wlott 1.7 ;;; This is called by %typep when it tries to match against a structure type,
300     ;;; and typep of types that are known to be structure types at compile time
301     ;;; are converted to this.
302 ram 1.1 ;;;
303     (defun structure-typep (object type)
304     (declare (optimize speed))
305 wlott 1.7 (let ((info (info type defined-structure-info type)))
306     (if info
307     (and (structurep object)
308     (let ((obj-name (%primitive structure-ref object 0)))
309     (or (eq obj-name type)
310     (if (member obj-name (c::dd-included-by info)
311     :test #'eq)
312     t nil))))
313     (error "~S is an unknown structure type specifier." type))))
314 ram 1.1
315    
316 wlott 1.7 ;;;; Equality predicates.
317 ram 1.1
318 wlott 1.7 ;;; EQ -- public.
319     ;;;
320     ;;; Real simple, 'cause the compiler takes care of it.
321     ;;;
322 ram 1.1
323 wlott 1.7 (defun eq (obj1 obj2)
324     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
325     (eq obj1 obj2))
326 ram 1.1
327    
328 wlott 1.7 ;;; EQUAL -- public.
329     ;;;
330 ram 1.1 (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 wlott 1.7 (unless (equal x-el y-el)
362 ram 1.1 (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 wlott 1.7 ;;; EQUALP -- public.
377     ;;;
378 ram 1.1 (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 wlott 1.7 (= length (length y))
395 ram 1.1 (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 wlott 1.7 (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 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5