From: Alexey Dejneka <adejneka@comail.ru>
Date: Thu, 5 Jun 2003 06:24:26 +0000 (+0000)
Subject: 0.8.0.34:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d7ca32c95549ea9dd6c68b813c4ac1f1d66984e1;p=sbcl.git

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

diff --git a/BUGS b/BUGS
index aa0675e..95fa250 100644
--- 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
--- 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
--- 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
--- 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
--- 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)))
 
 ;;; 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
--- 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
--- 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
--- 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"