X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=edd81f76be856acdc78d881b8593a962ed5fef12;hb=467a8e5dba8bfa2598ca8e22c1204dc173ce556f;hp=656bb635b5cb36831ba73327a69a17a71f9e97b8;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 656bb63..edd81f7 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -61,14 +61,12 @@ (funcall method type2 type1) (vanilla-intersection type1 type2)))) -;;; This is used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 -;;; method. INFO is a list of conses (SUPERCLASS-CLASS . -;;; {GUARD-TYPE-SPECIFIER | NIL}). This will never be called with a -;;; hairy type as TYPE2, since the hairy type TYPE2 method gets first -;;; crack. -;;; -;;; FIXME: Declare this as INLINE, since it's only used in one place. -(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) +;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 +;;; method. INFO is a list of conses +;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). +;;; This will never be called with a hairy type as TYPE2, since the +;;; hairy type TYPE2 method gets first crack. +(defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info) (values (and (sb!xc:typep type2 'sb!xc:class) (dolist (x info nil) @@ -94,7 +92,7 @@ ;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))). ;;; ;;; WHEN controls when the forms are executed. -(defmacro define-superclasses (type-class-name specs when) +(defmacro !define-superclasses (type-class-name specs when) (let ((type-class (gensym "TYPE-CLASS-")) (info (gensym "INFO"))) `(,when @@ -107,7 +105,7 @@ ',specs))) (setf (type-class-complex-subtypep-arg1 ,type-class) (lambda (type1 type2) - (has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) + (!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) @@ -130,23 +128,24 @@ ;;;; also be annotated with function or values types. ;;; the description of a keyword argument -(defstruct (key-info #-sb-xc-host (:pure t)) +(defstruct (key-info #-sb-xc-host (:pure t) + (:copier nil)) ;; the keyword (name (required-argument) :type keyword) ;; the type of the argument value (type (required-argument) :type ctype)) -(define-type-method (values :simple-subtypep :complex-subtypep-arg1) +(!define-type-method (values :simple-subtypep :complex-subtypep-arg1) (type1 type2) (declare (ignore type2)) (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1))) -(define-type-method (values :complex-subtypep-arg2) +(!define-type-method (values :complex-subtypep-arg2) (type1 type2) (declare (ignore type1)) (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) -(define-type-method (values :unparse) (type) +(!define-type-method (values :unparse) (type) (cons 'values (unparse-args-types type))) ;;; Return true if LIST1 and LIST2 have the same elements in the same @@ -167,7 +166,7 @@ (unless val (return (values nil t)))))) -(define-type-method (values :simple-=) (type1 type2) +(!define-type-method (values :simple-=) (type1 type2) (let ((rest1 (args-type-rest type1)) (rest2 (args-type-rest type2))) (cond ((or (args-type-keyp type1) (args-type-keyp type2) @@ -186,7 +185,7 @@ (values-type-optional type2)) (values (and req-val opt-val) (and req-win opt-win)))))))) -(define-type-class function) +(!define-type-class function) ;;; 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 @@ -194,7 +193,7 @@ (defvar *unparse-function-type-simplify*) (!cold-init-forms (setq *unparse-function-type-simplify* nil)) -(define-type-method (function :unparse) (type) +(!define-type-method (function :unparse) (type) (if *unparse-function-type-simplify* 'function (list 'function @@ -206,34 +205,34 @@ ;;; Since all function types are equivalent to FUNCTION, they are all ;;; subtypes of each other. -(define-type-method (function :simple-subtypep) (type1 type2) +(!define-type-method (function :simple-subtypep) (type1 type2) (declare (ignore type1 type2)) (values t t)) -(define-superclasses function ((function)) !cold-init-forms) +(!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-union) (type1 type2) (declare (ignore type1 type2)) (specifier-type 'function)) -(define-type-method (function :simple-intersection) (type1 type2) +(!define-type-method (function :simple-intersection) (type1 type2) (declare (ignore type1 type2)) (values (specifier-type 'function) t)) ;;; ### Not very real, but good enough for redefining transforms ;;; according to type: -(define-type-method (function :simple-=) (type1 type2) +(!define-type-method (function :simple-=) (type1 type2) (values (equalp type1 type2) t)) -(define-type-class constant :inherits values) +(!define-type-class constant :inherits values) -(define-type-method (constant :unparse) (type) +(!define-type-method (constant :unparse) (type) `(constant-argument ,(type-specifier (constant-type-type type)))) -(define-type-method (constant :simple-=) (type1 type2) +(!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-argument (type) (make-constant-type :type (specifier-type type))) ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE @@ -244,7 +243,7 @@ (multiple-value-bind (required optional restp rest keyp keys allowp aux) (parse-lambda-list lambda-list) (when aux - (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list)) + (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) (setf (args-type-required result) (mapcar #'specifier-type required)) (setf (args-type-optional result) (mapcar #'specifier-type optional)) (setf (args-type-rest result) (if restp (specifier-type rest) nil)) @@ -255,7 +254,8 @@ (error "Keyword type description is not a two-list: ~S." key)) (let ((kwd (first key))) (when (find kwd (key-info) :key #'key-info-name) - (error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list)) + (error "~@" + kwd lambda-list)) (key-info (make-key-info :name kwd :type (specifier-type (second key)))))) (setf (args-type-keywords result) (key-info))) @@ -291,7 +291,7 @@ (result))) -(def-type-translator function (&optional (args '*) (result '*)) +(!def-type-translator function (&optional (args '*) (result '*)) (let ((res (make-function-type :returns (values-specifier-type result)))) (if (eq args '*) @@ -299,7 +299,7 @@ (parse-args-types args res)) res)) -(def-type-translator values (&rest values) +(!def-type-translator values (&rest values) (let ((res (make-values-type))) (parse-args-types values res) res)) @@ -309,16 +309,19 @@ ;;;; We provide a few special operations that can be meaningfully used ;;;; on VALUES types (as well as on any other type). -;;; Return the type of the first value indicated by Type. This is used -;;; by people who don't want to have to deal with values types. -#!-sb-fluid (declaim (freeze-type values-type) (inline single-value-type)) +;;; Return the type of the first value indicated by TYPE. This is used +;;; by people who don't want to have to deal with VALUES types. +#!-sb-fluid (declaim (freeze-type values-type)) +; (inline single-value-type)) (defun single-value-type (type) (declare (type ctype type)) (cond ((values-type-p type) (or (car (args-type-required type)) - (car (args-type-optional type)) + (if (args-type-optional type) + (type-union (car (args-type-optional type)) + (specifier-type 'null))) (args-type-rest type) - *universal-type*)) + (specifier-type 'null))) ((eq type *wild-type*) *universal-type*) (t @@ -338,10 +341,10 @@ (values fixed (+ fixed (length (args-type-optional type)))))) (values nil nil))) -;;; Determine if Type corresponds to a definite number of values. The -;;; first value is a list of the types for each value, and the second -;;; value is the number of values. If the number of values is not -;;; fixed, then return NIL and :Unknown. +;;; Determine whether TYPE corresponds to a definite number of values. +;;; The first value is a list of the types for each value, and the +;;; second value is the number of values. If the number of values is +;;; not fixed, then return NIL and :UNKNOWN. (defun values-types (type) (declare (type ctype type)) (cond ((eq type *wild-type*) @@ -360,15 +363,15 @@ ;;; Return two values: ;;; 1. A list of all the positional (fixed and optional) types. ;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*. -;;; If no keywords or rest, *EMPTY-TYPE*. -(defun values-type-types (type) +;;; If no keywords or &REST, then the DEFAULT-TYPE. +(defun values-type-types (type &optional (default-type *empty-type*)) (declare (type values-type type)) (values (append (args-type-required type) (args-type-optional type)) (cond ((args-type-keyp type) *universal-type*) ((args-type-rest type)) (t - *empty-type*)))) + default-type)))) ;;; Return a list of OPERATION applied to the types in TYPES1 and ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter @@ -420,13 +423,16 @@ ;;; OPERATION returned true as its second value each time we called ;;; it. Since we approximate the intersection of VALUES types, the ;;; second value being true doesn't mean the result is exact. -(defun args-type-op (type1 type2 operation nreq) - (declare (type ctype type1 type2) (type function operation nreq)) +(defun args-type-op (type1 type2 operation nreq default-type) + (declare (type ctype type1 type2 default-type) + (type function operation nreq)) (if (or (values-type-p type1) (values-type-p type2)) (let ((type1 (coerce-to-values type1)) (type2 (coerce-to-values type2))) - (multiple-value-bind (types1 rest1) (values-type-types type1) - (multiple-value-bind (types2 rest2) (values-type-types type2) + (multiple-value-bind (types1 rest1) + (values-type-types type1 default-type) + (multiple-value-bind (types2 rest2) + (values-type-types type2 default-type) (multiple-value-bind (rest rest-exact) (funcall operation rest1 rest2) (multiple-value-bind (res res-exact) @@ -447,7 +453,7 @@ :optional (if opt-last (subseq opt 0 (1+ opt-last)) ()) - :rest (if (eq rest *empty-type*) nil rest)) + :rest (if (eq rest default-type) nil rest)) (and rest-exact res-exact))))))))) (funcall operation type1 type2))) @@ -468,7 +474,7 @@ ((eq type1 *empty-type*) type2) ((eq type2 *empty-type*) type1) (t - (values (args-type-op type1 type2 #'type-union #'min))))) + (values (args-type-op type1 type2 #'type-union #'min *empty-type*))))) (defun-cached (values-type-intersection :hash-function type-cache-hash :hash-bits 8 :values 2 @@ -479,7 +485,10 @@ (cond ((eq type1 *wild-type*) (values type2 t)) ((eq type2 *wild-type*) (values type1 t)) (t - (args-type-op type1 type2 #'type-intersection #'max)))) + (args-type-op type1 type2 + #'type-intersection + #'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 @@ -557,9 +566,9 @@ (eq type2 *empty-type*)) (values nil t)) (t - (invoke-type-method :simple-subtypep :complex-subtypep-arg2 - type1 type2 - :complex-arg1 :complex-subtypep-arg1)))) + (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1)))) ;;; Just parse the type specifiers and call CSUBTYPE. (defun sb!xc:subtypep (type1 type2) @@ -582,7 +591,7 @@ (declare (type ctype type1 type2)) (if (eq type1 type2) (values t t) - (invoke-type-method :simple-= :complex-= type1 type2))) + (!invoke-type-method :simple-= :complex-= type1 type2))) ;;; Not exactly the negation of TYPE=, since when the relationship is ;;; uncertain, we still return NIL, NIL. This is useful in cases where @@ -606,18 +615,18 @@ (declare (type ctype type1 type2)) (if (eq type1 type2) type1 - (let ((res (invoke-type-method :simple-union :complex-union - type1 type2 - :default :vanilla))) + (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)))) + (make-union-type-or-something (list type1 type2)))) (res) (t - (make-union-type (list type1 type2))))))) + (make-union-type-or-something (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 +;;; 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). @@ -630,9 +639,9 @@ (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)))) + (!invoke-type-method :simple-intersection :complex-intersection + type1 type2 + :default (values *empty-type* t)))) ;;; The first value is true unless the types don't intersect. The ;;; second value is true if the first value is definitely correct. NIL @@ -661,8 +670,8 @@ ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to ;;; early-type.lisp by WHN ca. 19990201.) -;;; Take a list of type specifiers, compute the translation and define -;;; it as a builtin type. +;;; Take a list of type specifiers, computing the translation of each +;;; specifier and defining it as a builtin type. (declaim (ftype (function (list) (values)) precompute-types)) (defun precompute-types (specs) (dolist (spec specs) @@ -674,7 +683,7 @@ ;;;; built-in types -(define-type-class named) +(!define-type-class named) (defvar *wild-type*) (defvar *empty-type*) @@ -696,32 +705,32 @@ (frob nil *empty-type*) (frob t *universal-type*))) -(define-type-method (named :simple-=) (type1 type2) +(!define-type-method (named :simple-=) (type1 type2) (values (eq type1 type2) t)) -(define-type-method (named :simple-subtypep) (type1 type2) +(!define-type-method (named :simple-subtypep) (type1 type2) (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) -(define-type-method (named :complex-subtypep-arg1) (type1 type2) +(!define-type-method (named :complex-subtypep-arg1) (type1 type2) (assert (not (hairy-type-p type2))) (values (eq type1 *empty-type*) t)) -(define-type-method (named :complex-subtypep-arg2) (type1 type2) +(!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) +(!define-type-method (named :complex-intersection) (type1 type2) (vanilla-intersection type1 type2)) -(define-type-method (named :unparse) (x) +(!define-type-method (named :unparse) (x) (named-type-name x)) ;;;; hairy and unknown types -(define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) +(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) -(define-type-method (hairy :simple-subtypep) (type1 type2) +(!define-type-method (hairy :simple-subtypep) (type1 type2) (let ((hairy-spec1 (hairy-type-specifier type1)) (hairy-spec2 (hairy-type-specifier type2))) (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not) @@ -733,7 +742,7 @@ (t (values nil nil))))) -(define-type-method (hairy :complex-subtypep-arg2) (type1 type2) +(!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) @@ -744,41 +753,55 @@ (t (values nil nil))))) -(define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2) +(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) -(define-type-method (hairy :simple-intersection :complex-intersection) +(!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 :complex-union) (type1 type2) + (make-union-type-or-something (list type1 type2))) -(define-type-method (hairy :simple-=) (type1 type2) +(!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) (hairy-type-specifier type2)) (values t t) (values nil nil))) -(def-type-translator not (&whole whole type) +(!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) +(!def-type-translator satisfies (&whole whole fun) (declare (ignore fun)) + ;; Check legality of arguments 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)))) (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) - (defconstant float-formats + (defparameter *float-formats* '(long-float double-float single-float short-float))) ;;; The type of a float format. -(deftype float-format () `(member ,@float-formats)) +(deftype float-format () `(member ,@*float-formats*)) #!+negative-zero-is-not-zero (defun make-numeric-type (&key class format (complexp :real) low high @@ -802,9 +825,9 @@ :high (canonicalise-high-bound high) :enumerable enumerable))) -(define-type-class number) +(!define-type-class number) -(define-type-method (number :simple-=) (type1 type2) +(!define-type-method (number :simple-=) (type1 type2) (values (and (eq (numeric-type-class type1) (numeric-type-class type2)) (eq (numeric-type-format type1) (numeric-type-format type2)) @@ -813,7 +836,7 @@ (equal (numeric-type-high type1) (numeric-type-high type2))) t)) -(define-type-method (number :unparse) (type) +(!define-type-method (number :unparse) (type) (let* ((complexp (numeric-type-complexp type)) (low (numeric-type-low type)) (high (numeric-type-high type)) @@ -953,7 +976,7 @@ (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) -(define-type-method (number :simple-subtypep) (type1 type2) +(!define-type-method (number :simple-subtypep) (type1 type2) (let ((class1 (numeric-type-class type1)) (class2 (numeric-type-class type2)) (complexp2 (numeric-type-complexp type2)) @@ -985,7 +1008,7 @@ (t (values nil t))))) -(define-superclasses number ((generic-number)) !cold-init-forms) +(!define-superclasses number ((generic-number)) !cold-init-forms) ;;; If the high bound of LOW is adjacent to the low bound of HIGH, ;;; then return true, otherwise NIL. @@ -1025,9 +1048,9 @@ ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. ;;; -;;; ### Note: we give up early, so keep from dropping lots of information on +;;; ### 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-union) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) @@ -1060,7 +1083,7 @@ (setf (info :type :builtin 'number) (make-numeric-type :complexp nil))) -(def-type-translator complex (&optional (spec '*)) +(!def-type-translator complex (&optional (spec '*)) (if (eq spec '*) (make-numeric-type :complexp :complex) (let ((type (specifier-type spec))) @@ -1089,7 +1112,7 @@ type bound)))) -(def-type-translator integer (&optional (low '*) (high '*)) +(!def-type-translator integer (&optional (low '*) (high '*)) (let* ((l (canonicalized-bound low 'integer)) (lb (if (consp l) (1+ (car l)) l)) (h (canonicalized-bound high 'integer)) @@ -1103,7 +1126,7 @@ :high hb))) (defmacro def-bounded-type (type class format) - `(def-type-translator ,type (&optional (low '*) (high '*)) + `(!def-type-translator ,type (&optional (low '*) (high '*)) (let ((lb (canonicalized-bound low ',type)) (hb (canonicalized-bound high ',type))) (unless (numeric-bound-test* lb hb <= <) @@ -1213,7 +1236,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-intersection) (type1 type2) (declare (type numeric-type type1 type2)) (if (numeric-types-intersect type1 type2) (let* ((class1 (numeric-type-class type1)) @@ -1251,19 +1274,19 @@ ;;; either one is null, return NIL. (defun float-format-max (f1 f2) (when (and f1 f2) - (dolist (f float-formats (error "Bad float format: ~S." f1)) + (dolist (f *float-formats* (error "bad float format: ~S" f1)) (when (or (eq f f1) (eq f f2)) (return f))))) -;;; Return the result of an operation on Type1 and Type2 according to +;;; Return the result of an operation on TYPE1 and TYPE2 according to ;;; the rules of numeric contagion. This is always NUMBER, some float ;;; format (possibly complex) or RATIONAL. Due to rational ;;; canonicalization, there isn't much we can do here with integers or ;;; rational complex numbers. ;;; -;;; If either argument is not a Numeric-Type, then return NUMBER. This +;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This ;;; is useful mainly for allowing types that are technically numbers, -;;; but not a Numeric-Type. +;;; but not a NUMERIC-TYPE. (defun numeric-contagion (type1 type2) (if (and (numeric-type-p type1) (numeric-type-p type2)) (let ((class1 (numeric-type-class type1)) @@ -1309,7 +1332,7 @@ ;;;; array types -(define-type-class array) +(!define-type-class array) ;;; What this does depends on the setting of the ;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized @@ -1320,7 +1343,7 @@ (array-type-specialized-element-type type) (array-type-element-type type))) -(define-type-method (array :simple-=) (type1 type2) +(!define-type-method (array :simple-=) (type1 type2) (values (and (equal (array-type-dimensions type1) (array-type-dimensions type2)) (eq (array-type-complexp type1) @@ -1329,7 +1352,7 @@ (specialized-element-type-maybe type2))) t)) -(define-type-method (array :unparse) (type) +(!define-type-method (array :unparse) (type) (let ((dims (array-type-dimensions type)) (eltype (type-specifier (array-type-element-type type))) (complexp (array-type-complexp type))) @@ -1369,12 +1392,12 @@ `(array ,eltype ,dims) `(simple-array ,eltype ,dims)))))) -(define-type-method (array :simple-subtypep) (type1 type2) +(!define-type-method (array :simple-subtypep) (type1 type2) (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 @@ -1387,20 +1410,29 @@ (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))))) - -(define-superclasses array + (;; 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) (vector vector) (array)) @@ -1435,7 +1467,7 @@ (t (values nil t))))) -(define-type-method (array :simple-intersection) (type1 type2) +(!define-type-method (array :simple-intersection) (type1 type2) (declare (type array-type type1 type2)) (if (array-types-intersect type1 type2) (let ((dims1 (array-type-dimensions type1)) @@ -1483,34 +1515,33 @@ ;;;; MEMBER types -(define-type-class member) +(!define-type-class member) -(define-type-method (member :unparse) (type) +(!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) (if (equal members '(nil)) 'null `(member ,@members)))) -(define-type-method (member :simple-subtypep) (type1 type2) +(!define-type-method (member :simple-subtypep) (type1 type2) (values (subsetp (member-type-members type1) (member-type-members type2)) t)) -(define-type-method (member :complex-subtypep-arg1) (type1 type2) - (block PUNT - (values (every-type-op ctypep type2 (member-type-members type1) - :list-first t) - t))) +(!define-type-method (member :complex-subtypep-arg1) (type1 type2) + (every/type (swapped-args-fun #'ctypep) + type2 + (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 ;;; subtype of the MEMBER type. -(define-type-method (member :complex-subtypep-arg2) (type1 type2) +(!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)))) -(define-type-method (member :simple-intersection) (type1 type2) +(!define-type-method (member :simple-intersection) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) (values (cond ((subsetp mem1 mem2) type1) @@ -1522,14 +1553,14 @@ *empty-type*)))) t))) -(define-type-method (member :complex-intersection) (type1 type2) - (block PUNT +(!define-type-method (member :complex-intersection) (type1 type2) + (block punt (collect ((members)) (let ((mem2 (member-type-members type2))) - (dolist (member mem2) + (dolist (member mem2) (multiple-value-bind (val win) (ctypep member type1) (unless win - (return-from PUNT (values type2 nil))) + (return-from punt (values type2 nil))) (when val (members member)))) (values (cond ((subsetp mem2 (members)) type2) @@ -1538,10 +1569,10 @@ (make-member-type :members (members)))) t))))) -;;; We don't need a :COMPLEX-UNION, 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) +;;; We don't need a :COMPLEX-UNION, 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) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) (cond ((subsetp mem1 mem2) type2) @@ -1549,13 +1580,14 @@ (t (make-member-type :members (union mem1 mem2)))))) -(define-type-method (member :simple-=) (type1 type2) +(!define-type-method (member :simple-=) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) - (values (and (subsetp mem1 mem2) (subsetp mem2 mem1)) + (values (and (subsetp mem1 mem2) + (subsetp mem2 mem1)) t))) -(define-type-method (member :complex-=) (type1 type2) +(!define-type-method (member :complex-=) (type1 type2) (if (type-enumerable type1) (multiple-value-bind (val win) (csubtypep type2 type1) (if (or val (not win)) @@ -1563,69 +1595,247 @@ (values nil t))) (values nil t))) -(def-type-translator member (&rest members) +(!def-type-translator member (&rest members) (if members (make-member-type :members (remove-duplicates members)) *empty-type*)) +;;;; intersection types +;;;; +;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach +;;;; of punting on all AND types, not just the unreasonably complicated +;;;; ones. The change was motivated by trying to get the KEYWORD type +;;;; to behave sensibly: +;;;; ;; reasonable definition +;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP))) +;;;; ;; reasonable behavior +;;;; (ASSERT (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 +;;;; not so good..) +;;;; +;;;; We still follow the example of CMU CL to some extent, by punting +;;;; (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) + ;; Allowing irreducible union types into intersection + ;; types leads to issues of canonicalization. Those might + ;; be soluble but it would be nicer just to avoid them + ;; entirely by punting to HAIRY-TYPE. -- WHN 2001-03-02 + (union-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)) + (every (lambda (xelement) + (position xelement y :test #'type=)) + x))) + (values (and (type<=-set types1 types2) + (type<=-set types2 types1)) + t))) + +;;; Two intersection types are equal if their subtypes are equal sets. +;;; +;;; FIXME: Might it be better to use +;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X)) +;;; instead, since SUBTYPEP is the usual relationship that we care +;;; 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) + (/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 (swapped-args-fun #'csubtypep) + type2 + (intersection-type-types type1))) + +(defun intersection-complex-subtypep-arg2 (type1 type2) + (every/type #'csubtypep type1 (intersection-type-types type2))) +(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) + (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2") + (intersection-complex-subtypep-arg2 type1 type2)) + +;;; shared logic for unions and intersections: Return a new type list +;;; where pairs of types which can be simplified by SIMPLIFY2-FUN have +;;; been replaced by their simplified forms. +(defun simplify-types (types simplify2-fun) + (declare (type function simplify2-fun)) + (let (;; our result, accumulated as a vector + (a (make-array (length types) :fill-pointer 0))) + (dolist (%type types (coerce a 'list)) + ;; Merge TYPE into RESULT. + (named-let again ((type %type)) + (dotimes (i (length a) (vector-push-extend type a)) + (let ((ai (aref a i))) + (multiple-value-bind (simplified win?) + (funcall simplify2-fun type ai) + (when win? + (setf (aref a i) (vector-pop a)) + ;; Give the new SIMPLIFIED its own chance to be + ;; pairwise simplified w.r.t. elements of A. + (return (again simplified)))))))))) + +;;; FIXME: See FIXME note for DEFUN SIMPLIFY2-UNION. +(defun simplify2-intersection (x y) + (let ((intersection (type-intersection x y))) + (if (and (or (intersection-type-p intersection) + (hairy-type-p intersection)) + (not (intersection-type-p x)) + (not (intersection-type-p y))) + (values nil nil) + (values intersection t)))) + +(!define-type-method (intersection :simple-intersection :complex-intersection) + (type1 type2) + (/show0 "entering INTERSECTION :SIMPLE-INTERSECTION :COMPLEX-INTERSECTION") + (flet ((type-components (type) + (typecase type + (intersection-type (intersection-type-types type)) + (t (list type))))) + (make-intersection-type-or-something + ;; FIXME: Here and in MAKE-UNION-TYPE and perhaps elsewhere we + ;; should be looking for simplifications and putting things into + ;; canonical form. + (append (type-components type1) + (type-components type2))))) + +(!def-type-translator and (&whole whole &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") + (if *xtype?* + (make-intersection-type-or-something + (mapcar #'specifier-type type-specifiers)) + (let ((res *wild-type*)) + (dolist (type-specifier type-specifiers res) + (let ((ctype (specifier-type type-specifier))) + (multiple-value-bind (int win) (type-intersection res ctype) + (unless win + (return (make-hairy-type :specifier whole))) + (setq res int))))))) + ;;;; union types ;;; Make a union type from the specifier types, setting ENUMERABLE in -;;; the result if all are enumerable. -(defun make-union-type (types) +;;; the result if all are enumerable; or take the easy way out if we +;;; recognize a special case which can be represented more simply. +(defun make-union-type-or-something (types) (declare (list types)) - (%make-union-type (every #'type-enumerable types) types)) + (/show0 "entering MAKE-UNION-TYPE-OR-SOMETHING") + (cond ((null types) + *empty-type*) + ((null (cdr types)) + (first types)) + (t + (%make-union-type (every #'type-enumerable types) types)))) -(define-type-class union) +(!define-type-class union) -;;; If LIST, then return that, otherwise the OR of the component types. -(define-type-method (union :unparse) (type) +;;; 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)) 'list `(or ,@(mapcar #'type-specifier (union-type-types type))))) -;;; Two union types are equal if every type in one is equal to some -;;; type in the other. -(define-type-method (union :simple-=) (type1 type2) - (block PUNT - (let ((types1 (union-type-types type1)) - (types2 (union-type-types type2))) - (values (and (dolist (type1 types1 t) - (unless (any-type-op type= type1 types2) - (return nil))) - (dolist (type2 types2 t) - (unless (any-type-op type= type2 types1) - (return nil)))) - t)))) +;;; Two union types are equal if their subtypes are equal sets. +(!define-type-method (union :simple-=) (type1 type2) + (type=-set (union-type-types type1) + (union-type-types type2))) ;;; Similarly, a union type is a subtype of another if every element ;;; of TYPE1 is a subtype of some element of TYPE2. -(define-type-method (union :simple-subtypep) (type1 type2) - (block PUNT - (let ((types2 (union-type-types type2))) - (values (dolist (type1 (union-type-types type1) t) - (unless (any-type-op csubtypep type1 types2) - (return nil))) - t)))) - -(define-type-method (union :complex-subtypep-arg1) (type1 type2) - (block PUNT - (values (every-type-op csubtypep type2 (union-type-types type1) - :list-first t) - t))) - -(define-type-method (union :complex-subtypep-arg2) (type1 type2) - (block PUNT - (values (any-type-op csubtypep type1 (union-type-types type2)) t))) - -(define-type-method (union :complex-union) (type1 type2) - (let* ((class1 (type-class-info type1))) +;;; +;;; 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))))))) + +(!define-type-method (union :complex-subtypep-arg1) (type1 type2) + (every/type (swapped-args-fun #'csubtypep) + type2 + (union-type-types type1))) + +(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))) + (make-union-type-or-something (cons this-type (res))) this-type)) (cond ((eq (type-class-info type) class1) (let ((union (funcall (type-class-simple-union class1) @@ -1640,13 +1850,13 @@ ;;; For the union of union types, we let the :COMPLEX-UNION method do ;;; the work. -(define-type-method (union :simple-union) (type1 type2) +(!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) +(!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)) @@ -1654,23 +1864,90 @@ (setq res (type-union res int)) (unless w (setq win nil)))))) -(def-type-translator or (&rest types) +;;; FIXME: Obviously, this could be implemented more efficiently if it +;;; were a primitive. (Making it construct the entire result before +;;; discarding it because it turns out to be insufficiently simple is +;;; less than optimum.) A little less obviously, if it were a +;;; primitive, we could use it a lot more -- basically everywhere we +;;; do MAKE-UNION-TYPE-OR-SOMETHING. So perhaps this should become +;;; a primitive; and SIMPLIFY2-INTERSECTION, too, for the same reason. +(defun simplify2-union (x y) + (let ((union (type-union x y))) + (if (and (or (union-type-p union) + (hairy-type-p union)) + (not (union-type-p x)) + (not (union-type-p y))) + (values nil nil) + (values union t)))) + +(!def-type-translator or (&rest type-specifiers) + ;; FIXME: new code -- doesn't work? + #| + (make-union-type-or-something + (simplify-types (mapcar #'specifier-type type-specifiers) + #'simplify2-union)) + |# + ;; old code (reduce #'type-union - (mapcar #'specifier-type types) + (mapcar #'specifier-type type-specifiers) :initial-value *empty-type*)) - -;;; We don't actually have intersection types, since the result of -;;; reasonable type intersections is always describable as a union of -;;; simple types. If something is too hairy to fit this mold, then we -;;; make a hairy type. -(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)))))) + +;;;; CONS types + +(!define-type-class cons) + +(!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) + (make-cons-type (specifier-type car-type-spec) + (specifier-type cdr-type-spec))) + +(!define-type-method (cons :unparse) (type) + (let ((car-eltype (type-specifier (cons-type-car-type type))) + (cdr-eltype (type-specifier (cons-type-cdr-type type)))) + (if (and (member car-eltype '(t *)) + (member cdr-eltype '(t *))) + 'cons + `(cons ,car-eltype ,cdr-eltype)))) + +(!define-type-method (cons :simple-=) (type1 type2) + (declare (type cons-type type1 type2)) + (and (type= (cons-type-car-type type1) (cons-type-car-type type2)) + (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)))) + +(!define-type-method (cons :simple-subtypep) (type1 type2) + (declare (type cons-type type1 type2)) + (multiple-value-bind (val-car win-car) + (csubtypep (cons-type-car-type type1) (cons-type-car-type type2)) + (multiple-value-bind (val-cdr win-cdr) + (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) + (if (and val-car val-cdr) + (values t (and win-car win-cdr)) + (values nil (or win-car win-cdr)))))) + +;;; Give up if a precise type is not possible, to avoid returning +;;; overly general types. +(!define-type-method (cons :simple-union) (type1 type2) + (declare (type cons-type type1 type2)) + (let ((car-type1 (cons-type-car-type type1)) + (car-type2 (cons-type-car-type type2)) + (cdr-type1 (cons-type-cdr-type type1)) + (cdr-type2 (cons-type-cdr-type type2))) + (cond ((type= car-type1 car-type2) + (make-cons-type car-type1 + (type-union cdr-type1 cdr-type2))) + ((type= cdr-type1 cdr-type2) + (make-cons-type (type-union cdr-type1 cdr-type2) + cdr-type1))))) + +(!define-type-method (cons :simple-intersection) (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))))) ;;; 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. @@ -1723,16 +2000,16 @@ (cond ((null (res)) *empty-type*) ((null (rest (res))) (first (res))) (t - (make-union-type (res))))))) + (make-union-type-or-something (res))))))) -(def-type-translator array (&optional (element-type '*) - (dimensions '*)) +(!def-type-translator array (&optional (element-type '*) + (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 '*)) +(!def-type-translator simple-array (&optional (element-type '*) + (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :element-type (specifier-type element-type)