Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv4113/src/compiler/generic
A couple of type-system fixups for #+sb-eval
... we have to have sb-eval:interpreted-function defined
on the host, so that the deftype for COMPILED-FUNCTION
does not involve any unknown types. So
... make !defstruct-with-alternate-metaclass compilable by the
host compiler, similarly to sb-xc:defstruct. Don't
quite do it properly: put a FIXME note in for posterity.
... move early-full-eval.lisp earlier in the build, and split
out the definition for compiled-function from
deftypes-for-target to late-deftypes-for-target (after
the interpreted-function class is defined)
... (declare (type compiled-function x)) should do a type check
for compiled-function, not for simply FUNCTION.
... the problem was actually in PRIMITIVE-TYPE on intersection
types; the computation was fairly bogus. Make it less
... also delete some stale classoid symbols.
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/primtype.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- primtype.lisp 8 Mar 2006 18:49:57 -0000 1.23
+++ primtype.lisp 14 Sep 2006 21:10:44 -0000 1.24
@@ -313,19 +313,33 @@
(let ((types (intersection-type-types type))
- (res (any))
- (exact nil))
- (dolist (type types (values res exact))
- (multiple-value-bind (ptype ptype-exact)
+ (res (any)))
+ ;; why NIL for the exact? Well, we assume that the
+ ;; intersection type is in fact doing something for us:
+ ;; that is, that each of the types in the intersection is
+ ;; in fact cutting off some of the type lattice. Since no
+ ;; intersection type is represented by a primitive type and
+ ;; primitive types are mutually exclusive, it follows that
+ ;; no intersection type can represent the entirety of the
+ ;; primitive type. (And NIL is the conservative answer,
+ ;; anyway). -- CSR, 2006-09-14
+ (dolist (type types (values res nil))
+ (multiple-value-bind (ptype)
- (when ptype-exact
- (aver (or (not exact) (eq ptype res)))
- (setq exact t))
- (when (or ptype-exact (and (not exact) (eq res (any))))
- ;; Try to find a narrower representation then
- ;; (any). Takes care of undecidable types in
- ;; intersections with decidable ones.
- (setq res ptype))))))
+ ;; if the result so far is (any), any improvement on
+ ;; the specificity of the primitive type is valid.
+ ((eq res (any))
+ (setq res ptype))
+ ;; if the primitive type returned is (any), the
+ ;; result so far is valid. Likewise, if the
+ ;; primitive type is the same as the result so far,
+ ;; everything is fine.
+ ((or (eq ptype (any)) (eq ptype res)))
+ ;; otherwise, we have something hairy and confusing,
+ ;; such as (and condition funcallable-instance).
+ ;; Punt.
+ (t (return (any))))))))
(let* ((members (member-type-members type))
(res (primitive-type-of (first members))))