0.8.3.12:

        * Fix bug in RETURN clause of LOOP
        ... make RETURN be equivalent to DO (RETURN ...)
        * cosmetic changes in constraint propagator;
        * fix EVAL-WHEN and package problem in
          compiler.impure-cload.test from the last commit.

diff --git a/src/code/loop.lisp b/src/code/loop.lisp
index 4be06cb..c000ead 100644 (file)
--- a/src/code/loop.lisp
+++ b/src/code/loop.lisp
@@ -1156,7 +1156,7 @@ code to be loaded.
     (setq *loop-names* (list name))))
 
 (defun loop-do-return ()
-  (loop-pseudo-body (loop-construct-return (loop-get-form))))
+  (loop-emit-body (loop-construct-return (loop-get-form))))
 \f
 ;;;; value accumulation: LIST
 

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index e155afd..fea3f16 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -411,16 +411,16 @@
          (when (eq (functional-kind fun) :let)
            (loop with call = (continuation-dest
                               (node-cont (first (lambda-refs fun))))
-              for var in (lambda-vars fun)
-              and val in (combination-args call)
-              when (and val
-                        (lambda-var-constraints var)
-                        ;; if VAR has no SETs, type inference is
-                        ;; fully performed by IR1 optimizer
-                        (lambda-var-sets var))
-              do (let* ((type (continuation-type val))
-                        (con (find-constraint 'typep var type nil)))
-                   (sset-adjoin con gen))))))
+                 for var in (lambda-vars fun)
+                 and val in (combination-args call)
+                 when (and val
+                           (lambda-var-constraints var)
+                           ;; if VAR has no SETs, type inference is
+                           ;; fully performed by IR1 optimizer
+                           (lambda-var-sets var))
+                 do (let* ((type (continuation-type val))
+                           (con (find-constraint 'typep var type nil)))
+                      (sset-adjoin con gen))))))
       (ref
        (let ((var (ok-ref-lambda-var node)))
          (when var
@@ -432,16 +432,15 @@
                       (con (find-constraint 'typep var atype nil)))
                  (sset-adjoin con gen)))))))
       (cset
-       (let ((var (set-var node)))
-         (when (lambda-var-p var)
-           (when set-preprocessor
-             (funcall set-preprocessor var))
-           (let ((cons (lambda-var-constraints var)))
-             (when cons
-               (sset-difference gen cons)
-               (let* ((type (single-value-type (node-derived-type node)))
-                      (con (find-constraint 'typep var type nil)))
-                 (sset-adjoin con gen)))))))))
+       (binding* ((var (set-var node))
+                  (nil (lambda-var-p var) :exit-if-null)
+                  (cons (lambda-var-constraints var) :exit-if-null))
+         (when set-preprocessor
+           (funcall set-preprocessor var))
+         (sset-difference gen cons)
+         (let* ((type (single-value-type (node-derived-type node)))
+                (con (find-constraint 'typep var type nil)))
+           (sset-adjoin con gen))))))
 
   gen)
 
@@ -532,11 +531,9 @@
   (constraint-propagate-in-block
    block (block-in block)
    :ref-preprocessor (lambda (node cons)
-                       (let ((var (ref-leaf node)))
-                         (when (lambda-var-p var)
-                           (let ((con (lambda-var-constraints var)))
-                             (when con
-                               (constrain-ref-type node con cons))))))))
+                       (let* ((var (ref-leaf node))
+                              (con (lambda-var-constraints var)))
+                         (constrain-ref-type node con cons)))))
 
 ;;; Give an empty constraints set to any var that doesn't have one and
 ;;; isn't a set closure var. Since a var that we previously rejected

diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp
index 5982b02..05a1145 100644 (file)
--- a/tests/compiler.impure-cload.lisp
+++ b/tests/compiler.impure-cload.lisp
@@ -1,5 +1,6 @@
-(load "assertoid.lisp")
-(use-package "ASSERTOID")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (load "assertoid.lisp")
+  (use-package "ASSERTOID"))
 
 ;;; bug 254: compiler falure
 (defpackage :bug254 (:use :cl))
@@ -142,6 +143,8 @@
 
 (delete-package :bug258)
 
+(in-package :cl-user)
+
 ;;;
 (defun bug233a (x)
   (declare (optimize (speed 2) (safety 3)))

diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp
index e1cba00..a29eb99 100644 (file)
--- a/tests/compiler.pure-cload.lisp
+++ b/tests/compiler.pure-cload.lisp
@@ -60,6 +60,15 @@
                        a b)
                  '(1 2 :a 1 2))))
 
+;;; bug in LOOP, reported by ??? on c.l.l
+(flet ((foo (l)
+         (loop for x in l
+               when (symbolp x) return x
+               while (numberp x)
+               collect (list x))))
+  (assert (equal (foo '(1 2 #\a 3)) '((1) (2))))
+  (assert (equal (foo '(1 2 x 3)) 'x)))
+
 ;;; bug 282
 ;;;
 ;;; Verify type checking policy in full calls: the callee is supposed

diff --git a/version.lisp-expr b/version.lisp-expr
index 6a80a42..8655a3a 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.3.11"
+"0.8.3.12"