(in-package "SB!KERNEL")
-(file-comment
- "$Header$")
-
(!begin-collecting-cold-init-forms)
;;; ### Remaining incorrectnesses:
(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)
;;; 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
',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)
;; 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
(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)
(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
(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
;;; 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
(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 '*)
(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))
;;;; 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
(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*)
;;; 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
;;; 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)
: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)))
((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
(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
(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)
(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
(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))))
(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
;;; (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)
\f
;;;; built-in types
-(define-type-class named)
+(!define-type-class named)
(defvar *wild-type*)
(defvar *empty-type*)
(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))
\f
;;;; 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)
(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)
(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)
+(!define-type-method (hairy :complex-union) (type1 type2)
(make-union-type (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))
(make-hairy-type :specifier whole))
-(def-type-translator satisfies (&whole whole fun)
+(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
(make-hairy-type :specifier whole))
\f
;;; 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
: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))
(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))
(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))
(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.
;;; 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)
(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)))
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))
: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 <= <)
;;; 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))
;;; 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))
\f
;;;; 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
(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)
(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)))
`(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)))
(t
(values nil t)))))
-(define-superclasses array
+(!define-superclasses array
((string string)
(vector vector)
(array))
(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))
\f
;;;; 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
+(!define-type-method (member :complex-subtypep-arg1) (type1 type2)
+ (block punt-type-method
(values (every-type-op ctypep type2 (member-type-members type1)
:list-first t)
t)))
;;; 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)
*empty-type*))))
t)))
-(define-type-method (member :complex-intersection) (type1 type2)
- (block PUNT
+(!define-type-method (member :complex-intersection) (type1 type2)
+ (block punt-type-method
(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-type-method (values type2 nil)))
(when val (members member))))
(values (cond ((subsetp mem2 (members)) 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)
+(!define-type-method (member :simple-union) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
(cond ((subsetp mem1 mem2) type2)
(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))
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))
(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*))
\f
+;;;; 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, which is unreasonable.)
+;;;;
+;;;; We still follow the example of CMU CL to some extent, by punting
+;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
+;;;; involving AND.
+
+;;; Make a union type from the specifier types; or punt (to opaque
+;;; HAIRY-TYPE) if the class looks as though it might get too hairy.
+(defun make-intersection-type (types)
+ (declare (list types))
+ ;; "If potentially too hairy.."
+ ;;
+ ;; (CMU CL punted for all AND-based types, and we'd like to avoid
+ ;; any really unreasonable cases which might have motivated them to
+ ;; do this, while still being reasonably effective on simple
+ ;; intersection types like KEYWORD.)
+ (if (any (lambda (type)
+ (or (union-type-p type)
+ (hairy-type-p type)))
+ types)
+ (make-hairy-type :specifier (mapcar #'type-specifier types))
+ (%make-intersection-type (some #'type-enumerable types) types)))
+
+(!define-type-class intersection)
+\f
;;;; union types
;;; Make a union type from the specifier types, setting ENUMERABLE in
(declare (list types))
(%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)
+(!define-type-method (union :unparse) (type)
(declare (type ctype type))
(if (type= type (specifier-type 'list))
'list
;;; 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
+(!define-type-method (union :simple-=) (type1 type2)
+ (block punt-type-method
(let ((types1 (union-type-types type1))
(types2 (union-type-types type2)))
(values (and (dolist (type1 types1 t)
;;; 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
+(!define-type-method (union :simple-subtypep) (type1 type2)
+ (block punt-type-method
(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
+(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
+ (block punt-type-method
(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
+(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
+ (block punt-type-method
(values (any-type-op csubtypep type1 (union-type-types type2)) t)))
-(define-type-method (union :complex-union) (type1 type2)
+(!define-type-method (union :complex-union) (type1 type2)
(let* ((class1 (type-class-info type1)))
(collect ((res))
(let ((this-type type1))
;;; 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)
+(!define-type-method (union :simple-intersection :complex-intersection)
(type1 type2)
(let ((res *empty-type*)
(win t))
(setq res (type-union res int))
(unless w (setq win nil))))))
-(def-type-translator or (&rest types)
+(!def-type-translator or (&rest types)
(reduce #'type-union
(mapcar #'specifier-type types)
:initial-value *empty-type*))
;;; 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)
+(!def-type-translator and (&whole spec &rest types)
(let ((res *wild-type*))
(dolist (type types res)
(let ((ctype (specifier-type type)))
(return (make-hairy-type :specifier spec)))
(setq res int))))))
\f
+;;;; 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)))))
+\f
;;; 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.
;;;
(t
(make-union-type (res)))))))
\f
-(def-type-translator array (&optional (element-type '*)
+(!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 '*)
+(!def-type-translator simple-array (&optional (element-type '*)
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
projects / sbcl.git / blobdiff