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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5