/[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.39 by dtc, Tue Apr 1 19:23:52 1997 UTC revision 1.39.2.1 by pw, Tue Jun 23 11:22:20 1998 UTC
# Line 29  Line 29 
29            functionp compiled-function-p eq eql equal equalp not            functionp compiled-function-p eq eql equal equalp not
30            type-of upgraded-array-element-type realp            type-of upgraded-array-element-type realp
31            ;; Names of types...            ;; Names of types...
32            array atom bignum bit bit-vector character common            array atom bignum bit bit-vector character
33            compiled-function complex cons double-float            compiled-function complex cons double-float
34            fixnum float function integer keyword list long-float nil            fixnum float function integer keyword list long-float nil
35            null number ratio rational real sequence short-float signed-byte            null number ratio rational real sequence short-float signed-byte
36            simple-array simple-bit-vector simple-string simple-vector            simple-array simple-bit-vector simple-string simple-vector
37            single-float standard-char string string-char symbol t            single-float standard-char base-char string symbol t
38            unsigned-byte vector satisfies))            unsigned-byte vector satisfies))
39    
40    
# Line 54  Line 54 
54        consp        consp
55        compiled-function-p        compiled-function-p
56        complexp        complexp
57          #+complex-float complex-double-float-p
58          #+complex-float complex-float-p
59          #+(and complex-float long-float) complex-long-float-p
60          #+complex-float complex-rational-p
61          #+complex-float complex-single-float-p
62        double-float-p        double-float-p
63        fdefn-p        fdefn-p
64        fixnump        fixnump
# Line 95  Line 100 
100        #+signed-array simple-array-signed-byte-32-p        #+signed-array simple-array-signed-byte-32-p
101        simple-array-single-float-p        simple-array-single-float-p
102        simple-array-double-float-p        simple-array-double-float-p
103          #+long-float simple-array-long-float-p
104          #+complex-float simple-array-complex-single-float-p
105          #+complex-float simple-array-complex-double-float-p
106          #+(and complex-float long-float) simple-array-complex-long-float-p
107        dylan::dylan-function-p        dylan::dylan-function-p
108        )))        )))
109    
# Line 122  Line 131 
131  ;;;  ;;;
132  (defun type-of (object)  (defun type-of (object)
133    "Return the type of OBJECT."    "Return the type of OBJECT."
134    (if (typep object '(or function array))    (if (typep object '(or function array #+complex-float complex))
135        (type-specifier (ctype-of object))        (type-specifier (ctype-of object))
136        (let* ((class (layout-class (layout-of object)))        (let* ((class (layout-class (layout-of object)))
137               (name (class-name class)))               (name (class-name class)))
# Line 203  Line 212 
212                   (long-float (typep num 'long-float))                   (long-float (typep num 'long-float))
213                   ((nil) (floatp num))))                   ((nil) (floatp num))))
214                ((nil) t)))                ((nil) t)))
215              #-negative-zero-is-not-zero
216            (flet ((bound-test (val)            (flet ((bound-test (val)
217                     (let ((low (numeric-type-low type))                     (let ((low (numeric-type-low type))
218                           (high (numeric-type-high type)))                           (high (numeric-type-high type)))
# Line 220  Line 230 
230                      (bound-test (imagpart object))))                      (bound-test (imagpart object))))
231                (:real                (:real
232                 (and (not (complexp object))                 (and (not (complexp object))
233                        (bound-test object)))))
234              #+negative-zero-is-not-zero
235              (labels ((signed-> (x y)
236                         (if (and (zerop x) (zerop y) (floatp x) (floatp y))
237                             (> (float-sign x) (float-sign y))
238                             (> x y)))
239                       (signed->= (x y)
240                         (if (and (zerop x) (zerop y) (floatp x) (floatp y))
241                             (>= (float-sign x) (float-sign y))
242                             (>= x y)))
243                       (bound-test (val)
244                         (let ((low (numeric-type-low type))
245                               (high (numeric-type-high type)))
246                           (and (cond ((null low) t)
247                                      ((listp low)
248                                       (signed-> val (car low)))
249                                      (t
250                                       (signed->= val low)))
251                                (cond ((null high) t)
252                                      ((listp high)
253                                       (signed-> (car high) val))
254                                      (t
255                                       (signed->= high val)))))))
256                (ecase (numeric-type-complexp type)
257                  ((nil) t)
258                  (:complex
259                   (and (complexp object)
260                        (bound-test (realpart object))
261                        (bound-test (imagpart object))))
262                  (:real
263                   (and (not (complexp object))
264                      (bound-test object)))))))                      (bound-test object)))))))
265      (array-type      (array-type
266       (and (arrayp object)       (and (arrayp object)
# Line 291  Line 332 
332  ;;;    Do type test from a class cell, allowing forward reference and  ;;;    Do type test from a class cell, allowing forward reference and
333  ;;; redefinition.  ;;; redefinition.
334  ;;;  ;;;
335  ;;; 2-Feb-97 add third arg optional for back compatibility and boot  (defun class-cell-typep (obj-layout cell object)
 (defun class-cell-typep (obj-layout cell &optional object)  
336    (let ((class (class-cell-class cell)))    (let ((class (class-cell-class cell)))
337      (unless class      (unless class
338        (error "Class has not yet been defined: ~S" (class-cell-name cell)))        (error "Class has not yet been defined: ~S" (class-cell-name cell)))

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.39.2.1

  ViewVC Help
Powered by ViewVC 1.1.5