mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

rename <control> to <abort>

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-02-19 10:49:24 +01:00
parent 07a0c7d5d9
commit 6e84cb95b1
6 changed files with 29 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

6
libguile/vm-i-system.c
View file

@ -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 ();
}

4
libguile/vm.c
View file

@ -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 ();
}

34
module/language/tree-il.scm
View file

@ -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)))

4
module/language/tree-il/analyze.scm
View file

@ -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)))

9
module/language/tree-il/compile-glil.scm
View file

@ -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)))))))

6
module/language/tree-il/primitives.scm
View file

@ -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)))