From: Christophe Rhodes Date: Mon, 3 May 2004 23:01:28 +0000 (+0000) Subject: 0.8.10.9: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=25c9bfeaaf0597e37271dde31eed7037dba391e0;p=sbcl.git 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 --- 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 ); 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 --- 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 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -211,25 +211,6 @@ ;;;; 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 --- 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 --- 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 --- 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 --- 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"