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

Diff of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by ram, Fri Jun 15 22:57:21 1990 UTC revision 1.7 by wlott, Fri Aug 24 18:12:12 1990 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-  ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; This code was written as part of the Spice Lisp project at
# Line 7  Line 7 
7  ;;; Scott Fahlman (FAHLMAN@CMUC).  ;;; Scott Fahlman (FAHLMAN@CMUC).
8  ;;; **********************************************************************  ;;; **********************************************************************
9  ;;;  ;;;
10  ;;; Predicate functions for Spice Lisp.  ;;; $Header$
 ;;; The type predicates are implementation-specific.  A different version  
 ;;;   of this file will be required for implementations with different  
 ;;;   data representations.  
11  ;;;  ;;;
12  ;;; Written and currently maintained by Scott Fahlman.  ;;; Predicate functions for CMU Common Lisp.
 ;;; Based on an earlier version by Joe Ginder.  
13  ;;;  ;;;
14  (in-package 'lisp)  ;;; Written by William Lott.
15    ;;;
16    
17    (in-package "EXTENSIONS")
18    (export '(structurep fixnump bignump bitp ratiop realp weak-pointer-p))
19    
20    (in-package "SYSTEM")
21    (export '(system-area-pointer system-area-pointer-p))
22    
23    (in-package "LISP" :use "KERNEL")
24    
25  (export '(typep null symbolp atom consp listp numberp integerp rationalp  (export '(typep null symbolp atom consp listp numberp integerp rationalp
26            floatp complexp characterp stringp bit-vector-p vectorp            floatp complexp characterp stringp bit-vector-p vectorp
27            simple-vector-p simple-string-p simple-bit-vector-p arrayp            simple-vector-p simple-string-p simple-bit-vector-p arrayp
# Line 25  Line 31 
31            array atom bignum bit bit-vector character common            array atom bignum bit bit-vector character common
32            compiled-function complex cons double-float            compiled-function complex cons double-float
33            fixnum float function integer keyword list long-float nil            fixnum float function integer keyword list long-float nil
34            null number ratio rational sequence short-float signed-byte            null number ratio rational real sequence short-float signed-byte
35            simple-array simple-bit-vector simple-string simple-vector            simple-array simple-bit-vector simple-string simple-vector
36            single-float standard-char string string-char symbol t            single-float standard-char string string-char symbol t
37            unsigned-byte vector structure satisfies))            unsigned-byte vector structure satisfies))
38    
 (in-package "EXTENSIONS")  
 (export '(structurep fixnump bignump bitp ratiop))  
 (in-package "LISP")  
39    
40    
41    ;;;; Primitive predicates.  These must be supported by the compiler.
42    
43  ;;; Data type predicates.  (eval-when (compile eval)
44      (defparameter primitive-predicates
45        '(array-header-p
46          arrayp
47          atom
48          base-char-p
49          bignump
50          bit-vector-p
51          characterp
52          consp
53          compiled-function-p
54          complexp
55          double-float-p
56          fixnump
57          floatp
58          functionp
59          integerp
60          listp
61          not
62          null
63          numberp
64          rationalp
65          ratiop
66          realp
67          simple-array-p
68          simple-bit-vector-p
69          simple-string-p
70          simple-vector-p
71          single-float-p
72          stringp
73          symbolp
74          system-area-pointer-p
75          weak-pointer-p
76          vectorp
77          c::unsigned-byte-32-p
78          c::signed-byte-32-p
79          c::simple-array-unsigned-byte-2-p
80          c::simple-array-unsigned-byte-4-p
81          c::simple-array-unsigned-byte-8-p
82          c::simple-array-unsigned-byte-16-p
83          c::simple-array-unsigned-byte-32-p
84          c::simple-array-single-float-p
85          c::simple-array-double-float-p
86          )))
87    
88    (macrolet
89        ((frob ()
90           `(progn
91              ,@(mapcar #'(lambda (pred)
92                            `(defun ,pred (object)
93                               ,(format nil
94                                        "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
95                                         and NIL otherwise."
96                                        (find (schar (string pred) 0) "AEIOUaeiou")
97                                        (string pred))
98                               (,pred object)))
99                        primitive-predicates))))
100      (frob))
101    
102  ;;; Translation from type keywords to specific predicates.  Assumes that  
103  ;;; the following are named structures and need no special type hackery:  ;;;; TYPE-OF -- public.
104  ;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE.  ;;;
105    ;;; Return the specifier for the type of object.  This is not simply
106  (defparameter type-pred-alist  ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
107    '((keyword . keywordp)  ;;; than type-of.
108      (common . commonp)  ;;;
109      (null . null)  (defun type-of (object)
110      (cons . consp)    "Return the type of OBJECT."
111      (list . listp)    (typecase object
112      (symbol . symbolp)      (null 'null)
113      (array . arrayp)      (cons 'cons)
114      (vector . vectorp)      (character
115      (bit-vector . bit-vector-p)       (typecase object
116      (string . stringp)         (standard-char 'standard-char)
117      (sequence . sequencep)         (base-character 'base-character)
118      (simple-array . simple-array-p)         (t 'character)))
119      (c::structure-vector . simple-vector-p)      (number
120      (simple-vector . simple-vector-p)       (etypecase object
121      (simple-string . simple-string-p)         (fixnum 'fixnum)
122      (simple-bit-vector . simple-bit-vector-p)         (bignum 'bignum)
123      (function . functionp)         (float
124      (compiled-function . compiled-function-p)          (etypecase object
125      (character . characterp)            (double-float 'double-float)
126      (number . numberp)            (single-float 'single-float)
127      (rational . rationalp)            (short-float 'short-float)
128      (float . floatp)            (long-float 'long-float)))
129      (string-char . %string-char-p)         (ratio 'ratio)
130      (integer . integerp)         (complex 'complex)))
131      (ratio . ratiop)      (symbol (if (typep object 'keyword)
132      (short-float . short-float-p)                  'keyword
133      (standard-char . %standard-char-p)                  'symbol))
134      (fixnum . fixnump)      (structure
135      (complex . complexp)       (%primitive c::structure-ref object 0))
136  ;    (single-float . single-float-p)      (array
137      (single-float . short-float-p)       (type-specifier (ctype-of object)))
138      (bignum . bignump)      (function
139      (double-float . double-float-p)       (type-specifier (ctype-of object)))
140      (bit . bitp)      (t
141      (long-float . long-float-p)       (warn "Can't figure out the type of ~S" object)
142      (structure . structurep)       t)))
     (atom . atom)))  
143    
144    
145  ;;;; TYPE-OF and auxiliary functions.  ;;;; SUBTYPEP -- public.
146    ;;;
147    ;;; Just parse the type specifiers and call csubtype.
148    ;;;
149    (defun subtypep (type1 type2)
150      "Return two values indicating the relationship between type1 and type2:
151      T and T: type1 definatly is a subtype of type2.
152      NIL and T: type1 definatly is not a subtype of type2.
153      NIL and NIL: who knows?"
154      (csubtypep (specifier-type type1) (specifier-type type2)))
155    
 (defun type-of (object)  
   "Returns the type of OBJECT as a type-specifier.  
   Since objects may be of more than one type, the choice is somewhat  
   arbitrary and may be implementation-dependent."  
   (if (null object) 'symbol  
       (case (%primitive get-type object)  
         (#.%+-fixnum-type 'fixnum)  
         (#.%bignum-type 'bignum)  
         (#.%ratio-type 'ratio)  
         ((#.%short-+-float-type #.%short---float-type) 'short-float)  
         (#.%long-float-type 'long-float)  
         (#.%complex-type 'complex)  
         (#.%string-type `(simple-string ,(%primitive vector-length object)))  
         (#.%bit-vector-type  
          `(simple-bit-vector ,(%primitive vector-length object)))  
         (#.%integer-vector-type (type-of-i-vector object))  
         (#.%general-vector-type (type-of-g-vector object))  
         (#.%array-type (type-of-array object))  
         (#.%function-type 'function)  
         (#.%symbol-type 'symbol)  
         (#.%list-type 'cons)  
         (#.%string-char-type 'string-char)  
         (#.%bitsy-char-type 'character)  
         (#.%--fixnum-type 'fixnum)  
         (t 'random))))  
   
 ;;; %String-Char-P is called by typep when the type specification  
 ;;; is string-char.  The CL string-char-p does not do the right thing.  
 (defun %string-char-p (x)  
   (and (characterp x)  
        (< (the fixnum (char-int x)) char-code-limit)))  
   
 ;;; Create the list-style description of a G-vector.  
   
 (defun type-of-g-vector (object)  
   (if (structurep object)  
       (%primitive header-ref object  
                   %g-vector-structure-name-slot)  
       `(simple-vector ,(%primitive vector-length object))))  
   
 ;;; I-Vector-Element-Type  --  Internal  
 ;;;  
 ;;;    Return a type specifier for the element type of an I-Vector.  
 ;;;  
 (defun i-vector-element-type (object)  
   (let ((ac (%primitive get-vector-access-code object)))  
     (if (< 0 ac 6)  
         (svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536)  
                   (mod 4294967296))  
                ac)  
         (error "Invalid I-Vector access code: ~S" ac))))  
   
 ;;; Create the list-style description of an I-vector.  
   
 (defun type-of-i-vector (object)  
   `(simple-array ,(i-vector-element-type object)  
                  ,(%primitive vector-length object)))  
   
   
 ;;; Create the list-style description of an array.  
   
 (defun type-of-array (object)  
   (with-array-data ((data-vector object) (start) (end))  
     (declare (ignore start end))  
     (let ((rank (- (the fixnum (%primitive header-length object))  
                    %array-first-dim-slot))  
           (length (%primitive header-ref object %array-length-slot)))  
       (declare (fixnum rank length))  
       (if (= rank 1)  
           (typecase data-vector  
             (simple-bit-vector `(bit-vector ,length))  
             (simple-string `(string ,length))  
             (simple-vector `(vector t ,length))  
             (t `(vector ,(i-vector-element-type data-vector) ,length)))  
           `(array  
             ,(typecase data-vector  
                (simple-bit-vector '(mod 2))  
                (simple-string 'string-char)  
                (simple-vector 't)  
                (t (i-vector-element-type data-vector)))  
             ,(array-dimensions object))))))  
156    
157  ;;;; TYPEP and auxiliary functions.  ;;;; TYPEP -- public.
158    ;;;
159    ;;; Just call %typep
160    ;;;
161    (defun typep (object type)
162      "Return T iff OBJECT is of type TYPE."
163      (declare (type (or list symbol) type))
164      (%typep object type))
165    
166  (defun %typep (object type)  ;;; %TYPEP -- internal.
167    (let ((type (type-expand type))  ;;;
168          temp)  ;;; The actual typep engine.  The compiler only generates calls to this
169      (cond ((symbolp type)  ;;; function when it can't figure out anything more intelligent to do.
170             (cond ((or (eq type t) (eq type '*)) t)  ;;;
171                   ((eq type 'nil) nil)  (defun %typep (object specifier)
172                   ((setq temp (assq type type-pred-alist))    (declare (type (or list symbol ctype) specifier))
173                    (funcall (cdr temp) object))    (let ((type (if (ctype-p specifier)
174                   (t (structure-typep object type))))                    specifier
175            ((listp type)                    (specifier-type specifier))))
176             ;; This handles list-style type specifiers.      (etypecase type
177             (case (car type)        (named-type
178               (vector (and (vectorp object)         (ecase (named-type-name type)
179                            (vector-eltype object (cadr type))           ((* t)
180                            (test-length object (caddr type))))            t)
181               (simple-vector (and (simple-vector-p object)           ((nil)
182                                   (test-length object (cadr type))))            nil)
183               (string (and (stringp object)           (character (characterp object))
184                            (test-length object (cadr type))))           (base-character (base-char-p object))
185               (simple-string (and (simple-string-p object)           (standard-char (and (characterp object) (standard-char-p object)))
186                                   (test-length object (cadr type))))           (extended-character
187               (bit-vector (and (bit-vector-p object)            (and (characterp object) (not (base-char-p object))))
188                                (test-length object (cadr type))))           (function (functionp object))
189               (simple-bit-vector (and (simple-bit-vector-p object)           (cons (consp object))
190                                       (test-length object (cadr type))))           (symbol (symbolp object))
191               (array (array-typep object type))           (keyword
192               (simple-array (and (not (array-header-p object))            (and (symbolp object)
193                                  (array-typep object type)))                 (eq (symbol-package object)
194               (satisfies (funcall (cadr type) object))                     (symbol-package :foo))))
195               (member (member object (cdr type)))           (system-area-pointer (system-area-pointer-p object))
196               (not (not (typep object (cadr type))))           (weak-pointer (weak-pointer-p object))
197               (or (dolist (x (cdr type) nil)           (structure (structurep object))))
198                     (if (typep object x) (return t))))        (numeric-type
199               (and (dolist (x (cdr type) t)         (and (numberp object)
200                      (if (not (typep object x)) (return nil))))              (let ((num (if (complexp object) (realpart object) object)))
201               (integer (and (integerp object) (test-limits object type)))                (ecase (numeric-type-class type)
202               (rational (and (rationalp object) (test-limits object type)))                  (integer (integerp num))
203               (float (and (floatp object) (test-limits object type)))                  (rational (rationalp num))
204               (short-float (and (short-float-p object)                  (float
205                                 (test-limits object type)))                   (ecase (numeric-type-format type)
206               (single-float (and (single-float-p object)                     (short-float (typep object 'short-float))
207                                  (test-limits object type)))                     (single-float (typep object 'single-float))
208               (double-float (and (double-float-p object)                     (double-float (typep object 'double-float))
209                                  (test-limits object type)))                     (long-float (typep object 'long-float))
210               (long-float (and (long-float-p object)                     ((nil) (floatp num))))
211                                (test-limits object type)))                  ((nil) t)))
212               (mod (and (integerp object)              (flet ((bound-test (val)
213                         (>= object 0)                       (let ((low (numeric-type-low type))
214                         (< object (cadr type))))                             (high (numeric-type-high type)))
215               (signed-byte                         (and (cond ((null low) t)
216                (and (integerp object)                                    ((listp low) (> val (car low)))
217                     (let ((n (cadr type)))                                    (t (>= val low)))
218                       (or (not n) (eq n '*)                              (cond ((null high) t)
219                           (> n (integer-length object))))))                                    ((listp high) (< val (car high)))
220               (unsigned-byte                                    (t (<= val high)))))))
221                (and (integerp object)                (ecase (numeric-type-complexp type)
222                     (not (minusp object))                  ((nil) t)
223                     (let ((n (cadr type)))                  (:complex
224                       (or (not n) (eq n '*)                   (and (complexp object)
225                           (>= n (integer-length object))))))                        (let ((re (realpart object))
226               (complex (and (numberp object)                              (im (imagpart object)))
227                             (or (not (cdr type))                          (and (bound-test (min re im))
228                                 (typep (realpart object) (cadr type)))))                               (bound-test (max re im))))))
229               (t (error "~S -- Illegal type specifier to TYPEP."  type))))                  (:real
230            (t (error "~S -- Illegal type specifier to TYPEP."  type)))))                   (and (not (complexp object))
231                          (bound-test object)))))))
232  (defun typep (obj type)        (array-type
233    "Returns T if OBJECT is of the specified TYPE, otherwise NIL."         (and (arrayp object)
234    (declare (notinline %typep))              (ecase (array-type-complexp type)
235    (%typep obj type))                ((t) (not (typep object 'simple-array)))
236                  ((nil) (typep object 'simple-array))
237                  (* t))
238  ;;; Given that the object is a vector of some sort, and that we've already              (or (eq (array-type-dimensions type) '*)
239  ;;; verified that it matches CAR of TYPE, see if the rest of the type                  (do ((want (array-type-dimensions type) (cdr want))
240  ;;; specifier wins.  Mild hack: Eltype Nil means either type not supplied                       (got (array-dimensions object) (cdr got)))
241  ;;; or was Nil.  Any vector can hold objects of type Nil, since there aren't                      ((and (null want) (null got)) t)
242  ;;; any, so (vector nil) is the same as (vector *).                    (unless (and want got
243  ;;;                                 (or (eq (car want) '*)
244  (defun vector-eltype (object eltype)                                     (= (car want) (car got))))
245    (let ((data (if (array-header-p object)                      (return nil))))
246                    (with-array-data ((data object) (start) (end))              (or (eq (array-type-element-type type) *wild-type*)
247                      (declare (ignore start end))                  (type= (array-type-specialized-element-type type)
248                      data)                         (specifier-type (array-element-type object))))))
249                    object))        (member-type
250          (eltype (type-expand eltype)))         (if (member object (member-type-members type)) t))
251      (case eltype        (structure-type
252        ((t) (simple-vector-p data))         (structure-typep object (structure-type-name type)))
253        (string-char (simple-string-p data))        (union-type
254        (bit (simple-bit-vector-p data))         (dolist (type (union-type-types type))
255        ((* nil) t)           (when (%typep object type)
256        (t             (return t))))
257         (subtypep eltype        (unknown-type
258                   (cond ((simple-vector-p data) t)         (let ((orig-spec (unknown-type-specifier type)))
259                         ((simple-string-p data) 'string-char)           (if (eq type specifier)
260                         ((simple-bit-vector-p data) 'bit)               ;; The type was unknown at compile time.  Therefore, we should
261                         (t               ;; try again at runtime, 'cause it might be known now.
262                          (i-vector-element-type data))))))))               (%typep object orig-spec)
263                 (error "Unknown type specifier: ~S" orig-spec))))
264          (hairy-type
265  ;;; Test sequence for specified length.         ;; Now the tricky stuff.
266           (let* ((hairy-spec (hairy-type-specifier type))
267  (defun test-length (object length)                (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
268    (or (null length)           (ecase symbol
269        (eq length '*)             (and
270        (= length (length object))))              (or (atom hairy-spec)
271                    (dolist (spec (cdr hairy-spec))
272                      (unless (%typep object spec)
273  ;;; See if object satisfies the specifier for an array.                      (return nil)))))
274               (not
275  (defun array-typep (object type)              (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
276    (and (arrayp object)                (error "Invalid type specifier: ~S" hairy-spec))
277         (vector-eltype object (cadr type))              (not (%typep object (cadr hairy-spec))))
278         (if (cddr type)             (satisfies
279             (let ((dims (third type)))              (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
280               (cond ((eq dims '*) t)                (error "Invalid type specifier: ~S" hairy-spec))
281                     ((numberp dims)              (if (funcall (cadr hairy-spec) object) t)))))
282                      (and (vectorp object)        (function-type
283                           (= (the fixnum (length (the vector object)))         (error "Function types are not a legal argument to TYPEP:~%  ~S"
284                              (the fixnum dims))))                specifier)))))
                    (t  
                     (dotimes (i (array-rank object) (null dims))  
                       (when (null dims) (return nil))  
                       (let ((dim (pop dims)))  
                         (unless (or (eq dim '*)  
                                     (= dim (array-dimension object i)))  
                           (return nil)))))))  
            t)))  
   
   
 ;;; Test whether a number falls within the specified limits.  
   
 (defun test-limits (object type)  
   (let ((low (cadr type))  
         (high (caddr type)))  
     (and (cond ((null low) t)  
                ((eq low '*) t)  
                ((numberp low) (>= object low))  
                ((and (consp low) (numberp (car low)))  
                 (> object (car low)))  
                (t nil))  
          (cond ((null high) t)  
                ((eq high '*) t)  
                ((numberp high) (<= object high))  
                ((and (consp high) (numberp (car high)))  
                 (< object (car high)))  
                (t nil)))))  
285    
286    
287  ;;; Structure-Typep  --  Internal  ;;; Structure-Typep  --  Internal
288  ;;;  ;;;
289  ;;; This is called by Typep if the type-specifier is a symbol and is not one of  ;;; This is called by %typep when it tries to match against a structure type,
290  ;;; the built-in Lisp types.  If it's a structure, see if it's that type, or if  ;;; and typep of types that are known to be structure types at compile time
291  ;;; it includes that type.  ;;; are converted to this.
292  ;;;  ;;;
293  (defun structure-typep (object type)  (defun structure-typep (object type)
294    (declare (optimize speed))    (declare (optimize speed))
295    (let ((type (type-expand type)))    (let ((info (info type defined-structure-info type)))
296      (if (symbolp type)      (if info
297          (let ((info (info type defined-structure-info type)))          (and (structurep object)
298            (if info               (let ((obj-name (%primitive structure-ref object 0)))
299                (and (structurep object)                 (or (eq obj-name type)
300                     (let ((obj-name (%primitive header-ref object 0)))                     (if (member obj-name (c::dd-included-by info)
301                       (or (eq obj-name type)                                 :test #'eq)
302                           (if (memq obj-name (c::dd-included-by info))                         t nil))))
303                               t nil))))          (error "~S is an unknown structure type specifier." type))))
               (error "~S is an unknown type specifier." type)))  
         (error "~S is an unknown type specifier." type))))  
304    
305    
306  ;;;; Assorted mumble-P type predicates.  ;;;; Equality predicates.
   
 (defun commonp (object)  
   "Returns T if object is a legal Common-Lisp type, NIL if object is any  
   sort of implementation-dependent or internal type."  
   (or (structurep object)  
       (let ((type-spec (type-of object)))  
         (if (listp type-spec) (setq type-spec (car type-spec)))  
         (when (memq type-spec  
                     '(character fixnum short-float single-float double-float  
                                 long-float vector string simple-vector  
                                 simple-string bignum ratio complex  
                                 compiled-function array symbol cons))  
           T))))  
   
 (defun bit-vector-p (object)  
   "Returns T if the object is a bit vector, else returns NIL."  
   (bit-vector-p object))  
   
 ;;; The following definitions are trivial because the compiler open-codes  
 ;;; all of these.  
   
 (defun null (object)  
   "Returns T if the object is NIL, else returns NIL."  
   (null object))  
   
 (defun not (object)  
   "Returns T if the object is NIL, else returns NIL."  
   (null object))  
   
 (defun symbolp (object)  
   "Returns T if the object is a symbol, else returns NIL."  
   (symbolp object))  
   
 (defun atom (object)  
   "Returns T if the object is not a cons, else returns NIL.  
   Note that (ATOM NIL) => T."  
   (atom object))  
   
 (defun consp (object)  
   "Returns T if the object is a cons cell, else returns NIL.  
   Note that (CONSP NIL) => NIL."  
   (consp object))  
   
 (defun listp (object)  
   "Returns T if the object is a cons cell or NIL, else returns NIL."  
   (listp object))  
   
 (defun numberp (object)  
   "Returns T if the object is any kind of number."  
   (numberp object))  
   
 (defun integerp (object)  
   "Returns T if the object is an integer (fixnum or bignum), else  
   returns NIL."  
   (integerp object))  
   
 (defun rationalp (object)  
   "Returns T if the object is an integer or a ratio, else returns NIL."  
   (rationalp object))  
   
 (defun floatp (object)  
   "Returns T if the object is a floating-point number, else returns NIL."  
   (floatp object))  
307    
308  (defun complexp (object)  ;;; EQ -- public.
309    "Returns T if the object is a complex number, else returns NIL."  ;;;
310    (complexp object))  ;;; Real simple, 'cause the compiler takes care of it.
311    ;;;
 (defun %standard-char-p (x)  
   (and (characterp x) (standard-char-p x)))  
   
 (defun characterp (object)  
   "Returns T if the object is a character, else returns NIL."  
   (characterp object))  
   
 (defun stringp (object)  
   "Returns T if the object is a string, else returns NIL."  
   (stringp object))  
   
 (defun simple-string-p (object)  
   "Returns T if the object is a simple string, else returns NIL."  
   (simple-string-p object))  
   
 (defun vectorp (object)  
   "Returns T if the object is any kind of vector, else returns NIL."  
   (vectorp object))  
   
 (defun simple-array-p (object)  
   "Returns T if the object is a simple array, else returns NIL."  
   (and (arrayp object) (not (array-header-p object))))  
   
 (defun simple-vector-p (object)  
   "Returns T if the object is a simple vector, else returns NIL."  
   (simple-vector-p object))  
   
 (defun simple-bit-vector-p (object)  
   "Returns T if the object is a simple bit vector, else returns NIL."  
   (simple-bit-vector-p object))  
   
 (defun arrayp (object)  
   "Returns T if the argument is any kind of array, else returns NIL."  
   (arrayp object))  
   
 (defun functionp (object)  
   "Returns T if the object is a function, suitable for use by FUNCALL  
   or APPLY, else returns NIL."  
   (functionp object))  
   
 (defun compiled-function-p (object)  
   "Returns T if the object is a compiled function object, else returns NIL."  
   (compiled-function-p object))  
   
 ;;; ### Dummy definition until we figure out what to really do...  
 (defun clos::funcallable-instance-p (object)  
   (declare (ignore object))  
   nil)  
   
 (defun sequencep (object)  
   "Returns T if object is a sequence, NIL otherwise."  
   (typep object 'sequence))  
   
   
 ;;; The following are not defined at user level, but are necessary for  
 ;;; internal use by TYPEP.  
   
 (defun structurep (object)  
   (structurep object))  
   
 (defun fixnump (object)  
   (fixnump object))  
   
 (defun bignump (object)  
   (bignump object))  
   
 (defun bitp (object)  
   (typep object 'bit))  
   
 (defun short-float-p (object)  
   (typep object 'short-float))  
   
 (defun single-float-p (object)  
   (typep object 'single-float))  
   
 (defun double-float-p (object)  
   (typep object 'double-float))  
   
 (defun long-float-p (object)  
   (typep object 'long-float))  
   
 (defun ratiop (object)  
   (ratiop object))  
312    
313  ;;; Some silly internal things for tenser array hacking:  (defun eq (obj1 obj2)
314      "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
315      (eq obj1 obj2))
316    
 (defun array-header-p (object)  
   (array-header-p object))  
   
 ;;;; Equality Predicates.  
   
 (defun eq (x y)  
   "Returns T if X and Y are the same object, else returns NIL."  
   (eq x y))  
   
 (defun eql (x y)  
   "Returns T if X and Y are EQ, or if they are numbers of the same  
   type and precisely equal value, or if they are characters and  
   are CHAR=, else returns NIL."  
   (eql x y))  
317    
318    ;;; EQUAL -- public.
319    ;;;
320  (defun equal (x y)  (defun equal (x y)
321    "Returns T if X and Y are EQL or if they are structured components    "Returns T if X and Y are EQL or if they are structured components
322    whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they    whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they
# Line 537  Line 348 
348                            (declare (fixnum i))                            (declare (fixnum i))
349                            (if (not (equal (svref x-el i) (svref y-el i)))                            (if (not (equal (svref x-el i) (svref y-el i)))
350                                (return-from equal nil))))                                (return-from equal nil))))
351                        (unless (or (eql x-el y-el)                        (unless (equal x-el y-el)
                                   (equal x-el y-el))  
352                          (return nil)))))))                          (return nil)))))))
353          ((bit-vector-p x)          ((bit-vector-p x)
354           (and (bit-vector-p y)           (and (bit-vector-p y)
# Line 553  Line 363 
363                      (return nil)))))                      (return nil)))))
364          (t nil)))          (t nil)))
365    
366    ;;; EQUALP -- public.
367    ;;;
368  (defun equalp (x y)  (defun equalp (x y)
369    "Just like EQUAL, but more liberal in several respects.    "Just like EQUAL, but more liberal in several respects.
370    Numbers may be of different types, as long as the values are identical    Numbers may be of different types, as long as the values are identical
# Line 569  Line 380 
380                (equalp (cdr x) (cdr y))))                (equalp (cdr x) (cdr y))))
381          ((vectorp x)          ((vectorp x)
382           (let ((length (length x)))           (let ((length (length x)))
            (declare (fixnum length))  
383             (and (vectorp y)             (and (vectorp y)
384                  (= length (the fixnum (length y)))                  (= length (length y))
385                  (dotimes (i length t)                  (dotimes (i length t)
386                    (let ((x-el (aref x i))                    (let ((x-el (aref x i))
387                          (y-el (aref y i)))                          (y-el (aref y i)))
# Line 579  Line 389 
389                                  (equalp x-el y-el))                                  (equalp x-el y-el))
390                        (return nil)))))))                        (return nil)))))))
391          ((arrayp x)          ((arrayp x)
392           (let ((rank (array-rank x))           (and (arrayp y)
393                 (len (%primitive header-ref x %array-length-slot)))                (= (array-rank x) (array-rank y))
394             (declare (fixnum rank len))                (dotimes (axis (array-rank x) t)
395             (and (arrayp y)                  (unless (= (array-dimension x axis)
396                  (= (the fixnum (array-rank y)) rank)                             (array-dimension y axis))
397                  (dotimes (i rank t)                    (return nil)))
398                    (unless (= (the fixnum (array-dimension x i))                (dotimes (index (array-total-size x) t)
399                               (the fixnum (array-dimension y i)))                  (unless (equalp (row-major-aref x index)
400                      (return nil)))                                  (row-major-aref y index))
401                  (with-array-data ((x-vec x) (x-start) (end))                    (return nil)))))
                   (declare (ignore end))  
                   (with-array-data ((y-vec y) (y-start) (end))  
                     (declare (ignore end))  
                     (do ((i x-start (1+ i))  
                          (j y-start (1+ j))  
                          (count len (1- count)))  
                         ((zerop count) t)  
                       (declare (fixnum i j count))  
                       (let ((x-el (aref x-vec i))  
                             (y-el (aref y-vec j)))  
                         (unless (or (eql x-el y-el)  
                                     (equalp x-el y-el))  
                           (return nil)))))))))  
402          (t nil)))          (t nil)))

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

  ViewVC Help
Powered by ViewVC 1.1.5