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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Feb 12 12:00:17 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.2: +7 -9 lines
Changed STRUCTURE-TYPEP to use INFO TYPE DEFINED-STRUCTURE-INFO.
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 ;;; Predicate functions for Spice Lisp.
11 ;;; The type predicates are implementation-specific. A different version
12 ;;; of this file will be required for implementations with different
13 ;;; data representations.
14 ;;;
15 ;;; Written and currently maintained by Scott Fahlman.
16 ;;; Based on an earlier version by Joe Ginder.
17 ;;;
18 (in-package 'lisp)
19 (export '(typep null symbolp atom consp listp numberp integerp rationalp
20 floatp complexp characterp stringp bit-vector-p vectorp
21 simple-vector-p simple-string-p simple-bit-vector-p arrayp
22 functionp compiled-function-p commonp eq eql equal equalp not
23 type-of
24 ;; Names of types...
25 array atom bignum bit bit-vector character common
26 compiled-function complex cons double-float
27 fixnum float function integer keyword list long-float nil
28 null number ratio rational sequence short-float signed-byte
29 simple-array simple-bit-vector simple-string simple-vector
30 single-float standard-char string string-char symbol t
31 unsigned-byte vector structure satisfies))
32
33 (in-package "EXTENSIONS")
34 (export '(structurep fixnump bignump bitp ratiop))
35 (in-package "LISP")
36
37
38 ;;; Data type predicates.
39
40 ;;; Translation from type keywords to specific predicates. Assumes that
41 ;;; the following are named structures and need no special type hackery:
42 ;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE.
43
44 (defconstant type-pred-alist
45 '((keyword . keywordp)
46 (common . commonp)
47 (null . null)
48 (cons . consp)
49 (list . listp)
50 (symbol . symbolp)
51 (array . arrayp)
52 (vector . vectorp)
53 (bit-vector . bit-vector-p)
54 (string . stringp)
55 (sequence . sequencep)
56 (simple-array . simple-array-p)
57 (simple-vector . simple-vector-p)
58 (simple-string . simple-string-p)
59 (simple-bit-vector . simple-bit-vector-p)
60 (function . functionp)
61 (compiled-function . compiled-function-p)
62 (character . characterp)
63 (number . numberp)
64 (rational . rationalp)
65 (float . floatp)
66 (string-char . %string-char-p)
67 (integer . integerp)
68 (ratio . ratiop)
69 (short-float . short-float-p)
70 (standard-char . %standard-char-p)
71 (fixnum . fixnump)
72 (complex . complexp)
73 ; (single-float . single-float-p)
74 (single-float . short-float-p)
75 (bignum . bignump)
76 (double-float . double-float-p)
77 (bit . bitp)
78 (long-float . long-float-p)
79 (structure . structurep)
80 (atom . atom)))
81
82
83 ;;;; TYPE-OF and auxiliary functions.
84
85 (defun type-of (object)
86 "Returns the type of OBJECT as a type-specifier.
87 Since objects may be of more than one type, the choice is somewhat
88 arbitrary and may be implementation-dependent."
89 (if (null object) 'symbol
90 (case (%primitive get-type object)
91 (#.%+-fixnum-type 'fixnum)
92 (#.%bignum-type 'bignum)
93 (#.%ratio-type 'ratio)
94 ((#.%short-+-float-type #.%short---float-type) 'short-float)
95 (#.%long-float-type 'long-float)
96 (#.%complex-type 'complex)
97 (#.%string-type `(simple-string ,(%primitive vector-length object)))
98 (#.%bit-vector-type
99 `(simple-bit-vector ,(%primitive vector-length object)))
100 (#.%integer-vector-type (type-of-i-vector object))
101 (#.%general-vector-type (type-of-g-vector object))
102 (#.%array-type (type-of-array object))
103 (#.%function-type 'function)
104 (#.%symbol-type 'symbol)
105 (#.%list-type 'cons)
106 (#.%string-char-type 'string-char)
107 (#.%bitsy-char-type 'character)
108 (#.%--fixnum-type 'fixnum)
109 (t 'random))))
110
111 ;;; %String-Char-P is called by typep when the type specification
112 ;;; is string-char. The CL string-char-p does not do the right thing.
113 (defun %string-char-p (x)
114 (and (characterp x)
115 (< (the fixnum (char-int x)) char-code-limit)))
116
117 ;;; Create the list-style description of a G-vector.
118
119 (defun type-of-g-vector (object)
120 (cond ((structurep object) (svref object 0))
121 (t `(simple-vector ,(%primitive vector-length object)))))
122
123 ;;; I-Vector-Element-Type -- Internal
124 ;;;
125 ;;; Return a type specifier for the element type of an I-Vector.
126 ;;;
127 (defun i-vector-element-type (object)
128 (let ((ac (%primitive get-vector-access-code object)))
129 (if (< 0 ac 6)
130 (svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536)
131 (mod 4294967296))
132 ac)
133 (error "Invalid I-Vector access code: ~S" ac))))
134
135 ;;; Create the list-style description of an I-vector.
136
137 (defun type-of-i-vector (object)
138 `(simple-array ,(i-vector-element-type object)
139 ,(%primitive vector-length object)))
140
141
142 ;;; Create the list-style description of an array.
143
144 (defun type-of-array (object)
145 (with-array-data ((data-vector object) (start) (end))
146 (declare (ignore start end))
147 (let ((rank (- (the fixnum (%primitive header-length object))
148 %array-first-dim-slot))
149 (length (%primitive header-ref object %array-length-slot)))
150 (declare (fixnum rank length))
151 (if (= rank 1)
152 (typecase data-vector
153 (simple-bit-vector `(bit-vector ,length))
154 (simple-string `(string ,length))
155 (simple-vector `(vector t ,length))
156 (t `(vector ,(i-vector-element-type data-vector) ,length)))
157 `(array
158 ,(typecase data-vector
159 (simple-bit-vector '(mod 2))
160 (simple-string 'string-char)
161 (simple-vector 't)
162 (t (i-vector-element-type data-vector)))
163 ,(array-dimensions object))))))
164
165 ;;;; TYPEP and auxiliary functions.
166
167 (defun %typep (object type)
168 (let ((type (type-expand type))
169 temp)
170 (cond ((symbolp type)
171 (cond ((or (eq type t) (eq type '*)) t)
172 ((eq type 'nil) nil)
173 ((setq temp (assq type type-pred-alist))
174 (funcall (cdr temp) object))
175 (t (structure-typep object type))))
176 ((listp type)
177 ;; This handles list-style type specifiers.
178 (case (car type)
179 (vector (and (vectorp object)
180 (vector-eltype object (cadr type))
181 (test-length object (caddr type))))
182 (simple-vector (and (simple-vector-p object)
183 (test-length object (cadr type))))
184 (string (and (stringp object)
185 (test-length object (cadr type))))
186 (simple-string (and (simple-string-p object)
187 (test-length object (cadr type))))
188 (bit-vector (and (bit-vector-p object)
189 (test-length object (cadr type))))
190 (simple-bit-vector (and (simple-bit-vector-p object)
191 (test-length object (cadr type))))
192 (array (array-typep object type))
193 (simple-array (and (not (array-header-p object))
194 (array-typep object type)))
195 (satisfies (funcall (cadr type) object))
196 (member (member object (cdr type)))
197 (not (not (typep object (cadr type))))
198 (or (dolist (x (cdr type) nil)
199 (if (typep object x) (return t))))
200 (and (dolist (x (cdr type) t)
201 (if (not (typep object x)) (return nil))))
202 (integer (and (integerp object) (test-limits object type)))
203 (rational (and (rationalp object) (test-limits object type)))
204 (float (and (floatp object) (test-limits object type)))
205 (short-float (and (short-float-p object)
206 (test-limits object type)))
207 (single-float (and (single-float-p object)
208 (test-limits object type)))
209 (double-float (and (double-float-p object)
210 (test-limits object type)))
211 (long-float (and (long-float-p object)
212 (test-limits object type)))
213 (mod (and (integerp object)
214 (>= object 0)
215 (< object (cadr type))))
216 (signed-byte
217 (and (integerp object)
218 (let ((n (cadr type)))
219 (or (not n) (eq n '*)
220 (> n (integer-length object))))))
221 (unsigned-byte
222 (and (integerp object)
223 (not (minusp object))
224 (let ((n (cadr type)))
225 (or (not n) (eq n '*)
226 (>= n (integer-length object))))))
227 (complex (and (numberp object)
228 (or (not (cdr type))
229 (typep (realpart object) (cadr type)))))
230 (t (error "~S -- Illegal type specifier to TYPEP." type))))
231 (t (error "~S -- Illegal type specifier to TYPEP." type)))))
232
233 (defun typep (obj type)
234 "Returns T if OBJECT is of the specified TYPE, otherwise NIL."
235 (declare (notinline %typep))
236 (%typep obj type))
237
238
239 ;;; Given that the object is a vector of some sort, and that we've already
240 ;;; verified that it matches CAR of TYPE, see if the rest of the type
241 ;;; specifier wins. Mild hack: Eltype Nil means either type not supplied
242 ;;; or was Nil. Any vector can hold objects of type Nil, since there aren't
243 ;;; any, so (vector nil) is the same as (vector *).
244 ;;;
245 (defun vector-eltype (object eltype)
246 (let ((data (if (array-header-p object)
247 (with-array-data ((data object) (start) (end))
248 (declare (ignore start end))
249 data)
250 object))
251 (eltype (type-expand eltype)))
252 (case eltype
253 ((t) (simple-vector-p data))
254 (string-char (simple-string-p data))
255 (bit (simple-bit-vector-p data))
256 ((* nil) t)
257 (t
258 (subtypep eltype
259 (cond ((simple-vector-p data) t)
260 ((simple-string-p data) 'string-char)
261 ((simple-bit-vector-p data) 'bit)
262 (t
263 (i-vector-element-type data))))))))
264
265
266 ;;; Test sequence for specified length.
267
268 (defun test-length (object length)
269 (or (null length)
270 (eq length '*)
271 (= length (length object))))
272
273
274 ;;; See if object satisfies the specifier for an array.
275
276 (defun array-typep (object type)
277 (and (arrayp object)
278 (vector-eltype object (cadr type))
279 (if (cddr type)
280 (let ((dims (third type)))
281 (cond ((eq dims '*) t)
282 ((numberp dims)
283 (and (vectorp object)
284 (= (the fixnum (length (the vector object)))
285 (the fixnum dims))))
286 (t
287 (dotimes (i (array-rank object) (null dims))
288 (when (null dims) (return nil))
289 (let ((dim (pop dims)))
290 (unless (or (eq dim '*)
291 (= dim (array-dimension object i)))
292 (return nil)))))))
293 t)))
294
295
296 ;;; Test whether a number falls within the specified limits.
297
298 (defun test-limits (object type)
299 (let ((low (cadr type))
300 (high (caddr type)))
301 (and (cond ((null low) t)
302 ((eq low '*) t)
303 ((numberp low) (>= object low))
304 ((and (consp low) (numberp (car low)))
305 (> object (car low)))
306 (t nil))
307 (cond ((null high) t)
308 ((eq high '*) t)
309 ((numberp high) (<= object high))
310 ((and (consp high) (numberp (car high)))
311 (< object (car high)))
312 (t nil)))))
313
314
315 ;;; Structure-Typep -- Internal
316 ;;;
317 ;;; This is called by Typep if the type-specifier is a symbol and is not one of
318 ;;; the built-in Lisp types. If it's a structure, see if it's that type, or if
319 ;;; it includes that type.
320 ;;;
321 (defun structure-typep (object type)
322 (declare (optimize speed))
323 (let ((type (type-expand type)))
324 (if (symbolp type)
325 (let ((def (info type defined-structure-info obj-name)))
326 (if def
327 (and (structurep object)
328 (let ((obj-name (%primitive header-ref object 0)))
329 (or (eq obj-name type)
330 (not (null (memq type (c::dd-includes def)))))))
331 (error "~S is an unknown type specifier." type)))
332 (error "~S is an unknown type specifier." type))))
333
334
335 ;;;; Assorted mumble-P type predicates.
336
337 (defun commonp (object)
338 "Returns T if object is a legal Common-Lisp type, NIL if object is any
339 sort of implementation-dependent or internal type."
340 (or (structurep object)
341 (let ((type-spec (type-of object)))
342 (if (listp type-spec) (setq type-spec (car type-spec)))
343 (when (memq type-spec
344 '(character fixnum short-float single-float double-float
345 long-float vector string simple-vector
346 simple-string bignum ratio complex
347 compiled-function array symbol cons))
348 T))))
349
350 (defun bit-vector-p (object)
351 "Returns T if the object is a bit vector, else returns NIL."
352 (bit-vector-p object))
353
354 ;;; The following definitions are trivial because the compiler open-codes
355 ;;; all of these.
356
357 (defun null (object)
358 "Returns T if the object is NIL, else returns NIL."
359 (null object))
360
361 (defun not (object)
362 "Returns T if the object is NIL, else returns NIL."
363 (null object))
364
365 (defun symbolp (object)
366 "Returns T if the object is a symbol, else returns NIL."
367 (symbolp object))
368
369 (defun atom (object)
370 "Returns T if the object is not a cons, else returns NIL.
371 Note that (ATOM NIL) => T."
372 (atom object))
373
374 (defun consp (object)
375 "Returns T if the object is a cons cell, else returns NIL.
376 Note that (CONSP NIL) => NIL."
377 (consp object))
378
379 (defun listp (object)
380 "Returns T if the object is a cons cell or NIL, else returns NIL."
381 (listp object))
382
383 (defun numberp (object)
384 "Returns T if the object is any kind of number."
385 (numberp object))
386
387 (defun integerp (object)
388 "Returns T if the object is an integer (fixnum or bignum), else
389 returns NIL."
390 (integerp object))
391
392 (defun rationalp (object)
393 "Returns T if the object is an integer or a ratio, else returns NIL."
394 (rationalp object))
395
396 (defun floatp (object)
397 "Returns T if the object is a floating-point number, else returns NIL."
398 (floatp object))
399
400 (defun complexp (object)
401 "Returns T if the object is a complex number, else returns NIL."
402 (complexp object))
403
404 (defun %standard-char-p (x)
405 (and (characterp x) (standard-char-p x)))
406
407 (defun characterp (object)
408 "Returns T if the object is a character, else returns NIL."
409 (characterp object))
410
411 (defun stringp (object)
412 "Returns T if the object is a string, else returns NIL."
413 (stringp object))
414
415 (defun simple-string-p (object)
416 "Returns T if the object is a simple string, else returns NIL."
417 (simple-string-p object))
418
419 (defun vectorp (object)
420 "Returns T if the object is any kind of vector, else returns NIL."
421 (vectorp object))
422
423 (defun simple-array-p (object)
424 "Returns T if the object is a simple array, else returns NIL."
425 (and (arrayp object) (not (array-header-p object))))
426
427 (defun simple-vector-p (object)
428 "Returns T if the object is a simple vector, else returns NIL."
429 (simple-vector-p object))
430
431 (defun simple-bit-vector-p (object)
432 "Returns T if the object is a simple bit vector, else returns NIL."
433 (simple-bit-vector-p object))
434
435 (defun arrayp (object)
436 "Returns T if the argument is any kind of array, else returns NIL."
437 (arrayp object))
438
439 (defun functionp (object)
440 "Returns T if the object is a function, suitable for use by FUNCALL
441 or APPLY, else returns NIL."
442 (functionp object))
443
444 (defun compiled-function-p (object)
445 "Returns T if the object is a compiled function object, else returns NIL."
446 (compiled-function-p object))
447
448 ;;; ### Dummy definition until we figure out what to really do...
449 (defun clos::funcallable-instance-p (object)
450 (declare (ignore object))
451 nil)
452
453 (defun sequencep (object)
454 "Returns T if object is a sequence, NIL otherwise."
455 (typep object 'sequence))
456
457
458 ;;; The following are not defined at user level, but are necessary for
459 ;;; internal use by TYPEP.
460
461 (defun structurep (object)
462 (structurep object))
463
464 (defun fixnump (object)
465 (fixnump object))
466
467 (defun bignump (object)
468 (bignump object))
469
470 (defun bitp (object)
471 (typep object 'bit))
472
473 (defun short-float-p (object)
474 (typep object 'short-float))
475
476 (defun single-float-p (object)
477 (typep object 'single-float))
478
479 (defun double-float-p (object)
480 (typep object 'double-float))
481
482 (defun long-float-p (object)
483 (typep object 'long-float))
484
485 (defun ratiop (object)
486 (ratiop object))
487
488 ;;; Some silly internal things for tenser array hacking:
489
490 (defun array-header-p (object)
491 (array-header-p object))
492
493 ;;;; Equality Predicates.
494
495 (defun eq (x y)
496 "Returns T if X and Y are the same object, else returns NIL."
497 (eq x y))
498
499 (defun eql (x y)
500 "Returns T if X and Y are EQ, or if they are numbers of the same
501 type and precisely equal value, or if they are characters and
502 are CHAR=, else returns NIL."
503 (eql x y))
504
505 (defun equal (x y)
506 "Returns T if X and Y are EQL or if they are structured components
507 whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
508 are the same length and have indentical components. Other arrays must be
509 EQ to be EQUAL."
510 (cond ((eql x y) t)
511 ((consp x)
512 (and (consp y)
513 (equal (car x) (car y))
514 (equal (cdr x) (cdr y))))
515 ((stringp x)
516 (and (stringp y) (string= x y)))
517 ((pathnamep x)
518 (and (pathnamep y)
519 (do* ((i 1 (1+ i))
520 (len (length x)))
521 ((>= i len) t)
522 (declare (fixnum i len))
523 (let ((x-el (svref x i))
524 (y-el (svref y i)))
525 (if (and (simple-vector-p x-el)
526 (simple-vector-p y-el))
527 (let ((lx (length x-el))
528 (ly (length y-el)))
529 (declare (fixnum lx ly))
530 (if (/= lx ly) (return nil))
531 (do ((i 0 (1+ i)))
532 ((>= i lx))
533 (declare (fixnum i))
534 (if (not (equal (svref x-el i) (svref y-el i)))
535 (return-from equal nil))))
536 (unless (or (eql x-el y-el)
537 (equal x-el y-el))
538 (return nil)))))))
539 ((bit-vector-p x)
540 (and (bit-vector-p y)
541 (= (the fixnum (length x))
542 (the fixnum (length y)))
543 (do ((i 0 (1+ i))
544 (length (length x)))
545 ((= i length) t)
546 (declare (fixnum i))
547 (or (= (the fixnum (bit x i))
548 (the fixnum (bit y i)))
549 (return nil)))))
550 (t nil)))
551
552
553 (defun equalp (x y)
554 "Just like EQUAL, but more liberal in several respects.
555 Numbers may be of different types, as long as the values are identical
556 after coercion. Characters may differ in alphabetic case. Vectors and
557 arrays must have identical dimensions and EQUALP elements, but may differ
558 in their type restriction."
559 (cond ((eql x y) t)
560 ((characterp x) (char-equal x y))
561 ((numberp x) (and (numberp y) (= x y)))
562 ((consp x)
563 (and (consp y)
564 (equalp (car x) (car y))
565 (equalp (cdr x) (cdr y))))
566 ((vectorp x)
567 (let ((length (length x)))
568 (declare (fixnum length))
569 (and (vectorp y)
570 (= length (the fixnum (length y)))
571 (dotimes (i length t)
572 (let ((x-el (aref x i))
573 (y-el (aref y i)))
574 (unless (or (eql x-el y-el)
575 (equalp x-el y-el))
576 (return nil)))))))
577 ((arrayp x)
578 (let ((rank (array-rank x))
579 (len (%primitive header-ref x %array-length-slot)))
580 (declare (fixnum rank len))
581 (and (arrayp y)
582 (= (the fixnum (array-rank y)) rank)
583 (dotimes (i rank t)
584 (unless (= (the fixnum (array-dimension x i))
585 (the fixnum (array-dimension y i)))
586 (return nil)))
587 (with-array-data ((x-vec x) (x-start) (end))
588 (declare (ignore end))
589 (with-array-data ((y-vec y) (y-start) (end))
590 (declare (ignore end))
591 (do ((i x-start (1+ i))
592 (j y-start (1+ j))
593 (count len (1- count)))
594 ((zerop count) t)
595 (declare (fixnum i j count))
596 (let ((x-el (aref x-vec i))
597 (y-el (aref y-vec j)))
598 (unless (or (eql x-el y-el)
599 (equalp x-el y-el))
600 (return nil)))))))))
601 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5