From: Alexey Dejneka <adejneka@comail.ru>
Date: Fri, 1 Nov 2002 17:31:49 +0000 (+0000)
Subject: 0.7.9.25:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cf6f2e4b33475c59d999e53d3d5c290726fe0a7c;p=sbcl.git

0.7.9.25:
        Fixed PROGV with different number of variables and values
        (bug from Paul Dietz' test suit)
---

diff --git a/NEWS b/NEWS
index f5f7b3c..739f51d 100644
--- a/NEWS
+++ b/NEWS
@@ -1363,6 +1363,8 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9:
         correct order
      ** MULTIPLE-VALUE-SETQ evaluates side-effectful places before
         value producing form
+     ** if more variables are given to PROGV than values, extra
+        variables are bound and made to have no value
    * fixed bug 166: compiler preserves "there is a way to go"
      invariant when deleting code
 
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index d32325b..b916025 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1333,15 +1333,26 @@
 (def-ir1-translator progv ((vars vals &body body) start cont)
   (ir1-convert
    start cont
-   (once-only ((n-save-bs '(%primitive current-binding-pointer)))
-     `(unwind-protect
-	  (progn
-	    (mapc (lambda (var val)
-		    (%primitive bind val var))
-		  ,vars
-		  ,vals)
-	    ,@body)
-	(%primitive unbind-to-here ,n-save-bs)))))
+   (let ((bind (gensym "BIND"))
+         (unbind (gensym "UNBIND")))
+     (once-only ((n-save-bs '(%primitive current-binding-pointer)))
+                `(unwind-protect
+                      (progn
+                        (labels ((,unbind (vars)
+                                   (declare (optimize (speed 2) (debug 0)))
+                                   (dolist (var vars)
+                                     (%primitive bind nil var)
+                                     (makunbound var)))
+                                 (,bind (vars vals)
+                                   (declare (optimize (speed 2) (debug 0)))
+                                   (cond ((null vars))
+                                         ((null vals) (,unbind vars))
+                                         (t (%primitive bind (car vals) (car vars))
+                                            (,bind (cdr vars) (cdr vals))))))
+                          (,bind ,vars ,vals))
+                        nil
+                        ,@body)
+                   (%primitive unbind-to-here ,n-save-bs))))))
 
 ;;;; non-local exit
 
diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp
index c1b5ef1..3f913cf 100644
--- a/tests/compiler.pure-cload.lisp
+++ b/tests/compiler.pure-cload.lisp
@@ -35,3 +35,27 @@
 ;;; This is a slightly different way of getting the same symptoms out
 ;;; of the sbcl-0.6.11.13 byte compiler bug.
 (print (setq *print-level* *print-level*))
+
+;;; PROGV with different numbers of variables and values
+(let ((a 1))
+  (declare (special a))
+  (assert (equal (list a (progv '(a b) '(:a :b :c)
+                           (assert (eq (symbol-value 'nil) nil))
+                           (list (symbol-value 'a) (symbol-value 'b)))
+                       a)
+                 '(1 (:a :b) 1)))
+  (assert (equal (list a (progv '(a b) '(:a :b)
+                           (assert (eq (symbol-value 'nil) nil))
+                           (list (symbol-value 'a) (symbol-value 'b)))
+                       a)
+                 '(1 (:a :b) 1)))
+  (assert (not (boundp 'b))))
+
+(let ((a 1) (b 2))
+  (declare (special a b))
+  (assert (equal (list a b (progv '(a b) '(:a)
+                             (assert (eq (symbol-value 'nil) nil))
+                             (assert (not (boundp 'b)))
+                             (symbol-value 'a))
+                       a b)
+                 '(1 2 :a 1 2))))
diff --git a/version.lisp-expr b/version.lisp-expr
index b5cf244..02ea309 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.24"
+"0.7.9.25"