X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=6ffd5c9b06e6d5e669da2b15ec83cfbb7c6f453f;hb=0eafb8764315871b03a457e2ff61bd3ec7a05a31;hp=523f792f17766979a86312486fbc8a7b09956362;hpb=6c765578c8dc4bcc7798e37c9918715f198b30da;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 523f792..6ffd5c9 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -31,9 +31,9 @@ ;;; ;;; RATIO and BIGNUM are not recognized as numeric types. -;;; FIXME: It seems to me that this should be set to NIL by default, -;;; and perhaps not even optionally set to T. -(defvar *use-implementation-types* t +;;; FIXME: This really should go away. Alas, it doesn't seem to be so +;;; simple to make it go away.. (See bug 123 in BUGS file.) +(defvar *use-implementation-types* t ; actually initialized in cold init #!+sb-doc "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how restrictive we are in determining type membership. If two types are the @@ -41,7 +41,6 @@ this switch is on. When it is off, we try to be as restrictive as the language allows, allowing us to detect more errors. Currently, this only affects array types.") - (!cold-init-forms (setq *use-implementation-types* t)) ;;; These functions are used as method for types which need a complex @@ -132,10 +131,10 @@ ;;; the description of a &KEY argument (defstruct (key-info #-sb-xc-host (:pure t) (:copier nil)) - ;; the key (not necessarily a keyword in ANSI) - (name (required-argument) :type symbol) + ;; the key (not necessarily a keyword in ANSI Common Lisp) + (name (missing-arg) :type symbol) ;; the type of the argument value - (type (required-argument) :type ctype)) + (type (missing-arg) :type ctype)) (!define-type-method (values :simple-subtypep :complex-subtypep-arg1) (type1 type2) @@ -193,18 +192,18 @@ ;;; a flag that we can bind to cause complex function types to be ;;; unparsed as FUNCTION. This is useful when we want a type that we ;;; can pass to TYPEP. -(defvar *unparse-function-type-simplify*) -(!cold-init-forms (setq *unparse-function-type-simplify* nil)) +(defvar *unparse-fun-type-simplify*) +(!cold-init-forms (setq *unparse-fun-type-simplify* nil)) (!define-type-method (function :unparse) (type) - (if *unparse-function-type-simplify* + (if *unparse-fun-type-simplify* 'function (list 'function - (if (function-type-wild-args type) + (if (fun-type-wild-args type) '* (unparse-args-types type)) (type-specifier - (function-type-returns type))))) + (fun-type-returns type))))) ;;; Since all function types are equivalent to FUNCTION, they are all ;;; subtypes of each other. @@ -230,12 +229,12 @@ (!define-type-class constant :inherits values) (!define-type-method (constant :unparse) (type) - `(constant-argument ,(type-specifier (constant-type-type type)))) + `(constant-arg ,(type-specifier (constant-type-type type)))) (!define-type-method (constant :simple-=) (type1 type2) (type= (constant-type-type type1) (constant-type-type type2))) -(!def-type-translator constant-argument (type) +(!def-type-translator constant-arg (type) (make-constant-type :type (specifier-type type))) ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE @@ -295,10 +294,9 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (let ((res (make-function-type - :returns (values-specifier-type result)))) + (let ((res (make-fun-type :returns (values-specifier-type result)))) (if (eq args '*) - (setf (function-type-wild-args res) t) + (setf (fun-type-wild-args res) t) (parse-args-types args res)) res)) @@ -333,9 +331,9 @@ ;;; Return the minimum number of arguments that a function can be ;;; called with, and the maximum number or NIL. If not a function ;;; type, return NIL, NIL. -(defun function-type-nargs (type) +(defun fun-type-nargs (type) (declare (type ctype type)) - (if (function-type-p type) + (if (fun-type-p type) (let ((fixed (length (args-type-required type)))) (if (or (args-type-rest type) (args-type-keyp type) @@ -383,12 +381,12 @@ (defun fixed-values-op (types1 types2 rest2 operation) (declare (list types1 types2) (type ctype rest2) (type function operation)) (let ((exact t)) - (values (mapcar #'(lambda (t1 t2) - (multiple-value-bind (res win) - (funcall operation t1 t2) - (unless win - (setq exact nil)) - res)) + (values (mapcar (lambda (t1 t2) + (multiple-value-bind (res win) + (funcall operation t1 t2) + (unless win + (setq exact nil)) + res)) types1 (append types2 (make-list (- (length types1) (length types2)) @@ -802,6 +800,7 @@ (defun simplified-compound-types (input-types %compound-type-p simplify2) (let ((simplified-types (make-array (length input-types) :fill-pointer 0 + :adjustable t :element-type 'ctype ;; (This INITIAL-ELEMENT shouldn't ;; matter, but helps avoid type @@ -876,7 +875,7 @@ (defvar *wild-type*) (defvar *empty-type*) (defvar *universal-type*) - +(defvar *universal-fun-type*) (!cold-init-forms (macrolet ((frob (name var) `(progn @@ -891,7 +890,10 @@ ;; Ts and *UNIVERSAL-TYPE*s. (frob * *wild-type*) (frob nil *empty-type*) - (frob t *universal-type*))) + (frob t *universal-type*)) + (setf *universal-fun-type* + (make-fun-type :wild-args t + :returns *wild-type*))) (!define-type-method (named :simple-=) (type1 type2) ;; FIXME: BUG 85: This assertion failed when I added it in @@ -974,7 +976,75 @@ (t (values nil nil))))) -(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2) +(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2) + (let ((hairy-spec (hairy-type-specifier type1))) + (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not)) + ;; You may not believe this. I couldn't either. But then I + ;; sat down and drew lots of Venn diagrams. Comments + ;; involving a and b refer to the call (subtypep '(not a) + ;; 'b) -- CSR, 2002-02-27. + (block nil + ;; (Several logical truths in this block are true as + ;; long as b/=T. As of sbcl-0.7.1.28, it seems + ;; impossible to construct a case with b=T where we + ;; actually reach this type method, but we'll test for + ;; and exclude this case anyway, since future + ;; maintenance might make it possible for it to end up + ;; in this code.) + (multiple-value-bind (equal certain) + (type= type2 (specifier-type t)) + (unless certain + (return (values nil nil))) + (when equal + (return (values t t)))) + (let ((complement-type1 (specifier-type (cadr hairy-spec)))) + ;; Do the special cases first, in order to give us a + ;; chance if subtype/supertype relationships are hairy. + (multiple-value-bind (equal certain) + (type= complement-type1 type2) + ;; If a = b, ~a is not a subtype of b (unless b=T, + ;; which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; This (TYPE= TYPE1 TYPE2) branch would never be + ;; taken, as type1 and type2 will only be equal if + ;; they're both NOT types, and then the + ;; :SIMPLE-SUBTYPEP method would be used instead. + ;; ((type= type1 type2) (values t t)) + (multiple-value-bind (equal certain) + (csubtypep complement-type1 type2) + ;; If a is a subtype of b, ~a is not a subtype of b + ;; (unless b=T, which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + (multiple-value-bind (equal certain) + (csubtypep type2 complement-type1) + ;; If b is a subtype of a, ~a is not a subtype of b. + ;; (FIXME: That's not true if a=T. Do we know at + ;; this point that a is not T?) + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; Other cases here would rely on being able to catch + ;; all possible cases, which the fragility of this + ;; type system doesn't inspire me; for instance, if a + ;; is type= to ~b, then we want T, T; if this is not + ;; the case and the types are disjoint (have an + ;; intersection of *empty-type*) then we want NIL, T; + ;; else if the union of a and b is the + ;; *universal-type* then we want T, T. So currently we + ;; still claim to be unsure about e.g. (subtypep '(not + ;; fixnum) 'single-float). + ))) + (t + (values nil nil))))) + +(!define-type-method (hairy :complex-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) @@ -994,9 +1064,11 @@ ;; Check legality of arguments. (destructuring-bind (not typespec) whole (declare (ignore not)) - (specifier-type typespec)) ; must be legal typespec - ;; Create object. - (make-hairy-type :specifier whole)) + (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec + (if (and (listp spec) (eq (car spec) 'not)) + ;; canonicalize (not (not foo)) + (specifier-type (cadr spec)) + (make-hairy-type :specifier whole))))) (!def-type-translator satisfies (&whole whole fun) (declare (ignore fun)) @@ -1276,34 +1348,80 @@ (if (eq typespec '*) (make-numeric-type :complexp :complex) (labels ((not-numeric () - ;; FIXME: should probably be TYPE-ERROR (error "The component type for COMPLEX is not numeric: ~S" typespec)) + (not-real () + (error "The component type for COMPLEX is not real: ~S" + typespec)) (complex1 (component-type) (unless (numeric-type-p component-type) - ;; FIXME: As per the FIXME below, ANSI says we're - ;; supposed to handle any subtype of REAL, not only - ;; those which can be represented as NUMERIC-TYPE. (not-numeric)) (when (eq (numeric-type-complexp component-type) :complex) - (error "The component type for COMPLEX is complex: ~S" - typespec)) - (modified-numeric-type component-type :complexp :complex))) - (let ((type (specifier-type typespec))) - (typecase type - ;; This is all that CMU CL handled. - (numeric-type (complex1 type)) - ;; We need to handle UNION-TYPEs in order to deal with - ;; REAL and FLOAT being represented as UNION-TYPEs of more - ;; primitive types. + (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)))))) + (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 type)))) - ;; FIXME: ANSI just says that TYPESPEC is a subtype of type - ;; REAL, not necessarily a NUMERIC-TYPE. E.g. TYPESPEC could - ;; legally be (AND REAL (SATISFIES ODDP))! But like the old - ;; CMU CL code, we're still not nearly that general. - (t (not-numeric))))))) + (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)))) + (t + (multiple-value-bind (subtypep certainly) + (csubtypep ctype (specifier-type 'real)) + (if (and (not subtypep) certainly) + (not-real) + ;; ANSI just says that TYPESPEC is any subtype of + ;; type REAL, not necessarily a NUMERIC-TYPE. In + ;; particular, at this point TYPESPEC could legally be + ;; an intersection type like (AND REAL (SATISFIES ODDP)), + ;; in which case we fall through the logic above and + ;; end up here, stumped. + (bug "~@<(known bug #145): The type ~S is too hairy to be + used for a COMPLEX component.~:@>" + typespec))))))))) ;;; If X is *, return NIL, otherwise return the bound, which must be a ;;; member of TYPE or a one-element list of a member of TYPE. @@ -1713,8 +1831,8 @@ ;; See whether dimensions are compatible. (cond ((not (or (eq dims1 '*) (eq dims2 '*) (and (= (length dims1) (length dims2)) - (every #'(lambda (x y) - (or (eq x '*) (eq y '*) (= x y))) + (every (lambda (x y) + (or (eq x '*) (eq y '*) (= x y))) dims1 dims2)))) (values nil t)) ;; See whether complexpness is compatible. @@ -1912,16 +2030,18 @@ (type=-set (intersection-type-types type1) (intersection-type-types type2))) -(flet ((intersection-complex-subtypep-arg1 (type1 type2) - (any/type (swapped-args-fun #'csubtypep) - type2 - (intersection-type-types type1)))) - (!define-type-method (intersection :simple-subtypep) (type1 type2) - (every/type #'intersection-complex-subtypep-arg1 - type1 - (intersection-type-types type2))) - (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) - (intersection-complex-subtypep-arg1 type1 type2))) +(defun %intersection-complex-subtypep-arg1 (type1 type2) + (any/type (swapped-args-fun #'csubtypep) + type2 + (intersection-type-types type1))) + +(!define-type-method (intersection :simple-subtypep) (type1 type2) + (every/type #'%intersection-complex-subtypep-arg1 + type1 + (intersection-type-types type2))) + +(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (%intersection-complex-subtypep-arg1 type1 type2)) (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) (every/type #'csubtypep type1 (intersection-type-types type2))) @@ -2152,7 +2272,7 @@ ;; that an object of type FUNCTION doesn't satisfy it, so ;; we return success no matter what. t) - (;; Otherwise both of them must be FUNCTION-TYPE objects. + (;; Otherwise both of them must be FUN-TYPE objects. t ;; FIXME: For now we only check compatibility of the return ;; type, not argument types, and we don't even check the @@ -2161,11 +2281,11 @@ ;; compatibility of the arguments, we should (1) redo ;; VALUES-TYPES-EQUAL-OR-INTERSECT as ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to - ;; the ARGS-TYPE slices of the FUNCTION-TYPEs. (ARGS-TYPE - ;; is a base class both of VALUES-TYPE and of FUNCTION-TYPE.) + ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE + ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) (values-types-equal-or-intersect - (function-type-returns defined-ftype) - (function-type-returns declared-ftype)))))) + (fun-type-returns defined-ftype) + (fun-type-returns declared-ftype)))))) ;;; This messy case of CTYPE for NUMBER is shared between the ;;; cross-compiler and the target system. @@ -2185,6 +2305,15 @@ :low low :high high)))) -(!defun-from-collected-cold-init-forms !late-type-cold-init) +(locally + ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type + ;; checking for declarations in structure accessors. Otherwise we + ;; can get caught in a chicken-and-egg bootstrapping problem, whose + ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal + ;; instruction trap. I haven't tracked it down, but I'm guessing it + ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set + ;; yet. -- WHN + (declare (optimize (safety 0))) + (!defun-from-collected-cold-init-forms !late-type-cold-init)) (/show0 "late-type.lisp end of file")