From: Taylor R Campbell <campbell@mumble.net>
Date: Mon, 26 Aug 2019 00:21:27 +0000 (+0000)
Subject: Fix store-value restarts for unassigned/unbound variable references.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~61
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8cbede4dbb7956d077fba4c29236e0523da20fbd;p=mit-scheme.git

Fix store-value restarts for unassigned/unbound variable references.

Turns out these have been busted since 2007...
---

diff --git a/src/microcode/cmpint.c b/src/microcode/cmpint.c
index 8d93fdb23..fe34a0fe1 100644
--- a/src/microcode/cmpint.c
+++ b/src/microcode/cmpint.c
@@ -1395,7 +1395,7 @@ DEFINE_SCHEME_ENTRY (comp_lookup_trap_restart)
 {
   RESTORE_LAST_RETURN_CODE ();
   {
-    SCHEME_OBJECT name = GET_EXP;
+    SCHEME_OBJECT name = (STACK_POP ());
     SCHEME_OBJECT environment = (STACK_POP ());
     SCHEME_OBJECT val;
     long code = (lookup_variable (environment, name, (&val)));
@@ -1436,7 +1436,7 @@ DEFINE_SCHEME_ENTRY (comp_safe_lookup_trap_restart)
 {
   RESTORE_LAST_RETURN_CODE ();
   {
-    SCHEME_OBJECT name = GET_EXP;
+    SCHEME_OBJECT name = (STACK_POP ());
     SCHEME_OBJECT environment = (STACK_POP ());
     SCHEME_OBJECT val;
     long code = (safe_lookup_variable (environment, name, (&val)));
@@ -1477,7 +1477,7 @@ DEFINE_SCHEME_ENTRY (comp_unassigned_p_trap_restart)
 {
   RESTORE_LAST_RETURN_CODE ();
   {
-    SCHEME_OBJECT name = GET_EXP;
+    SCHEME_OBJECT name = (STACK_POP ());
     SCHEME_OBJECT environment = (STACK_POP ());
     SCHEME_OBJECT val;
     long code = (variable_unassigned_p (environment, name, (&val)));
diff --git a/tests/compiler/test-vartrap.scm b/tests/compiler/test-vartrap.scm
index 139c6c757..529d2d47f 100644
--- a/tests/compiler/test-vartrap.scm
+++ b/tests/compiler/test-vartrap.scm
@@ -33,27 +33,40 @@ USA.
       (body)
       (xfail body)))
 
-(define-test 'restart-unassigned
-  (lambda ()
-    (define program
-      '(begin
-         (declare (usual-integrations))
-         (define null)                  ;unassigned
-         (define (map1 f l)
-           (let loop ((l l))
-             (if (pair? l)
-                 (cons (f (car l)) (loop (cdr l)))
-                 null)))
-         map1))
-    (let* ((env (make-top-level-environment))
-           (scode (syntax&integrate program '() env))
-           (expr (compile-scode scode))
-           (map1 (eval expr env)))
-      (assert-equal
-       (bind-condition-handler (list condition-type:unassigned-variable)
-           (lambda (condition)
-             condition
-             (use-value '()))
-         (lambda ()
-           (map1 - '(1 2 3))))
-       '(-1 -2 -3)))))
+(define (define-restart-test name definitions condition-type restarter)
+  (define-test name
+    (lambda ()
+      (define program
+        `(begin
+           (declare (usual-integrations))
+           ,@definitions
+           (define (map1 f l)
+             (let loop ((l l))
+               (if (pair? l)
+                   (cons (f (car l)) (loop (cdr l)))
+                   null)))
+           map1))
+      (let* ((env (make-top-level-environment))
+             (scode (syntax&integrate program '() env))
+             (expr (compile-scode scode))
+             (map1 (eval expr env)))
+        (assert-equal
+         (bind-condition-handler (list condition-type)
+             (lambda (condition)
+               condition
+               (restarter '()))
+           (lambda ()
+             (map1 - '(1 2 3))))
+         '(-1 -2 -3))))))
+
+(define-restart-test 'unbound/use-value '()
+  condition-type:unbound-variable use-value)
+
+(define-restart-test 'unbound/store-value '()
+  condition-type:unbound-variable store-value)
+
+(define-restart-test 'unassigned/use-value '((define null))
+  condition-type:unassigned-variable use-value)
+
+(define-restart-test 'unassigned/store-value '((define null))
+  condition-type:unassigned-variable store-value)