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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5