X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=eec991e1d58e043951e5ff913801126af9b138fd;hb=0c7ffa8fb85a94482814835c9f28abfd0400ab99;hp=ecf460acefd272d7095c30b19f0e945a441f1ff6;hpb=cbaa1997bb097a55d108df592ac3b7eb4a703fff;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index ecf460a..eec991e 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)) @@ -466,7 +464,7 @@ ;;; than the precise result. ;;; ;;; The return convention seems to be analogous to -;;; TYPES-INTERSECT. -- WHN 19990910. +;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910. (defun-cached (values-type-union :hash-function type-cache-hash :hash-bits 8 :default nil @@ -493,22 +491,19 @@ #'max (specifier-type 'null))))) -;;; This is like TYPES-INTERSECT, except that it sort of works on -;;; VALUES types. Note that due to the semantics of +;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of +;;; works on VALUES types. Note that due to the semantics of ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when -;;; there isn't really any intersection (?). -;;; -;;; The return convention seems to be analogous to -;;; TYPES-INTERSECT. -- WHN 19990910. -(defun values-types-intersect (type1 type2) +;;; there isn't really any intersection. +(defun values-types-equal-or-intersect (type1 type2) (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) - (values 't t)) + (values t t)) ((or (values-type-p type1) (values-type-p type2)) (multiple-value-bind (res win) (values-type-intersection type1 type2) (values (not (eq res *empty-type*)) win))) (t - (types-intersect type1 type2)))) + (types-equal-or-intersect type1 type2)))) ;;; a SUBTYPEP-like operation that can be used on any types, including ;;; VALUES types @@ -522,7 +517,7 @@ (cond ((eq type2 *wild-type*) (values t t)) ((eq type1 *wild-type*) (values (eq type2 *universal-type*) t)) - ((not (values-types-intersect type1 type2)) + ((not (values-types-equal-or-intersect type1 type2)) (values nil t)) (t (if (or (values-type-p type1) (values-type-p type2)) @@ -615,17 +610,9 @@ ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish ;; between not finding a method and having a method return NIL. (flet ((1way (x y) - (let ((result (!invoke-type-method :simple-union2 :complex-union2 - x y - :default nil))) - ;; UNION2 type methods are supposed to return results - ;; which are better than just brute-forcibly smashing the - ;; terms together into UNION-TYPEs. But they're derived - ;; from old CMU CL UNION type methods which played by - ;; somewhat different rules. Here we check to make sure - ;; we don't get ambushed by diehard old-style code. - (assert (not (union-type-p result))) - result))) + (!invoke-type-method :simple-union2 :complex-union2 + x y + :default nil))) (declare (inline 1way)) (or (1way type1 type2) (1way type2 type1)))) @@ -675,20 +662,9 @@ ;; ;; (Why yes, CLOS probably *would* be nicer..) (flet ((1way (x y) - (let ((result - (!invoke-type-method :simple-intersection2 - :complex-intersection2 - x y - :default :no-type-method-found))) - ;; INTERSECTION2 type methods are supposed to return - ;; results which are better than just brute-forcibly - ;; smashing the terms together into INTERSECTION-TYPEs. - ;; But they're derived from old CMU CL INTERSECTION type - ;; methods which played by somewhat different rules. Here - ;; we check to make sure we don't get ambushed by diehard - ;; old-style code. - (assert (not (intersection-type-p result))) - result))) + (!invoke-type-method :simple-intersection2 :complex-intersection2 + x y + :default :no-type-method-found))) (declare (inline 1way)) (let ((xy (1way type1 type2))) (or (and (not (eql xy :no-type-method-found)) xy) @@ -698,7 +674,7 @@ (eql yx :no-type-method-found)) *empty-type*) (t - (assert (and (not xy) (not yx))) ; else handled above + (aver (and (not xy) (not yx))) ; else handled above nil)))))))) (defun-cached (type-intersection2 :hash-function type-cache-hash @@ -730,15 +706,15 @@ ((hairy-type-p type1) type2) (t type1))) -;;; The first value is true unless the types don't intersect. The -;;; second value is true if the first value is definitely correct. NIL -;;; is considered to intersect with any type. If T is a subtype of -;;; either type, then we also return T, T. This way we recognize -;;; that hairy types might intersect with T. +;;; a test useful for checking whether a derived type matches a +;;; declared type ;;; -;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT, -;;; and rename VALUES-TYPES-INTERSECT the same way. -(defun types-intersect (type1 type2) +;;; The first value is true unless the types don't intersect and +;;; aren't equal. The second value is true if the first value is +;;; definitely correct. NIL is considered to intersect with any type. +;;; If T is a subtype of either type, then we also return T, T. This +;;; way we recognize that hairy types might intersect with T. +(defun types-equal-or-intersect (type1 type2) (declare (type ctype type1 type2)) (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) (values t t) @@ -778,20 +754,43 @@ ;;; shared logic for unions and intersections: Stuff TYPE into the ;;; vector TYPES, finding pairs of types which can be simplified by -;;; SIMPLIFY2 and replacing them by their simplified forms. -(defun accumulate-compound-type (type types simplify2) +;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them +;;; by their simplified forms. +(defun accumulate1-compound-type (type types %compound-type-p simplify2) (declare (type ctype type)) (declare (type (vector ctype) types)) (declare (type function simplify2)) + ;; Any input object satisfying %COMPOUND-TYPE-P should've been + ;; broken into components before it reached us. + (aver (not (funcall %compound-type-p type))) (dotimes (i (length types) (vector-push-extend type types)) (let ((simplified2 (funcall simplify2 type (aref types i)))) (when simplified2 ;; Discard the old (AREF TYPES I). (setf (aref types i) (vector-pop types)) - ;; Add the new SIMPLIFIED2 to TYPES, by tail recursing. + ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing. + ;; (Note that the tail recursion is indirect: we go through + ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is + ;; handled properly if it satisfies %COMPOUND-TYPE-P.) (return (accumulate-compound-type simplified2 types + %compound-type-p simplify2))))) + ;; Voila. + (values)) + +;;; shared logic for unions and intersections: Use +;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either +;;; all in one step or, if %COMPOUND-TYPE-P is satisfied, +;;; component by component. +(defun accumulate-compound-type (type types %compound-type-p simplify2) + (declare (type function %compound-type-p simplify2)) + (flet ((accumulate1 (x) + (accumulate1-compound-type x types %compound-type-p simplify2))) + (declare (inline accumulate1)) + (if (funcall %compound-type-p type) + (map nil #'accumulate1 (compound-type-types type)) + (accumulate1 type))) (values)) ;;; shared logic for unions and intersections: Return a vector of @@ -806,13 +805,11 @@ ;; matter, but helps avoid type ;; warnings at compile time.) :initial-element *empty-type*))) - (flet ((accumulate (type) - (accumulate-compound-type type simplified-types simplify2))) - (declare (inline accumulate)) - (dolist (type input-types) - (if (funcall %compound-type-p type) - (map nil #'accumulate (compound-type-types type)) - (accumulate type)))) + (dolist (input-type input-types) + (accumulate-compound-type input-type + simplified-types + %compound-type-p + simplify2)) simplified-types)) ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE @@ -843,6 +840,7 @@ (let ((simplified-types (simplified-compound-types input-types #'intersection-type-p #'type-intersection2))) + (declare (type (vector ctype) simplified-types)) ;; We want to have a canonical representation of types (or failing ;; that, punt to HAIRY-TYPE). Canonical representation would have ;; intersections inside unions but not vice versa, since you can @@ -876,7 +874,7 @@ (defvar *wild-type*) (defvar *empty-type*) (defvar *universal-type*) - +(defvar *universal-fun-type*) (!cold-init-forms (macrolet ((frob (name var) `(progn @@ -891,36 +889,39 @@ ;; 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 ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's ;; just commented out. - ;;(assert (not (eq type1 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) (!define-type-method (named :simple-subtypep) (type1 type2) - (assert (not (eq type1 *wild-type*))) ; * isn't really a type. + (aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) (!define-type-method (named :complex-subtypep-arg1) (type1 type2) - (assert (not (eq type1 *wild-type*))) ; * isn't really a type. + (aver (not (eq type1 *wild-type*))) ; * isn't really a type. ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..) - (assert (not (hairy-type-p type2))) + (aver (not (hairy-type-p type2))) ;; Besides the old CMU CL assertion above, we also need to avoid ;; compound types, else we could get into trouble with - ;; (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR))) + ;; (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR))) ;; or - ;; (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))). - (assert (not (compound-type-p type2))) + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))). + (aver (not (compound-type-p type2))) ;; Then, since TYPE2 is reasonably tractable, we're good to go. (values (eq type1 *empty-type*) t)) (!define-type-method (named :complex-subtypep-arg2) (type1 type2) - (assert (not (eq type2 *wild-type*))) ; * isn't really a type. + (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) ((hairy-type-p type1) @@ -935,12 +936,12 @@ (!define-type-method (named :complex-intersection2) (type1 type2) ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13. ;; Perhaps when bug 85 is fixed it can be reenabled. - ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-intersection2 type1 type2)) (!define-type-method (named :complex-union2) (type1 type2) ;; Perhaps when bug 85 is fixed this can be reenabled. - ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-union2 type1 type2)) (!define-type-method (named :unparse) (x) @@ -1014,28 +1015,6 @@ ;;;; numeric types -#!+negative-zero-is-not-zero -(defun make-numeric-type (&key class format (complexp :real) low high - enumerable) - (flet ((canonicalise-low-bound (x) - ;; Canonicalise a low bound of (-0.0) to 0.0. - (if (and (consp x) (floatp (car x)) (zerop (car x)) - (minusp (float-sign (car x)))) - (float 0.0 (car x)) - x)) - (canonicalise-high-bound (x) - ;; Canonicalise a high bound of (+0.0) to -0.0. - (if (and (consp x) (floatp (car x)) (zerop (car x)) - (plusp (float-sign (car x)))) - (float -0.0 (car x)) - x))) - (%make-numeric-type :class class - :format format - :complexp complexp - :low (canonicalise-low-bound low) - :high (canonicalise-high-bound high) - :enumerable enumerable))) - (!define-type-class number) (!define-type-method (number :simple-=) (type1 type2) @@ -1091,7 +1070,7 @@ 'complex `(complex ,base+bounds))) ((nil) - (assert (eq base+bounds 'real)) + (aver (eq base+bounds 'real)) 'number))))) ;;; Return true if X is "less than or equal" to Y, taking open bounds @@ -1294,17 +1273,38 @@ (setf (info :type :builtin 'number) (make-numeric-type :complexp nil))) -(!def-type-translator complex (&optional (spec '*)) - (if (eq spec '*) +(!def-type-translator complex (&optional (typespec '*)) + (if (eq typespec '*) (make-numeric-type :complexp :complex) - (let ((type (specifier-type spec))) - (unless (numeric-type-p type) - (error "The component type for COMPLEX is not numeric: ~S" spec)) - (when (eq (numeric-type-complexp type) :complex) - (error "The component type for COMPLEX is complex: ~S" spec)) - (let ((res (copy-numeric-type type))) - (setf (numeric-type-complexp res) :complex) - res)))) + (labels ((not-numeric () + ;; FIXME: should probably be TYPE-ERROR + (error "The component type for COMPLEX is not numeric: ~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. + (union-type (apply #'type-union + (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))))))) ;;; 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. @@ -1345,8 +1345,66 @@ (make-numeric-type :class ',class :format ',format :low lb :high hb)))) (!def-bounded-type rational rational nil) -(!def-bounded-type float float nil) -(!def-bounded-type real nil nil) + +;;; Unlike CMU CL, we represent the types FLOAT and REAL as +;;; UNION-TYPEs of more primitive types, in order to make +;;; type representation more unique, avoiding problems in the +;;; simplification of things like +;;; (subtypep '(or (single-float -1.0 1.0) (single-float 0.1)) +;;; '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0))) +;;; When we allowed REAL to remain as a separate NUMERIC-TYPE, +;;; it was too easy for the first argument to be simplified to +;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified +;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the +;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because +;;; the first argument can't be seen to be a subtype of any of the +;;; terms in the second argument. +;;; +;;; The old CMU CL way was: +;;; (!def-bounded-type float float nil) +;;; (!def-bounded-type real nil nil) +;;; +;;; FIXME: If this new way works for a while with no weird new +;;; problems, we can go back and rip out support for separate FLOAT +;;; and REAL flavors of NUMERIC-TYPE. The new way was added in +;;; sbcl-0.6.11.22, 2001-03-21. +;;; +;;; FIXME: It's probably necessary to do something to fix the +;;; analogous problem with INTEGER and RATIONAL types. Perhaps +;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER). +(defun coerce-bound (bound type inner-coerce-bound-fun) + (declare (type function inner-coerce-bound-fun)) + (cond ((eql bound '*) + bound) + ((consp bound) + (destructuring-bind (inner-bound) bound + (list (funcall inner-coerce-bound-fun inner-bound type)))) + (t + (funcall inner-coerce-bound-fun bound type)))) +(defun inner-coerce-real-bound (bound type) + (ecase type + (rational (rationalize bound)) + (float (if (floatp bound) + bound + ;; Coerce to the widest float format available, to + ;; avoid unnecessary loss of precision: + (coerce bound 'long-float))))) +(defun coerced-real-bound (bound type) + (coerce-bound bound type #'inner-coerce-real-bound)) +(defun coerced-float-bound (bound type) + (coerce-bound bound type #'coerce)) +(!def-type-translator real (&optional (low '*) (high '*)) + (specifier-type `(or (float ,(coerced-real-bound low 'float) + ,(coerced-real-bound high 'float)) + (rational ,(coerced-real-bound low 'rational) + ,(coerced-real-bound high 'rational))))) +(!def-type-translator float (&optional (low '*) (high '*)) + (specifier-type + `(or (single-float ,(coerced-float-bound low 'single-float) + ,(coerced-float-bound high 'single-float)) + (double-float ,(coerced-float-bound low 'double-float) + ,(coerced-float-bound high 'double-float)) + #!+long-float ,(error "stub: no long float support yet")))) (defmacro !define-float-format (f) `(!def-bounded-type ,f float ,f)) @@ -1432,7 +1490,7 @@ nil)) ;;; Handle the case of type intersection on two numeric types. We use -;;; TYPES-INTERSECT to throw out the case of types with no +;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no ;;; intersection. If an attribute in TYPE1 is unspecified, then we use ;;; TYPE2's attribute, which must be at least as restrictive. If the ;;; types intersect, then the only attributes that can be specified @@ -1656,8 +1714,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. @@ -1744,7 +1802,7 @@ ;;; subtype of the MEMBER type. (!define-type-method (member :complex-subtypep-arg2) (type1 type2) (cond ((not (type-enumerable type1)) (values nil t)) - ((types-intersect type1 type2) (values nil nil)) + ((types-equal-or-intersect type1 type2) (values nil nil)) (t (values nil t)))) (!define-type-method (member :simple-intersection2) (type1 type2) @@ -1812,7 +1870,7 @@ ;;;; ;; reasonable definition ;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP))) ;;;; ;; reasonable behavior -;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL)) +;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL)) ;;;; Without understanding a little about the semantics of AND, we'd ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's @@ -1855,16 +1913,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))) @@ -1893,23 +1953,10 @@ ;;; Similarly, a union type is a subtype of another if every element ;;; of TYPE1 is a subtype of some element of TYPE2. -;;; -;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and -;;; similarly in INTERSECTION-TYPE, with the logic in the -;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2 -;;; methods. Ideally there's probably some way to make the -;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO -;;; methods in such a way that this definition could go away, but I -;;; don't grok the system well enough to tell whether it's simple to -;;; arrange this. -- WHN 2000-02-03 (!define-type-method (union :simple-subtypep) (type1 type2) - (dolist (t1 (union-type-types type1) (values t t)) - (multiple-value-bind (subtypep validp) - (union-complex-subtypep-arg2 t1 type2) - (cond ((not validp) - (return (values nil nil))) - ((not subtypep) - (return (values nil t))))))) + (every/type (swapped-args-fun #'union-complex-subtypep-arg2) + type2 + (union-type-types type1))) (defun union-complex-subtypep-arg1 (type1 type2) (every/type (swapped-args-fun #'csubtypep) @@ -1942,33 +1989,26 @@ ((union-complex-subtypep-arg1 type2 type1) type2) (t + ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2 + ;; operations in a particular order, and gives up if any of + ;; the sub-unions turn out not to be simple. In other cases + ;; ca. sbcl-0.6.11.15, that approach to taking a union was a + ;; bad idea, since it can overlook simplifications which + ;; might occur if the terms were accumulated in a different + ;; order. It's possible that that will be a problem here too. + ;; However, I can't think of a good example to demonstrate + ;; it, and without an example to demonstrate it I can't write + ;; test cases, and without test cases I don't want to + ;; complicate the code to address what's still a hypothetical + ;; problem. So I punted. -- WHN 2001-03-20 (let ((accumulator *empty-type*)) (dolist (t2 (union-type-types type2) accumulator) (setf accumulator (type-union2 accumulator (type-intersection type1 t2))) - ;; When our result isn't simple any more - (when (or - ;; (TYPE-UNION2 couldn't find a sufficiently simple - ;; result, so we can't either.) - (null accumulator) - ;; (A result containing an intersection isn't - ;; sufficiently simple for us. FIXME: Maybe it - ;; should be sufficiently simple for us? - ;; UNION-TYPEs aren't supposed to be nested inside - ;; INTERSECTION-TYPEs, so if we punt with NIL, - ;; we're condemning the expression to become a - ;; HAIRY-TYPE. If it were possible for us to - ;; return an INTERSECTION-TYPE, then the - ;; INTERSECTION-TYPE-TYPES could be merged into - ;; the outer INTERSECTION-TYPE which may be under - ;; construction. E.g. if this function could - ;; return an intersection type, and the calling - ;; functions were smart enough to handle it, then - ;; we could simplify (AND (OR FIXNUM KEYWORD) - ;; SYMBOL) to KEYWORD, even though KEYWORD - ;; is an intersection type.) - (intersection-type-p accumulator)) + ;; When our result isn't simple any more (because + ;; TYPE-UNION2 was unable to give us a simple result) + (unless accumulator (return nil))))))) (!def-type-translator or (&rest type-specifiers) @@ -2067,7 +2107,7 @@ (multiple-value-bind (val win) (csubtypep x-type y-type) (unless win (return-from type-difference nil)) (when val (return)) - (when (types-intersect x-type y-type) + (when (types-equal-or-intersect x-type y-type) (return-from type-difference nil)))))) (let ((y-mem (find-if #'member-type-p y-types))) (when y-mem @@ -2093,6 +2133,70 @@ :element-type (specifier-type element-type) :complexp nil))) -(!defun-from-collected-cold-init-forms !late-type-cold-init) +;;;; utilities shared between cross-compiler and target system + +;;; Does the type derived from compilation of an actual function +;;; definition satisfy declarations of a function's type? +(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype) + (declare (type ctype defined-ftype declared-ftype)) + (flet ((is-built-in-class-function-p (ctype) + (and (built-in-class-p ctype) + (eq (built-in-class-%name ctype) 'function)))) + (cond (;; DECLARED-FTYPE could certainly be #; + ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). + (is-built-in-class-function-p declared-ftype) + ;; In that case, any definition satisfies the declaration. + t) + (;; It's not clear whether or how DEFINED-FTYPE might be + ;; #, but it's not obviously + ;; invalid, so let's handle that case too, just in case. + (is-built-in-class-function-p defined-ftype) + ;; No matter what DECLARED-FTYPE might be, we can't prove + ;; that an object of type FUNCTION doesn't satisfy it, so + ;; we return success no matter what. + t) + (;; 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 + ;; return type very precisely (as per bug 94a). It would be + ;; good to do a better job. Perhaps to check the + ;; 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 FUN-TYPEs. (ARGS-TYPE + ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) + (values-types-equal-or-intersect + (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. +(defun ctype-of-number (x) + (let ((num (if (complexp x) (realpart x) x))) + (multiple-value-bind (complexp low high) + (if (complexp x) + (let ((imag (imagpart x))) + (values :complex (min num imag) (max num imag))) + (values :real num num)) + (make-numeric-type :class (etypecase num + (integer 'integer) + (rational 'rational) + (float 'float)) + :format (and (floatp num) (float-format-name num)) + :complexp complexp + :low low + :high high)))) + +(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")