X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=3d848ac4d2085d26a1f7726ee01587f06bb9d230;hb=e049902f5e7c30501d2dbb7a41d058a0c717fc1f;hp=d32325b6923caed5e75b8358a01de555cb37266c;hpb=df81175171338132825adfd1e522f350878986da;p=sbcl.git

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index d32325b..3d848ac 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -291,7 +291,7 @@
 
     (cond ((and (eq (continuation-type-check cont) t)
 		(multiple-value-bind (check types)
-		    (continuation-check-types cont)
+		    (continuation-check-types cont nil)
 		  (aver (eq check :simple))
 		  ;; If the proven type is a subtype of the possibly
 		  ;; weakened type check then it's always true and is
@@ -323,7 +323,7 @@
 	 (nlocs (length locs)))
     (aver (= nlocs (length ptypes)))
     (if (eq (continuation-type-check cont) t)
-	(multiple-value-bind (check types) (continuation-check-types cont)
+	(multiple-value-bind (check types) (continuation-check-types cont nil)
 	  (aver (eq check :simple))
 	  (let ((ntypes (length types)))
 	    (mapcar (lambda (from to-type assertion)
@@ -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