From ecb4ed10ea21cfb09239c299b165aede1b6bf58b Mon Sep 17 00:00:00 2001
From: Marius Gerbershagen <marius.gerbershagen@gmail.com>
Date: Sat, 2 Jan 2021 16:38:21 +0100
Subject: [PATCH] cmp: fix progv for return during evaluation of symbol and
 value arguments

Closes #620.
---
 src/cmp/cmpvar.lsp                  | 11 +++++------
 src/tests/normal-tests/compiler.lsp | 24 ++++++++++++++++++++++++
 2 files changed, 29 insertions(+), 6 deletions(-)

diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp
index 590b3081..5da23a69 100644
--- a/src/cmp/cmpvar.lsp
+++ b/src/cmp/cmpvar.lsp
@@ -394,16 +394,15 @@
   (let* ((*lcl* *lcl*)
          (lcl (next-lcl))
          (sym-loc (make-lcl-var))
-         (val-loc (make-lcl-var))
-         (*unwind-exit* (cons lcl *unwind-exit*)))
+         (val-loc (make-lcl-var)))
     (wt-nl-open-brace)
     (wt-nl "cl_object " sym-loc ", " val-loc "; cl_index " lcl ";")
     (let ((*destination* sym-loc)) (c2expr* symbols))
     (let ((*destination* val-loc)) (c2expr* values))
-    (wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
-    (c2expr body)
-    (wt-nl-close-brace)
-    ))
+    (let ((*unwind-exit* (cons lcl *unwind-exit*)))
+      (wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
+      (c2expr body)
+      (wt-nl-close-brace))))
 
 (defun c1psetq (old-args &aux (args nil) (use-psetf nil))
   ;; A first pass ensures that none of the assigned locations is
diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp
index 500253e1..67b09621 100644
--- a/src/tests/normal-tests/compiler.lsp
+++ b/src/tests/normal-tests/compiler.lsp
@@ -1943,3 +1943,27 @@
            (code `(defmethod test-method ()
                     ,test-obj)))
       (finishes (eval code)))))
+
+;;; Date 2021-01-02
+;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/620
+;;; Description
+;;;
+;;;     RETURN inside the symbol or value arguments for PROGV leads to
+;;;     a segfault
+(ext:with-clean-symbols (*s*)
+  (test cmp.0083.progv-return
+    (proclaim '(special *s*))
+    (is (eql 0 (funcall (compile nil
+                                 '(lambda ()
+                                   (block nil
+                                     (progv (list (return 0)) (list 1))))))))
+    (is (eql 0 (funcall (compile nil
+                                 '(lambda ()
+                                   (block nil
+                                     (progv '(*s*) (list (return 0)))))))))
+    (is (not (boundp '*s*)))
+    (is (eql 1 (funcall (compile nil
+                                 '(lambda ()
+                                   (block nil
+                                     (progv '(*s*) (list 0) (return 1) *s*)))))))
+    (is (not (boundp '*s*)))))