summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-02-19 10:49:24 +0100
committerAndy Wingo <wingo@pobox.com>2010-02-19 12:10:11 +0100
commit6e84cb95b18d81ef7a8490cccdfb08d3f88116ea (patch)
tree41d26678df853cb3e6f77bdb08ebe962c58306f5
parent07a0c7d5d9523936d5fe4cac595bd75859416c9e (diff)
downloadguile-6e84cb95b18d81ef7a8490cccdfb08d3f88116ea.tar.gz
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.
-rw-r--r--libguile/vm-i-system.c6
-rw-r--r--libguile/vm.c4
-rw-r--r--module/language/tree-il.scm34
-rw-r--r--module/language/tree-il/analyze.scm4
-rw-r--r--module/language/tree-il/compile-glil.scm9
-rw-r--r--module/language/tree-il/primitives.scm6
6 files changed, 29 insertions, 34 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 15e339492..c72b84d0e 100644
--- 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 66d89a4fe..c8dd07eab 100644
--- 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 47b2d831a..1ae39e874 100644
--- 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))
@@ -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)))))
(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 3363103e0..2d1a25289 100644
--- 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 d85de2aa2..85c9c116e 100644
--- 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 76bc88b7c..48cb03c04 100644
--- 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)))