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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Sat Dec 5 22:10:02 1992 UTC (21 years, 4 months ago) by wlott
Branch: MAIN
Branch point for: new_struct
Changes since 1.27: +31 -3 lines
Added support for dylan funciton subtypes.
1 wlott 1.7 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ram 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.16 ;;; 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 wlott 1.28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.28 1992/12/05 22:10:02 wlott Exp $")
11 ram 1.16 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.7 ;;; Predicate functions for CMU Common Lisp.
15 ram 1.1 ;;;
16 wlott 1.7 ;;; Written by William Lott.
17     ;;;
18    
19     (in-package "EXTENSIONS")
20 wlott 1.26 (export '(structurep fixnump bignump bitp ratiop weak-pointer-p))
21 wlott 1.7
22     (in-package "SYSTEM")
23     (export '(system-area-pointer system-area-pointer-p))
24    
25     (in-package "LISP" :use "KERNEL")
26    
27 ram 1.1 (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 wlott 1.26 type-of upgraded-array-element-type realp
32 ram 1.1 ;; 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 wlott 1.7 null number ratio rational real sequence short-float signed-byte
37 ram 1.1 simple-array simple-bit-vector simple-string simple-vector
38     single-float standard-char string string-char symbol t
39     unsigned-byte vector structure satisfies))
40    
41    
42 wlott 1.7
43     ;;;; Primitive predicates. These must be supported by the compiler.
44 ram 1.1
45 wlott 1.7 (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 wlott 1.18 code-component-p
55 wlott 1.7 consp
56     compiled-function-p
57     complexp
58     double-float-p
59 wlott 1.25 fdefn-p
60 wlott 1.7 fixnump
61     floatp
62     functionp
63     integerp
64     listp
65 wlott 1.10 long-float-p
66 wlott 1.18 lra-p
67 wlott 1.7 not
68     null
69     numberp
70     rationalp
71     ratiop
72     realp
73 wlott 1.18 scavenger-hook-p
74 wlott 1.10 short-float-p
75 wlott 1.7 simple-array-p
76     simple-bit-vector-p
77     simple-string-p
78     simple-vector-p
79     single-float-p
80     stringp
81 wlott 1.9 structurep
82 wlott 1.7 symbolp
83     system-area-pointer-p
84     weak-pointer-p
85     vectorp
86 ram 1.20 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 wlott 1.28 dylan::dylan-function-p
96 wlott 1.7 )))
97 ram 1.1
98 wlott 1.7 (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 ram 1.1
112    
113 wlott 1.7 ;;;; 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 ram 1.1 (defun type-of (object)
120 wlott 1.7 "Return the type of OBJECT."
121     (typecase object
122 wlott 1.8 ;; First the ones that we can tell by testing the lowtag
123     (fixnum 'fixnum)
124     (function (type-specifier (ctype-of object)))
125 wlott 1.7 (null 'null)
126 wlott 1.8 (list 'cons)
127    
128     ;; Any other immediates.
129 wlott 1.7 (character
130     (typecase object
131     (standard-char 'standard-char)
132 wlott 1.19 (base-char 'base-char)
133 wlott 1.7 (t 'character)))
134 wlott 1.8
135     ;; And now for the complicated ones.
136 wlott 1.7 (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 wlott 1.8 (symbol
149     (if (eq (symbol-package object)
150     (symbol-package :foo))
151     'keyword
152     'symbol))
153 ram 1.24 (structure
154     (let ((name (structure-ref object 0)))
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 wlott 1.8 (array (type-specifier (ctype-of object)))
162     (system-area-pointer 'system-area-pointer)
163     (weak-pointer 'weak-pointer)
164 wlott 1.18 (code-component 'code-component)
165     (lra 'lra)
166 wlott 1.25 (fdefn 'fdefn)
167 wlott 1.18 (scavenger-hook 'scavenger-hook)
168 wlott 1.7 (t
169     (warn "Can't figure out the type of ~S" object)
170     t)))
171 ram 1.22
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 wlott 1.7
181     ;;;; SUBTYPEP -- public.
182 ram 1.1 ;;;
183 wlott 1.7 ;;; 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 ram 1.1
192    
193 wlott 1.7 ;;;; 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 ram 1.1
202 wlott 1.28 (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 wlott 1.7 ;;; %TYPEP -- internal.
210 ram 1.1 ;;;
211 wlott 1.7 ;;; 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 wlott 1.13 (%%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 wlott 1.28 (case (named-type-name type)
225 wlott 1.13 ((* t)
226     t)
227     ((nil)
228     nil)
229     (character (characterp object))
230 wlott 1.19 (base-char (base-char-p object))
231 wlott 1.13 (standard-char (and (characterp object) (standard-char-p object)))
232 wlott 1.19 (extended-char
233 wlott 1.13 (and (characterp object) (not (base-char-p object))))
234     (function (functionp object))
235     (cons (consp object))
236     (symbol (symbolp object))
237     (keyword
238     (and (symbolp object)
239     (eq (symbol-package object)
240     (symbol-package :foo))))
241     (system-area-pointer (system-area-pointer-p object))
242     (weak-pointer (weak-pointer-p object))
243 wlott 1.18 (code-component (code-component-p object))
244     (lra (lra-p object))
245 wlott 1.25 (fdefn (fdefn-p object))
246 wlott 1.18 (scavenger-hook (scavenger-hook-p object))
247 wlott 1.28 (structure (structurep object))
248     (dylan::dylan-function (dylan::dylan-function-p object))
249     (dylan::generic-function
250     (only-if-bound dylan::generic-function-p object))
251     (dylan::exit-function
252     (only-if-bound dylan::exit-function-p object))
253     (dylan::next-method-func
254     (only-if-bound dylan::next-method-func-p object))
255     (dylan::method
256     (only-if-bound dylan::method-p object))
257     (dylan::defined-method
258     (only-if-bound dylan::defined-method-p object))
259     (dylan::builtin-method
260     (only-if-bound dylan::builtin-method-p object))
261     (dylan::slot-accessor-method
262     (only-if-bound dylan::slot-accessor-method-p object))
263     (dylan::slot-setter-method
264     (only-if-bound dylan::slot-setter-method-p object))
265     (dylan::slot-getter-method
266     (only-if-bound dylan::slot-getter-method-p object))
267     (t nil)))
268 wlott 1.13 (numeric-type
269     (and (numberp object)
270     (let ((num (if (complexp object) (realpart object) object)))
271     (ecase (numeric-type-class type)
272     (integer (integerp num))
273     (rational (rationalp num))
274     (float
275     (ecase (numeric-type-format type)
276     (short-float (typep object 'short-float))
277     (single-float (typep object 'single-float))
278     (double-float (typep object 'double-float))
279     (long-float (typep object 'long-float))
280     ((nil) (floatp num))))
281 wlott 1.27 ((nil) t)))
282 wlott 1.13 (flet ((bound-test (val)
283     (let ((low (numeric-type-low type))
284     (high (numeric-type-high type)))
285     (and (cond ((null low) t)
286     ((listp low) (> val (car low)))
287     (t (>= val low)))
288     (cond ((null high) t)
289     ((listp high) (< val (car high)))
290     (t (<= val high)))))))
291     (ecase (numeric-type-complexp type)
292     ((nil) t)
293     (:complex
294     (and (complexp object)
295 wlott 1.26 (bound-test (realpart object))
296     (bound-test (imagpart object))))
297 wlott 1.13 (:real
298     (and (not (complexp object))
299     (bound-test object)))))))
300     (array-type
301     (and (arrayp object)
302     (ecase (array-type-complexp type)
303     ((t) (not (typep object 'simple-array)))
304     ((nil) (typep object 'simple-array))
305     (* t))
306     (or (eq (array-type-dimensions type) '*)
307     (do ((want (array-type-dimensions type) (cdr want))
308     (got (array-dimensions object) (cdr got)))
309     ((and (null want) (null got)) t)
310     (unless (and want got
311     (or (eq (car want) '*)
312     (= (car want) (car got))))
313     (return nil))))
314     (or (eq (array-type-element-type type) *wild-type*)
315     (type= (array-type-specialized-element-type type)
316     (specifier-type (array-element-type object))))))
317     (member-type
318     (if (member object (member-type-members type)) t))
319     (structure-type
320     (structure-typep object (structure-type-name type)))
321     (union-type
322     (dolist (type (union-type-types type))
323     (when (%%typep object type)
324     (return t))))
325     (unknown-type
326     ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
327     ;; a defined structure in the core.
328     (let ((orig-spec (unknown-type-specifier type)))
329     (if (and (symbolp orig-spec)
330     (info type defined-structure-info orig-spec))
331     (structure-typep object orig-spec)
332     (error "Unknown type specifier: ~S" orig-spec))))
333     (hairy-type
334     ;; Now the tricky stuff.
335     (let* ((hairy-spec (hairy-type-specifier type))
336     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
337     (ecase symbol
338     (and
339     (or (atom hairy-spec)
340 ram 1.21 (dolist (spec (cdr hairy-spec) t)
341 wlott 1.14 (unless (%%typep object (specifier-type spec))
342 wlott 1.13 (return nil)))))
343     (not
344     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
345     (error "Invalid type specifier: ~S" hairy-spec))
346 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
347 wlott 1.13 (satisfies
348     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
349     (error "Invalid type specifier: ~S" hairy-spec))
350 wlott 1.17 (let ((fn (cadr hairy-spec)))
351     (if (funcall (typecase fn
352     (function fn)
353     (symbol (symbol-function fn))
354     (t
355     (coerce fn 'function)))
356     object)
357     t
358     nil))))))
359 wlott 1.23 (alien-type-type
360     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
361 wlott 1.13 (function-type
362     (error "Function types are not a legal argument to TYPEP:~% ~S"
363     (type-specifier type)))))
364    
365 ram 1.1
366    
367     ;;; Structure-Typep -- Internal
368     ;;;
369 wlott 1.7 ;;; This is called by %typep when it tries to match against a structure type,
370     ;;; and typep of types that are known to be structure types at compile time
371     ;;; are converted to this.
372 ram 1.1 ;;;
373     (defun structure-typep (object type)
374     (declare (optimize speed))
375 wlott 1.7 (let ((info (info type defined-structure-info type)))
376     (if info
377     (and (structurep object)
378 ram 1.20 (let ((obj-name (structure-ref object 0)))
379 wlott 1.7 (or (eq obj-name type)
380     (if (member obj-name (c::dd-included-by info)
381     :test #'eq)
382     t nil))))
383     (error "~S is an unknown structure type specifier." type))))
384 ram 1.1
385    
386 wlott 1.7 ;;;; Equality predicates.
387 ram 1.1
388 wlott 1.7 ;;; EQ -- public.
389     ;;;
390     ;;; Real simple, 'cause the compiler takes care of it.
391     ;;;
392 ram 1.1
393 wlott 1.7 (defun eq (obj1 obj2)
394     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
395     (eq obj1 obj2))
396 ram 1.1
397    
398 wlott 1.7 ;;; EQUAL -- public.
399     ;;;
400 ram 1.1 (defun equal (x y)
401     "Returns T if X and Y are EQL or if they are structured components
402     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
403     are the same length and have indentical components. Other arrays must be
404     EQ to be EQUAL."
405     (cond ((eql x y) t)
406     ((consp x)
407     (and (consp y)
408     (equal (car x) (car y))
409     (equal (cdr x) (cdr y))))
410     ((stringp x)
411     (and (stringp y) (string= x y)))
412     ((pathnamep x)
413 ram 1.20 (and (pathnamep y) (pathname= x y)))
414 ram 1.1 ((bit-vector-p x)
415     (and (bit-vector-p y)
416     (= (the fixnum (length x))
417     (the fixnum (length y)))
418     (do ((i 0 (1+ i))
419     (length (length x)))
420     ((= i length) t)
421     (declare (fixnum i))
422     (or (= (the fixnum (bit x i))
423     (the fixnum (bit y i)))
424     (return nil)))))
425     (t nil)))
426    
427 wlott 1.7 ;;; EQUALP -- public.
428     ;;;
429 ram 1.1 (defun equalp (x y)
430     "Just like EQUAL, but more liberal in several respects.
431     Numbers may be of different types, as long as the values are identical
432     after coercion. Characters may differ in alphabetic case. Vectors and
433     arrays must have identical dimensions and EQUALP elements, but may differ
434     in their type restriction."
435 wlott 1.12 (cond ((eq x y) t)
436 ram 1.1 ((characterp x) (char-equal x y))
437     ((numberp x) (and (numberp y) (= x y)))
438     ((consp x)
439     (and (consp y)
440     (equalp (car x) (car y))
441     (equalp (cdr x) (cdr y))))
442 ram 1.20 ((pathnamep x)
443     (and (pathnamep y) (pathname= x y)))
444 wlott 1.12 ((structurep x)
445 ram 1.20 (let ((length (structure-length x)))
446 wlott 1.12 (and (structurep y)
447 ram 1.20 (= length (structure-length y))
448 wlott 1.12 (dotimes (i length t)
449 ram 1.20 (let ((x-el (structure-ref x i))
450     (y-el (structure-ref y i)))
451 wlott 1.12 (unless (or (eq x-el y-el)
452     (equalp x-el y-el))
453     (return nil)))))))
454 ram 1.1 ((vectorp x)
455     (let ((length (length x)))
456     (and (vectorp y)
457 wlott 1.7 (= length (length y))
458 ram 1.1 (dotimes (i length t)
459     (let ((x-el (aref x i))
460     (y-el (aref y i)))
461 wlott 1.12 (unless (or (eq x-el y-el)
462 ram 1.1 (equalp x-el y-el))
463     (return nil)))))))
464     ((arrayp x)
465 wlott 1.7 (and (arrayp y)
466     (= (array-rank x) (array-rank y))
467     (dotimes (axis (array-rank x) t)
468     (unless (= (array-dimension x axis)
469     (array-dimension y axis))
470     (return nil)))
471     (dotimes (index (array-total-size x) t)
472 wlott 1.12 (let ((x-el (row-major-aref x index))
473     (y-el (row-major-aref y index)))
474     (unless (or (eq x-el y-el)
475     (equalp x-el y-el))
476     (return nil))))))
477 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5