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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Feb 8 12:33:34 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.1: +0 -16 lines
Moved TYPE-EXPAND to eval from here.
1 ram 1.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     (case (info type kind type)
326     ((:primitive :structure)
327     (and (structurep object)
328     (let ((obj-name (%primitive header-ref object 0)))
329     (or (eq obj-name type)
330     (let ((def (info type structure-info obj-name)))
331     (not (null (memq type (c::dd-includes def)))))))))
332     (t
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