0.6.10.6:

	defined INTERSECTION-TYPE by analogy with UNION-TYPE (aiming
		to fix bug #12)
	renamed PUNT blocknames in type methods to PUNT-TYPE-METHOD
	renamed PUNT-IF-TOO-LONG to PUNT-PRINT-IF-TOO-LONG

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 9ea843f..762ce26 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1061,7 +1061,7 @@ is a good idea, but see SB-SYS for blurring of boundaries."
              "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"
              "PARSE-DEFMACRO" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE"
              "PARSE-UNKNOWN-TYPE-SPECIFIER"
-             "PATHNAME-DESIGNATOR" "PUNT-IF-TOO-LONG"
+             "PATHNAME-DESIGNATOR" "PUNT-PRINT-IF-TOO-LONG"
              "READER-PACKAGE-ERROR"
              #!+gengc "*SAVED-STATE-CHAIN*"
              "SCALE-DOUBLE-FLOAT" "SCALE-LONG-FLOAT"

diff --git a/src/code/early-print.lisp b/src/code/early-print.lisp
index 5dd2e92..6f7d9e6 100644 (file)
--- a/src/code/early-print.lisp
+++ b/src/code/early-print.lisp
@@ -33,7 +33,7 @@
              (let ((*current-level* (1+ *current-level*)))
                (,flet-name)))))))
 
-(defmacro punt-if-too-long (index stream)
+(defmacro punt-print-if-too-long (index stream)
   #!+sb-doc
   "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY*
    is NIL) by outputting \"...\" and returning from the block named NIL."

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index c4fe88a..1b34a4e 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -84,8 +84,9 @@
         form)))
 
 ;;; A HAIRY-TYPE represents anything too weird to be described
-;;; reasonably or to be useful, such as AND, NOT and SATISFIES and
-;;; unknown types. We just remember the original type spec.
+;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
+;;; and unreasonably complicated types involving AND. We just remember
+;;; the original type spec.
 (defstruct (hairy-type (:include ctype
                                 (class-info (type-class-or-lose 'hairy))
                                 (enumerable t))

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 576c771..e9c4a67 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1503,7 +1503,7 @@
          t))
 
 (!define-type-method (member :complex-subtypep-arg1) (type1 type2)
-  (block PUNT
+  (block punt-type-method
     (values (every-type-op ctypep type2 (member-type-members type1)
                           :list-first t)
            t)))
@@ -1530,13 +1530,13 @@
            t)))
 
 (!define-type-method (member :complex-intersection) (type1 type2)
-  (block PUNT
+  (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)
@@ -1575,6 +1575,42 @@
     (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
@@ -1595,7 +1631,7 @@
 ;;; 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
+  (block punt-type-method
     (let ((types1 (union-type-types type1))
          (types2 (union-type-types type2)))
       (values (and (dolist (type1 types1 t)
@@ -1609,7 +1645,7 @@
 ;;; 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
+  (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)
@@ -1617,13 +1653,13 @@
              t))))
 
 (!define-type-method (union :complex-subtypep-arg1) (type1 type2)
-  (block PUNT
+  (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
+  (block punt-type-method
     (values (any-type-op csubtypep type1 (union-type-types type2)) t)))
 
 (!define-type-method (union :complex-union) (type1 type2)

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 7b4d3fe..d715bf1 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -925,7 +925,7 @@
     (let ((length 0)
          (list list))
       (loop
-       (punt-if-too-long length stream)
+       (punt-print-if-too-long length stream)
        (output-object (pop list) stream)
        (unless list
          (return))
@@ -958,7 +958,7 @@
           (dotimes (i (length vector))
             (unless (zerop i)
               (write-char #\space stream))
-            (punt-if-too-long i stream)
+            (punt-print-if-too-long i stream)
             (output-object (aref vector i) stream))
           (write-string ")" stream)))))
 
@@ -1020,13 +1020,13 @@
             (dotimes (i dimension)
               (unless (zerop i)
                 (write-char #\space stream))
-              (punt-if-too-long i stream)
+              (punt-print-if-too-long i stream)
               (sub-output-array-guts array dimensions stream index)
               (incf index count)))
           (write-char #\) stream)))))
 
-;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for use
-;;; until CLOS is set up (at which time it will be replaced with
+;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
+;;; use until CLOS is set up (at which time it will be replaced with
 ;;; the real generic function implementation)
 (defun print-object (instance stream)
   (default-structure-print instance stream *current-level*))

diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp
index b160271..0d76fe9 100644 (file)
--- a/src/code/typedefs.lisp
+++ b/src/code/typedefs.lisp
@@ -106,7 +106,7 @@
           (,n-uncertain nil))
        (dolist (,n-this ,list
                        (if ,n-uncertain
-                           (return-from PUNT ,default)
+                           (return-from punt-type-method ,default)
                            nil))
         (multiple-value-bind (,n-val ,n-win)
             ,(if list-first
@@ -126,7 +126,7 @@
             ,(if list-first
                  `(,op ,n-this ,n-thing)
                `(,op ,n-thing ,n-this))
-          (unless ,n-win (return-from PUNT ,default))
+          (unless ,n-win (return-from punt-type-method ,default))
           (unless ,n-val (return nil)))))))
 
 ;;; Compute the intersection for types that intersect only when one is a

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index 7204f6f..e2f4340 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -372,7 +372,8 @@
                             (declare (ignorable ,type-var ,class-var
                                                 ,value-var))
                             ,@body
-                            (unless (zerop (logand ,n-info compact-info-entry-last))
+                            (unless (zerop (logand ,n-info
+                                                   compact-info-entry-last))
                               (return-from ,PUNT))))))))))))))
 
 ;;; Return code to iterate over a volatile info environment.

diff --git a/version.lisp-expr b/version.lisp-expr
index e5b2320..bd39bec 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -15,4 +15,4 @@
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
-"0.6.10.5"
+"0.6.10.6"