Changeset 318

Timestamp:

Jan 17, 2004, 7:50:44 PM (21 years ago)

Author:

Gary Byers

Message:

Lots more changes.

File:

• trunk/ccl/level-1/l1-typesys.lisp (modified) (25 diffs)

trunk/ccl/level-1/l1-typesys.lisp

@@ -137 +137 @@
           arglist))
 
-(eval-when (:compile-toplevel)
-  (warn "Fix EVAL-WHEN in EXPAND-TYPE-MACRO"))
 
 (defun expand-type-macro (definer name arglist body env)
@@ -144 +142 @@
   (multiple-value-bind (lambda doc)
       (parse-macro-internal name arglist body env '*)
-      `(eval-when (#|:compile-toplevel|# :load-toplevel :execute)
+      `(eval-when (:compile-toplevel :load-toplevel :execute)
          (,definer ',name
                    (nfunction ,name ,lambda)
@@ -1930 +1928 @@
 (deftype float-format () `(member ,@float-formats))
 
+(defun type-bound-number (x)
+  (if (consp x)
+      (destructuring-bind (result) x result)
+      x))
+
 (defun make-numeric-ctype (&key class 
                                 format
@@ -1937 +1940 @@
                                 enumerable
                                 predicate)
-  (let ((ctype (%istruct 'numeric-ctype
-                         (type-class-or-lose 'number)
-                         enumerable
-                         class
-                         format
-                         complexp
-                         low
-                         high
-                         predicate))) 
-    ctype))
+  ;; if interval is empty
+  (if (and low
+           high
+           (if (or (consp low) (consp high)) ; if either bound is exclusive
+             (>= (type-bound-number low) (type-bound-number high))
+             (> low high)))
+    *empty-type*
+    (multiple-value-bind (canonical-low canonical-high)
+        (case class
+          (integer
+           ;; INTEGER types always have their LOW and HIGH bounds
+           ;; represented as inclusive, not exclusive values.
+           (values (if (consp low)
+                     (1+ (type-bound-number low))
+                     low)
+                   (if (consp high)
+                     (1- (type-bound-number high))
+                     high)))
+          (t 
+           ;; no canonicalization necessary
+           (values low high)))
+      (when (and (eq class 'rational)
+                 (integerp canonical-low)
+                 (integerp canonical-high)
+                 (= canonical-low canonical-high))
+        (setf class 'integer))
+      (%istruct 'numeric-ctype
+                (type-class-or-lose 'number)
+                enumerable
+                class
+                format
+                complexp
+                canonical-low
+                canonical-high
+                predicate))))
     
 
@@ -1976 +2004 @@
 
 (define-type-method (number :unparse) (type)
- (let* ((complexp (numeric-ctype-complexp type))
-        (low (numeric-ctype-low type))
-        (high (numeric-ctype-high type))
-        (base (case (numeric-ctype-class type)
-                (integer 'integer)
-                (rational 'rational)
-                (float (or (numeric-ctype-format type) 'float))
-                (t 'real))))
+  (let* ((complexp (numeric-ctype-complexp type))
+         (low (numeric-ctype-low type))
+         (high (numeric-ctype-high type))
+         (base (case (numeric-ctype-class type)
+                 (integer 'integer)
+                 (rational 'rational)
+                 (float (or (numeric-ctype-format type) 'float))
+                 (t 'real))))
     (let ((base+bounds
-             (cond ((and (eq base 'integer) high low)
-                      (let ((high-count (logcount high))
-                              (high-length (integer-length high)))
-                        (cond ((= low 0)
-                                 (cond ((= high 0) '(integer 0 0))
-                                         ((= high 1) 'bit)
-                                         ((and (= high-count high-length)
-                                               (plusp high-length))
-                                          `(unsigned-byte ,high-length))
-                                         (t
-                                          `(mod ,(1+ high)))))
-                                ((and (= low most-negative-fixnum)
-                                        (= high most-positive-fixnum))
-                                 'fixnum)
-                                ((and (= low (lognot high))
-                                        (= high-count high-length)
-                                        (> high-count 0))
-                                 `(signed-byte ,(1+ high-length)))
-                                (t
-                                 `(integer ,low ,high)))))
-                     (high `(,base ,(or low '*) ,high))
-                     (low
-                      (if (and (eq base 'integer) (= low 0))
-                        'unsigned-byte
-                        `(,base ,low)))
-                     (t base))))
+           (cond ((and (eq base 'integer) high low)
+                  (let ((high-count (logcount high))
+                        (high-length (integer-length high)))
+                    (cond ((= low 0)
+                           (cond ((= high 0) '(integer 0 0))
+                                 ((= high 1) 'bit)
+                                 ((and (= high-count high-length)
+                                       (plusp high-length))
+                                  `(unsigned-byte ,high-length))
+                                 (t
+                                  `(mod ,(1+ high)))))
+                          ((and (= low most-negative-fixnum)
+                                (= high most-positive-fixnum))
+                           'fixnum)
+                          ((and (= low (lognot high))
+                                (= high-count high-length)
+                                (> high-count 0))
+                           `(signed-byte ,(1+ high-length)))
+                          (t
+                           `(integer ,low ,high)))))
+                 (high `(,base ,(or low '*) ,high))
+                 (low
+                  (if (and (eq base 'integer) (= low 0))
+                      'unsigned-byte
+                      `(,base ,low)))
+                 (t base))))
       (ecase complexp
-          (:real 
-           base+bounds)
-          (:complex
-           (if (eq base+bounds 'real)
+        (:real
+         base+bounds)
+        (:complex
+         (if (eq base+bounds 'real)
              'complex
              `(complex ,base+bounds)))
-          ((nil)
-           (assert (eq base+bounds 'real))
-           'number)))))
+        ((nil)
+         (assert (eq base+bounds 'real))
+         'number)))))
 
 ;;; Numeric-Bound-Test  --  Internal
@@ -2076 +2104 @@
 (defmacro numeric-bound-max (x y closed open max-p)
   (once-only ((n-x x)
-                (n-y y))
-    `(cond ((not ,n-x) ,(if max-p nil n-y))
-             ((not ,n-y) ,(if max-p nil n-x))
-             ((consp ,n-x)
-              (if (consp ,n-y)
-                  (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y)
-                  (if (,open (car ,n-x) ,n-y) ,n-x ,n-y)))
-             (t
-              (if (consp ,n-y)
-                  (if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
-                  (if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
+              (n-y y))
+    `(cond
+      ((not ,n-x) ,(if max-p nil n-y))
+      ((not ,n-y) ,(if max-p nil n-x))
+      ((consp ,n-x)
+       (if (consp ,n-y)
+         (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y)
+         (if (,open (car ,n-x) ,n-y) ,n-x ,n-y)))
+      (t
+       (if (consp ,n-y)
+         (if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
+         (if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
 
 
@@ -2132 +2161 @@
 (defun numeric-types-adjacent (low high)
   (let ((low-bound (numeric-ctype-high low))
-          (high-bound (numeric-ctype-low high)))
+        (high-bound (numeric-ctype-low high)))
     (cond ((not (and low-bound high-bound)) nil)
             ((consp low-bound)
@@ -2144 +2173 @@
              nil))))
 
-;;; NUMBER :SIMPLE-UNION method  -- Internal
-;;;
-;;; Return the a numeric type that is a supertype for both type1 and type2.
+;;;
+;;; Return a numeric type that is a supertype for both type1 and type2.
 ;;; 
-;;; ### Note: we give up early, so keep from dropping lots of information on
-;;; the floor by returning overly general types.
-;;;
 (define-type-method (number :simple-union) (type1 type2)
   (declare (type numeric-ctype type1 type2))
   (cond ((csubtypep type1 type2) type2)
-          ((csubtypep type2 type1) type1)
-          (t
-           (let ((class1 (numeric-ctype-class type1))
-                 (format1 (numeric-ctype-format type1))
-                 (complexp1 (numeric-ctype-complexp type1))
-                 (class2 (numeric-ctype-class type2))
-                 (format2 (numeric-ctype-format type2))
-                 (complexp2 (numeric-ctype-complexp type2)))
-             (when (and (eq class1 class2)
-                          (eq format1 format2)
-                          (eq complexp1 complexp2)
-                          (or (numeric-types-intersect type1 type2)
-                                (numeric-types-adjacent type1 type2)
-                                (numeric-types-adjacent type2 type1)))
+        ((csubtypep type2 type1) type1)
+        (t
+         (let ((class1 (numeric-ctype-class type1))
+               (format1 (numeric-ctype-format type1))
+               (complexp1 (numeric-ctype-complexp type1))
+               (class2 (numeric-ctype-class type2))
+               (format2 (numeric-ctype-format type2))
+               (complexp2 (numeric-ctype-complexp type2)))
+           (when (and (eq class1 class2)
+                      (eq format1 format2)
+                      (eq complexp1 complexp2)
+                      (or (numeric-types-intersect type1 type2)
+                          (numeric-types-adjacent type1 type2)
+                          (numeric-types-adjacent type2 type1)))
                (make-numeric-ctype
                 :class class1
@@ -2173 +2198 @@
                 :complexp complexp1
                 :low (numeric-bound-max (numeric-ctype-low type1)
-                                              (numeric-ctype-low type2)
-                                              < <= t)
+                                        (numeric-ctype-low type2)
+                                        <= < t)
                 :high (numeric-bound-max (numeric-ctype-high type1)
-                                               (numeric-ctype-high type2)
-                                               > >= t)))))))
+                                         (numeric-ctype-high type2)
+                                         >= > t)))))))
 
 (setf (info-type-kind 'number) :primitive
@@ -2534 +2559 @@
                      (bit 'bit-vector)
                      (base-char 'base-string)
-                     #|(character 'string)|#
                      (* 'vector)
                      (t `(vector ,eltype)))
@@ -2540 +2564 @@
                      (bit `(bit-vector ,(car dims)))
                      (base-char `(base-string ,(car dims)))
-                     (character `(string ,(car dims)))
                      (t `(vector ,eltype ,(car dims)))))
                (if (eq (car dims) '*)
@@ -2546 +2569 @@
                      (bit 'simple-bit-vector)
                      (base-char 'simple-base-string)
-                     (character 'simple-base-string)
                      ((t) 'simple-vector)
                      (t `(simple-array ,eltype (*))))
@@ -2552 +2574 @@
                      (bit `(simple-bit-vector ,(car dims)))
                      (base-char `(simple-base-string ,(car dims)))
-                     (character `(simple-base-string ,(car dims)))
                      ((t) `(simple-vector ,(car dims)))
                      (t `(simple-array ,eltype ,dims))))))
@@ -2641 +2662 @@
                               (mapcar #'(lambda (x y) (if (eq x '*) y x))
                                       dims1 dims2)))
-           :complexp (if (eq complexp1 '*) complexp2 complexp1)
+           :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
            :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
     *empty-type*))
@@ -2696 +2717 @@
               (dolist (stype-name specialized-array-element-types
                                         (specifier-type 't))
-                  (let ((stype (specifier-type stype-name)))
-                    (when (csubtypep eltype stype)
-                      (return stype))))))
+                (let ((stype (specifier-type stype-name)))
+                  (when (csubtypep eltype stype)
+                    (return stype))))))
     
     type))
@@ -2710 +2731 @@
 ;;; and intersection are well defined.
 
-(defun make-member-ctype (&key members)
+(defun %make-member-ctype (members)
   (%istruct 'member-ctype
             (type-class-or-lose 'member)
             t
             members))
+
+(defun make-member-ctype (&key members)
+  (let* ((singlep (subsetp '(-0.0f0 0.0f0) members))
+         (doublep (subsetp '(-0.0d0 0.0d0) members))
+         (union-types
+          (if singlep
+            (if doublep
+              (list *ctype-of-single-float-0* *ctype-of-double-float-0*)
+              (list *ctype-of-single-float-0*))
+            (if doublep
+              (list *ctype-of-single-float-0*)))))
+    (if union-types
+      (progn
+        (if singlep
+          (setq members (set-difference '(-0.0f0 0.0f0) members)))
+        (if doublep
+          (setq members (set-difference '(-0.d00 0.0d0) members)))
+        (make-union-ctype (if (null members)
+                            union-types
+                            (cons (%make-member-ctype members) union-types))))
+      (%make-member-ctype members))))
+        
 
 (defun member-ctype-p (x) (istruct-typep x 'member-ctype))
@@ -3249 +3292 @@
             ;;; -could- try to find all such classes, but
             ;;; punt instead.
-            (t (if (and (typep class1 'standard-class)
-                        (typep class2 'standard-class))
-                 (find-class-intersection class1 class2)
+            (t (or (find-class-intersection class1 class2)
                  *empty-type*)))
       nil)))
@@ -3417 +3458 @@
                     (float
                      (ecase (numeric-ctype-format type)
-                       (short-float (typep num 'short-float))
                        (single-float (typep num 'single-float))
                        (double-float (typep num 'double-float))
-                       (long-float (typep num 'long-float))
                        ((nil) (floatp num))))
                     ((nil) t)))
@@ -3542 +3581 @@
                                    (rational 'rational)
                                    (float 'float))
-                          :format (and (floatp num) (float-format-name num))
+                          :format (and (floatp num)
+                                       (if (typep num 'double-float)
+                                         'double-float
+                                         'single-float))
                           :complexp complexp
                           :low low
@@ -3562 +3604 @@
      (%class.ctype (class-of x)))))
 
+(defvar *ctype-of-double-float-0* (ctype-of 0.0d0))
+(defvar *ctype-of-single-float-0* (ctype-of 0.0f0))
+
+
 
 
@@ -3604 +3650 @@
 
 (deftype string (&optional size)
-  `(base-string ,size))
+  `(array character (,size)))
 
 (deftype simple-string (&optional size)
-  `(simple-base-string ,size))
+  `(simple-array character (,size)))
 
 (deftype extended-string (&optional size)
@@ -3703 +3749 @@
   `(simple-array single-float (,size)))
 
+(deftype short-float (&optional low high)
+  `(single-float ,low ,high))
+
+(deftype long-float (&optional low high)
+  `(double-float ,low ,high))
+
+;;; As empty a type as you're likely to find ...
+(deftype extended-char ()
+  nil)
 )
+
 
 (let* ((builtin-translations 
@@ -3725 +3781 @@
           (double-float . double-float)
           (long-float . double-float)
-          (short-float . short-float)
-          (single-float . short-float)
-          (rational . rational)   ; why not (or ratio integer)?
-          (ratio . (and rational (not integer))) ; why not ratio
+          (single-float . single-float)
+          (short-float . single-float)
+
+          (rational . rational)
           (integer . integer)
+          (ratio . (and rational (not integer)))
           (fixnum . (integer ,most-negative-fixnum ,most-positive-fixnum))
           (bignum . (or (integer * (,most-negative-fixnum))
@@ -3739 +3796 @@
           (info-type-builtin (car spec)) (specifier-type (cdr spec)))))
 
+
+
+
+
        
 (precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000)
@@ -3748 +3809 @@
                     ))
 
+
 (precompute-types *cl-types*)
+
+;;; Treat CHARACTER and BASE-CHAR as equivalent.
+(setf (info-type-builtin 'character) (info-type-builtin 'base-char))
+;;; And EXTENDED-CHAR as empty.
+(setf (info-type-builtin 'extended-char) *empty-type*)
+
 (defparameter *null-type* (specifier-type 'null))