rename <control> to <abort>

* libguile/vm-i-system.c (abort): Rename instruction from `throw'.
* libguile/vm.c (vm_abort): Rename from vm_throw.
* module/language/tree-il.scm (<abort>, make-abort, abort-src,
  abort-tag, abort-args: Rename from <control> & company.

* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/primitives.scm: Fix all callers.

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 15e3394..c72b84d 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1508,7 +1508,7 @@ VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (86, throw, "throw", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1)
 {
   unsigned n = FETCH ();
   SCM k;
@@ -1517,8 +1517,8 @@ VM_DEFINE_INSTRUCTION (86, throw, "throw", 1, -1, -1)
   POP (args);
   POP (k);
   SYNC_REGISTER ();
-  vm_throw (vm, k, args);
-  /* vm_throw should not return */
+  vm_abort (vm, k, args);
+  /* vm_abort should not return */
   abort ();
 }
 

diff --git a/libguile/vm.c b/libguile/vm.c
index 66d89a4..c8dd07e 100644 (file)
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -207,9 +207,9 @@ vm_dispatch_hook (SCM vm, int hook_num)
  */
 #define VM_SETJMP(jmpbuf) 0
 
-static void vm_throw (SCM vm, SCM k, SCM args) SCM_NORETURN;
+static void vm_abort (SCM vm, SCM tag, SCM args) SCM_NORETURN;
 static void
-vm_throw (SCM vm, SCM k, SCM args)
+vm_abort (SCM vm, SCM tag, SCM args)
 {
   abort ();
 }

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 47b2d83..1ae39e8 100644 (file)
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -48,7 +48,7 @@
             <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
             <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
             <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
-            <control> control? make-control control-src control-tag control-type control-args
+            <abort> abort? make-abort abort-src abort-tag abort-args
 
             parse-tree-il
             unparse-tree-il
@@ -82,7 +82,7 @@
   (<dynwind> winder body unwinder)
   (<dynlet> fluids vals body)
   (<prompt> tag body handler)
-  (<control> tag type args))
+  (<abort> tag args))
   
 \f
 
@@ -182,8 +182,8 @@
      ((prompt ,tag ,body ,handler)
       (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
      
-     ((control ,tag ,type ,args)
-      (make-control loc (retrans tag) type (map retrans args)))
+     ((abort ,tag ,type ,args)
+      (make-abort loc (retrans tag) type (map retrans args)))
 
      (else
       (error "unrecognized tree-il" exp)))))
@@ -260,8 +260,8 @@
     ((<prompt> tag body handler)
      `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)))
     
-    ((<control> tag type args)
-     `(control ,(unparse-tree-il tag) ,type ,(map unparse-tree-il args)))))
+    ((<abort> tag args)
+     `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)))))
 
 (define (tree-il->scheme e)
   (record-case e
@@ -352,10 +352,8 @@
        ,(tree-il->scheme handler)))
     
 
-    ((<control> tag type args)
-     (case type
-       ((throw) `(throw ,(tree-il->scheme tag) ,@(map tree-il->scheme args)))
-       (else (error "bad control type" type))))))
+    ((<abort> tag args)
+     `(@abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)))))
 
 \f
 (define (tree-il-fold leaf down up seed tree)
@@ -420,7 +418,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
            (up tree
                (loop tag (loop body (loop handler
                                           (down tree result))))))
-          ((<control> tag type args)
+          ((<abort> tag args)
            (up tree (loop tag (loop args (down tree result)))))
           (else
            (leaf tree result))))))
@@ -489,7 +487,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
                   (let*-values (((seed ...) (foldts tag seed ...))
                                 ((seed ...) (foldts body seed ...)))
                     (foldts handler seed ...)))
-                 ((<control> tag args)
+                 ((<abort> tag args)
                   (let*-values (((seed ...) (foldts tag seed ...)))
                     (fold-values foldts args seed ...)))
                  (else
@@ -563,9 +561,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
        (set! (prompt-body x) (lp body))
        (set! (prompt-handler x) (lp handler)))
       
-      ((<control> tag args)
-       (set! (control-tag x) (lp tag))
-       (set! (control-args x) (map lp args)))
+      ((<abort> tag args)
+       (set! (abort-tag x) (lp tag))
+       (set! (abort-args x) (map lp args)))
       
       (else #f))
     
@@ -638,9 +636,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
          (set! (prompt-body x) (lp body))
          (set! (prompt-handler x) (lp handler)))
         
-        ((<control> tag args)
-         (set! (control-tag x) (lp tag))
-         (set! (control-args x) (map lp args)))
+        ((<abort> tag args)
+         (set! (abort-tag x) (lp tag))
+         (set! (abort-args x) (map lp args)))
         
         (else #f))
       x)))

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 3363103..2d1a252 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -345,7 +345,7 @@
       ((<prompt> tag body handler)
        (lset-union eq? (step tag) (step handler)))
       
-      ((<control> tag type args)
+      ((<abort> tag args)
        (apply lset-union eq? (step tag) (map step args)))
       
       (else '())))
@@ -513,7 +513,7 @@
                      (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
          (max (recur tag) (recur body) (recur handler))))
       
-      ((<control> tag type args)
+      ((<abort> tag args)
        (apply max (recur tag) (map recur args)))
       
       (else n)))

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index d85de2a..85c9c11 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -1118,10 +1118,7 @@
                  (and (eq? context 'drop) (not RA)))
              (emit-label POST))))
 
-      ((<control> src tag type args)
+      ((<abort> src tag args)
        (comp-push tag)
-       (case type
-         ((throw)
-          (for-each comp-push args)
-          (emit-code src (make-glil-call 'throw (length args))))
-         (else (error "bad control type" x)))))))
+       (for-each comp-push args)
+       (emit-code src (make-glil-call 'abort (length args)))))))

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 76bc88b..48cb03c 100644 (file)
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -439,11 +439,11 @@
             'control
             (case-lambda
               ((src tag . args)
-               (make-control src tag 'throw args))
+               (make-abort src tag args))
               (else #f)))
 (hashq-set! *primitive-expand-table*
             '@control
             (case-lambda
-              ((src tag type . args)
-               (make-control src tag (if (const? type) (const-exp type) (error "what ho" type)) args))
+              ((src tag . args)
+               (make-abort src tag args))
               (else #f)))