From e58b011bbe611f10fbc316eea0a3e205c3e40ac7 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 10 Feb 2001 22:17:17 +0000 Subject: [PATCH] 0.6.10.14: fixing bug 40.. UPGRADED-ARRAY-ELEMENT-TYPE now signals an error when the type is undefined. TYPEP and SUBTYPEP now catch type arguments which are arrays with undefined element types. also cleaned up UPGRADED-COMPLEX-PART-TYPE a little.. UPGRADED-COMPLEX-PART-TYPE signals an error for undefined type. UPGRADED-COMPLEX-PART-TYPE always returns a value which is a subtype of REAL. --- BUGS | 9 --------- NEWS | 3 +++ src/code/late-type.lisp | 29 +++++++++++++++++++---------- src/code/pred.lisp | 7 ++++--- src/code/seq.lisp | 5 +++-- src/code/target-numbers.lisp | 9 ++++++--- src/code/typep.lisp | 12 +++++++++--- src/compiler/generic/vm-type.lisp | 2 +- src/compiler/typetran.lisp | 13 ------------- tests/assertoid.lisp | 7 +++++++ tests/pathnames.impure.lisp | 4 +--- tests/type.impure.lisp | 27 +++++++++++++++++++++++++++ version.lisp-expr | 2 +- 13 files changed, 81 insertions(+), 48 deletions(-) diff --git a/BUGS b/BUGS index 68cbee7..2afa760 100644 --- a/BUGS +++ b/BUGS @@ -406,15 +406,6 @@ returning an array as first value always. accepting &REST even when it's not followed by an argument name: (DEFMETHOD FOO ((X T) &REST) NIL) -40: - TYPEP treats the result of UPGRADED-ARRAY-ELEMENT-TYPE as gospel, - so that (TYPEP (MAKE-ARRAY 3) '(VECTOR SOMETHING-NOT-DEFINED-YET)) - returns (VALUES T T). Probably it should be an error instead, - complaining that the type SOMETHING-NOT-DEFINED-YET is not defined. - Or perhaps UPGRADED-ARRAY-ELEMENT-TYPE should just fail when a type - isn't defined yet. (What if the definition of - SOMETHING-NOT-DEFINED-YET turns out to be SINGLE-FLOAT?) - 41: TYPEP of VALUES types is sometimes implemented very inefficiently, e.g. in (DEFTYPE INDEXOID () '(INTEGER 0 1000)) diff --git a/NEWS b/NEWS index b6e2a51..8c22dbd 100644 --- a/NEWS +++ b/NEWS @@ -650,6 +650,9 @@ changes in sbcl-0.6.11 relative to sbcl-0.6.10: but like most other programs, it defaults to copying the Unix environment from the original process instead of starting the new process in an empty environment. +* fixed bug 40: TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE, + and UPGRADED-COMPLEX-PART-TYPE now work better with of compound + types built from undefined types, e.g. '(VECTOR SOME-UNDEF-TYPE). * Extensions which manipulate the Unix environment now support an :ENVIRONMENT keyword option which doesn't smash case or do other bad things. The CMU-CL-style :ENV option is retained diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 8706017..1e73b31 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1381,8 +1381,8 @@ (let ((dims1 (array-type-dimensions type1)) (dims2 (array-type-dimensions type2)) (complexp2 (array-type-complexp type2))) - ;; See whether dimensions are compatible. - (cond ((not (or (eq dims2 '*) + (cond (;; not subtypep unless dimensions are compatible + (not (or (eq dims2 '*) (and (not (eq dims1 '*)) ;; (sbcl-0.6.4 has trouble figuring out that ;; DIMS1 and DIMS2 must be lists at this @@ -1395,18 +1395,27 @@ (the list dims1) (the list dims2))))) (values nil t)) - ;; See whether complexpness is compatible. + ;; not subtypep unless complexness is compatible ((not (or (eq complexp2 :maybe) (eq (array-type-complexp type1) complexp2))) (values nil t)) - ;; If the TYPE2 eltype is wild, we win. Otherwise, the types - ;; must be identical. - ((or (eq (array-type-element-type type2) *wild-type*) - (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2))) + ;; Since we didn't fail any of the tests above, we win + ;; if the TYPE2 element type is wild. + ((eq (array-type-element-type type2) *wild-type*) (values t t)) - (t - (values nil t))))) + (;; Since we didn't match any of the special cases above, we + ;; can't give a good answer unless both the element types + ;; have been defined. + (or (unknown-type-p (array-type-element-type type1)) + (unknown-type-p (array-type-element-type type2))) + (values nil nil)) + (;; Otherwise, the subtype relationship holds iff the + ;; types are equal, and they're equal iff the specialized + ;; element types are identical. + t + (values (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2)) + t))))) (!define-superclasses array ((string string) diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 86bad39..f144d02 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -141,9 +141,10 @@ #!+sb-doc "Return the element type that will actually be used to implement an array with the specifier :ELEMENT-TYPE Spec." - (type-specifier - (array-type-specialized-element-type - (specifier-type `(array ,spec))))) + (if (unknown-type-p (specifier-type spec)) + (error "undefined type: ~S" spec) + (type-specifier (array-type-specialized-element-type + (specifier-type `(array ,spec)))))) ;;;; equality predicates diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 4292c35..77ae156 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -186,11 +186,12 @@ (vlen (car (array-type-dimensions type)))) (if (and (numberp vlen) (/= vlen length)) (error 'simple-type-error - ;; these two are under-specified by ANSI + ;; These two are under-specified by ANSI. :datum (type-specifier type) :expected-type (type-specifier type) :format-control - "The length of ~S does not match the specified length of ~S." + "The length of ~S does not match the specified ~ + length=~S." :format-arguments (list (type-specifier type) length))) (if iep diff --git a/src/code/target-numbers.lisp b/src/code/target-numbers.lisp index 6b8f6c6..f77355d 100644 --- a/src/code/target-numbers.lisp +++ b/src/code/target-numbers.lisp @@ -210,8 +210,10 @@ (defun upgraded-complex-part-type (spec) #!+sb-doc "Returns the element type of the most specialized COMPLEX number type that - can hold parts of type Spec." - (cond ((subtypep spec 'single-float) + can hold parts of type SPEC." + (cond ((unknown-type-p (specifier-type spec)) + (error "undefined type: ~S" spec)) + ((subtypep spec 'single-float) 'single-float) ((subtypep spec 'double-float) 'double-float) @@ -220,7 +222,8 @@ 'long-float) ((subtypep spec 'rational) 'rational) - (t))) + (t + 'real))) (defun complex (realpart &optional (imagpart 0)) #!+sb-doc diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 8c58fac..a21ec02 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -9,7 +9,7 @@ (in-package "SB!KERNEL") -;;; The actual TYPEP engine. The compiler only generates calls to this +;;; the actual TYPEP engine. The compiler only generates calls to this ;;; function when it can't figure out anything more intelligent to do. (defun %typep (object specifier) (%%typep object @@ -101,6 +101,12 @@ (or (eq (car want) '*) (= (car want) (car got)))) (return nil)))) + (if (unknown-type-p (array-type-element-type type)) + ;; better to fail this way than to get bogosities like + ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T + (error "~@" + (type-specifier type)) + t) (or (eq (array-type-element-type type) *wild-type*) (values (type= (array-type-specialized-element-type type) (specifier-type (array-element-type @@ -159,7 +165,7 @@ (error "Function types are not a legal argument to TYPEP:~% ~S" (type-specifier type))))) -;;; Do type test from a class cell, allowing forward reference and +;;; Do a type test from a class cell, allowing forward reference and ;;; redefinition. (defun class-cell-typep (obj-layout cell object) (let ((class (class-cell-class cell))) @@ -167,7 +173,7 @@ (error "The class ~S has not yet been defined." (class-cell-name cell))) (class-typep obj-layout class object))) -;;; Test whether Obj-Layout is from an instance of Class. +;;; Test whether OBJ-LAYOUT is from an instance of CLASS. (defun class-typep (obj-layout class object) (declare (optimize speed)) (when (layout-invalid obj-layout) diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index a24de41..8da9e72 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -122,7 +122,7 @@ ;;; This function is called when the type code wants to find out how ;;; an array will actually be implemented. We set the -;;; Specialized-Element-Type to correspond to the actual +;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual ;;; specialization used in this implementation. (declaim (ftype (function (array-type) array-type) specialize-array-type)) (defun specialize-array-type (type) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index a883da0..e1071a8 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -460,19 +460,6 @@ ',(find-class-cell name) object))))))))) -#| -;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE -;;; which corresponds to the value returned by -;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that -;;; result might change when we encounter a DEFTYPE. -(declaim (maybe-inline upgraded-array-element-ctype-2)) -(defun upgraded-array-element-ctype-2 (spec) - (let ((ctype (specifier-type `(array ,spec)))) - (values (array-type-specialized-element-type - (specifier-type `(array ,spec))) - (not (unknown-type-p (array-type-element-type ctype)))))) -|# - ;;; If the specifier argument is a quoted constant, then we consider ;;; converting into a simple predicate or other stuff. If the type is ;;; constant, but we can't transform the call, then we convert to diff --git a/tests/assertoid.lisp b/tests/assertoid.lisp index 4b1e9bf..c6dd931 100644 --- a/tests/assertoid.lisp +++ b/tests/assertoid.lisp @@ -14,6 +14,13 @@ (cl:in-package :cl-user) +(defmacro grab-condition (&body body) + `(nth-value 1 + (ignore-errors ,@body))) + +(defmacro raises-error? (&body body) + `(typep (nth-value 1 (ignore-errors ,@body)) 'error)) + ;;; EXPR is an expression to evaluate (both with EVAL and with ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of ;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 4afbba0..0824498 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -16,9 +16,7 @@ (in-package "CL-USER") -(defmacro grab-condition (&body body) - `(nth-value 1 - (ignore-errors ,@body))) +(load "assertoid.lisp") (setf (logical-pathname-translations "demo0") '(("**;*.*.*" "/tmp/"))) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 33b3f0c..9784892 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -1,5 +1,7 @@ (in-package :cl-user) +(load "assertoid.lisp") + (let ((types '(character integer fixnum (integer 0 10) single-float (single-float -1.0 1.0) (single-float 0.1) @@ -22,5 +24,30 @@ (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10)))) +;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T +;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T. +(assert (raises-error? (upgraded-array-element-type 'some-undef-type))) +(assert (eql (upgraded-array-element-type t) t)) +(assert (raises-error? (upgraded-complex-part-type 'some-undef-type))) +(assert (subtypep (upgraded-complex-part-type 'fixnum) 'real)) + +;;; Do reasonable things with undefined types, and with compound types +;;; built from undefined types. +;;; +;;; part I: TYPEP +(assert (typep #(11) '(simple-array t 1))) +(assert (typep #(11) '(simple-array (or integer symbol) 1))) +(assert (raises-error? (typep #(11) '(simple-array undef-type 1)))) +(assert (not (typep 11 '(simple-array undef-type 1)))) +;;; part II: SUBTYPEP +(assert (subtypep '(vector some-undef-type) 'vector)) +(assert (not (subtypep '(vector some-undef-type) 'integer))) +(macrolet ((nilnil (expr) + `(assert (equal '(nil nil) (multiple-value-list ,expr))))) + (nilnil (subtypep 'utype-1 'utype-2)) + (nilnil (subtypep '(vector utype-1) '(vector utype-2))) + (nilnil (subtypep '(vector utype-1) '(vector t))) + (nilnil (subtypep '(vector t) '(vector utype-2)))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 8c7d29b..28fb7e2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.10.13" +"0.6.10.14" -- 1.7.10.4