Skip to content

Instantly share code, notes, and snippets.

@shirok shirok/gist:2011209

Created Mar 10, 2012
Embed
What would you like to do?
diff --git a/ChangeLog b/ChangeLog
index 6487bf4..ab6422d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,17 @@
+2012-03-10 Shiro Kawai <shiro@acm.org>
+
+ * src/vm.c (Scm_VMCallCC, throw_continuation): Be a bit clever to
+ extract arity of the captured continuation if possible. The info
+ may be lost by valid program transformation (e.g.
+ (receive (a b) (let/cc k (print (arity k)) (values 1 2)) (cons a b))
+ would print 2, but
+ (receive xs (let/cc k (print (arity k)) (values 1 2)) (apply cons x))
+ and
+ (call-with-values (^() (let/cc k (print (arity k)) (values 1 2)))
+ cons)
+ would print #<arity-at-least 0>, so this info can't be used reliably
+ to change program behavior, but may be useful for diagnostics.
+
2012-03-09 Shiro Kawai <shiro@acm.org>
* lib/gauche/portutil.scm (port-map, port-fold): Guarantee to call
diff --git a/src/builtin-syms.scm b/src/builtin-syms.scm
index 1e43ff2..9a282be 100644
--- a/src/builtin-syms.scm
+++ b/src/builtin-syms.scm
@@ -143,6 +143,11 @@
(syntax SCM_SYM_SYNTAX)
(macro SCM_SYM_MACRO)
(inline SCM_SYM_INLINE)
+ ;; The following symbols are used as the name of SUBRs created
+ ;; for (partial) continuations. These are for information only,
+ ;; and may be changed, so the user code shouldn't count on it.
+ (continuation SCM_SYM_CONTINUATION)
+ (partial-continuation SCM_SYM_PARTIAL_CONTINUATION)
;; regexp
(seq SCM_SYM_SEQ)
diff --git a/src/gauche/vm.h b/src/gauche/vm.h
index d1fde10..3e7019c 100644
--- a/src/gauche/vm.h
+++ b/src/gauche/vm.h
@@ -257,6 +257,11 @@ typedef struct ScmEscapePointRec {
with-error-handler uses the latter model,
but SRFI-34's guard needs the former model.
*/
+ int reqargs; /* keeps the required # of values if this ep
+ represents a captured continuation. */
+ int optargs; /* keeps the optional # of values (in the same
+ sense as ScmProcedure->optargs) if this ep
+ represents a captured continuation. */
} ScmEscapePoint;
/* Link management */
diff --git a/src/vm.c b/src/vm.c
index 4a26257..5c7657b 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -486,11 +486,12 @@ static void vm_unregister(ScmVM *vm)
} while (0)
#define CALL_CCONT(p, v, d) p(v, d)
+#define CCONTP(c) ((c)->argp == NULL)
/* pop a continuation frame, i.e. return from a procedure. */
#define POP_CONT() \
do { \
- if (CONT->argp == NULL) { \
+ if (CCONTP(CONT)) { \
void *data__[SCM_CCONT_DATA_SIZE]; \
ScmObj v__ = VAL0; \
ScmCContinuationProc *after__; \
@@ -2091,6 +2092,7 @@ static ScmObj with_error_handler(ScmVM *vm, ScmObj handler,
ep->errorReporting =
SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_ERROR_BEING_REPORTED);
ep->rewindBefore = rewindBefore;
+ ep->reqargs = ep->optargs = 0; /* unused, but be a good citizen. */
vm->escapePoint = ep; /* This will be done in install_ehandler, but
make sure ep is visible from save_cont
@@ -2239,9 +2241,24 @@ static ScmObj throw_cont_cc(ScmObj result, void **data)
static ScmObj throw_continuation(ScmObj *argframe, int nargs, void *data)
{
ScmEscapePoint *ep = (ScmEscapePoint*)data;
- ScmObj args = argframe[0];
ScmVM *vm = theVM;
ScmObj handlers_to_call;
+ ScmObj args;
+ int n;
+
+ /* Fold the arguments. TODO: We can get away with these consing. */
+ SCM_ASSERT(nargs == ep->reqargs + ep->optargs);
+ if (ep->optargs > 0) {
+ args = argframe[nargs-1];
+ for (n = 1; n < ep->optargs; n++) {
+ args = Scm_Cons(argframe[nargs - 1 - n], args);
+ }
+ } else {
+ args = SCM_NIL;
+ }
+ for (n = 0; n < ep->reqargs; n++) {
+ args = Scm_Cons(argframe[nargs - 1 - ep->optargs - n], args);
+ }
if (ep->cstack && vm->cstack != ep->cstack) {
ScmCStack *cs;
@@ -2279,9 +2296,26 @@ ScmObj Scm_VMCallCC(ScmObj proc)
ep->cont = vm->cont;
ep->handlers = vm->handlers;
ep->cstack = vm->cstack;
-
- contproc = Scm_MakeSubr(throw_continuation, ep, 0, 1,
- SCM_MAKE_STR("continuation"));
+ ep->reqargs = 0;
+ ep->optargs = 1;
+
+ /* Try to get the arity of the continuation if possible. We do 'best
+ effort'---if we can't figure it out for sure, we just fall back to
+ the default #<arity-at-least 0>. NB: If we see the C continuation,
+ we fall back to the default, for we don't know what C continuation
+ expects.
+ */
+ if (vm->cont && vm->cont->pc && !CCONTP(vm->cont)) {
+ ScmWord insn = *vm->cont->pc;
+ switch (SCM_VM_INSN_CODE(insn)) {
+ case SCM_VM_RECEIVE:;
+ case SCM_VM_TAIL_RECEIVE:
+ ep->reqargs = SCM_VM_INSN_ARG0(insn);
+ ep->optargs = SCM_VM_INSN_ARG1(insn);
+ }
+ }
+ contproc = Scm_MakeSubr(throw_continuation, ep, ep->reqargs, ep->optargs,
+ SCM_SYM_CONTINUATION);
return Scm_VMApply1(proc, contproc);
}
@@ -2317,8 +2351,11 @@ ScmObj Scm_VMCallPC(ScmObj proc)
ep->handlers = vm->handlers;
ep->cstack = NULL; /* so that the partial continuation can be run
on any cstack state. */
- contproc = Scm_MakeSubr(throw_continuation, ep, 0, 1,
- SCM_MAKE_STR("partial continuation"));
+ ep->reqargs = 0; /* we might be able to do the same thing as Scm_VMCallCC
+ to set partial cont's arity, but for now...*/
+ ep->optargs = 1;
+ contproc = Scm_MakeSubr(throw_continuation, ep, ep->reqargs, ep->optargs,
+ SCM_SYM_PARTIAL_CONTINUATION);
/* Remove the saved continuation chain.
NB: c can be NULL if we've been executing a partial continuation.
It's ok, for a continuation pointed by cstack will be restored
diff --git a/test/dynwind.scm b/test/dynwind.scm
index 8408914..17caa43 100644
--- a/test/dynwind.scm
+++ b/test/dynwind.scm
@@ -42,12 +42,30 @@
(lambda (c) (c 1 2 3)))
(list x y z)))
-(test* "call/cc (values4)" (test-error)
+(test* "call/cc (values4)" '(1 2 (3 4))
+ (receive (x y . z)
+ (call-with-current-continuation
+ (lambda (c) (c 1 2 3 4)))
+ (list x y z)))
+
+(test* "call/cc (values5)" '(1 2 ())
+ (receive (x y . z)
+ (call-with-current-continuation
+ (lambda (c) (c 1 2)))
+ (list x y z)))
+
+(test* "call/cc (values6)" (test-error)
(receive (x y)
(call-with-current-continuation
(lambda (c) (c 1 2 3)))
(list x y)))
+(test* "call/cc (values7)" (test-error)
+ (receive (x y)
+ (call-with-current-continuation
+ (lambda (c) (c 1)))
+ (list x y)))
+
;; continuation invoked while inline procedure is prepared.
;; a test to see call/cc won't mess up the VM stack.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.