0.8.0.34:

        * Fixed bug 253.
        * "Exactly" declare types of alien routines.

diff --git a/BUGS b/BUGS
index aa0675e..95fa250 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1180,23 +1180,13 @@ WORKAROUND:
   does not cause a warning. (BTW: old SBCL issued a warning, but for a
   function, which was never called!)
 
-252:
-  (reported by Eric Marsden on sbcl-devel 2003-06-02)
-  Block-compiling (using the :block-compile argument to COMPILE-FILE)
-  causes an internal error on a simple file containing
-
-    (defun foo (x)
-      (list x))
-    (defun bar (x)
-      (+ x (foo x)))
-
-  (fixed in 0.8.0.27)
-
 253: "type checking is embedded THEs"
   Compiler cannot perform type checking in
 
     (let () (list (the fixnum (the unsigned-byte (eval -1)))))
 
+  (fixed in 0.8.0.34)
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index cb061ee..fe4aff5 100644 (file)
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -678,7 +678,7 @@
         ;; alien values) both messy to do by hand and very important
         ;; for performance of later code which uses the return value.
         (declaim (ftype (function ,(lisp-arg-types)
-                                   (values ,@(lisp-result-types)))
+                                   (values ,@(lisp-result-types) &optional))
                          ,lisp-name))
         (defun ,lisp-name ,(lisp-args)
           ,@(docs)

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index ec5e9aa..e437e9b 100644 (file)
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -244,6 +244,7 @@
                 ((and (continuation-single-value-p cont)
                       (or (not (args-type-rest ctype))
                           (eq (args-type-rest ctype) *universal-type*)))
+                 (principal-continuation-single-valuify cont)
                  (let ((creq (car (args-type-required ctype))))
                    (multiple-value-setq (ctype atype)
                      (if creq

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index d7afaee..f65cc3a 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1720,6 +1720,7 @@
   (unless (continuation-single-value-p (node-cont node))
     (give-up-ir1-transform))
   (setf (node-derived-type node) *wild-type*)
+  (principal-continuation-single-valuify (node-cont node))
   (if vals
       (let ((dummies (make-gensym-list (length (cdr vals)))))
        `(lambda (val ,@dummies)

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 39ea55e..eaf3377 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -515,11 +515,6 @@
       (mv-combination
        (eq (basic-combination-fun dest) cont))
       (cast
-       nil
-       ;; The following property means that the cast chain allows
-       ;; changing number of values, produced by the USE of CONT, but
-       ;; derived types of the casts must be updated (TODO: how?).
-       #+nil
        (locally
            (declare (notinline continuation-single-value-p))
          (and (not (values-type-p (cast-asserted-type dest)))
@@ -532,6 +527,15 @@
         for dest = (continuation-dest prev)
         while (cast-p dest)
         finally (return (values dest prev))))
+
+(defun principal-continuation-single-valuify (cont)
+  (loop for prev = cont then (node-cont dest)
+     for dest = (continuation-dest prev)
+     while (cast-p dest)
+     do (setf (node-derived-type dest)
+              (make-short-values-type (list (single-value-type
+                                             (node-derived-type dest)))))
+     (reoptimize-continuation prev)))
 \f
 ;;; Return a new LEXENV just like DEFAULT except for the specified
 ;;; slot values. Values for the alist slots are NCONCed to the

diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index bca2bda..e37c4f1 100644 (file)
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -704,21 +704,6 @@
     (relist*
      form locally walked-body)))
 
-(defun walk-let-if (form context env)
-  (let ((test (cadr form))
-       (bindings (caddr form))
-       (body (cdddr form)))
-    (walk-form-internal
-      `(let ()
-        (declare (special ,@(mapcar (lambda (x) (if (listp x) (car x) x))
-                                    bindings)))
-        (flet ((.let-if-dummy. () ,@body))
-          (if ,test
-              (let ,bindings (.let-if-dummy.))
-              (.let-if-dummy.))))
-      context
-      env)))
-
 (defun walk-multiple-value-setq (form context env)
   (let ((vars (cadr form)))
     (if (some (lambda (var)

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 5691e98..c1ad3e3 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -402,3 +402,10 @@
                                 :external-format '#:nonsense)))
 
 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
+
+(let ((f (compile nil
+                  '(lambda (v)
+                    (declare (optimize (safety 3)))
+                    (list (the fixnum (the (real 0) (eval v))))))))
+  (assert (raises-error? (funcall f 0.1) type-error))
+  (assert (raises-error? (funcall f -1) type-error)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 0ef889b..37dd033 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.33"
+"0.8.0.34"