;;; ### Remaining incorrectnesses:
;;;
-;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an
-;;; exhaustive partition or coalesce contiguous ranges of numeric
-;;; types.
-;;;
;;; There are all sorts of nasty problems with open bounds on FLOAT
;;; types (and probably FLOAT types in general.)
-;;;
-;;; RATIO and BIGNUM are not recognized as numeric types.
;;; FIXME: This really should go away. Alas, it doesn't seem to be so
;;; simple to make it go away.. (See bug 123 in BUGS file.)
;;; 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)
- (when (or (not (cdr x))
- (csubtypep type1 (specifier-type (cdr x))))
- (return
- (or (eq type2 (car x))
- (let ((inherits (layout-inherits (class-layout (car x)))))
- (dotimes (i (length inherits) nil)
- (when (eq type2 (layout-class (svref inherits i)))
- (return t)))))))))
- t))
+ ;; If TYPE2 might be concealing something related to our class
+ ;; hierarchy
+ (if (type-might-contain-other-types-p type2)
+ ;; too confusing, gotta punt
+ (values nil nil)
+ ;; ordinary case expected by old CMU CL code, where the taxonomy
+ ;; of TYPE2's representation accurately reflects the taxonomy of
+ ;; the underlying set
+ (values
+ ;; FIXME: This old CMU CL code probably deserves a comment
+ ;; explaining to us mere mortals how it works...
+ (and (sb!xc:typep type2 'classoid)
+ (dolist (x info nil)
+ (when (or (not (cdr x))
+ (csubtypep type1 (specifier-type (cdr x))))
+ (return
+ (or (eq type2 (car x))
+ (let ((inherits (layout-inherits
+ (classoid-layout (car x)))))
+ (dotimes (i (length inherits) nil)
+ (when (eq type2 (layout-classoid (svref inherits i)))
+ (return t)))))))))
+ t)))
;;; This function takes a list of specs, each of the form
;;; (SUPERCLASS-NAME &OPTIONAL GUARD).
;;;
;;; WHEN controls when the forms are executed.
(defmacro !define-superclasses (type-class-name specs when)
- (let ((type-class (gensym "TYPE-CLASS-"))
- (info (gensym "INFO")))
+ (with-unique-names (type-class info)
`(,when
(let ((,type-class (type-class-or-lose ',type-class-name))
(,info (mapcar (lambda (spec)
(destructuring-bind
(super &optional guard)
spec
- (cons (sb!xc:find-class super) guard)))
+ (cons (find-classoid super) guard)))
',specs)))
(setf (type-class-complex-subtypep-arg1 ,type-class)
(lambda (type1 type2)
(type-specifier
(fun-type-returns type)))))
-;;; Since all function types are equivalent to FUNCTION, they are all
-;;; subtypes of each other.
+;;; The meaning of this is a little confused. On the one hand, all
+;;; function objects are represented the same way regardless of the
+;;; arglists and return values, and apps don't get to ask things like
+;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the
+;;; other hand, Python wants to reason about function types. So...
(!define-type-method (function :simple-subtypep) (type1 type2)
- (declare (ignore type1 type2))
- (values t t))
+ (flet ((fun-type-simple-p (type)
+ (not (or (fun-type-rest type)
+ (fun-type-keyp type))))
+ (every-csubtypep (types1 types2)
+ (loop
+ for a1 in types1
+ for a2 in types2
+ do (multiple-value-bind (res sure-p)
+ (csubtypep a1 a2)
+ (unless res (return (values res sure-p))))
+ finally (return (values t t)))))
+ (and/type (values-subtypep (fun-type-returns type1)
+ (fun-type-returns type2))
+ (cond ((fun-type-wild-args type2) (values t t))
+ ((fun-type-wild-args type1)
+ (cond ((fun-type-keyp type2) (values nil nil))
+ ((not (fun-type-rest type2)) (values nil t))
+ ((not (null (fun-type-required type2))) (values nil t))
+ (t (and/type (type= *universal-type* (fun-type-rest type2))
+ (every/type #'type= *universal-type*
+ (fun-type-optional type2))))))
+ ((not (and (fun-type-simple-p type1)
+ (fun-type-simple-p type2)))
+ (values nil nil))
+ (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
+ (multiple-value-bind (min2 max2) (fun-type-nargs type2)
+ (cond ((or (> max1 max2) (< min1 min2))
+ (values nil t))
+ ((and (= min1 min2) (= max1 max2))
+ (and/type (every-csubtypep (fun-type-required type1)
+ (fun-type-required type2))
+ (every-csubtypep (fun-type-optional type1)
+ (fun-type-optional type2))))
+ (t (every-csubtypep
+ (concatenate 'list
+ (fun-type-required type1)
+ (fun-type-optional type1))
+ (concatenate 'list
+ (fun-type-required type2)
+ (fun-type-optional type2))))))))))))
(!define-superclasses function ((function)) !cold-init-forms)
(declare (ignore type1 type2))
(specifier-type 'function))
+;;; The union or intersection of a subclass of FUNCTION with a
+;;; FUNCTION type is somewhat complicated.
+(!define-type-method (function :complex-intersection2) (type1 type2)
+ (cond
+ ((type= type1 (specifier-type 'function)) type2)
+ ((csubtypep type1 (specifier-type 'function)) nil)
+ (t :call-other-method)))
+(!define-type-method (function :complex-union2) (type1 type2)
+ (cond
+ ((type= type1 (specifier-type 'function)) type1)
+ (t nil)))
+
;;; ### Not very real, but good enough for redefining transforms
;;; according to type:
(!define-type-method (function :simple-=) (type1 type2)
(!define-type-class constant :inherits values)
(!define-type-method (constant :unparse) (type)
- `(constant-argument ,(type-specifier (constant-type-type type))))
+ `(constant-arg ,(type-specifier (constant-type-type type))))
(!define-type-method (constant :simple-=) (type1 type2)
(type= (constant-type-type type1) (constant-type-type type2)))
-(!def-type-translator constant-argument (type)
+(!def-type-translator constant-arg (type)
(make-constant-type :type (specifier-type type)))
-;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
-;;; structure, fill in the slots in the structure accordingly. This is
-;;; used for both FUNCTION and VALUES types.
-(declaim (ftype (function (list args-type) (values)) parse-args-types))
-(defun parse-args-types (lambda-list result)
- (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))
- (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))
- (setf (args-type-keyp result) keyp)
- (collect ((key-info))
- (dolist (key keys)
- (unless (proper-list-of-length-p key 2)
- (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: ~2I~_~S~:>"
- kwd lambda-list))
- (key-info (make-key-info :name kwd
- :type (specifier-type (second key))))))
- (setf (args-type-keywords result) (key-info)))
- (setf (args-type-allowp result) allowp)
- (values)))
-
;;; Return the lambda-list-like type specification corresponding
;;; to an ARGS-TYPE.
(declaim (ftype (function (args-type) list) unparse-args-types))
(result)))
(!def-type-translator function (&optional (args '*) (result '*))
- (let ((res (make-fun-type :returns (values-specifier-type result))))
- (if (eq args '*)
- (setf (fun-type-wild-args res) t)
- (parse-args-types args res))
- res))
+ (make-fun-type :args args :returns (values-specifier-type result)))
(!def-type-translator values (&rest values)
- (let ((res (make-values-type)))
- (parse-args-types values res)
- res))
+ (make-values-type :args values))
\f
;;;; VALUES types interfaces
;;;;
;;; type, return NIL, NIL.
(defun fun-type-nargs (type)
(declare (type ctype type))
- (if (fun-type-p type)
+ (if (and (fun-type-p type) (not (fun-type-wild-args type)))
(let ((fixed (length (args-type-required type))))
(if (or (args-type-rest type)
(args-type-keyp type)
:initial-element rest2)))
exact)))
-;;; If Type isn't a values type, then make it into one:
+;;; If TYPE isn't a values type, then make it into one:
;;; <type> ==> (values type &rest t)
(defun coerce-to-values (type)
(declare (type ctype type))
(defun args-type-op (type1 type2 operation nreq default-type)
(declare (type ctype type1 type2 default-type)
(type function operation nreq))
+ (when (eq type1 type2)
+ (values type1 t))
(if (or (values-type-p type1) (values-type-p type2))
(let ((type1 (coerce-to-values type1))
(type2 (coerce-to-values type2)))
(eq type1 *empty-type*)
(eq type2 *wild-type*))
(values t t))
- ((or (eq type1 *wild-type*)
- (eq type2 *empty-type*))
+ ((eq type1 *wild-type*)
(values nil t))
(t
(!invoke-type-method :simple-subtypep :complex-subtypep-arg2
:complex-arg1 :complex-subtypep-arg1))))
;;; Just parse the type specifiers and call CSUBTYPE.
-(defun sb!xc:subtypep (type1 type2)
+(defun sb!xc:subtypep (type1 type2 &optional environment)
#!+sb-doc
"Return two values indicating the relationship between type1 and type2.
If values are T and T, type1 definitely is a subtype of type2.
If values are NIL and T, type1 definitely is not a subtype of type2.
If values are NIL and NIL, it couldn't be determined."
+ (declare (ignore environment))
(csubtypep (specifier-type type1) (specifier-type type2)))
;;; If two types are definitely equivalent, return true. The second
(declare (type ctype type1 type2))
(cond ((eq type1 type2)
type1)
+ ((csubtypep type1 type2) type2)
+ ((csubtypep type2 type1) type1)
((or (union-type-p type1)
(union-type-p type2))
;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
(flet ((1way (x y)
(!invoke-type-method :simple-intersection2 :complex-intersection2
x y
- :default :no-type-method-found)))
+ :default :call-other-method)))
(declare (inline 1way))
(let ((xy (1way type1 type2)))
- (or (and (not (eql xy :no-type-method-found)) xy)
+ (or (and (not (eql xy :call-other-method)) 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))
+ (or (and (not (eql yx :call-other-method)) yx)
+ (cond ((and (eql xy :call-other-method)
+ (eql yx :call-other-method))
*empty-type*)
(t
(aver (and (not xy) (not yx))) ; else handled above
((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
(cond ((eq type1 type2)
+ ;; FIXME: For some reason, this doesn't catch e.g. type1 =
+ ;; type2 = (SPECIFIER-TYPE
+ ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10
type1)
((or (intersection-type-p type1)
(intersection-type-p type2))
(let ((res (specifier-type spec)))
(unless (unknown-type-p res)
(setf (info :type :builtin spec) res)
- (setf (info :type :kind spec) :primitive))))
+ ;; KLUDGE: the three copies of this idiom in this file (and
+ ;; the one in class.lisp as at sbcl-0.7.4.1x) should be
+ ;; coalesced, or perhaps the error-detecting code that
+ ;; disallows redefinition of :PRIMITIVE types should be
+ ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than
+ ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to
+ ;; cause redefinition errors when precompute-types is called
+ ;; for a second time while building the target compiler using
+ ;; the cross-compiler. -- CSR, trying to explain why this
+ ;; isn't completely wrong, 2002-06-07
+ (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive))))
(values))
\f
;;;; general TYPE-UNION and TYPE-INTERSECTION operations
(defun accumulate1-compound-type (type types %compound-type-p simplify2)
(declare (type ctype type))
(declare (type (vector ctype) types))
- (declare (type function simplify2))
+ (declare (type function %compound-type-p simplify2))
;; Any input object satisfying %COMPOUND-TYPE-P should've been
;; broken into components before it reached us.
(aver (not (funcall %compound-type-p type)))
(defun simplified-compound-types (input-types %compound-type-p simplify2)
(let ((simplified-types (make-array (length input-types)
:fill-pointer 0
+ :adjustable t
:element-type 'ctype
;; (This INITIAL-ELEMENT shouldn't
;; matter, but helps avoid type
;;; 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)
+(defun make-probably-compound-type (constructor types enumerable identity)
(declare (type function constructor))
(declare (type (vector ctype) types))
(declare (type ctype identity))
;; 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
+ ;; type, so we need to MAKE-PROBABLY-COMPOUND-TYPE
;; 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 maybe-distribute-one-union (union-type types)
+ (let* ((intersection (apply #'type-intersection types))
+ (union (mapcar (lambda (x) (type-intersection x intersection))
+ (union-type-types union-type))))
+ (if (notany (lambda (x) (or (hairy-type-p x)
+ (intersection-type-p x)))
+ union)
+ union
+ nil)))
+
(defun type-intersection (&rest input-types)
+ (%type-intersection input-types))
+(defun-cached (%type-intersection :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(let ((simplified-types (simplified-compound-types input-types
#'intersection-type-p
#'type-intersection2)))
;; 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.
+ ;; we try to generate a simple type by distributing the union; if
+ ;; the type can't be made simple, we punt to HAIRY-TYPE.
(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*))))
+ (let* ((first-union (find-if #'union-type-p simplified-types))
+ (other-types (coerce (remove first-union simplified-types)
+ 'list))
+ (distributed (maybe-distribute-one-union first-union
+ other-types)))
+ (if distributed
+ (apply #'type-union distributed)
+ (make-hairy-type
+ :specifier `(and ,@(map 'list
+ #'type-specifier
+ simplified-types)))))
+ (make-probably-compound-type #'%make-intersection-type
+ simplified-types
+ (some #'type-enumerable
+ simplified-types)
+ *universal-type*))))
(defun type-union (&rest input-types)
+ (%type-union input-types))
+(defun-cached (%type-union :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(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*)))
+ (make-probably-compound-type #'make-union-type
+ simplified-types
+ (every #'type-enumerable simplified-types)
+ *empty-type*)))
\f
;;;; built-in types
(macrolet ((frob (name var)
`(progn
(setq ,var (make-named-type :name ',name))
- (setf (info :type :kind ',name) :primitive)
+ (setf (info :type :kind ',name)
+ #+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin ',name) ,var))))
;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
;; special symbol which can be stuck in some places where an
(frob t *universal-type*))
(setf *universal-fun-type*
(make-fun-type :wild-args t
- :returns *wild-type*)))
+ :returns *wild-type*)))
(!define-type-method (named :simple-=) (type1 type2)
;; FIXME: BUG 85: This assertion failed when I added it in
;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
+(!define-type-method (named :complex-=) (type1 type2)
+ (cond
+ ((and (eq type2 *empty-type*)
+ (intersection-type-p type1)
+ ;; not allowed to be unsure on these... FIXME: keep the list
+ ;; of CL types that are intersection types once and only
+ ;; once.
+ (not (or (type= type1 (specifier-type 'ratio))
+ (type= type1 (specifier-type 'keyword)))))
+ ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
+ ;; STREAM) can get here. In general, we can't really tell
+ ;; whether these are equal to NIL or not, so
+ (values nil nil))
+ ((type-might-contain-other-types-p type1)
+ (invoke-complex-=-other-method type1 type2))
+ (t (values nil t))))
+
(!define-type-method (named :simple-subtypep) (type1 type2)
(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
- (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
- ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause
- ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over
- ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..)
- (aver (not (hairy-type-p type2)))
- ;; Besides the old CMU CL assertion above, we also need to avoid
- ;; compound types, else we could get into trouble with
- ;; (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR)))
- ;; or
- ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))).
- (aver (not (compound-type-p type2)))
- ;; Then, since TYPE2 is reasonably tractable, we're good to go.
- (values (eq type1 *empty-type*) t))
+ ;; This AVER causes problems if we write accurate methods for the
+ ;; union (and possibly intersection) types which then delegate to
+ ;; us; while a user shouldn't get here, because of the odd status of
+ ;; *wild-type* a type-intersection executed by the compiler can. -
+ ;; CSR, 2002-04-10
+ ;;
+ ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
+ (cond ((eq type1 *empty-type*)
+ t)
+ (;; When TYPE2 might be the universal type in disguise
+ (type-might-contain-other-types-p type2)
+ ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
+ ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
+ ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
+ ;; HAIRY-TYPEs as we used to. Instead we deal with the
+ ;; problem (where at least part of the problem is cases like
+ ;; (SUBTYPEP T '(SATISFIES FOO))
+ ;; or
+ ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR)))
+ ;; where the second type is a hairy type like SATISFIES, or
+ ;; is a compound type which might contain a hairy type) by
+ ;; returning uncertainty.
+ (values nil nil))
+ (t
+ ;; By elimination, TYPE1 is the universal type.
+ (aver (or (eq type1 *wild-type*) (eq type1 *universal-type*)))
+ ;; This case would have been picked off by the SIMPLE-SUBTYPEP
+ ;; method, and so shouldn't appear here.
+ (aver (not (eq type2 *universal-type*)))
+ ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the
+ ;; universal type in disguise, TYPE2 is not a superset of TYPE1.
+ (values nil t))))
(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
(aver (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))
+ ((type-might-contain-other-types-p type1)
+ ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
+ ;; disguise. So we'd better delegate.
+ (invoke-complex-subtypep-arg1-method type1 type2))
(t
;; FIXME: This seems to rely on there only being 2 or 3
- ;; HAIRY-TYPE values, and the exclusion of various
+ ;; NAMED-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))))
\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)
(let ((hairy-spec1 (hairy-type-specifier type1))
(hairy-spec2 (hairy-type-specifier type2)))
- (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not)
- (consp hairy-spec2) (eq (car hairy-spec2) 'not))
- (csubtypep (specifier-type (cadr hairy-spec2))
- (specifier-type (cadr hairy-spec1))))
- ((equal hairy-spec1 hairy-spec2)
+ (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
(values t t))
(t
(values nil nil)))))
(!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))
- (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)))))
+ (invoke-complex-subtypep-arg1-method type1 type2))
-(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
+(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
(declare (ignore type1 type2))
(values nil nil))
-(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
- (type1 type2)
+(!define-type-method (hairy :complex-=) (type1 type2)
(declare (ignore type1 type2))
- nil)
+ (values nil nil))
+
+(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
+ (type1 type2)
+ (if (type= type1 type2)
+ type1
+ nil))
+
+(!define-type-method (hairy :simple-union2)
+ (type1 type2)
+ (if (type= type1 type2)
+ type1
+ nil))
(!define-type-method (hairy :simple-=) (type1 type2)
- (if (equal (hairy-type-specifier type1)
- (hairy-type-specifier type2))
+ (if (equal-but-no-car-recursion (hairy-type-specifier type1)
+ (hairy-type-specifier type2))
(values t t)
(values nil nil)))
-(!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.
(error 'simple-type-error
:datum predicate-name
:expected-type 'symbol
- :format-control "~S is not a symbol."
+ :format-control "The SATISFIES predicate name is not a symbol: ~S"
:format-arguments (list predicate-name))))
;; Create object.
(make-hairy-type :specifier whole))
\f
+;;;; negation types
+
+(!define-type-method (negation :unparse) (x)
+ `(not ,(type-specifier (negation-type-type x))))
+
+(!define-type-method (negation :simple-subtypep) (type1 type2)
+ (csubtypep (negation-type-type type2) (negation-type-type type1)))
+
+(!define-type-method (negation :complex-subtypep-arg2) (type1 type2)
+ (let* ((complement-type2 (negation-type-type type2))
+ (intersection2 (type-intersection2 type1
+ complement-type2)))
+ (if intersection2
+ ;; FIXME: if uncertain, maybe try arg1?
+ (type= intersection2 *empty-type*)
+ (invoke-complex-subtypep-arg1-method type1 type2))))
+
+(!define-type-method (negation :complex-subtypep-arg1) (type1 type2)
+ ;; "Incrementally extended heuristic algorithms tend inexorably toward the
+ ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
+ ;;
+ ;; You may not believe this. I couldn't either. But then I sat down
+ ;; and drew lots of Venn diagrams. Comments involving a and b refer
+ ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27.
+ (block nil
+ ;; (Several logical truths in this block are true as long as
+ ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a
+ ;; case with b=T where we actually reach this type method, but
+ ;; we'll test for and exclude this case anyway, since future
+ ;; maintenance might make it possible for it to end up in this
+ ;; code.)
+ (multiple-value-bind (equal certain)
+ (type= type2 *universal-type*)
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values t t))))
+ (let ((complement-type1 (negation-type-type type1)))
+ ;; Do the special cases first, in order to give us a chance if
+ ;; subtype/supertype relationships are hairy.
+ (multiple-value-bind (equal certain)
+ (type= complement-type1 type2)
+ ;; If a = b, ~a is not a subtype of b (unless b=T, which was
+ ;; excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; KLUDGE: ANSI requires that the SUBTYPEP result between any
+ ;; two built-in atomic type specifiers never be uncertain. This
+ ;; is hard to do cleanly for the built-in types whose
+ ;; definitions include (NOT FOO), i.e. CONS and RATIO. However,
+ ;; we can do it with this hack, which uses our global knowledge
+ ;; that our implementation of the type system uses disjoint
+ ;; implementation types to represent disjoint sets (except when
+ ;; types are contained in other types). (This is a KLUDGE
+ ;; because it's fragile. Various changes in internal
+ ;; representation in the type system could make it start
+ ;; confidently returning incorrect results.) -- WHN 2002-03-08
+ (unless (or (type-might-contain-other-types-p complement-type1)
+ (type-might-contain-other-types-p type2))
+ ;; Because of the way our types which don't contain other
+ ;; types are disjoint subsets of the space of possible values,
+ ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B
+ ;; is not T, as checked above).
+ (return (values nil t)))
+ ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as
+ ;; TYPE1 and TYPE2 will only be equal if they're both NOT types,
+ ;; and then the :SIMPLE-SUBTYPEP method would be used instead.
+ ;; But a CSUBTYPEP relationship might still hold:
+ (multiple-value-bind (equal certain)
+ (csubtypep complement-type1 type2)
+ ;; If a is a subtype of b, ~a is not a subtype of b (unless
+ ;; b=T, which was excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ (multiple-value-bind (equal certain)
+ (csubtypep type2 complement-type1)
+ ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME:
+ ;; That's not true if a=T. Do we know at this point that a is
+ ;; not T?)
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE?
+ ;; KLUDGE case above: Other cases here would rely on being able
+ ;; to catch all possible cases, which the fragility of this type
+ ;; system doesn't inspire me; for instance, if a is type= to ~b,
+ ;; then we want T, T; if this is not the case and the types are
+ ;; disjoint (have an intersection of *empty-type*) then we want
+ ;; NIL, T; else if the union of a and b is the *universal-type*
+ ;; then we want T, T. So currently we still claim to be unsure
+ ;; about e.g. (subtypep '(not fixnum) 'single-float).
+ ;;
+ ;; OTOH we might still get here:
+ (values nil nil))))
+
+(!define-type-method (negation :complex-=) (type1 type2)
+ ;; (NOT FOO) isn't equivalent to anything that's not a negation
+ ;; type, except possibly a type that might contain it in disguise.
+ (declare (ignore type2))
+ (if (type-might-contain-other-types-p type1)
+ (values nil nil)
+ (values nil t)))
+
+(!define-type-method (negation :simple-intersection2) (type1 type2)
+ (let ((not1 (negation-type-type type1))
+ (not2 (negation-type-type type2)))
+ (cond
+ ((csubtypep not1 not2) type2)
+ ((csubtypep not2 not1) type1)
+ ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2
+ ;; method, below? The clause would read
+ ;;
+ ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*)
+ ;;
+ ;; but with proper canonicalization of negation types, there's
+ ;; no way of constructing two negation types with union of their
+ ;; negations being the universal type.
+ (t
+ (aver (not (eq (type-union not1 not2) *universal-type*)))
+ nil))))
+
+(!define-type-method (negation :complex-intersection2) (type1 type2)
+ (cond
+ ((csubtypep type1 (negation-type-type type2)) *empty-type*)
+ ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+ type1)
+ (t nil)))
+
+(!define-type-method (negation :simple-union2) (type1 type2)
+ (let ((not1 (negation-type-type type1))
+ (not2 (negation-type-type type2)))
+ (cond
+ ((csubtypep not1 not2) type1)
+ ((csubtypep not2 not1) type2)
+ ((eq (type-intersection not1 not2) *empty-type*)
+ *universal-type*)
+ (t nil))))
+
+(!define-type-method (negation :complex-union2) (type1 type2)
+ (cond
+ ((csubtypep (negation-type-type type2) type1) *universal-type*)
+ ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+ type2)
+ (t nil)))
+
+(!define-type-method (negation :simple-=) (type1 type2)
+ (type= (negation-type-type type1) (negation-type-type type2)))
+
+(!def-type-translator not (typespec)
+ (let* ((not-type (specifier-type typespec))
+ (spec (type-specifier not-type)))
+ (cond
+ ;; canonicalize (NOT (NOT FOO))
+ ((and (listp spec) (eq (car spec) 'not))
+ (specifier-type (cadr spec)))
+ ;; canonicalize (NOT NIL) and (NOT T)
+ ((eq not-type *empty-type*) *universal-type*)
+ ((eq not-type *universal-type*) *empty-type*)
+ ((and (numeric-type-p not-type)
+ (null (numeric-type-low not-type))
+ (null (numeric-type-high not-type)))
+ (make-negation-type :type not-type))
+ ((numeric-type-p not-type)
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type not-type :low nil :high nil))
+ (cond
+ ((null (numeric-type-low not-type))
+ (modified-numeric-type
+ not-type
+ :low (let ((h (numeric-type-high not-type)))
+ (if (consp h) (car h) (list h)))
+ :high nil))
+ ((null (numeric-type-high not-type))
+ (modified-numeric-type
+ not-type
+ :low nil
+ :high (let ((l (numeric-type-low not-type)))
+ (if (consp l) (car l) (list l)))))
+ (t (type-union
+ (modified-numeric-type
+ not-type
+ :low nil
+ :high (let ((l (numeric-type-low not-type)))
+ (if (consp l) (car l) (list l))))
+ (modified-numeric-type
+ not-type
+ :low (let ((h (numeric-type-high not-type)))
+ (if (consp h) (car h) (list h)))
+ :high nil))))))
+ ((intersection-type-p not-type)
+ (apply #'type-union
+ (mapcar #'(lambda (x)
+ (specifier-type `(not ,(type-specifier x))))
+ (intersection-type-types not-type))))
+ ((union-type-p not-type)
+ (apply #'type-intersection
+ (mapcar #'(lambda (x)
+ (specifier-type `(not ,(type-specifier x))))
+ (union-type-types not-type))))
+ ((member-type-p not-type)
+ (let ((members (member-type-members not-type)))
+ (if (some #'floatp members)
+ (let (floats)
+ (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0)
+ #!+long-float (0.0l0 . -0.0l0)))
+ (when (member (car pair) members)
+ (aver (not (member (cdr pair) members)))
+ (push (cdr pair) floats)
+ (setf members (remove (car pair) members)))
+ (when (member (cdr pair) members)
+ (aver (not (member (car pair) members)))
+ (push (car pair) floats)
+ (setf members (remove (cdr pair) members))))
+ (apply #'type-intersection
+ (if (null members)
+ *universal-type*
+ (make-negation-type
+ :type (make-member-type :members members)))
+ (mapcar
+ (lambda (x)
+ (let ((type (ctype-of x)))
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type type
+ :low nil :high nil))
+ (modified-numeric-type type
+ :low nil :high (list x))
+ (make-member-type :members (list x))
+ (modified-numeric-type type
+ :low (list x) :high nil))))
+ floats)))
+ (make-negation-type :type not-type))))
+ ((and (cons-type-p not-type)
+ (eq (cons-type-car-type not-type) *universal-type*)
+ (eq (cons-type-cdr-type not-type) *universal-type*))
+ (make-negation-type :type not-type))
+ ((cons-type-p not-type)
+ (type-union
+ (make-negation-type :type (specifier-type 'cons))
+ (cond
+ ((and (not (eq (cons-type-car-type not-type) *universal-type*))
+ (not (eq (cons-type-cdr-type not-type) *universal-type*)))
+ (type-union
+ (make-cons-type
+ (specifier-type `(not ,(type-specifier
+ (cons-type-car-type not-type))))
+ *universal-type*)
+ (make-cons-type
+ *universal-type*
+ (specifier-type `(not ,(type-specifier
+ (cons-type-cdr-type not-type)))))))
+ ((not (eq (cons-type-car-type not-type) *universal-type*))
+ (make-cons-type
+ (specifier-type `(not ,(type-specifier
+ (cons-type-car-type not-type))))
+ *universal-type*))
+ ((not (eq (cons-type-cdr-type not-type) *universal-type*))
+ (make-cons-type
+ *universal-type*
+ (specifier-type `(not ,(type-specifier
+ (cons-type-cdr-type not-type))))))
+ (t (bug "Weird CONS type ~S" not-type)))))
+ (t (make-negation-type :type not-type)))))
+\f
;;;; numeric types
(!define-type-class number)
(and (eq (numeric-type-class type1) (numeric-type-class type2))
(eq (numeric-type-format type1) (numeric-type-format type2))
(eq (numeric-type-complexp type1) (numeric-type-complexp type2))
- (equal (numeric-type-low type1) (numeric-type-low type2))
- (equal (numeric-type-high type1) (numeric-type-high type2)))
+ (equalp (numeric-type-low type1) (numeric-type-low type2))
+ (equalp (numeric-type-high type1) (numeric-type-high type2)))
t))
(!define-type-method (number :unparse) (type)
`(unsigned-byte ,high-length))
(t
`(mod ,(1+ high)))))
- ((and (= low sb!vm:*target-most-negative-fixnum*)
- (= high sb!vm:*target-most-positive-fixnum*))
+ ((and (= low sb!xc:most-negative-fixnum)
+ (= high sb!xc:most-positive-fixnum))
'fixnum)
((and (= low (lognot high))
(= high-count high-length)
;;;
;;; This is for comparing bounds of the same kind, e.g. upper and
;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds.
-#!-negative-zero-is-not-zero
(defmacro numeric-bound-test (x y closed open)
`(cond ((not ,y) t)
((not ,x) nil)
(,open ,x (car ,y))
(,closed ,x ,y)))))
-#!+negative-zero-is-not-zero
-(defmacro numeric-bound-test-zero (op x y)
- `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y))
- (,op (float-sign ,x) (float-sign ,y))
- (,op ,x ,y)))
-
-#!+negative-zero-is-not-zero
-(defmacro numeric-bound-test (x y closed open)
- `(cond ((not ,y) t)
- ((not ,x) nil)
- ((consp ,x)
- (if (consp ,y)
- (numeric-bound-test-zero ,closed (car ,x) (car ,y))
- (numeric-bound-test-zero ,closed (car ,x) ,y)))
- (t
- (if (consp ,y)
- (numeric-bound-test-zero ,open ,x (car ,y))
- (numeric-bound-test-zero ,closed ,x ,y)))))
-
;;; This is used to compare upper and lower bounds. This is different
;;; from the same-bound case:
;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we
;;; return true if *either* arg is NIL.
;;; -- an open inner bound is "greater" and also squeezes the interval,
;;; causing us to use the OPEN test for those cases as well.
-#!-negative-zero-is-not-zero
(defmacro numeric-bound-test* (x y closed open)
`(cond ((not ,y) t)
((not ,x) t)
(,open ,x (car ,y))
(,closed ,x ,y)))))
-#!+negative-zero-is-not-zero
-(defmacro numeric-bound-test* (x y closed open)
- `(cond ((not ,y) t)
- ((not ,x) t)
- ((consp ,x)
- (if (consp ,y)
- (numeric-bound-test-zero ,open (car ,x) (car ,y))
- (numeric-bound-test-zero ,open (car ,x) ,y)))
- (t
- (if (consp ,y)
- (numeric-bound-test-zero ,open ,x (car ,y))
- (numeric-bound-test-zero ,closed ,x ,y)))))
-
;;; Return whichever of the numeric bounds X and Y is "maximal"
;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >).
;;; This is only meaningful for maximizing like bounds, i.e. upper and
(null complexp2)))
(values nil t))
;; If the classes are specified and different, the types are
- ;; disjoint unless type2 is rational and type1 is integer.
+ ;; disjoint unless type2 is RATIONAL and type1 is INTEGER.
+ ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL
+ ;; X X) for integral X, but this is dealt with in the
+ ;; canonicalization inside MAKE-NUMERIC-TYPE ]
((not (or (eq class1 class2)
(null class2)
- (and (eq class1 'integer)
- (eq class2 'rational))))
+ (and (eq class1 'integer) (eq class2 'rational))))
(values nil t))
;; If the float formats are specified and different, the types
;; are disjoint.
(t
(values nil t)))))
-(!define-superclasses number ((generic-number)) !cold-init-forms)
+(!define-superclasses number ((number)) !cold-init-forms)
;;; If the high bound of LOW is adjacent to the low bound of HIGH,
;;; then return true, otherwise NIL.
(cond ((not (and low-bound high-bound)) nil)
((and (consp low-bound) (consp high-bound)) nil)
((consp low-bound)
- #!-negative-zero-is-not-zero
(let ((low-value (car low-bound)))
(or (eql low-value high-bound)
(and (eql low-value -0f0) (eql high-bound 0f0))
(and (eql low-value 0f0) (eql high-bound -0f0))
(and (eql low-value -0d0) (eql high-bound 0d0))
- (and (eql low-value 0d0) (eql high-bound -0d0))))
- #!+negative-zero-is-not-zero
- (eql (car low-bound) high-bound))
+ (and (eql low-value 0d0) (eql high-bound -0d0)))))
((consp high-bound)
- #!-negative-zero-is-not-zero
(let ((high-value (car high-bound)))
(or (eql high-value low-bound)
(and (eql high-value -0f0) (eql low-bound 0f0))
(and (eql high-value 0f0) (eql low-bound -0f0))
(and (eql high-value -0d0) (eql low-bound 0d0))
- (and (eql high-value 0d0) (eql low-bound -0d0))))
- #!+negative-zero-is-not-zero
- (eql (car high-bound) low-bound))
- #!+negative-zero-is-not-zero
- ((or (and (eql low-bound -0f0) (eql high-bound 0f0))
- (and (eql low-bound -0d0) (eql high-bound 0d0))))
+ (and (eql high-value 0d0) (eql low-bound -0d0)))))
((and (eq (numeric-type-class low) 'integer)
(eq (numeric-type-class high) 'integer))
(eql (1+ low-bound) high-bound))
;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
;;;
-;;; ### Note: we give up early to keep from dropping lots of information on
-;;; the floor by returning overly general types.
+;;; Old comment, probably no longer applicable:
+;;;
+;;; ### 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-union2) (type1 type2)
(declare (type numeric-type type1 type2))
(cond ((csubtypep type1 type2) type2)
(class2 (numeric-type-class type2))
(format2 (numeric-type-format type2))
(complexp2 (numeric-type-complexp type2)))
- (when (and (eq class1 class2)
- (eq format1 format2)
- (eq complexp1 complexp2)
- (or (numeric-types-intersect type1 type2)
- (numeric-types-adjacent type1 type2)
- (numeric-types-adjacent type2 type1)))
- (make-numeric-type
- :class class1
- :format format1
- :complexp complexp1
- :low (numeric-bound-max (numeric-type-low type1)
- (numeric-type-low type2)
- <= < t)
- :high (numeric-bound-max (numeric-type-high type1)
- (numeric-type-high type2)
- >= > t)))))))
+ (cond
+ ((and (eq class1 class2)
+ (eq format1 format2)
+ (eq complexp1 complexp2)
+ (or (numeric-types-intersect type1 type2)
+ (numeric-types-adjacent type1 type2)
+ (numeric-types-adjacent type2 type1)))
+ (make-numeric-type
+ :class class1
+ :format format1
+ :complexp complexp1
+ :low (numeric-bound-max (numeric-type-low type1)
+ (numeric-type-low type2)
+ <= < t)
+ :high (numeric-bound-max (numeric-type-high type1)
+ (numeric-type-high type2)
+ >= > t)))
+ ;; FIXME: These two clauses are almost identical, and the
+ ;; consequents are in fact identical in every respect.
+ ((and (eq class1 'rational)
+ (eq class2 'integer)
+ (eq format1 format2)
+ (eq complexp1 complexp2)
+ (integerp (numeric-type-low type2))
+ (integerp (numeric-type-high type2))
+ (= (numeric-type-low type2) (numeric-type-high type2))
+ (or (numeric-types-adjacent type1 type2)
+ (numeric-types-adjacent type2 type1)))
+ (make-numeric-type
+ :class 'rational
+ :format format1
+ :complexp complexp1
+ :low (numeric-bound-max (numeric-type-low type1)
+ (numeric-type-low type2)
+ <= < t)
+ :high (numeric-bound-max (numeric-type-high type1)
+ (numeric-type-high type2)
+ >= > t)))
+ ((and (eq class1 'integer)
+ (eq class2 'rational)
+ (eq format1 format2)
+ (eq complexp1 complexp2)
+ (integerp (numeric-type-low type1))
+ (integerp (numeric-type-high type1))
+ (= (numeric-type-low type1) (numeric-type-high type1))
+ (or (numeric-types-adjacent type1 type2)
+ (numeric-types-adjacent type2 type1)))
+ (make-numeric-type
+ :class 'rational
+ :format format1
+ :complexp complexp1
+ :low (numeric-bound-max (numeric-type-low type1)
+ (numeric-type-low type2)
+ <= < t)
+ :high (numeric-bound-max (numeric-type-high type1)
+ (numeric-type-high type2)
+ >= > t)))
+ (t nil))))))
+
(!cold-init-forms
- (setf (info :type :kind 'number) :primitive)
+ (setf (info :type :kind 'number)
+ #+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin 'number)
(make-numeric-type :complexp nil)))
(if (eq typespec '*)
(make-numeric-type :complexp :complex)
(labels ((not-numeric ()
- ;; FIXME: should probably be TYPE-ERROR
(error "The component type for COMPLEX is not numeric: ~S"
typespec))
+ (not-real ()
+ (error "The component type for COMPLEX is not real: ~S"
+ typespec))
(complex1 (component-type)
(unless (numeric-type-p component-type)
- ;; FIXME: As per the FIXME below, ANSI says we're
- ;; supposed to handle any subtype of REAL, not only
- ;; those which can be represented as NUMERIC-TYPE.
(not-numeric))
(when (eq (numeric-type-complexp component-type) :complex)
- (error "The component type for COMPLEX is complex: ~S"
- typespec))
- (modified-numeric-type component-type :complexp :complex)))
- (let ((type (specifier-type typespec)))
- (typecase type
- ;; This is all that CMU CL handled.
- (numeric-type (complex1 type))
- ;; We need to handle UNION-TYPEs in order to deal with
- ;; REAL and FLOAT being represented as UNION-TYPEs of more
- ;; primitive types.
+ (not-real))
+ (modified-numeric-type component-type :complexp :complex))
+ (complex-union (component)
+ (unless (numberp component)
+ (not-numeric))
+ ;; KLUDGE: This TYPECASE more or less does
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
+ ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
+ ;; but uses logic cut and pasted from the DEFUN of
+ ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
+ ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
+ ;; would tend to break the code here. Unfortunately,
+ ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
+ ;; would cause another kind of fragility, because
+ ;; ANSI's definition of TYPE-OF is so weak that e.g.
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
+ ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
+ ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
+ ;; So using TYPE-OF would mean that ANSI-conforming
+ ;; maintenance changes in TYPE-OF could break the code here.
+ ;; It's not clear how best to fix this. -- WHN 2002-01-21,
+ ;; trying to summarize CSR's concerns in his patch
+ (typecase component
+ (complex (error "The component type for COMPLEX (EQL X) ~
+ is complex: ~S"
+ component))
+ ((eql 0) (specifier-type nil)) ; as required by ANSI
+ (single-float (specifier-type '(complex single-float)))
+ (double-float (specifier-type '(complex double-float)))
+ #!+long-float
+ (long-float (specifier-type '(complex long-float)))
+ (rational (specifier-type '(complex rational)))
+ (t (specifier-type '(complex real))))))
+ (let ((ctype (specifier-type typespec)))
+ (typecase ctype
+ (numeric-type (complex1 ctype))
(union-type (apply #'type-union
+ ;; FIXME: This code could suffer from
+ ;; (admittedly very obscure) cases of
+ ;; bug 145 e.g. when TYPE is
+ ;; (OR (AND INTEGER (SATISFIES ODDP))
+ ;; (AND FLOAT (SATISFIES FOO))
+ ;; and not even report the problem very well.
(mapcar #'complex1
- (union-type-types type))))
- ;; FIXME: ANSI just says that TYPESPEC is a subtype of type
- ;; REAL, not necessarily a NUMERIC-TYPE. E.g. TYPESPEC could
- ;; legally be (AND REAL (SATISFIES ODDP))! But like the old
- ;; CMU CL code, we're still not nearly that general.
- (t (not-numeric)))))))
+ (union-type-types ctype))))
+ ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
+ ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
+ ;; ANSI, equal to type NIL, the empty set.
+ (member-type (apply #'type-union
+ (mapcar #'complex-union
+ (member-type-members ctype))))
+ (t
+ (multiple-value-bind (subtypep certainly)
+ (csubtypep ctype (specifier-type 'real))
+ (if (and (not subtypep) certainly)
+ (not-real)
+ ;; ANSI just says that TYPESPEC is any subtype of
+ ;; type REAL, not necessarily a NUMERIC-TYPE. In
+ ;; particular, at this point TYPESPEC could legally be
+ ;; an intersection type like (AND REAL (SATISFIES ODDP)),
+ ;; in which case we fall through the logic above and
+ ;; end up here, stumped.
+ (bug "~@<(known bug #145): The type ~S is too hairy to be
+ used for a COMPLEX component.~:@>"
+ typespec)))))))))
;;; If X is *, return NIL, otherwise return the bound, which must be a
;;; member of TYPE or a one-element list of a member of TYPE.
(lb (if (consp l) (1+ (car l)) l))
(h (canonicalized-bound high 'integer))
(hb (if (consp h) (1- (car h)) h)))
- (when (and hb lb (< hb lb))
- (error "Lower bound ~S is greater than upper bound ~S." l h))
- (make-numeric-type :class 'integer
- :complexp :real
- :enumerable (not (null (and l h)))
- :low lb
- :high hb)))
+ (if (and hb lb (< hb lb))
+ *empty-type*
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :enumerable (not (null (and l h)))
+ :low lb
+ :high hb))))
(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)))
- (unless (numeric-bound-test* lb hb <= <)
- (error "Lower bound ~S is not less than upper bound ~S." low high))
- (make-numeric-type :class ',class :format ',format :low lb :high hb))))
+ (if (not (numeric-bound-test* lb hb <= <))
+ *empty-type*
+ (make-numeric-type :class ',class
+ :format ',format
+ :low lb
+ :high hb)))))
(!def-bounded-type rational rational nil)
(array-type-element-type type)))
(!define-type-method (array :simple-=) (type1 type2)
- (values (and (equal (array-type-dimensions type1)
- (array-type-dimensions type2))
- (eq (array-type-complexp type1)
- (array-type-complexp type2))
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
- t))
+ (if (or (unknown-type-p (array-type-element-type type1))
+ (unknown-type-p (array-type-element-type type2)))
+ (multiple-value-bind (equalp certainp)
+ (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ ;; by its nature, the call to TYPE= should never return NIL,
+ ;; T, as we don't know what the UNKNOWN-TYPE will grow up to
+ ;; be. -- CSR, 2002-08-19
+ (aver (not (and (not equalp) certainp)))
+ (values equalp certainp))
+ (values (and (equal (array-type-dimensions type1)
+ (array-type-dimensions type2))
+ (eq (array-type-complexp type1)
+ (array-type-complexp type2))
+ (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2)))
+ t)))
(!define-type-method (array :unparse) (type)
(let ((dims (array-type-dimensions type))
(eq complexp2 :maybe)
(eq complexp1 complexp2)))
(values nil t))
- ;; If either element type is wild, then they intersect.
- ;; Otherwise, the types must be identical.
- ((or (eq (array-type-element-type type1) *wild-type*)
- (eq (array-type-element-type type2) *wild-type*)
+ ;; Old comment:
+ ;;
+ ;; If either element type is wild, then they intersect.
+ ;; Otherwise, the types must be identical.
+ ;;
+ ;; FIXME: There seems to have been a fair amount of
+ ;; confusion about the distinction between requested element
+ ;; type and specialized element type; here is one of
+ ;; them. If we request an array to hold objects of an
+ ;; unknown type, we can do no better than represent that
+ ;; type as an array specialized on wild-type. We keep the
+ ;; requested element-type in the -ELEMENT-TYPE slot, and
+ ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here,
+ ;; we must test for the SPECIALIZED slot being *WILD-TYPE*,
+ ;; not just the ELEMENT-TYPE slot. Maybe the return value
+ ;; in that specific case should be T, NIL? Or maybe this
+ ;; function should really be called
+ ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this
+ ;; was responsible for bug #123, and this whole issue could
+ ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
+ ((or (eq (array-type-specialized-element-type type1) *wild-type*)
+ (eq (array-type-specialized-element-type type2) *wild-type*)
(type= (specialized-element-type-maybe type1)
(specialized-element-type-maybe type2)))
(!define-type-method (member :unparse) (type)
(let ((members (member-type-members type)))
- (if (equal members '(nil))
- 'null
- `(member ,@members))))
+ (cond
+ ((equal members '(nil)) 'null)
+ ((type= type (specifier-type 'standard-char)) 'standard-char)
+ (t `(member ,@members)))))
(!define-type-method (member :simple-subtypep) (type1 type2)
(values (subsetp (member-type-members type1) (member-type-members type2))
;;; subtype of the MEMBER type.
(!define-type-method (member :complex-subtypep-arg2) (type1 type2)
(cond ((not (type-enumerable type1)) (values nil t))
- ((types-equal-or-intersect type1 type2) (values nil nil))
+ ((types-equal-or-intersect type1 type2)
+ (invoke-complex-subtypep-arg1-method type1 type2))
(t (values nil t))))
(!define-type-method (member :simple-intersection2) (type1 type2)
*empty-type*))))))
(!define-type-method (member :complex-intersection2) (type1 type2)
- (block punt
+ (block punt
(collect ((members))
(let ((mem2 (member-type-members type2)))
(dolist (member mem2)
(!def-type-translator member (&rest members)
(if members
- (make-member-type :members (remove-duplicates members))
- *empty-type*))
+ (let (ms numbers)
+ (dolist (m (remove-duplicates members))
+ (typecase m
+ (float (if (zerop m)
+ (push m ms)
+ (push (ctype-of m) numbers)))
+ (number (push (ctype-of m) numbers))
+ (t (push m ms))))
+ (apply #'type-union
+ (if ms
+ (make-member-type :members ms)
+ *empty-type*)
+ (nreverse numbers)))
+ *empty-type*))
\f
;;;; intersection types
;;;;
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
(declare (type ctype type))
- (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
+ (or (find type '(ratio 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)
- (flet (;; true if every type in the set X matches a type in the set Y
- (type<=-set (x y)
+ (flet ((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)))
+ (every/type (lambda (x y-element)
+ (any/type #'type= y-element x))
+ x y)))
+ (and/type (type<=-set types1 types2)
+ (type<=-set types2 types1))))
;;; Two intersection types are equal if their subtypes are equal sets.
;;;
(intersection-type-types type2)))
(defun %intersection-complex-subtypep-arg1 (type1 type2)
- (any/type (swapped-args-fun #'csubtypep)
- type2
- (intersection-type-types type1)))
+ (type= type1 (type-intersection type1 type2)))
-(!define-type-method (intersection :simple-subtypep) (type1 type2)
+(defun %intersection-simple-subtypep (type1 type2)
(every/type #'%intersection-complex-subtypep-arg1
type1
(intersection-type-types type2)))
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (%intersection-simple-subtypep type1 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)
+(defun %intersection-complex-subtypep-arg2 (type1 type2)
(every/type #'csubtypep type1 (intersection-type-types type2)))
+(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+ (%intersection-complex-subtypep-arg2 type1 type2))
+
+;;; FIXME: This will look eeriely familiar to readers of the UNION
+;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's
+;;; because it was generated by cut'n'paste methods. Given that
+;;; intersections and unions have all sorts of symmetries known to
+;;; mathematics, it shouldn't be beyond the ken of some programmers to
+;;; reflect those symmetries in code in a way that ties them together
+;;; more strongly than having two independent near-copies :-/
+(!define-type-method (intersection :simple-union2 :complex-union2)
+ (type1 type2)
+ ;; Within this method, type2 is guaranteed to be an intersection
+ ;; type:
+ (aver (intersection-type-p type2))
+ ;; Make sure to call only the applicable methods...
+ (cond ((and (intersection-type-p type1)
+ (%intersection-simple-subtypep type1 type2)) type2)
+ ((and (intersection-type-p type1)
+ (%intersection-simple-subtypep type2 type1)) type1)
+ ((and (not (intersection-type-p type1))
+ (%intersection-complex-subtypep-arg2 type1 type2))
+ type2)
+ ((and (not (intersection-type-p type1))
+ (%intersection-complex-subtypep-arg1 type2 type1))
+ type1)
+ ;; KLUDGE: This special (and somewhat hairy) magic is required
+ ;; to deal with the RATIONAL/INTEGER special case. The UNION
+ ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER))
+ ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28
+ ((and (csubtypep type2 (specifier-type 'ratio))
+ (numeric-type-p type1)
+ (csubtypep type1 (specifier-type 'integer))
+ (csubtypep type2
+ (make-numeric-type
+ :class 'rational
+ :complexp nil
+ :low (if (null (numeric-type-low type1))
+ nil
+ (list (1- (numeric-type-low type1))))
+ :high (if (null (numeric-type-high type1))
+ nil
+ (list (1+ (numeric-type-high type1)))))))
+ (type-union type1
+ (apply #'type-intersection
+ (remove (specifier-type '(not integer))
+ (intersection-type-types type2)
+ :test #'type=))))
+ (t
+ (let ((accumulator *universal-type*))
+ (do ((t2s (intersection-type-types type2) (cdr t2s)))
+ ((null t2s) accumulator)
+ (let ((union (type-union type1 (car t2s))))
+ (when (union-type-p union)
+ ;; we have to give up here -- there are all sorts of
+ ;; ordering worries, but it's better than before.
+ ;; Doing exactly the same as in the UNION
+ ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack
+ ;; overflow with the mutual recursion never bottoming
+ ;; out.
+ (if (and (eq accumulator *universal-type*)
+ (null (cdr t2s)))
+ ;; KLUDGE: if we get here, we have a partially
+ ;; simplified result. While this isn't by any
+ ;; means a universal simplification, including
+ ;; this logic here means that we can get (OR
+ ;; KEYWORD (NOT KEYWORD)) canonicalized to T.
+ (return union)
+ (return nil)))
+ (setf accumulator
+ (type-intersection accumulator union))))))))
+
(!def-type-translator and (&whole whole &rest type-specifiers)
(apply #'type-intersection
(mapcar #'specifier-type
(!define-type-class union)
-;;; The LIST type has a special name. Other union types just get
-;;; mechanically unparsed.
+;;; The LIST, FLOAT and REAL types have special names. 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)))))
-
+ (cond
+ ((type= type (specifier-type 'list)) 'list)
+ ((type= type (specifier-type 'float)) 'float)
+ ((type= type (specifier-type 'real)) 'real)
+ ((type= type (specifier-type 'sequence)) 'sequence)
+ ((type= type (specifier-type 'bignum)) 'bignum)
+ (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
+
+;;; Two union types are equal if they are each subtypes of each
+;;; other. We need to be this clever because our complex subtypep
+;;; methods are now more accurate; we don't get infinite recursion
+;;; because the simple-subtypep method delegates to complex-subtypep
+;;; of the individual types of type1. - CSR, 2002-04-09
+;;;
+;;; Previous comment, now obsolete, but worth keeping around because
+;;; it is true, though too strong a condition:
+;;;
;;; 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)))
+ (multiple-value-bind (subtype certain?)
+ (csubtypep type1 type2)
+ (if subtype
+ (csubtypep type2 type1)
+ ;; we might as well become as certain as possible.
+ (if certain?
+ (values nil t)
+ (multiple-value-bind (subtype certain?)
+ (csubtypep type2 type1)
+ (declare (ignore subtype))
+ (values nil certain?))))))
+
+(!define-type-method (union :complex-=) (type1 type2)
+ (declare (ignore type1))
+ (if (some #'type-might-contain-other-types-p
+ (union-type-types type2))
+ (values nil nil)
+ (values nil 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)
+;;; Similarly, a union type is a subtype of another if and only if
+;;; every element of TYPE1 is a subtype of TYPE2.
+(defun union-simple-subtypep (type1 type2)
(every/type (swapped-args-fun #'union-complex-subtypep-arg2)
type2
(union-type-types type1)))
+(!define-type-method (union :simple-subtypep) (type1 type2)
+ (union-simple-subtypep type1 type2))
+
(defun union-complex-subtypep-arg1 (type1 type2)
(every/type (swapped-args-fun #'csubtypep)
type2
(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)))
+ (multiple-value-bind (sub-value sub-certain?)
+ ;; was: (any/type #'csubtypep type1 (union-type-types type2)),
+ ;; which turns out to be too restrictive, causing bug 91.
+ ;;
+ ;; the following reimplementation might look dodgy. It is
+ ;; dodgy. It depends on the union :complex-= method not doing
+ ;; very much work -- certainly, not using subtypep. Reasoning:
+ (progn
+ ;; At this stage, we know that type2 is a union type and type1
+ ;; isn't. We might as well check this, though:
+ (aver (union-type-p type2))
+ (aver (not (union-type-p type1)))
+ ;; A is a subset of (B1 u B2)
+ ;; <=> A n (B1 u B2) = A
+ ;; <=> (A n B1) u (A n B2) = A
+ ;;
+ ;; But, we have to be careful not to delegate this type= to
+ ;; something that could invoke subtypep, which might get us
+ ;; back here -> stack explosion. We therefore ensure that the
+ ;; second type (which is the one that's dispatched on) is
+ ;; either a union type (where we've ensured that the complex-=
+ ;; method will not call subtypep) or something with no union
+ ;; types involved, in which case we'll never come back here.
+ ;;
+ ;; If we don't do this, then e.g.
+ ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
+ ;; would loop infinitely, as the member :complex-= method is
+ ;; implemented in terms of subtypep.
+ ;;
+ ;; Ouch. - CSR, 2002-04-10
+ (type= type1
+ (apply #'type-union
+ (mapcar (lambda (x) (type-intersection type1 x))
+ (union-type-types type2)))))
+ (if sub-certain?
+ (values sub-value sub-certain?)
+ ;; The ANY/TYPE expression above is a sufficient condition for
+ ;; subsetness, but not a necessary one, so we might get a more
+ ;; certain answer by this CALL-NEXT-METHOD-ish step when the
+ ;; ANY/TYPE expression is uncertain.
+ (invoke-complex-subtypep-arg1-method type1 type2))))
+
(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
(union-complex-subtypep-arg2 type1 type2))
;; 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)
+ ;;
+ ;; Within this method, type2 is guaranteed to be a union type:
+ (aver (union-type-p type2))
+ ;; Make sure to call only the applicable methods...
+ (cond ((and (union-type-p type1)
+ (union-simple-subtypep type1 type2)) type1)
+ ((and (union-type-p type1)
+ (union-simple-subtypep type2 type1)) type2)
+ ((and (not (union-type-p type1))
+ (union-complex-subtypep-arg2 type1 type2))
type1)
- ((union-complex-subtypep-arg1 type2 type1)
+ ((and (not (union-type-p type1))
+ (union-complex-subtypep-arg1 type2 type1))
type2)
(t
;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
(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 (because
- ;; TYPE-UNION2 was unable to give us a simple result)
- (unless accumulator
- (return nil)))))))
+ (type-union accumulator
+ (type-intersection type1 t2))))))))
(!def-type-translator or (&rest type-specifiers)
(apply #'type-union
(!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)))
+ (let ((car-type (specifier-type car-type-spec))
+ (cdr-type (specifier-type cdr-type-spec)))
+ (make-cons-type car-type cdr-type)))
(!define-type-method (cons :unparse) (type)
(let ((car-eltype (type-specifier (cons-type-car-type type)))
(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)))))
-
+ ;; UGH. -- CSR, 2003-02-24
+ (macrolet ((frob-car (car1 car2 cdr1 cdr2)
+ `(type-union
+ (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
+ (make-cons-type
+ (type-intersection ,car2
+ (specifier-type
+ `(not ,(type-specifier ,car1))))
+ ,cdr2))))
+ (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 car-type1 car-type2)
+ cdr-type1))
+ ((csubtypep car-type1 car-type2)
+ (frob-car car-type1 car-type2 cdr-type1 cdr-type2))
+ ((csubtypep car-type2 car-type1)
+ (frob-car car-type2 car-type1 cdr-type2 cdr-type1))
+ ;; Don't put these in -- consider the effect of taking the
+ ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
+ ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
+ #+nil
+ ((csubtypep cdr-type1 cdr-type2)
+ (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2))
+ #+nil
+ ((csubtypep cdr-type2 cdr-type1)
+ (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1))))))
+
(!define-type-method (cons :simple-intersection2) (type1 type2)
(declare (type cons-type type1 type2))
(let (car-int2
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
+ :complexp :maybe
:element-type (specifier-type element-type))))
(!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)
- :complexp nil)))
+ :complexp nil
+ :element-type (specifier-type element-type))))
\f
;;;; utilities shared between cross-compiler and target system
(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype)
(declare (type ctype defined-ftype declared-ftype))
(flet ((is-built-in-class-function-p (ctype)
- (and (built-in-class-p ctype)
- (eq (built-in-class-%name ctype) 'function))))
+ (and (built-in-classoid-p ctype)
+ (eq (built-in-classoid-name ctype) 'function))))
(cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
(is-built-in-class-function-p declared-ftype)
projects / sbcl.git / blobdiff