0.8.10.9:

	Fix bugs in COMPLEX type specifier and UPGRADED-COMPLEX-PART-TYPE
	... make them more tightly coupled;
	... rearrange COMPLEX type translator so that it can use
		CTYPE-OF (and thus remove logic duplication)
	... implement U-C-P-T in terms of (specifier-type `(complex ,x))
	... fix MEMBER type specifier not to use CTYPE-OF on complex
		members;
	... add tests.

diff --git a/NEWS b/NEWS
index c88b78e..ed70bfd 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2410,6 +2410,10 @@ changes in sbcl-0.8.11 relative to sbcl-0.8.10:
     to diagnose and fix failures.  (thanks to Nikodemus Siivola)
   * fixed bug reported by PFD in lisppaste #747 (and Bruno Haible from
     CLISP test suite): WRITE-TO-STRING is not constant-foldable.
+  * fixed bugs in COMPLEX type specifier: UPGRADED-COMPLEX-PART-TYPE
+    is now consistent with (COMPLEX <x>); bugs in treatment of COMPLEX
+    MEMBER and UNION types have likewise been fixed.  (thanks to Bruno
+    Haible)
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 6992712..ac0ce01 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1465,9 +1465,8 @@
        (:real
         base+bounds)
        (:complex
-        (if (eq base+bounds 'real)
-            'complex
-            `(complex ,base+bounds)))
+        (aver (neq base+bounds 'real))
+        `(complex ,base+bounds))
        ((nil)
         (aver (eq base+bounds 'real))
         'number)))))
@@ -1703,68 +1702,40 @@
 
 (!def-type-translator complex (&optional (typespec '*))
   (if (eq typespec '*)
-      (make-numeric-type :complexp :complex)
+      (specifier-type '(complex real))
       (labels ((not-numeric ()
                 (error "The component type for COMPLEX is not numeric: ~S"
                        typespec))
               (not-real ()
-                (error "The component type for COMPLEX is not real: ~S"
+                (error "The component type for COMPLEX is not a subtype of REAL: ~S"
                        typespec))
               (complex1 (component-type)
                 (unless (numeric-type-p component-type)
                   (not-numeric))
                 (when (eq (numeric-type-complexp component-type) :complex)
                   (not-real))
-                (modified-numeric-type component-type :complexp :complex))
-              (complex-union (component)
-                (unless (numberp component)
-                  (not-numeric))
-                ;; KLUDGE: This TYPECASE more or less does
-                ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
-                ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
-                ;; but uses logic cut and pasted from the DEFUN of
-                ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
-                ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
-                ;; would tend to break the code here. Unfortunately,
-                ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
-                ;; would cause another kind of fragility, because
-                ;; ANSI's definition of TYPE-OF is so weak that e.g.
-                ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
-                ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
-                ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
-                ;; So using TYPE-OF would mean that ANSI-conforming
-                ;; maintenance changes in TYPE-OF could break the code here.
-                ;; It's not clear how best to fix this. -- WHN 2002-01-21,
-                ;; trying to summarize CSR's concerns in his patch
-                (typecase component
-                  (complex (error "The component type for COMPLEX (EQL X) ~
-                                    is complex: ~S"
-                                  component))
-                  ((eql 0) (specifier-type nil)) ; as required by ANSI
-                  (single-float (specifier-type '(complex single-float)))
-                  (double-float (specifier-type '(complex double-float)))
-                  #!+long-float
-                  (long-float (specifier-type '(complex long-float)))
-                  (rational (specifier-type '(complex rational)))
-                  (t (specifier-type '(complex real))))))
+                (if (csubtypep component-type (specifier-type '(eql 0)))
+                    *empty-type*
+                    (modified-numeric-type component-type
+                                           :complexp :complex))))
        (let ((ctype (specifier-type typespec)))
-         (typecase ctype
-           (numeric-type (complex1 ctype))
-           (union-type (apply #'type-union
-                              ;; FIXME: This code could suffer from
-                              ;; (admittedly very obscure) cases of
-                              ;; bug 145 e.g. when TYPE is
-                              ;;   (OR (AND INTEGER (SATISFIES ODDP))
-                              ;;       (AND FLOAT (SATISFIES FOO))
-                              ;; and not even report the problem very well.
-                              (mapcar #'complex1
-                                      (union-type-types ctype))))
-           ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
-           ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
-           ;; ANSI, equal to type NIL, the empty set.
-           (member-type (apply #'type-union
-                               (mapcar #'complex-union
-                                       (member-type-members ctype))))
+         (cond
+           ((eq ctype *empty-type*) *empty-type*)
+           ((eq ctype *universal-type*) (not-real))
+           ((typep ctype 'numeric-type) (complex1 ctype))
+           ((typep ctype 'union-type)
+            (apply #'type-union
+                   ;; FIXME: This code could suffer from (admittedly
+                   ;; very obscure) cases of bug 145 e.g. when TYPE
+                   ;; is
+                   ;;   (OR (AND INTEGER (SATISFIES ODDP))
+                   ;;       (AND FLOAT (SATISFIES FOO))
+                   ;; and not even report the problem very well.
+                   (mapcar #'complex1 (union-type-types ctype))))
+           ((typep ctype 'member-type)
+            (apply #'type-union
+                   (mapcar (lambda (x) (complex1 (ctype-of x)))
+                           (member-type-members ctype))))
            (t
             (multiple-value-bind (subtypep certainly)
                 (csubtypep ctype (specifier-type 'real))
@@ -2413,7 +2384,7 @@
            (float (if (zerop m)
                       (push m ms)
                       (push (ctype-of m) numbers)))
-           (number (push (ctype-of m) numbers))
+           (real (push (ctype-of m) numbers))
            (t (push m ms))))
        (apply #'type-union
               (if ms
@@ -2590,6 +2561,7 @@
     ((type= type (specifier-type 'bignum)) 'bignum)
     ((type= type (specifier-type 'simple-string)) 'simple-string)
     ((type= type (specifier-type 'string)) 'string)
+    ((type= type (specifier-type 'complex)) 'complex)
     (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
 
 ;;; Two union types are equal if they are each subtypes of each

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 72e8761..fc7af0f 100644 (file)
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -211,25 +211,6 @@
 \f
 ;;;; COMPLEXes
 
-(defun upgraded-complex-part-type (spec &optional environment)
-  #!+sb-doc
-  "Return the element type of the most specialized COMPLEX number type that
-   can hold parts of type SPEC."
-  (declare (ignore environment))
-  (cond ((unknown-type-p (specifier-type spec))
-        (error "undefined type: ~S" spec))
-       ((subtypep spec 'single-float)
-        'single-float)
-       ((subtypep spec 'double-float)
-        'double-float)
-       #!+long-float
-       ((subtypep spec 'long-float)
-        'long-float)
-       ((subtypep spec 'rational)
-        'rational)
-       (t
-        'real)))
-
 (defun complex (realpart &optional (imagpart 0))
   #!+sb-doc
   "Return a complex number with the specified real and imaginary components."

diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp
index 8d1d526..d489b03 100644 (file)
--- a/src/cold/defun-load-or-cload-xcompiler.lisp
+++ b/src/cold/defun-load-or-cload-xcompiler.lisp
@@ -131,6 +131,7 @@
                    "SUBTYPEP"
                    "TYPE-OF" "TYPEP"
                    "UPGRADED-ARRAY-ELEMENT-TYPE"
+                   "UPGRADED-COMPLEX-PART-TYPE"
                    "WITH-COMPILATION-UNIT"))
       (export (intern name package-name) package-name)))
   ;; don't watch:

diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp
index a900222..e43b2d4 100644 (file)
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -137,6 +137,27 @@
       (type-specifier (array-type-specialized-element-type
                       (specifier-type `(array ,spec))))))
 
+(defun sb!xc:upgraded-complex-part-type (spec &optional environment)
+  #!+sb-doc
+  "Return the element type of the most specialized COMPLEX number type that
+   can hold parts of type SPEC."
+  (declare (ignore environment))
+  (if (unknown-type-p (specifier-type spec))
+      (error "undefined type: ~S" spec)
+      (let ((ctype (specifier-type `(complex ,spec))))
+       (cond
+         ((eq ctype *empty-type*) '(eql 0))
+         ((csubtypep ctype (specifier-type '(complex single-float)))
+          'single-float)
+         ((csubtypep ctype (specifier-type '(complex double-float)))
+          'double-float)
+         #!+long-float
+         ((csubtypep ctype (specifier-type '(complex long-float)))
+          'long-float)
+         ((csubtypep ctype (specifier-type '(complex rational)))
+          'rational)
+         (t 'real)))))
+
 ;;; Return the most specific integer type that can be quickly checked that
 ;;; includes the given type.
 (defun containing-integer-type (subtype)

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 085ba71..1bd07f4 100644 (file)
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -201,3 +201,21 @@
 (dotimes (i 100)
   (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i)))))
     (eval `(typep ,x (class-of ,x)))))
+
+(assert (not (typep #c(1 2) '(member #c(2 1)))))
+(assert (typep #c(1 2) '(member #c(1 2))))
+(assert (subtypep 'nil '(complex nil)))
+(assert (subtypep '(complex nil) 'nil))
+(assert (subtypep 'nil '(complex (eql 0))))
+(assert (subtypep '(complex (eql 0)) 'nil))
+(assert (subtypep 'nil '(complex (integer 0 0))))
+(assert (subtypep '(complex (integer 0 0)) 'nil))
+(assert (subtypep 'nil '(complex (rational 0 0))))
+(assert (subtypep '(complex (rational 0 0)) 'nil))
+(assert (subtypep 'complex '(complex real)))
+(assert (subtypep '(complex real) 'complex))
+(assert (subtypep '(complex (eql 1)) '(complex (member 1 2))))
+(assert (equal (multiple-value-list
+               (subtypep '(complex (integer 1 2))
+                         '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2))))
+              '(nil t)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 4759316..e201742 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.10.8"
+"0.8.10.9"