0.8.0.39:

        * Convert proclaimed function result type into a type check.
        ... recanned several incautious worms.

diff --git a/BUGS b/BUGS
index 95fa250..1d1a83d 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -722,63 +722,6 @@ WORKAROUND:
           :ACCRUED-EXCEPTIONS (:INEXACT)
           :FAST-MODE NIL)
 
-187: "type inference confusion around DEFTRANSFORM time"
-  (reported even more verbosely on sbcl-devel 2002-06-28 as "strange
-  bug in DEFTRANSFORM")
-  After the file below is compiled and loaded in sbcl-0.7.5, executing
-    (TCX (MAKE-ARRAY 4 :FILL-POINTER 2) 0)
-  at the REPL returns an adjustable vector, which is wrong. Presumably
-  somehow the DERIVE-TYPE information for the output values of %WAD is
-  being mispropagated as a type constraint on the input values of %WAD,
-  and so causing the type test to be optimized away. It's unclear how
-  hand-expanding the DEFTRANSFORM would change this, but it suggests
-  the DEFTRANSFORM machinery (or at least the way DEFTRANSFORMs are
-  invoked at a particular phase) is involved.
-    (cl:in-package :sb-c)
-    (eval-when (:compile-toplevel)
-    ;;; standin for %DATA-VECTOR-AND-INDEX
-    (defknown %dvai (array index) 
-      (values t t) 
-      (foldable flushable))
-    (deftransform %dvai ((array index)
-                         (vector t)
-                         *
-                         :important t)
-      (let* ((atype (continuation-type array))
-             (eltype (array-type-specialized-element-type atype)))
-        (when (eq eltype *wild-type*)
-          (give-up-ir1-transform
-           "specialized array element type not known at compile-time"))
-        (when (not (array-type-complexp atype))
-          (give-up-ir1-transform "SIMPLE array!"))
-        `(if (array-header-p array)
-             (%wad array index nil)
-             (values array index))))
-    ;;; standin for %WITH-ARRAY-DATA
-    (defknown %wad (array index (or index null))
-      (values (simple-array * (*)) index index index)
-      (foldable flushable))
-    ;;; (Commenting out this optimizer causes the bug to go away.)
-    (defoptimizer (%wad derive-type) ((array start end))
-      (let ((atype (continuation-type array)))
-        (when (array-type-p atype)
-          (values-specifier-type
-           `(values (simple-array ,(type-specifier
-                                    (array-type-specialized-element-type atype))
-                                  (*))
-                    index index index)))))
-    ) ; EVAL-WHEN
-    (defun %wad (array start end)
-      (format t "~&in %WAD~%")
-      (%with-array-data array start end))
-    (cl:in-package :cl-user)
-    (defun tcx (v i)
-      (declare (type (vector t) v))
-      (declare (notinline sb-kernel::%with-array-data))
-      ;; (Hand-expending DEFTRANSFORM %DVAI here also causes the bug to
-      ;; go away.) 
-      (sb-c::%dvai v i))
-
 188: "compiler performance fiasco involving type inference and UNION-TYPE"
   (In sbcl-0.7.6.10, DEFTRANSFORM CONCATENATE was commented out until this
   bug could be fixed properly, so you won't see the bug unless you restore

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 3993a91..2b817a3 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -51,7 +51,9 @@
 
 (defun %data-vector-and-index (array index)
   (if (array-header-p array)
-      (%with-array-data array index nil)
+      (multiple-value-bind (vector index)
+          (%with-array-data array index nil)
+        (values vector index))
       (values array index)))
 
 ;;; It'd waste space to expand copies of error handling in every

diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index fe13620..68e5d9f 100644 (file)
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -296,7 +296,7 @@
   "Return the logarithm of NUMBER in the base BASE, which defaults to e."
   (if base-p
       (cond
-       ((zerop base) base) ; ANSI spec
+       ((zerop base) 0f0) ; FIXME: type
        ((and (typep number '(integer (0) *))
              (typep base '(integer (0) *)))
         (coerce (/ (log2 number) (log2 base)) 'single-float))

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index e7de625..c76ee42 100644 (file)
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -817,8 +817,7 @@ a host-structure or string."
 (defun namestring (pathname)
   #!+sb-doc
   "Construct the full (name)string form of the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (when pathname
       (let ((host (%pathname-host pathname)))
@@ -830,8 +829,7 @@ a host-structure or string."
 (defun host-namestring (pathname)
   #!+sb-doc
   "Return a string representation of the name of the host in the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -843,8 +841,7 @@ a host-structure or string."
 (defun directory-namestring (pathname)
   #!+sb-doc
   "Return a string representation of the directories used in the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -856,8 +853,7 @@ a host-structure or string."
 (defun file-namestring (pathname)
   #!+sb-doc
   "Return a string representation of the name used in the pathname."
-  (declare (type pathname-designator pathname)
-          (values (or null simple-base-string)))
+  (declare (type pathname-designator pathname))
   (with-pathname (pathname pathname)
     (let ((host (%pathname-host pathname)))
       (if host
@@ -1429,11 +1425,12 @@ a host-structure or string."
                    ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return
                    ;; the original directory.
                    path-directory))))
-    (make-pathname :host (pathname-host pathname)
-                   :directory enough-directory
-                   :name (pathname-name pathname)
-                   :type (pathname-type pathname)
-                   :version (pathname-version pathname))))
+    (unparse-logical-namestring
+     (make-pathname :host (pathname-host pathname)
+                    :directory enough-directory
+                    :name (pathname-name pathname)
+                    :type (pathname-type pathname)
+                    :version (pathname-version pathname)))))
 
 (defun unparse-logical-namestring (pathname)
   (declare (type logical-pathname pathname))

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index d58a2af..d331db6 100644 (file)
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -725,23 +725,21 @@
               (find-lambda-types functional type where))))
       (let* ((type-returns (fun-type-returns type))
             (return (lambda-return (main-entry functional)))
-            (atype (when return
-                      nil
-                     #+nil(continuation-derived-type (return-result return))))) ; !!
+            (dtype (when return
+                      (continuation-derived-type (return-result return)))))
        (cond
-        ((and atype (not (values-types-equal-or-intersect atype
+        ((and dtype (not (values-types-equal-or-intersect dtype
                                                           type-returns)))
          (note-lossage
           "The result type from ~A:~%  ~S~@
-          conflicts with the definition's result type assertion:~%  ~S"
-          where (type-specifier type-returns) (type-specifier atype))
+          conflicts with the definition's result type:~%  ~S"
+          where (type-specifier type-returns) (type-specifier dtype))
          nil)
         (*lossage-detected* nil)
         ((not really-assert) t)
         (t
-         (when atype
-           (assert-continuation-type (return-result return) atype
-                                      (lexenv-policy (functional-lexenv functional))))
+         (assert-continuation-type (return-result return) type-returns
+                                    (lexenv-policy (functional-lexenv functional)))
          (loop for var in vars and type in types do
            (cond ((basic-var-sets var)
                   (when (and unwinnage-fun

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 1bb7372..7112bf1 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -634,7 +634,8 @@
 (defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence
   (call)
   :derive-type (sequence-result-nth-arg 1))
-(defknown sb!impl::sort-vector (vector index index function (or function null)) vector
+(defknown sb!impl::sort-vector (vector index index function (or function null))
+  * ; SORT-VECTOR works through side-effect
   (call))
 
 (defknown merge (type-specifier sequence sequence callable
@@ -1065,9 +1066,9 @@
                           (member nil :host :device
                                   :directory :name
                                   :type :version))
-  boolean
+  t
   ())
-(defknown pathname-match-p (pathname-designator pathname-designator) boolean
+(defknown pathname-match-p (pathname-designator pathname-designator) t
   ())
 (defknown translate-pathname (pathname-designator
                              pathname-designator
@@ -1131,7 +1132,7 @@
   pathname-version (flushable))
 
 (defknown (namestring file-namestring directory-namestring host-namestring)
-  (pathname-designator) simple-string
+  (pathname-designator) (or simple-string null)
   (unsafely-flushable))
 
 (defknown enough-namestring (pathname-designator &optional pathname-designator)

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index c57459a..15943b7 100644 (file)
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -47,7 +47,7 @@
 
 ;;; Make the default keyword for a &KEY arg, checking that the keyword
 ;;; isn't already used by one of the VARS.
-(declaim (ftype (sfunction (symbol list t) keyword) make-keyword-for-arg))
+(declaim (ftype (sfunction (symbol list t) symbol) make-keyword-for-arg))
 (defun make-keyword-for-arg (symbol vars keywordify)
   (let ((key (if (and keywordify (not (keywordp symbol)))
                 (keywordicate symbol)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c1a53a9..124d841 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3431,7 +3431,7 @@
                   (loop for i of-type index
                         from (ash current-heap-size -1) downto 1 do
                         (%heapify i))
-                  (loop 
+                  (loop
                    (when (< current-heap-size 2)
                      (return))
                    (rotatef (%elt 1) (%elt current-heap-size))

diff --git a/version.lisp-expr b/version.lisp-expr
index 3ea0b99..fab9773 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.38"
+"0.8.0.39"