/[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.18.2.1 by ram, Mon Feb 24 15:01:29 1992 UTC revision 1.65 by rtoy, Tue Apr 20 17:57:45 2010 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
9  ;;;  ;;;
10  ;;; **********************************************************************  ;;; **********************************************************************
11  ;;;  ;;;
 ;;; $Header$  
 ;;;  
12  ;;; Predicate functions for CMU Common Lisp.  ;;; Predicate functions for CMU Common Lisp.
13  ;;;  ;;;
14  ;;; Written by William Lott.  ;;; Written by William Lott.
15  ;;;  ;;;
16    
17  (in-package "EXTENSIONS")  (in-package "KERNEL")
18  (export '(structurep fixnump bignump bitp ratiop realp weak-pointer-p))  (intl:textdomain "cmucl")
19    
20    (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
21              %typep class-cell-typep))
22    
23    #+double-double
24    (export '(double-double-float-p))
25    
26  (in-package "SYSTEM")  (in-package "SYSTEM")
27  (export '(system-area-pointer system-area-pointer-p))  (export '(system-area-pointer system-area-pointer-p))
28    
29  (in-package "LISP" :use "KERNEL")  (in-package "LISP")
30    
31  (export '(typep null symbolp atom consp listp numberp integerp rationalp  (export '(typep null symbolp atom consp listp numberp integerp rationalp
32            floatp complexp characterp stringp bit-vector-p vectorp            floatp complexp characterp stringp bit-vector-p vectorp
33            simple-vector-p simple-string-p simple-bit-vector-p arrayp            simple-vector-p simple-string-p simple-bit-vector-p arrayp
34            functionp compiled-function-p commonp eq eql equal equalp not            functionp compiled-function-p eq eql equal equalp not
35            type-of            type-of upgraded-array-element-type realp
36            ;; Names of types...            ;; Names of types...
37            array atom bignum bit bit-vector character common            array atom bignum bit bit-vector character
38            compiled-function complex cons double-float            compiled-function complex cons double-float
39            fixnum float function integer keyword list long-float nil            fixnum float function integer keyword list long-float nil
40            null number ratio rational real sequence short-float signed-byte            null number ratio rational real sequence short-float signed-byte
41            simple-array simple-bit-vector simple-string simple-vector            simple-array simple-bit-vector simple-string simple-vector
42            single-float standard-char string string-char symbol t            single-float standard-char base-char string symbol t
43            unsigned-byte vector structure satisfies))            unsigned-byte vector satisfies))
44    
45    
46    
# Line 57  Line 59 
59        consp        consp
60        compiled-function-p        compiled-function-p
61        complexp        complexp
62          complex-double-float-p
63          complex-float-p
64          #+long-float complex-long-float-p
65          #+double-double complex-double-double-float-p
66          complex-rational-p
67          complex-single-float-p
68          #+double-double double-double-float-p
69        double-float-p        double-float-p
70          fdefn-p
71        fixnump        fixnump
72        floatp        floatp
73        functionp        functionp
# Line 79  Line 89 
89        simple-vector-p        simple-vector-p
90        single-float-p        single-float-p
91        stringp        stringp
92        structurep        %instancep
93        symbolp        symbolp
94        system-area-pointer-p        system-area-pointer-p
95        weak-pointer-p        weak-pointer-p
96        vectorp        vectorp
97        c::unsigned-byte-32-p        unsigned-byte-32-p
98        c::signed-byte-32-p        signed-byte-32-p
99        c::simple-array-unsigned-byte-2-p        simple-array-unsigned-byte-2-p
100        c::simple-array-unsigned-byte-4-p        simple-array-unsigned-byte-4-p
101        c::simple-array-unsigned-byte-8-p        simple-array-unsigned-byte-8-p
102        c::simple-array-unsigned-byte-16-p        simple-array-unsigned-byte-16-p
103        c::simple-array-unsigned-byte-32-p        simple-array-unsigned-byte-32-p
104        c::simple-array-single-float-p        simple-array-signed-byte-8-p
105        c::simple-array-double-float-p        simple-array-signed-byte-16-p
106          simple-array-signed-byte-30-p
107          simple-array-signed-byte-32-p
108          simple-array-single-float-p
109          simple-array-double-float-p
110          #+long-float simple-array-long-float-p
111          #+double-double simple-array-double-double-float-p
112          simple-array-complex-single-float-p
113          simple-array-complex-double-float-p
114          #+long-float simple-array-complex-long-float-p
115          #+double-double simple-array-complex-double-double-float-p
116        )))        )))
117    
118  (macrolet  (macrolet
# Line 114  Line 134 
134  ;;;  ;;;
135  ;;; Return the specifier for the type of object.  This is not simply  ;;; Return the specifier for the type of object.  This is not simply
136  ;;; (type-specifier (ctype-of object)) because ctype-of has different goals  ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
137  ;;; than type-of.  ;;; than type-of.  In particular, speed is more important than precision, and
138    ;;; it is not permitted to return member types.
139  ;;;  ;;;
140  (defun type-of (object)  (defun type-of (object)
141    "Return the type of OBJECT."    "Return the type of OBJECT."
142    (typecase object    (typecase object
143      ;; First the ones that we can tell by testing the lowtag      ((or array complex)
144      (fixnum 'fixnum)       (type-specifier (ctype-of object)))
145      (function (type-specifier (ctype-of object)))      (integer
146      (null 'null)       `(integer ,object ,object))
147      (list 'cons)      ((member t)
148         'boolean)
149      ;; Any other immediates.      (keyword
150      (character       'keyword)
151       (typecase object      (standard-char
152         (standard-char 'standard-char)       'standard-char)
        (base-character 'base-character)  
        (t 'character)))  
   
     ;; And now for the complicated ones.  
     (number  
      (etypecase object  
        (fixnum 'fixnum)  
        (bignum 'bignum)  
        (float  
         (etypecase object  
           (double-float 'double-float)  
           (single-float 'single-float)  
           (short-float 'short-float)  
           (long-float 'long-float)))  
        (ratio 'ratio)  
        (complex 'complex)))  
     (symbol  
      (if (eq (symbol-package object)  
              (symbol-package :foo))  
          'keyword  
          'symbol))  
     (structure (c::structure-ref object 0))  
     (array (type-specifier (ctype-of object)))  
     (system-area-pointer 'system-area-pointer)  
     (weak-pointer 'weak-pointer)  
     (code-component 'code-component)  
     (lra 'lra)  
     (scavenger-hook 'scavenger-hook)  
153      (t      (t
154       (warn "Can't figure out the type of ~S" object)       (let* ((class (layout-class (layout-of object)))
155       t)))              (name (%class-name class)))
156           (if (%instancep object)
157               (if (eq name 'alien-internals:alien-value)
158                   `(alien:alien ,(alien-internals:unparse-alien-type
159                                   (alien-internals:alien-value-type object)))
160                   (let ((proper-name (class-proper-name class)))
161                     (if (kernel::class-p proper-name)
162                         (%class-pcl-class proper-name)
163                         proper-name)))
164               name)))))
165    
166    
167    ;;;; UPGRADED-ARRAY-ELEMENT-TYPE  --  public
168    ;;;
169    (defun upgraded-array-element-type (spec &optional environment)
170      "Return the element type that will actually be used to implement an array
171       with the specifier :ELEMENT-TYPE Spec."
172      ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
173      (declare (ignore environment))
174      (type-specifier
175       (array-type-specialized-element-type
176        (specifier-type `(array ,spec)))))
177    
178  ;;;; SUBTYPEP -- public.  ;;;; SUBTYPEP -- public.
179  ;;;  ;;;
180  ;;; Just parse the type specifiers and call csubtype.  ;;; Just parse the type specifiers and call csubtype.
181  ;;;  ;;;
182  (defun subtypep (type1 type2)  (defun subtypep (type1 type2 &optional environment)
183    "Return two values indicating the relationship between type1 and type2:    "Return two values indicating the relationship between type1 and type2:
184    T and T: type1 definatly is a subtype of type2.    T and T: type1 definitely is a subtype of type2.
185    NIL and T: type1 definatly is not a subtype of type2.    NIL and T: type1 definitely is not a subtype of type2.
186    NIL and NIL: who knows?"    NIL and NIL: who knows?"
187      (declare (ignore environment))
188    (csubtypep (specifier-type type1) (specifier-type type2)))    (csubtypep (specifier-type type1) (specifier-type type2)))
189    
190    
191  ;;;; TYPEP -- public.  ;;;; TYPEP:
192    
193    (declaim (start-block typep %typep class-cell-typep))
194    
195    ;;; TYPEP -- public.
196  ;;;  ;;;
197  ;;; Just call %typep  ;;; Just call %typep
198  ;;;  ;;;
199  (defun typep (object type)  (defun typep (object type &optional environment)
200    "Return T iff OBJECT is of type TYPE."    "Return T iff OBJECT is of type TYPE."
201    (declare (type (or list symbol) type))    (declare (ignore environment))
202    (%typep object type))    (%typep object type))
203    
204    
205  ;;; %TYPEP -- internal.  ;;; %TYPEP -- internal.
206  ;;;  ;;;
207  ;;; The actual typep engine.  The compiler only generates calls to this  ;;; The actual typep engine.  The compiler only generates calls to this
# Line 199  Line 218 
218    (etypecase type    (etypecase type
219      (named-type      (named-type
220       (ecase (named-type-name type)       (ecase (named-type-name type)
221         ((* t)         ((* t) t)
222          t)         ((nil) nil)))
        ((nil)  
         nil)  
        (character (characterp object))  
        (base-character (base-char-p object))  
        (standard-char (and (characterp object) (standard-char-p object)))  
        (extended-character  
         (and (characterp object) (not (base-char-p object))))  
        (function (functionp object))  
        (cons (consp object))  
        (symbol (symbolp object))  
        (keyword  
         (and (symbolp object)  
              (eq (symbol-package object)  
                  (symbol-package :foo))))  
        (system-area-pointer (system-area-pointer-p object))  
        (weak-pointer (weak-pointer-p object))  
        (code-component (code-component-p object))  
        (lra (lra-p object))  
        (scavenger-hook (scavenger-hook-p object))  
        (structure (structurep object))))  
223      (numeric-type      (numeric-type
224       (and (numberp object)       (and (numberp object)
225            (let ((num (if (complexp object) (realpart object) object)))            (let ((num (if (complexp object) (realpart object) object)))
# Line 229  Line 228 
228                (rational (rationalp num))                (rational (rationalp num))
229                (float                (float
230                 (ecase (numeric-type-format type)                 (ecase (numeric-type-format type)
231                   (short-float (typep object 'short-float))                   (short-float (typep num 'short-float))
232                   (single-float (typep object 'single-float))                   (single-float (typep num 'single-float))
233                   (double-float (typep object 'double-float))                   (double-float (typep num 'double-float))
234                   (long-float (typep object 'long-float))                   (long-float (typep num 'long-float))
235                     (double-double-float (typep num 'double-double-float))
236                   ((nil) (floatp num))))                   ((nil) (floatp num))))
237                ((nil) t)))                ((nil) t)))
238            (flet ((bound-test (val)            (flet ((bound-test (val)
239                               (let ((low (numeric-type-low type))                     (let ((low (numeric-type-low type))
240                                     (high (numeric-type-high type)))                           (high (numeric-type-high type)))
241                                 (and (cond ((null low) t)                       (and (cond ((null low) t)
242                                            ((listp low) (> val (car low)))                                  ((listp low) (> val (car low)))
243                                            (t (>= val low)))                                  (t (>= val low)))
244                                      (cond ((null high) t)                            (cond ((null high) t)
245                                            ((listp high) (< val (car high)))                                  ((listp high) (< val (car high)))
246                                            (t (<= val high)))))))                                  (t (<= val high)))))))
247              (ecase (numeric-type-complexp type)              (ecase (numeric-type-complexp type)
248                ((nil) t)                ((nil) t)
249                (:complex                (:complex
250                 (and (complexp object)                 (and (complexp object)
251                      (let ((re (realpart object))                      (bound-test (realpart object))
252                            (im (imagpart object)))                      (bound-test (imagpart object))))
                       (and (bound-test (min re im))  
                            (bound-test (max re im))))))  
253                (:real                (:real
254                 (and (not (complexp object))                 (and (not (complexp object))
255                      (bound-test object)))))))                      (bound-test object)))))))
# Line 260  Line 258 
258            (ecase (array-type-complexp type)            (ecase (array-type-complexp type)
259              ((t) (not (typep object 'simple-array)))              ((t) (not (typep object 'simple-array)))
260              ((nil) (typep object 'simple-array))              ((nil) (typep object 'simple-array))
261              (* t))              ((* :maybe) t))
262            (or (eq (array-type-dimensions type) '*)            (or (eq (array-type-dimensions type) '*)
263                (do ((want (array-type-dimensions type) (cdr want))                (do ((want (array-type-dimensions type) (cdr want))
264                     (got (array-dimensions object) (cdr got)))                     (got (array-dimensions object) (cdr got)))
# Line 269  Line 267 
267                               (or (eq (car want) '*)                               (or (eq (car want) '*)
268                                   (= (car want) (car got))))                                   (= (car want) (car got))))
269                    (return nil))))                    (return nil))))
270              (if (unknown-type-p (array-type-element-type type))
271                  ;; better to fail this way than to get bogosities like
272                  ;;   (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
273                  (error (intl:gettext "~@<unknown element type in array type: ~2I~_~S~:>")
274                         (type-specifier type))
275                  t)
276            (or (eq (array-type-element-type type) *wild-type*)            (or (eq (array-type-element-type type) *wild-type*)
277                (type= (array-type-specialized-element-type type)                (values (type= (array-type-specialized-element-type type)
278                       (specifier-type (array-element-type object))))))                               (specifier-type (array-element-type
279                                                  object)))))))
280      (member-type      (member-type
281       (if (member object (member-type-members type)) t))       (if (member object (member-type-members type)) t))
282      (structure-type      (kernel::class
283       (structure-typep object (structure-type-name type)))       (class-typep (layout-of object) type object))
284      (union-type      (union-type
285       (dolist (type (union-type-types type))       (some (lambda (type) (%%typep object type))
286         (when (%%typep object type)             (union-type-types type)))
287           (return t))))      (intersection-type
288         (every (lambda (type) (%%typep object type))
289                (intersection-type-types type)))
290        (cons-type
291         (and (consp object)
292              (%%typep (car object) (cons-type-car-type type))
293              (%%typep (cdr object) (cons-type-cdr-type type))))
294      (unknown-type      (unknown-type
295       ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be       ;; Parse it again to make sure it's really undefined.
296       ;; a defined structure in the core.       (let ((reparse (specifier-type (unknown-type-specifier type))))
297       (let ((orig-spec (unknown-type-specifier type)))         (if (typep reparse 'unknown-type)
298         (if (and (symbolp orig-spec)             (error (intl:gettext "Unknown type specifier: ~S")
299                  (info type defined-structure-info orig-spec))                    (unknown-type-specifier reparse))
300             (structure-typep object orig-spec)             (%%typep object reparse))))
301             (error "Unknown type specifier: ~S" orig-spec))))      (negation-type
302         (not (%%typep object (negation-type-type type))))
303      (hairy-type      (hairy-type
304       ;; Now the tricky stuff.       ;; Now the tricky stuff.
305       (let* ((hairy-spec (hairy-type-specifier type))       (let* ((hairy-spec (hairy-type-specifier type))
306              (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))              (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
307         (ecase symbol         (ecase symbol
308           (and           (and
309            (or (atom hairy-spec)            (every (lambda (spec) (%%typep object (specifier-type spec)))
310                (dolist (spec (cdr hairy-spec) t)                   (rest hairy-spec)))
311                  (unless (%%typep object (specifier-type spec))           ;; Note: it should be safe to skip OR here, because union
312                    (return nil)))))           ;; types can always be represented as UNION-TYPE in general
313             ;; or other CTYPEs in special cases; we never need to use
314             ;; HAIRY-TYPE for them.
315           (not           (not
316            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
317              (error "Invalid type specifier: ~S" hairy-spec))              (error (intl:gettext "Invalid type specifier: ~S") hairy-spec))
318            (not (%%typep object (specifier-type (cadr hairy-spec)))))            (not (%%typep object (specifier-type (cadr hairy-spec)))))
319           (satisfies           (satisfies
320            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))            (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
321              (error "Invalid type specifier: ~S" hairy-spec))              (error (intl:gettext "Invalid type specifier: ~S") hairy-spec))
322            (let ((fn (cadr hairy-spec)))            (let ((fn (cadr hairy-spec)))
323              (if (funcall (typecase fn              (if (funcall (typecase fn
324                             (function fn)                             (function fn)
# Line 314  Line 328 
328                           object)                           object)
329                  t                  t
330                  nil))))))                  nil))))))
331        (alien-type-type
332         (alien-internals:alien-typep object (alien-type-type-alien-type type)))
333      (function-type      (function-type
334       (error "Function types are not a legal argument to TYPEP:~%  ~S"       (error (intl:gettext "Function types are not a legal argument to TYPEP:~%  ~S")
335              (type-specifier type)))))              (type-specifier type)))))
336    
337    
338    ;;; CLASS-CELL-TYPEP  --  Interface
339    ;;;
340    ;;;    Do type test from a class cell, allowing forward reference and
341    ;;; redefinition.
342    ;;;
343    (defun class-cell-typep (obj-layout cell object)
344      (let ((class (class-cell-class cell)))
345        (unless class
346          (error (intl:gettext "Class has not yet been defined: ~S") (class-cell-name cell)))
347        (class-typep obj-layout class object)))
348    
349    
350  ;;; Structure-Typep  --  Internal  ;;; CLASS-TYPEP  --  Internal
351  ;;;  ;;;
352  ;;; This is called by %typep when it tries to match against a structure type,  ;;;    Test whether Obj-Layout is from an instance of Class.
 ;;; and typep of types that are known to be structure types at compile time  
 ;;; are converted to this.  
353  ;;;  ;;;
354  (defun structure-typep (object type)  (defun class-typep (obj-layout class object)
355    (declare (optimize speed))    (declare (optimize speed))
356    (let ((info (info type defined-structure-info type)))    (when (layout-invalid obj-layout)
357      (if info      (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)
358          (and (structurep object)          (setq obj-layout (pcl::check-wrapper-validity object))
359               (let ((obj-name (c::structure-ref object 0)))          (error (intl:gettext "TYPEP on obsolete object (was class ~S).")
360                 (or (eq obj-name type)                 (class-proper-name (layout-class obj-layout)))))
361                     (if (member obj-name (c::dd-included-by info)    (let ((layout (%class-layout class))
362                                 :test #'eq)          (obj-inherits (layout-inherits obj-layout)))
363                         t nil))))      (when (layout-invalid layout)
364          (error "~S is an unknown structure type specifier." type))))        (error (intl:gettext "Class is currently invalid: ~S") class))
365        (or (eq obj-layout layout)
366            (dotimes (i (length obj-inherits) nil)
367              (when (eq (svref obj-inherits i) layout)
368                (return t))))))
369    
370    (declaim (end-block))
371    
372    
373  ;;;; Equality predicates.  ;;;; Equality predicates.
# Line 366  Line 397 
397          ((stringp x)          ((stringp x)
398           (and (stringp y) (string= x y)))           (and (stringp y) (string= x y)))
399          ((pathnamep x)          ((pathnamep x)
400           (and (pathnamep y)           (and (pathnamep y) (pathname= x y)))
               (do* ((i 1 (1+ i))  
                     (len (c::structure-length x)))  
                    ((>= i len) t)  
                 (declare (fixnum i len))  
                 (let ((x-el (c::structure-ref x i))  
                       (y-el (c::structure-ref y i)))  
                   (if (and (simple-vector-p x-el)  
                            (simple-vector-p y-el))  
                       (let ((lx (length x-el))  
                             (ly (length y-el)))  
                         (declare (fixnum lx ly))  
                         (if (/= lx ly) (return nil))  
                         (do ((i 0 (1+ i)))  
                             ((>= i lx))  
                           (declare (fixnum i))  
                           (if (not (equal (svref x-el i) (svref y-el i)))  
                               (return-from equal nil))))  
                       (unless (equal x-el y-el)  
                         (return nil)))))))  
401          ((bit-vector-p x)          ((bit-vector-p x)
402           (and (bit-vector-p y)           (and (bit-vector-p y)
403                (= (the fixnum (length x))                (= (the fixnum (length x))
# Line 408  Line 420 
420    arrays must have identical dimensions and EQUALP elements, but may differ    arrays must have identical dimensions and EQUALP elements, but may differ
421    in their type restriction."    in their type restriction."
422    (cond ((eq x y) t)    (cond ((eq x y) t)
423          ((characterp x) (char-equal x y))          ((characterp x) (and (characterp y) (char-equal x y)))
424          ((numberp x) (and (numberp y) (= x y)))          ((numberp x) (and (numberp y) (= x y)))
425          ((consp x)          ((consp x)
426           (and (consp y)           (and (consp y)
427                (equalp (car x) (car y))                (equalp (car x) (car y))
428                (equalp (cdr x) (cdr y))))                (equalp (cdr x) (cdr y))))
429          ((structurep x)          ((pathnamep x)
430           (let ((length (c::structure-length x)))           (and (pathnamep y) (pathname= x y)))
431             (and (structurep y)          ((hash-table-p x)
432                  (= length (c::structure-length y))           (and (hash-table-p y)
433                  (dotimes (i length t)                (eql (hash-table-count x) (hash-table-count y))
434                    (let ((x-el (c::structure-ref x i))                (eql (hash-table-test x) (hash-table-test y))
435                          (y-el (c::structure-ref y i)))                (with-hash-table-iterator (next x)
436                    (loop
437                     (multiple-value-bind (more x-key x-value)
438                         (next)
439                       (cond (more
440                              (multiple-value-bind (y-value foundp)
441                                  (gethash x-key y)
442                                (unless (and foundp (equalp x-value y-value))
443                                  (return nil))))
444                             (t
445                              (return t))))))))
446            ((%instancep x)
447             (let* ((layout-x (%instance-layout x))
448                    (len (layout-length layout-x)))
449               (and (%instancep y)
450                    (eq layout-x (%instance-layout y))
451                    (structure-class-p (layout-class layout-x))
452                    (do ((i 1 (1+ i)))
453                        ((= i len) t)
454                      (declare (fixnum i))
455                      (let ((x-el (%instance-ref x i))
456                            (y-el (%instance-ref y i)))
457                      (unless (or (eq x-el y-el)                      (unless (or (eq x-el y-el)
458                                  (equalp x-el y-el))                                  (equalp x-el y-el))
459                        (return nil)))))))                        (return nil)))))))

Legend:
Removed from v.1.18.2.1  
changed lines
  Added in v.1.65

  ViewVC Help
Powered by ViewVC 1.1.5