X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-type.lisp;h=ecf460acefd272d7095c30b19f0e945a441f1ff6;hb=cbaa1997bb097a55d108df592ac3b7eb4a703fff;hp=e61294d86511bf34de7acefb1d41a775b92125e3;hpb=854b904d18932d85fa3255a22e4872a7de97092a;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index e61294d..ecf460a 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -16,6 +16,8 @@ (in-package "SB!KERNEL") +(/show0 "late-type.lisp 19") + (!begin-collecting-cold-init-forms) ;;; ### Remaining incorrectnesses: @@ -55,11 +57,11 @@ (if subtypep-arg1 (funcall subtypep-arg1 type1 type2) (values nil t)))) -(defun delegate-complex-intersection (type1 type2) - (let ((method (type-class-complex-intersection (type-class-info type1)))) - (if (and method (not (eq method #'delegate-complex-intersection))) +(defun delegate-complex-intersection2 (type1 type2) + (let ((method (type-class-complex-intersection2 (type-class-info type1)))) + (if (and method (not (eq method #'delegate-complex-intersection2))) (funcall method type2 type1) - (vanilla-intersection type1 type2)))) + (hierarchical-intersection2 type1 type2)))) ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 ;;; method. INFO is a list of conses @@ -108,8 +110,8 @@ (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) (setf (type-class-complex-subtypep-arg2 ,type-class) #'delegate-complex-subtypep-arg2) - (setf (type-class-complex-intersection ,type-class) - #'delegate-complex-intersection))))) + (setf (type-class-complex-intersection2 ,type-class) + #'delegate-complex-intersection2))))) ;;;; FUNCTION and VALUES types ;;;; @@ -127,22 +129,24 @@ ;;;; -- Many of the places that can be annotated with real types can ;;;; also be annotated with function or values types. -;;; the description of a keyword argument -(defstruct (key-info #-sb-xc-host (:pure t)) - ;; the keyword - (name (required-argument) :type keyword) +;;; 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 type of the argument value (type (required-argument) :type ctype)) (!define-type-method (values :simple-subtypep :complex-subtypep-arg1) - (type1 type2) + (type1 type2) (declare (ignore type2)) - (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1))) + ;; FIXME: should be TYPE-ERROR, here and in next method + (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1))) (!define-type-method (values :complex-subtypep-arg2) - (type1 type2) + (type1 type2) (declare (ignore type1)) - (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) + (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2))) (!define-type-method (values :unparse) (type) (cons 'values (unparse-args-types type))) @@ -211,12 +215,12 @@ (!define-superclasses function ((function)) !cold-init-forms) ;;; The union or intersection of two FUNCTION types is FUNCTION. -(!define-type-method (function :simple-union) (type1 type2) +(!define-type-method (function :simple-union2) (type1 type2) (declare (ignore type1 type2)) (specifier-type 'function)) -(!define-type-method (function :simple-intersection) (type1 type2) +(!define-type-method (function :simple-intersection2) (type1 type2) (declare (ignore type1 type2)) - (values (specifier-type 'function) t)) + (specifier-type 'function)) ;;; ### Not very real, but good enough for redefining transforms ;;; according to type: @@ -326,7 +330,7 @@ (t type))) -;;; Return the minmum number of arguments that a function can be +;;; 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) @@ -410,7 +414,7 @@ ;;; This has the virtue of always keeping the VALUES type specifier ;;; outermost, and retains all of the information that is really ;;; useful for static type analysis. We want to know what is always -;;; true of each value independently. It is worthless to know that IF +;;; true of each value independently. It is worthless to know that if ;;; the first value is B0 then the second will be B1. ;;; ;;; If the VALUES count signatures differ, then we produce a result with @@ -602,62 +606,149 @@ (values (not res) t) (values nil nil)))) +;;; the type method dispatch case of TYPE-UNION2 +(defun %type-union2 (type1 type2) + ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give + ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike + ;; %TYPE-INTERSECTION2, though, I don't have a specific case which + ;; demonstrates this is actually necessary. Also unlike + ;; %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))) + (declare (inline 1way)) + (or (1way type1 type2) + (1way type2 type1)))) + ;;; Find a type which includes both types. Any inexactness is ;;; represented by the fuzzy element types; we return a single value ;;; that is precise to the best of our knowledge. This result is -;;; simplified into the canonical form, thus is not a UNION type -;;; unless there is no other way to represent the result. -(defun-cached (type-union :hash-function type-cache-hash - :hash-bits 8 - :init-wrapper !cold-init-forms) +;;; simplified into the canonical form, thus is not a UNION-TYPE +;;; unless we find no other way to represent the result. +(defun-cached (type-union2 :hash-function type-cache-hash + :hash-bits 8 + :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) + ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And + ;; Paste technique of programming. If it stays around (as opposed to + ;; e.g. fading away in favor of some CLOS solution) the shared logic + ;; should probably become shared code. -- WHN 2001-03-16 (declare (type ctype type1 type2)) - (if (eq type1 type2) - type1 - (let ((res (!invoke-type-method :simple-union :complex-union - type1 type2 - :default :vanilla))) - (cond ((eq res :vanilla) - (or (vanilla-union type1 type2) - (make-union-type (list type1 type2)))) - (res) - (t - (make-union-type (list type1 type2))))))) - -;;; Return as restrictive a type as we can discover that is no more -;;; restrictive than the intersection of Type1 and Type2. The second -;;; value is true if the result is exact. At worst, we randomly return -;;; one of the arguments as the first value (trying not to return a -;;; hairy type). -(defun-cached (type-intersection :hash-function type-cache-hash - :hash-bits 8 - :values 2 - :default (values nil :empty) - :init-wrapper !cold-init-forms) + (cond ((eq type1 type2) + type1) + ((or (union-type-p type1) + (union-type-p type2)) + ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES + ;; values broken out and united separately. The full TYPE-UNION + ;; function knows how to do this, so let it handle it. + (type-union type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-union2 type1 type2)))) + +;;; the type method dispatch case of TYPE-INTERSECTION2 +(defun %type-intersection2 (type1 type2) + ;; We want to give both argument orders a chance at + ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type + ;; methods could give noncommutative results, e.g. + ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE) + ;; => NIL, NIL + ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*) + ;; => #, T + ;; We also need to distinguish between the case where we found a + ;; type method, and it returned NIL, and the case where we fell + ;; through without finding any type method. An example of the first + ;; case is the intersection of a HAIRY-TYPE with some ordinary type. + ;; An example of the second case is the intersection of two + ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and + ;; ARRAY. + ;; + ;; (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))) + (declare (inline 1way)) + (let ((xy (1way type1 type2))) + (or (and (not (eql xy :no-type-method-found)) xy) + (let ((yx (1way type2 type1))) + (or (and (not (eql yx :no-type-method-found)) yx) + (cond ((and (eql xy :no-type-method-found) + (eql yx :no-type-method-found)) + *empty-type*) + (t + (assert (and (not xy) (not yx))) ; else handled above + nil)))))))) + +(defun-cached (type-intersection2 :hash-function type-cache-hash + :hash-bits 8 + :values 1 + :default nil + :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) - (if (eq type1 type2) - (values type1 t) - (!invoke-type-method :simple-intersection :complex-intersection - type1 type2 - :default (values *empty-type* t)))) + (cond ((eq type1 type2) + type1) + ((or (intersection-type-p type1) + (intersection-type-p type2)) + ;; Intersections of INTERSECTION-TYPE should have the + ;; INTERSECTION-TYPE-TYPES values broken out and intersected + ;; separately. The full TYPE-INTERSECTION function knows how + ;; to do that, so let it handle it. + (type-intersection type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-intersection2 type1 type2)))) + +;;; Return as restrictive and simple a type as we can discover that is +;;; no more restrictive than the intersection of TYPE1 and TYPE2. At +;;; worst, we arbitrarily return one of the arguments as the first +;;; value (trying not to return a hairy type). +(defun type-approx-intersection2 (type1 type2) + (cond ((type-intersection2 type1 type2)) + ((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 consider hairy -;;; types to intersect with T. +;;; either type, then we also return T, T. This way we recognize +;;; that hairy types might intersect with T. +;;; +;;; 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) (declare (type ctype type1 type2)) (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) (values t t) - (multiple-value-bind (val winp) (type-intersection type1 type2) - (cond ((not winp) + (let ((intersection2 (type-intersection2 type1 type2))) + (cond ((not intersection2) (if (or (csubtypep *universal-type* type1) (csubtypep *universal-type* type2)) (values t t) (values t nil))) - ((eq val *empty-type*) (values nil t)) + ((eq intersection2 *empty-type*) (values nil t)) (t (values t t)))))) ;;; Return a Common Lisp type specifier corresponding to the TYPE @@ -680,6 +771,104 @@ (setf (info :type :kind spec) :primitive)))) (values)) +;;;; general TYPE-UNION and TYPE-INTERSECTION operations +;;;; +;;;; These are fully general operations on CTYPEs: they'll always +;;;; return a CTYPE representing the result. + +;;; 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) + (declare (type ctype type)) + (declare (type (vector ctype) types)) + (declare (type function simplify2)) + (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. + (return (accumulate-compound-type simplified2 + types + simplify2))))) + (values)) + +;;; shared logic for unions and intersections: Return a vector of +;;; types representing the same types as INPUT-TYPES, but with +;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their +;;; component types, and with any SIMPLY2 simplifications applied. +(defun simplified-compound-types (input-types %compound-type-p simplify2) + (let ((simplified-types (make-array (length input-types) + :fill-pointer 0 + :element-type 'ctype + ;; (This INITIAL-ELEMENT shouldn't + ;; 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)))) + simplified-types)) + +;;; shared logic for unions and intersections: Make a COMPOUND-TYPE +;;; object whose components are the types in TYPES, or skip to special +;;; cases when TYPES is short. +(defun make-compound-type-or-something (constructor types enumerable identity) + (declare (type function constructor)) + (declare (type (vector ctype) types)) + (declare (type ctype identity)) + (case (length types) + (0 identity) + (1 (aref types 0)) + (t (funcall constructor + enumerable + ;; FIXME: This should be just (COERCE TYPES 'LIST), but as + ;; of sbcl-0.6.11.17 the COERCE optimizer is really + ;; brain-dead, so that would generate a full call to + ;; SPECIFIER-TYPE at runtime, so we get into bootstrap + ;; problems in cold init because 'LIST is a compound + ;; type, so we need to MAKE-COMPOUND-TYPE-OR-SOMETHING + ;; before we know what 'LIST is. Once the COERCE + ;; optimizer is less brain-dead, we can make this + ;; (COERCE TYPES 'LIST) again. + #+sb-xc-host (coerce types 'list) + #-sb-xc-host (coerce-to-list types))))) + +(defun type-intersection (&rest input-types) + (let ((simplified-types (simplified-compound-types input-types + #'intersection-type-p + #'type-intersection2))) + ;; 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 + ;; always achieve that by the distributive rule. But we don't want + ;; to just apply the distributive rule, since it would be too easy + ;; to end up with unreasonably huge type expressions. So instead + ;; we punt to HAIRY-TYPE when this comes up. + (if (and (> (length simplified-types) 1) + (some #'union-type-p simplified-types)) + (make-hairy-type + :specifier `(and ,@(map 'list #'type-specifier simplified-types))) + (make-compound-type-or-something #'%make-intersection-type + simplified-types + (some #'type-enumerable + simplified-types) + *universal-type*)))) + +(defun type-union (&rest input-types) + (let ((simplified-types (simplified-compound-types input-types + #'union-type-p + #'type-union2))) + (make-compound-type-or-something #'%make-union-type + simplified-types + (every #'type-enumerable simplified-types) + *empty-type*))) + ;;;; built-in types (!define-type-class named) @@ -705,22 +894,54 @@ (frob t *universal-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. (values (eq type1 type2) t)) (!define-type-method (named :simple-subtypep) (type1 type2) + (assert (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 (hairy-type-p type2))) + (assert (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))) + ;; 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))) + ;; or + ;; (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))). + (assert (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) - (if (hairy-type-p type1) - (values nil nil) - (values (not (eq type2 *empty-type*)) t))) - -(!define-type-method (named :complex-intersection) (type1 type2) - (vanilla-intersection type1 type2)) + (assert (not (eq type2 *wild-type*))) ; * isn't really a type. + (cond ((eq type2 *universal-type*) + (values t t)) + ((hairy-type-p type1) + (values nil nil)) + (t + ;; FIXME: This seems to rely on there only being 2 or 3 + ;; HAIRY-TYPE values, and the exclusion of various + ;; possibilities above. It would be good to explain it and/or + ;; rewrite it so that it's clearer. + (values (not (eq type2 *empty-type*)) t)))) + +(!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. + (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. + (hierarchical-union2 type1 type2)) (!define-type-method (named :unparse) (x) (named-type-name x)) @@ -744,10 +965,11 @@ (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) (let ((hairy-spec (hairy-type-specifier type2))) (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not)) - (multiple-value-bind (val win) - (type-intersection type1 (specifier-type (cadr hairy-spec))) - (if win - (values (eq val *empty-type*) t) + (let* ((complement-type2 (specifier-type (cadr hairy-spec))) + (intersection2 (type-intersection2 type1 + complement-type2))) + (if intersection2 + (values (eq intersection2 *empty-type*) t) (values nil nil)))) (t (values nil nil))))) @@ -756,13 +978,10 @@ (declare (ignore type1 type2)) (values nil nil)) -(!define-type-method (hairy :simple-intersection :complex-intersection) - (type1 type2) - (declare (ignore type2)) - (values type1 nil)) - -(!define-type-method (hairy :complex-union) (type1 type2) - (make-union-type (list type1 type2))) +(!define-type-method (hairy :simple-intersection2 :complex-intersection2) + (type1 type2) + (declare (ignore type1 type2)) + nil) (!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) @@ -772,22 +991,29 @@ (!def-type-translator not (&whole whole type) (declare (ignore type)) + ;; 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)) (!def-type-translator satisfies (&whole whole fun) (declare (ignore fun)) + ;; Check legality of arguments. + (destructuring-bind (satisfies predicate-name) whole + (declare (ignore satisfies)) + (unless (symbolp predicate-name) + (error 'simple-type-error + :datum predicate-name + :expected-type 'symbol + :format-control "~S is not a symbol." + :format-arguments (list predicate-name)))) + ;; Create object. (make-hairy-type :specifier whole)) ;;;; numeric types -;;; A list of all the float formats, in order of decreasing precision. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *float-formats* - '(long-float double-float single-float short-float))) - -;;; The type of a float format. -(deftype float-format () `(member ,@*float-formats*)) - #!+negative-zero-is-not-zero (defun make-numeric-type (&key class format (complexp :real) low high enumerable) @@ -1035,7 +1261,7 @@ ;;; ;;; ### Note: we give up early to keep from dropping lots of information on ;;; the floor by returning overly general types. -(!define-type-method (number :simple-union) (type1 type2) +(!define-type-method (number :simple-union2) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) @@ -1073,9 +1299,9 @@ (make-numeric-type :complexp :complex) (let ((type (specifier-type spec))) (unless (numeric-type-p type) - (error "Component type for Complex is not numeric: ~S." spec)) + (error "The component type for COMPLEX is not numeric: ~S" spec)) (when (eq (numeric-type-complexp type) :complex) - (error "Component type for Complex is complex: ~S." spec)) + (error "The component type for COMPLEX is complex: ~S" spec)) (let ((res (copy-numeric-type type))) (setf (numeric-type-complexp res) :complex) res)))) @@ -1110,7 +1336,7 @@ :low lb :high hb))) -(defmacro def-bounded-type (type class format) +(defmacro !def-bounded-type (type class format) `(!def-type-translator ,type (&optional (low '*) (high '*)) (let ((lb (canonicalized-bound low ',type)) (hb (canonicalized-bound high ',type))) @@ -1118,17 +1344,17 @@ (error "Lower bound ~S is not less than upper bound ~S." low high)) (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) +(!def-bounded-type rational rational nil) +(!def-bounded-type float float nil) +(!def-bounded-type real nil nil) -(defmacro define-float-format (f) - `(def-bounded-type ,f float ,f)) +(defmacro !define-float-format (f) + `(!def-bounded-type ,f float ,f)) -(define-float-format short-float) -(define-float-format single-float) -(define-float-format double-float) -(define-float-format long-float) +(!define-float-format short-float) +(!define-float-format single-float) +(!define-float-format double-float) +(!define-float-format long-float) (defun numeric-types-intersect (type1 type2) (declare (type numeric-type type1 type2)) @@ -1205,7 +1431,7 @@ (if (consp x) (list res) res))))) nil)) -;;; Handle the case of TYPE-INTERSECTION on two numeric types. We use +;;; Handle the case of type intersection on two numeric types. We use ;;; TYPES-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 @@ -1221,7 +1447,7 @@ ;;; appropriate numeric type before maximizing. This avoids possible ;;; confusion due to mixed-type comparisons (but I think the result is ;;; the same). -(!define-type-method (number :simple-intersection) (type1 type2) +(!define-type-method (number :simple-intersection2) (type1 type2) (declare (type numeric-type type1 type2)) (if (numeric-types-intersect type1 type2) (let* ((class1 (numeric-type-class type1)) @@ -1234,26 +1460,24 @@ 'rational)))) (format (or (numeric-type-format type1) (numeric-type-format type2)))) - (values - (make-numeric-type - :class class - :format format - :complexp (or (numeric-type-complexp type1) - (numeric-type-complexp type2)) - :low (numeric-bound-max - (round-numeric-bound (numeric-type-low type1) - class format t) - (round-numeric-bound (numeric-type-low type2) - class format t) - > >= nil) - :high (numeric-bound-max - (round-numeric-bound (numeric-type-high type1) - class format nil) - (round-numeric-bound (numeric-type-high type2) - class format nil) - < <= nil)) - t)) - (values *empty-type* t))) + (make-numeric-type + :class class + :format format + :complexp (or (numeric-type-complexp type1) + (numeric-type-complexp type2)) + :low (numeric-bound-max + (round-numeric-bound (numeric-type-low type1) + class format t) + (round-numeric-bound (numeric-type-low type2) + class format t) + > >= nil) + :high (numeric-bound-max + (round-numeric-bound (numeric-type-high type1) + class format nil) + (round-numeric-bound (numeric-type-high type2) + class format nil) + < <= nil))) + *empty-type*)) ;;; Given two float formats, return the one with more precision. If ;;; either one is null, return NIL. @@ -1452,7 +1676,7 @@ (t (values nil t))))) -(!define-type-method (array :simple-intersection) (type1 type2) +(!define-type-method (array :simple-intersection2) (type1 type2) (declare (type array-type type1 type2)) (if (array-types-intersect type1 type2) (let ((dims1 (array-type-dimensions type1)) @@ -1461,18 +1685,16 @@ (complexp2 (array-type-complexp type2)) (eltype1 (array-type-element-type type1)) (eltype2 (array-type-element-type type2))) - (values - (specialize-array-type - (make-array-type - :dimensions (cond ((eq dims1 '*) dims2) - ((eq dims2 '*) dims1) - (t - (mapcar (lambda (x y) (if (eq x '*) y x)) - dims1 dims2))) - :complexp (if (eq complexp1 :maybe) complexp2 complexp1) - :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))) - t)) - (values *empty-type* t))) + (specialize-array-type + (make-array-type + :dimensions (cond ((eq dims1 '*) dims2) + ((eq dims2 '*) dims1) + (t + (mapcar (lambda (x y) (if (eq x '*) y x)) + dims1 dims2))) + :complexp (if (eq complexp1 :maybe) complexp2 complexp1) + :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))) + *empty-type*)) ;;; Check a supplied dimension list to determine whether it is legal, ;;; and return it in canonical form (as either '* or a list). @@ -1513,10 +1735,9 @@ t)) (!define-type-method (member :complex-subtypep-arg1) (type1 type2) - (every/type #'ctypep + (every/type (swapped-args-fun #'ctypep) type2 - (member-type-members type1) - :list-first t)) + (member-type-members type1))) ;;; We punt if the odd type is enumerable and intersects with the ;;; MEMBER type. If not enumerable, then it is definitely not a @@ -1524,41 +1745,37 @@ (!define-type-method (member :complex-subtypep-arg2) (type1 type2) (cond ((not (type-enumerable type1)) (values nil t)) ((types-intersect type1 type2) (values nil nil)) - (t - (values nil t)))) + (t (values nil t)))) -(!define-type-method (member :simple-intersection) (type1 type2) +(!define-type-method (member :simple-intersection2) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) - (values (cond ((subsetp mem1 mem2) type1) - ((subsetp mem2 mem1) type2) - (t - (let ((res (intersection mem1 mem2))) - (if res - (make-member-type :members res) - *empty-type*)))) - t))) + (cond ((subsetp mem1 mem2) type1) + ((subsetp mem2 mem1) type2) + (t + (let ((res (intersection mem1 mem2))) + (if res + (make-member-type :members res) + *empty-type*)))))) -(!define-type-method (member :complex-intersection) (type1 type2) +(!define-type-method (member :complex-intersection2) (type1 type2) (block punt (collect ((members)) (let ((mem2 (member-type-members type2))) (dolist (member mem2) (multiple-value-bind (val win) (ctypep member type1) (unless win - (return-from punt (values type2 nil))) + (return-from punt nil)) (when val (members member)))) + (cond ((subsetp mem2 (members)) type2) + ((null (members)) *empty-type*) + (t + (make-member-type :members (members)))))))) - (values (cond ((subsetp mem2 (members)) type2) - ((null (members)) *empty-type*) - (t - (make-member-type :members (members)))) - t))))) - -;;; We don't need a :COMPLEX-UNION, since the only interesting case is +;;; We don't need a :COMPLEX-UNION2, since the only interesting case is ;;; a union type, and the member/union interaction is handled by the ;;; union type method. -(!define-type-method (member :simple-union) (type1 type2) +(!define-type-method (member :simple-union2) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) (cond ((subsetp mem1 mem2) type2) @@ -1605,45 +1822,18 @@ ;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types ;;;; involving AND. -;;; In general, make an INTERSECTION-TYPE object from the specifier -;;; types. But in various special cases, dodge instead, representing -;;; the intersection type in some other way. -(defun make-intersection-type-or-something (types) - (declare (list types)) - (/show0 "entering MAKE-INTERSECTION-TYPE-OR-SOMETHING") - (cond ((null types) - *universal-type*) - ((null (cdr types)) - (first types)) - (;; if potentially too hairy - (some (lambda (type) - (or (union-type-p type) - (hairy-type-p type))) - types) - ;; (CMU CL punted to HAIRY-TYPE like this for all AND-based - ;; types. We don't want to do that for simple intersection - ;; types like the definition of KEYWORD, hence the guard - ;; clause above. But we do want to punt for any really - ;; unreasonable cases which might have motivated them to punt - ;; in all cases, hence the punt-to-HAIRY-TYPE code below.) - (make-hairy-type :specifier `(and ,@(mapcar #'type-specifier types)))) - (t - (%make-intersection-type (some #'type-enumerable types) types)))) - (!define-type-class intersection) ;;; A few intersection types have special names. The others just get ;;; mechanically unparsed. (!define-type-method (intersection :unparse) (type) (declare (type ctype type)) - (/show0 "entering INTERSECTION :UNPARSE") (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=) `(and ,@(mapcar #'type-specifier (intersection-type-types type))))) ;;; shared machinery for type equality: true if every type in the set ;;; TYPES1 matches a type in the set TYPES2 and vice versa (defun type=-set (types1 types2) - (/show0 "entering TYPE=-SET") (flet (;; true if every type in the set X matches a type in the set Y (type<=-set (x y) (declare (type list x y)) @@ -1662,103 +1852,34 @@ ;;; most about, so it would be good to leverage any ingenuity there ;;; in this more obscure method? (!define-type-method (intersection :simple-=) (type1 type2) - (/show0 "entering INTERSECTION :SIMPLE-=") (type=-set (intersection-type-types type1) (intersection-type-types type2))) -(!define-type-method (intersection :simple-subtypep) (type1 type2) - (declare (type list type1 type2)) - (/show0 "entering INTERSECTION :SIMPLE-SUBTYPEP") - (let ((certain? t)) - (dolist (t1 (intersection-type-types type1) (values nil certain?)) - (multiple-value-bind (subtypep validp) - (intersection-complex-subtypep-arg2 t1 type2) - (cond ((not validp) - (setf certain? nil)) - (subtypep - (return (values t t)))))))) - -(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) - (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1") - (any/type #'csubtypep - type2 - (intersection-type-types type1) - :list-first t)) - -(defun intersection-complex-subtypep-arg2 (type1 type2) - (every/type #'csubtypep 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))) + (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) - (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2") - (intersection-complex-subtypep-arg2 type1 type2)) - -;;; Return a new type list where pairs of types whose intersections -;;; can be represented simply have been replaced by their simple -;;; representations. -(defun simplify-intersection-type-types (%types) - (/show0 "entering SIMPLE-INTERSECTION-TYPE-TYPES") - (do* ((types (copy-list %types)) ; (to undestructivize the algorithm below) - (i-types types (cdr i-types)) - (i-type (car i-types) (car i-types))) - ((null i-types)) - (do* ((pre-j-types i-types (cdr pre-j-types)) - (j-types (cdr pre-j-types) (cdr pre-j-types)) - (j-type (car j-types) (car j-types))) - ((null j-types)) - (multiple-value-bind (isect win) (type-intersection i-type j-type) - (when win - ;; Overwrite I-TYPES with the intersection, and delete - ;; J-TYPES from the list. - (setf (car i-types) isect - (cdr pre-j-types) (cdr j-types))))) - (/show0 "leaving SIMPLE-INTERSECTION-TYPE-TYPES") - types)) - -(!define-type-method (intersection :simple-intersection :complex-intersection) - (type1 type2) - (/show0 "entering INTERSECTION :SIMPLE-INTERSECTION :COMPLEX-INTERSECTION") - (let ((type1types (intersection-type-types type1)) - (type2types (if (intersection-type-p type2) - (intersection-type-types type2) - (list type2)))) - (make-intersection-type-or-something - (simplify-intersection-type-types - (append type1types type2types))))) - -#| -(!def-type-translator and (&rest type-specifiers) - ;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which - ;; will reduce to a 1-element list any list of types which CMU CL - ;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING - ;; (which knows to treat a 1-element intersection as the element - ;; itself) we should recover CMU CL's behavior for anything which it - ;; could handle usefully (i.e. could without punting to HAIRY-TYPE). - (/show0 "entering type translator for AND") - (make-intersection-type-or-something - (simplify-intersection-type-types - (mapcar #'specifier-type type-specifiers)))) -|# -;;; (REMOVEME once INTERSECTION-TYPE works.) -(!def-type-translator and (&whole spec &rest types) - (let ((res *wild-type*)) - (dolist (type types res) - (let ((ctype (specifier-type type))) - (multiple-value-bind (int win) (type-intersection res ctype) - (unless win - (return (make-hairy-type :specifier spec))) - (setq res int)))))) + (every/type #'csubtypep type1 (intersection-type-types type2))) + +(!def-type-translator and (&whole whole &rest type-specifiers) + (apply #'type-intersection + (mapcar #'specifier-type + type-specifiers))) ;;;; union types -;;; Make a union type from the specifier types, setting ENUMERABLE in -;;; the result if all are enumerable. -(defun make-union-type (types) - (declare (list types)) - (%make-union-type (every #'type-enumerable types) types)) - (!define-type-class union) -;;; The LIST type has a special name. Other union types -;;; just get mechanically unparsed. +;;; The LIST type has a special name. Other union types just get +;;; mechanically unparsed. (!define-type-method (union :unparse) (type) (declare (type ctype type)) (if (type= type (specifier-type 'list)) @@ -1790,56 +1911,70 @@ ((not subtypep) (return (values nil t))))))) -(!define-type-method (union :complex-subtypep-arg1) (type1 type2) - (every/type #'csubtypep +(defun union-complex-subtypep-arg1 (type1 type2) + (every/type (swapped-args-fun #'csubtypep) type2 - (union-type-types type1) - :list-first t)) + (union-type-types type1))) +(!define-type-method (union :complex-subtypep-arg1) (type1 type2) + (union-complex-subtypep-arg1 type1 type2)) (defun union-complex-subtypep-arg2 (type1 type2) (any/type #'csubtypep type1 (union-type-types type2))) (!define-type-method (union :complex-subtypep-arg2) (type1 type2) (union-complex-subtypep-arg2 type1 type2)) -(!define-type-method (union :complex-union) (type1 type2) - (let ((class1 (type-class-info type1))) - (collect ((res)) - (let ((this-type type1)) - (dolist (type (union-type-types type2) - (if (res) - (make-union-type (cons this-type (res))) - this-type)) - (cond ((eq (type-class-info type) class1) - (let ((union (funcall (type-class-simple-union class1) - this-type type))) - (if union - (setq this-type union) - (res type)))) - ((csubtypep type this-type)) - ((csubtypep type1 type) (return type2)) - (t - (res type)))))))) - -;;; For the union of union types, we let the :COMPLEX-UNION method do -;;; the work. -(!define-type-method (union :simple-union) (type1 type2) - (let ((res type1)) - (dolist (t2 (union-type-types type2) res) - (setq res (type-union res t2))))) - -(!define-type-method (union :simple-intersection :complex-intersection) - (type1 type2) - (let ((res *empty-type*) - (win t)) - (dolist (type (union-type-types type2) (values res win)) - (multiple-value-bind (int w) (type-intersection type1 type) - (setq res (type-union res int)) - (unless w (setq win nil)))))) +(!define-type-method (union :simple-intersection2 :complex-intersection2) + (type1 type2) + ;; The CSUBTYPEP clauses here let us simplify e.g. + ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST) + ;; (SPECIFIER-TYPE '(OR LIST VECTOR))) + ;; (where LIST is (OR CONS NULL)). + ;; + ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice + ;; versa, but it's important that we pre-expand them into + ;; specialized operations on individual elements of + ;; UNION-TYPE-TYPES, instead of using the ordinary call to + ;; CSUBTYPEP, in order to avoid possibly invoking any methods which + ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus + ;; cause infinite recursion. + (cond ((union-complex-subtypep-arg2 type1 type2) + type1) + ((union-complex-subtypep-arg1 type2 type1) + type2) + (t + (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)) + (return nil))))))) (!def-type-translator or (&rest type-specifiers) - (reduce #'type-union - (mapcar #'specifier-type type-specifiers) - :initial-value *empty-type*)) + (apply #'type-union + (mapcar #'specifier-type + type-specifiers))) ;;;; CONS types @@ -1874,7 +2009,7 @@ ;;; Give up if a precise type is not possible, to avoid returning ;;; overly general types. -(!define-type-method (cons :simple-union) (type1 type2) +(!define-type-method (cons :simple-union2) (type1 type2) (declare (type cons-type type1 type2)) (let ((car-type1 (cons-type-car-type type1)) (car-type2 (cons-type-car-type type2)) @@ -1887,16 +2022,15 @@ (make-cons-type (type-union cdr-type1 cdr-type2) cdr-type1))))) -(!define-type-method (cons :simple-intersection) (type1 type2) +(!define-type-method (cons :simple-intersection2) (type1 type2) (declare (type cons-type type1 type2)) - (multiple-value-bind (int-car win-car) - (type-intersection (cons-type-car-type type1) - (cons-type-car-type type2)) - (multiple-value-bind (int-cdr win-cdr) - (type-intersection (cons-type-cdr-type type1) - (cons-type-cdr-type type2)) - (values (make-cons-type int-car int-cdr) - (and win-car win-cdr))))) + (let (car-int2 + cdr-int2) + (and (setf car-int2 (type-intersection2 (cons-type-car-type type1) + (cons-type-car-type type2))) + (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1) + (cons-type-cdr-type type2))) + (make-cons-type car-int2 cdr-int2)))) ;;; Return the type that describes all objects that are in X but not ;;; in Y. If we can't determine this type, then return NIL. @@ -1935,7 +2069,6 @@ (when val (return)) (when (types-intersect x-type y-type) (return-from type-difference nil)))))) - (let ((y-mem (find-if #'member-type-p y-types))) (when y-mem (let ((members (member-type-members y-mem))) @@ -1945,23 +2078,21 @@ (multiple-value-bind (val win) (ctypep member x-type) (when (or (not win) val) (return-from type-difference nil))))))))) - - (cond ((null (res)) *empty-type*) - ((null (rest (res))) (first (res))) - (t - (make-union-type (res))))))) + (apply #'type-union (res))))) (!def-type-translator array (&optional (element-type '*) - (dimensions '*)) + (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :element-type (specifier-type element-type)))) (!def-type-translator simple-array (&optional (element-type '*) - (dimensions '*)) + (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :element-type (specifier-type element-type) :complexp nil))) (!defun-from-collected-cold-init-forms !late-type-cold-init) + +(/show0 "late-type.lisp end of file")