~ chicken-core (chicken-5) 8f0193bd64df78440f1f31953acfb81db84cf91a
commit 8f0193bd64df78440f1f31953acfb81db84cf91a
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jul 15 10:01:32 2015 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jul 15 10:37:23 2015 +0200
added correctly working "base" apply, repaired C_apply once more
diff --git a/chicken.h b/chicken.h
index 660d0b13..0f9925ac 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1219,6 +1219,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_pointer_address(x) ((C_byte *)C_block_item((x), 0))
#define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x)
#define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
+#define C_do_apply(c, av) ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av))
#define C_kontinue(k, r) { C_word avk[ 2 ]; avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); }
#define C_fetch_byte(x, p) (((unsigned C_byte *)C_data_pointer(x))[ p ])
#define C_poke_integer(x, i, n) (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
diff --git a/runtime.c b/runtime.c
index b0a7d6fb..147565cc 100644
--- a/runtime.c
+++ b/runtime.c
@@ -1748,6 +1748,7 @@ void barf(int code, char *loc, ...)
av = C_alloc(c + 4);
if(!C_immediatep(err)) {
+ va_start(v, loc);
av[ 0 ] = err;
/* No continuation is passed: '##sys#error-hook' may not return: */
av[ 1 ] = C_SCHEME_UNDEFINED;
@@ -1764,7 +1765,7 @@ void barf(int code, char *loc, ...)
av[ i + 4 ] = va_arg(v, C_word);
va_end(v);
- C_apply(c + 4, av);
+ C_do_apply(c + 4, av);
}
else panic(msg);
}
@@ -1789,8 +1790,7 @@ C_regparm double C_fcall C_milliseconds(void)
struct timeval tv;
if(C_gettimeofday(&tv, NULL) == -1) return 0;
- else return
- C_floor(((double)tv.tv_sec - C_startup_time_seconds) * 1000.0 + tv.tv_usec / 1000);
+ else return C_floor(((double)tv.tv_sec - C_startup_time_seconds) * 1000.0 + tv.tv_usec / 1000);
#endif
}
@@ -1901,7 +1901,7 @@ C_word C_fcall C_callback(C_word closure, int argc)
C_memcpy(av + 2, C_temporary_stack, (argc - 2) * sizeof(C_word));
#ifdef HAVE_SIGSETJMP
- if(!C_sigsetjmp(C_restart, 0)) C_apply(argc, av);
+ if(!C_sigsetjmp(C_restart, 0)) C_do_apply(argc, av);
#else
if(!C_setjmp(C_restart)) C_do_apply(argc, av);
#endif
@@ -3667,8 +3667,8 @@ void handle_interrupt(void *trampoline)
av[ 0 ] = proc;
av[ 1 ] = C_SCHEME_UNDEFINED;
av[ 2 ] = reason;
- av[ 2 ] = state;
- C_apply(3, av);
+ av[ 3 ] = state;
+ C_do_apply(4, av);
}
@@ -5942,17 +5942,26 @@ C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
void C_ccall C_apply(C_word c, C_word *av)
{
- C_word closure = av[ 0 ];
- C_word k = av[ 1 ];
- C_word fn = av[ 2 ];
+ C_word
+ /* closure = av[ 0 ] */
+ k = av[ 1 ],
+ fn = av[ 2 ];
int i, n = c - 3;
int m = n;
- C_word x, skip;
+ C_word x, skip, *ptr;
if(c < 4) C_bad_min_argc(c, 4);
- if(C_immediatep(fn) || C_header_bits(fn) != C_CLOSURE_TYPE) {
+ if(C_immediatep(fn) || C_header_bits(fn) != C_CLOSURE_TYPE)
barf(C_NOT_A_CLOSURE_ERROR, "apply", fn);
+
+ ptr = C_temporary_stack_limit;
+ *(ptr++) = fn;
+ *(ptr++) = k;
+
+ if(n > 1) {
+ C_memcpy(ptr, av + 3, (n - 1) * sizeof(C_word));
+ ptr += n - 1;
}
x = av[ c - 1 ];
@@ -5966,32 +5975,22 @@ void C_ccall C_apply(C_word c, C_word *av)
if(C_temporary_stack < C_temporary_stack_limit)
barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
- C_save(x);
+ *(ptr++) = x;
++m;
}
- if(c > 4) {
- C_temporary_stack -= n - 1;
-
- if(C_temporary_stack < C_temporary_stack_limit)
- barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
-
- C_memcpy(C_temporary_stack, av + 3, n * sizeof(C_word));
- }
-
- C_save(k);
- C_save(fn);
- ((C_proc)(void *)C_block_item(fn, 0))(m + 1, C_temporary_stack);
+ ((C_proc)(void *)C_block_item(fn, 0))(m + 1, C_temporary_stack_limit);
}
void C_ccall C_call_cc(C_word c, C_word *av)
{
- C_word closure = av[ 0 ];
- C_word k = av[ 1 ];
- C_word cont = av[ 2 ];
- C_word *a = C_alloc(3);
- C_word wrapper;
+ C_word
+ /* closure = av[ 0 ] */
+ k = av[ 1 ],
+ cont = av[ 2 ],
+ *a = C_alloc(3),
+ wrapper;
void *pr = (void *)C_block_item(cont,0);
C_word av2[ 3 ];
@@ -6037,7 +6036,7 @@ void C_ccall call_cc_values_wrapper(C_word c, C_word *av)
if(c > 2) --n;
else av[ 1 ] = C_SCHEME_UNBOUND;
- C_apply(n - 2, av);
+ C_do_apply(n - 2, av);
}
@@ -6069,7 +6068,7 @@ void C_ccall C_values(C_word c, C_word *av)
if(C_block_item(k, 0) == (C_word)values_continuation) {
av[ 0 ] = k; /* reuse av */
av[ 1 ] = C_SCHEME_UNBOUND; /* unbound value marks direct invocation */
- C_apply(n - 2, av);
+ C_do_apply(n - 2, av);
}
if(c != 3) {
@@ -6110,7 +6109,7 @@ void C_ccall C_apply_values(C_word c, C_word *av)
av2[ 0 ] = k;
av2[ 1 ] = C_SCHEME_UNBOUND; /* unbound value marks direct invocation */
C_memcpy(av2 + 2, C_temporary_stack, n * sizeof(C_word));
- C_apply(n, av2);
+ C_do_apply(n, av2);
}
if(C_immediatep(lst) || (C_block_header(lst) == C_PAIR_TAG && C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)) {
@@ -6148,7 +6147,7 @@ void C_ccall C_call_with_values(C_word c, C_word *av)
kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
av[ 0 ] = thunk; /* reuse av */
av[ 1 ] = kk;
- C_apply(0, av);
+ C_do_apply(0, av);
}
@@ -6165,7 +6164,7 @@ void C_ccall C_u_call_with_values(C_word c, C_word *av)
kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
av[ 0 ] = thunk; /* reuse av */
av[ 1 ] = kk;
- C_apply(0, av);
+ C_do_apply(0, av);
}
@@ -6193,7 +6192,7 @@ void C_ccall values_continuation(C_word c, C_word *av)
C_memcpy(av2 + 2, av + 2, (n - 2) * sizeof(C_word));
}
- C_apply(n - 2, av2);
+ C_do_apply(n - 2, av2);
}
@@ -8773,7 +8772,7 @@ void C_ccall C_call_with_cthulhu(C_word c, C_word *av)
av2[ 1 ] = C_closure(&a, 1, (C_word)termination_continuation); /* k */
av2[ 2 ] = proc;
av2[ 3 ] = C_SCHEME_END_OF_LIST;
- C_apply(4, av2);
+ C_do_apply(4, av2);
}
Trap