compiler/vm: implement sys:abscond-from special form.

* share/txr/stdlib/asm.tl (abscsr): New instruction.
(op-abscsr): New opcode class, derived from op-retsr.

* share/txr/stdlib/compiler.tl: Handle sys:abscond-from via
comp-return-from method.
(compiler comp-return-from): Handle sys:abscond-from by
switching to abscsr opcode instead of ret pseudo-op.

* vm.c (vm_abscsr): New static function.
(vm_execute): Dispatch ABSCSR opcode.

* vmop.h: Regenerated.

4 files changed, 30 insertions, 14 deletions

diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl
index b6e8dff5..88c801e2 100644
--- a/share/txr/stdlib/asm.tl
+++ b/share/txr/stdlib/asm.tl
@@ -569,6 +569,8 @@
                                (t 'retrr))]))
         real.(asm asm syntax)))))
 
+(defopcode-derived op-abscsr abscsr auto op-retsr)
+
 (defopcode op-catch catch auto
   (:method asm (me asm syntax)
     me.(chk-arg-count 4 syntax)
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index f1ccccd4..ad78295c 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -176,7 +176,7 @@
             (if me.(comp-if oreg env form))
             (unwind-protect me.(comp-unwind-protect oreg env form))
             ((block block*) me.(comp-block oreg env form))
-            (return-from me.(comp-return-from oreg env form))
+            ((return-from sys:abscond-from) me.(comp-return-from oreg env form))
             (return me.(comp-return oreg env form))
             ((let let*) me.(comp-let oreg env form))
             ((sys:fbind sys:lbind) me.(comp-fbind oreg env form))
@@ -447,10 +447,11 @@
     (let* ((nreg (if (null name)
                    nil
                    me.(get-dreg name)))
+           (opcode (if (eq op 'return-from) 'ret 'abscsr))
            (vfrag me.(compile oreg env value)))
       (new (frag oreg
                  ^(,*vfrag.code
-                   (ret ,nreg ,vfrag.oreg))
+                   (,opcode ,nreg ,vfrag.oreg))
                  vfrag.fvars
                  vfrag.ffuns)))))
 
diff --git a/vm.c b/vm.c
index 3b9c64ca..f36652f0 100644
--- a/vm.c
+++ b/vm.c
@@ -660,6 +660,15 @@ static void vm_retrr(struct vm *vm, vm_word_t insn)
   vm_no_block_err(vm, tag);
 }
 
+static void vm_abscsr(struct vm *vm, vm_word_t insn)
+{
+  val res = vm_get(vm->dspl, vm_insn_operand(insn));
+  val tag = vm_get(vm->dspl, vm_insn_extra(insn));
+
+  uw_block_abscond(tag, res);
+  vm_no_block_err(vm, tag);
+}
+
 static void vm_catch(struct vm *vm, vm_word_t insn)
 {
   unsigned catch_ip = vm_insn_bigop(insn);
@@ -852,6 +861,9 @@ static val vm_execute(struct vm *vm)
     case RETRR:
       vm_retrr(vm, insn);
       break;
+    case ABSCSR:
+      vm_abscsr(vm, insn);
+      break;
     case CATCH:
       vm_catch(vm, insn);
       break;
diff --git a/vmop.h b/vmop.h
index 065b159e..827340e2 100644
--- a/vmop.h
+++ b/vmop.h
@@ -51,16 +51,17 @@ typedef enum vm_op {
   RETSR = 22,
   RETRS = 23,
   RETRR = 24,
-  CATCH = 25,
-  HANDLE = 26,
-  GETV = 27,
-  GETF = 28,
-  GETL1 = 29,
-  GETVB = 30,
-  GETFB = 31,
-  GETL1B = 32,
-  SETV = 33,
-  SETL1 = 34,
-  BINDV = 35,
-  CLOSE = 36,
+  ABSCSR = 25,
+  CATCH = 26,
+  HANDLE = 27,
+  GETV = 28,
+  GETF = 29,
+  GETL1 = 30,
+  GETVB = 31,
+  GETFB = 32,
+  GETL1B = 33,
+  SETV = 34,
+  SETL1 = 35,
+  BINDV = 36,
+  CLOSE = 37,
 } vm_op_t;