Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory sc8prcvs8.sourceforge.net:/tmp/cvsserv4113/src/compiler/generic
Modified Files:
primtype.lisp
Log Message:
0.9.16.30:
A couple of typesystem fixups for #+sbeval
... we have to have sbeval:interpretedfunction defined
on the host, so that the deftype for COMPILEDFUNCTION
does not involve any unknown types. So
... make !defstructwithalternatemetaclass compilable by the
host compiler, similarly to sbxc:defstruct. Don't
quite do it properly: put a FIXME note in for posterity.
... move earlyfulleval.lisp earlier in the build, and split
out the definition for compiledfunction from
deftypesfortarget to latedeftypesfortarget (after
the interpretedfunction class is defined)
... (declare (type compiledfunction x)) should do a type check
for compiledfunction, not for simply FUNCTION.
... the problem was actually in PRIMITIVETYPE on intersection
types; the computation was fairly bogus. Make it less
bogus.
... also delete some stale classoid symbols.
Index: primtype.lisp
===================================================================
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 @@
(return (any)))))))))))
(intersectiontype
(let ((types (intersectiontypetypes type))
 (res (any))
 (exact nil))
 (dolist (type types (values res exact))
 (multiplevaluebind (ptype ptypeexact)
+ (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, 20060914
+ (dolist (type types (values res nil))
+ (multiplevaluebind (ptype)
(primitivetype type)
 (when ptypeexact
 (aver (or (not exact) (eq ptype res)))
 (setq exact t))
 (when (or ptypeexact (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))))))
+ (cond
+ ;; 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 funcallableinstance).
+ ;; Punt.
+ (t (return (any))))))))
(membertype
(let* ((members (membertypemembers type))
(res (primitivetypeof (first members))))
