[git] GnuPG - branch, master, updated. gnupg-2.1.15-350-gee08677
by Justus Winter
cvs at cvs.gnupg.org
Thu Nov 10 15:58:27 CET 2016
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "The GNU Privacy Guard".
The branch, master has been updated
via ee08677d63a900cea85228024861a4f5c5a87c69 (commit)
via e0cbd3389e2dd6ec19ee3a4c7bad81fa0f1907f5 (commit)
via d3a98ff5bc972a4c9b01b9e5338a4a59b5b4ac48 (commit)
via 568cfcde45a0d6c456d8f8be1ea0e408416badad (commit)
via 9ee184bc0afaea06785d836ed175b851b9ae532f (commit)
via d7c5799c282a03dcce0e3d327075233353cb76cc (commit)
from 088d955bd8a6ec8bbf76c8a4c01eb08499d1d9fa (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit ee08677d63a900cea85228024861a4f5c5a87c69
Author: Justus Winter <justus at g10code.com>
Date: Thu Nov 10 14:47:00 2016 +0100
gpgscm: Recover cells from the list of recently allocated cells.
* tests/gpgscm/scheme.c (ok_to_freely_gc): Recover cells.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 105d2a1..146b9e6 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -805,6 +805,17 @@ static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
car(sc->sink) = holder;
}
+static INLINE void ok_to_freely_gc(scheme *sc)
+{
+ pointer a = car(sc->sink), next;
+ car(sc->sink) = sc->NIL;
+ while (a != sc->NIL)
+ {
+ next = cdr(a);
+ free_cell(sc, a);
+ a = next;
+ }
+}
static pointer get_cell(scheme *sc, pointer a, pointer b)
{
@@ -832,12 +843,6 @@ static pointer get_vector_object(scheme *sc, int len, pointer init)
return cells;
}
-static INLINE void ok_to_freely_gc(scheme *sc)
-{
- car(sc->sink) = sc->NIL;
-}
-
-
#if defined TSGRIND
static void check_cell_alloced(pointer p, int expect_alloced)
{
commit e0cbd3389e2dd6ec19ee3a4c7bad81fa0f1907f5
Author: Justus Winter <justus at g10code.com>
Date: Thu Nov 10 14:02:11 2016 +0100
gpgscm: Recover cells used to maintain interpreter state.
* tests/gpgscm/scheme.c (free_cell): New function.
(free_cons): Likewise.
(_s_return): Use the new function to recover cells used to save the
state of the interpreter in 's_save'. This reduces the need to do a
garbage collection considerably.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 90cb8fd..105d2a1 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -773,6 +773,26 @@ static pointer find_consecutive_cells(scheme *sc, int n) {
return sc->NIL;
}
+/* Free a cell. This is dangerous. Only free cells that are not
+ * referenced. */
+static INLINE void
+free_cell(scheme *sc, pointer a)
+{
+ cdr(a) = sc->free_cell;
+ sc->free_cell = a;
+ sc->fcells += 1;
+}
+
+/* Free a cell and retrieve its content. This is dangerous. Only
+ * free cells that are not referenced. */
+static INLINE void
+free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr)
+{
+ *r_car = car(a);
+ *r_cdr = cdr(a);
+ free_cell(sc, a);
+}
+
/* To retain recent allocs before interpreter knows about them -
Tehom */
@@ -2481,14 +2501,17 @@ static void dump_stack_free(scheme *sc)
}
static pointer _s_return(scheme *sc, pointer a) {
- sc->value = (a);
- if(sc->dump==sc->NIL) return sc->NIL;
- sc->op = ivalue(car(sc->dump));
- sc->args = cadr(sc->dump);
- sc->envir = caddr(sc->dump);
- sc->code = cadddr(sc->dump);
- sc->dump = cddddr(sc->dump);
- return sc->T;
+ pointer dump = sc->dump;
+ pointer op;
+ sc->value = (a);
+ if (dump == sc->NIL)
+ return sc->NIL;
+ free_cons(sc, dump, &op, &dump);
+ sc->op = ivalue(op);
+ free_cons(sc, dump, &sc->args, &dump);
+ free_cons(sc, dump, &sc->envir, &dump);
+ free_cons(sc, dump, &sc->code, &sc->dump);
+ return sc->T;
}
static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
commit d3a98ff5bc972a4c9b01b9e5338a4a59b5b4ac48
Author: Justus Winter <justus at g10code.com>
Date: Thu Nov 10 11:47:08 2016 +0100
gpgscm: Reduce opcode dispatch overhead.
* tests/gpgscm/scheme.c (s_thread_to): New macro.
(CASE): Likewise.
(opexe_[0-6]): Use 'CASE' instead of 'case' statements, replace
's_goto' with 's_thread_to' where applicable.
--
This is a straight-forward optimization that replaces 's_goto' in
certain cases. Instead of returning to the calling function, and
dispatching the next opcode, we can jump to the opcode handler.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 884ffd5..90cb8fd 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2436,10 +2436,33 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
/* Too small to turn into function */
# define BEGIN do {
# define END } while (0)
+
+/* Bounce back to Eval_Cycle and execute A. */
#define s_goto(sc,a) BEGIN \
sc->op = (int)(a); \
return sc->T; END
+#if USE_THREADED_CODE
+
+/* Do not bounce back to Eval_Cycle but execute A by jumping directly
+ * to it. Only applicable if A is part of the same dispatch
+ * function. */
+#define s_thread_to(sc, a) \
+ BEGIN \
+ op = (int) (a); \
+ goto a; \
+ END
+
+/* Define a label OP and emit a case statement for OP. For use in the
+ * dispatch functions. The slightly peculiar goto that is never
+ * executed avoids warnings about unused labels. */
+#define CASE(OP) if (0) goto OP; OP: case OP
+
+#else /* USE_THREADED_CODE */
+#define s_thread_to(sc, a) s_goto(sc, a)
+#define CASE(OP) case OP
+#endif /* USE_THREADED_CODE */
+
#define s_return(sc,a) return _s_return(sc,a)
static INLINE void dump_stack_reset(scheme *sc)
@@ -2485,7 +2508,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
pointer x, y;
switch (op) {
- case OP_LOAD: /* load */
+ CASE(OP_LOAD): /* load */
if(file_interactive(sc)) {
fprintf(sc->outport->_object._port->rep.stdio.file,
"Loading %s\n", strvalue(car(sc->args)));
@@ -2496,10 +2519,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
else
{
sc->args = mk_integer(sc,sc->file_i);
- s_goto(sc,OP_T0LVL);
+ s_thread_to(sc,OP_T0LVL);
}
- case OP_T0LVL: /* top level */
+ CASE(OP_T0LVL): /* top level */
/* If we reached the end of file, this loop is done. */
if(sc->loadport->_object._port->kind & port_saw_EOF)
{
@@ -2533,23 +2556,23 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
- s_goto(sc,OP_READ_INTERNAL);
+ s_thread_to(sc,OP_READ_INTERNAL);
- case OP_T1LVL: /* top level */
+ CASE(OP_T1LVL): /* top level */
sc->code = sc->value;
sc->inport=sc->save_inport;
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- case OP_READ_INTERNAL: /* internal read */
+ CASE(OP_READ_INTERNAL): /* internal read */
sc->tok = token(sc);
if(sc->tok==TOK_EOF)
{ s_return(sc,sc->EOF_OBJ); }
s_goto(sc,OP_RDSEXPR);
- case OP_GENSYM:
+ CASE(OP_GENSYM):
s_return(sc, gensym(sc));
- case OP_VALUEPRINT: /* print evaluation result */
+ CASE(OP_VALUEPRINT): /* print evaluation result */
/* OP_VALUEPRINT is always pushed, because when changing from
non-interactive to interactive mode, it needs to be
already on the stack */
@@ -2564,7 +2587,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->value);
}
- case OP_EVAL: /* main part of evaluation */
+ CASE(OP_EVAL): /* main part of evaluation */
#if USE_TRACING
if(sc->tracing) {
/*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
@@ -2574,7 +2597,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_P0LIST);
}
/* fall through */
- case OP_REAL_EVAL:
+ CASE(OP_REAL_EVAL):
#endif
if (is_symbol(sc->code)) { /* symbol */
x=find_slot_in_env(sc,sc->envir,sc->code,1);
@@ -2591,46 +2614,46 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
/* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
}
} else {
s_return(sc,sc->code);
}
- case OP_E0ARGS: /* eval arguments */
+ CASE(OP_E0ARGS): /* eval arguments */
if (is_macro(sc->value)) { /* macro expansion */
s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
sc->args = cons(sc,sc->code, sc->NIL);
sc->code = sc->value;
- s_goto(sc,OP_APPLY);
+ s_thread_to(sc,OP_APPLY);
} else {
sc->code = cdr(sc->code);
- s_goto(sc,OP_E1ARGS);
+ s_thread_to(sc,OP_E1ARGS);
}
- case OP_E1ARGS: /* eval arguments */
+ CASE(OP_E1ARGS): /* eval arguments */
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code)) { /* continue */
s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
sc->code = car(sc->code);
sc->args = sc->NIL;
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
sc->code = car(sc->args);
sc->args = cdr(sc->args);
- s_goto(sc,OP_APPLY);
+ s_thread_to(sc,OP_APPLY);
}
#if USE_TRACING
- case OP_TRACING: {
+ CASE(OP_TRACING): {
int tr=sc->tracing;
sc->tracing=ivalue(car(sc->args));
s_return(sc,mk_integer(sc,tr));
}
#endif
- case OP_APPLY: /* apply 'code' to 'args' */
+ CASE(OP_APPLY): /* apply 'code' to 'args' */
#if USE_TRACING
if(sc->tracing) {
s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
@@ -2640,7 +2663,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_P0LIST);
}
/* fall through */
- case OP_REAL_APPLY:
+ CASE(OP_REAL_APPLY):
#endif
if (is_proc(sc->code)) {
s_goto(sc,procnum(sc->code)); /* PROCEDURE */
@@ -2676,7 +2699,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
}
sc->code = cdr(closure_code(sc->code));
sc->args = sc->NIL;
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
} else if (is_continuation(sc->code)) { /* CONTINUATION */
sc->dump = cont_dump(sc->code);
s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
@@ -2684,12 +2707,12 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
Error_1(sc,"illegal function",sc->code);
}
- case OP_DOMACRO: /* do macro */
+ CASE(OP_DOMACRO): /* do macro */
sc->code = sc->value;
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
#if USE_COMPILE_HOOK
- case OP_LAMBDA: /* lambda */
+ CASE(OP_LAMBDA): /* lambda */
/* If the hook is defined, apply it to sc->code, otherwise
set sc->value fall through */
{
@@ -2701,20 +2724,20 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_LAMBDA1,sc->args,sc->code);
sc->args=cons(sc,sc->code,sc->NIL);
sc->code=slot_value_in_env(f);
- s_goto(sc,OP_APPLY);
+ s_thread_to(sc,OP_APPLY);
}
}
- case OP_LAMBDA1:
+ CASE(OP_LAMBDA1):
s_return(sc,mk_closure(sc, sc->value, sc->envir));
#else
- case OP_LAMBDA: /* lambda */
+ CASE(OP_LAMBDA): /* lambda */
s_return(sc,mk_closure(sc, sc->code, sc->envir));
#endif
- case OP_MKCLOSURE: /* make-closure */
+ CASE(OP_MKCLOSURE): /* make-closure */
x=car(sc->args);
if(car(x)==sc->LAMBDA) {
x=cdr(x);
@@ -2726,10 +2749,10 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,mk_closure(sc, x, y));
- case OP_QUOTE: /* quote */
+ CASE(OP_QUOTE): /* quote */
s_return(sc,car(sc->code));
- case OP_DEF0: /* define */
+ CASE(OP_DEF0): /* define */
if(is_immutable(car(sc->code)))
Error_1(sc,"define: unable to alter immutable", car(sc->code));
@@ -2744,9 +2767,9 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
Error_0(sc,"variable is not a symbol");
}
s_save(sc,OP_DEF1, sc->NIL, x);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- case OP_DEF1: /* define */
+ CASE(OP_DEF1): /* define */
x=find_slot_in_env(sc,sc->envir,sc->code,0);
if (x != sc->NIL) {
set_slot_in_env(sc, x, sc->value);
@@ -2756,21 +2779,21 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->code);
- case OP_DEFP: /* defined? */
+ CASE(OP_DEFP): /* defined? */
x=sc->envir;
if(cdr(sc->args)!=sc->NIL) {
x=cadr(sc->args);
}
s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
- case OP_SET0: /* set! */
+ CASE(OP_SET0): /* set! */
if(is_immutable(car(sc->code)))
Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
s_save(sc,OP_SET1, sc->NIL, car(sc->code));
sc->code = cadr(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- case OP_SET1: /* set! */
+ CASE(OP_SET1): /* set! */
y=find_slot_in_env(sc,sc->envir,sc->code,1);
if (y != sc->NIL) {
set_slot_in_env(sc, y, sc->value);
@@ -2780,7 +2803,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
}
- case OP_BEGIN: /* begin */
+ CASE(OP_BEGIN): /* begin */
if (!is_pair(sc->code)) {
s_return(sc,sc->code);
}
@@ -2788,28 +2811,28 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
}
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- case OP_IF0: /* if */
+ CASE(OP_IF0): /* if */
s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- case OP_IF1: /* if */
+ CASE(OP_IF1): /* if */
if (is_true(sc->value))
sc->code = car(sc->code);
else
sc->code = cadr(sc->code); /* (if #f 1) ==> () because
* car(sc->NIL) = sc->NIL */
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- case OP_LET0: /* let */
+ CASE(OP_LET0): /* let */
sc->args = sc->NIL;
sc->value = sc->code;
sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
- s_goto(sc,OP_LET1);
+ s_thread_to(sc,OP_LET1);
- case OP_LET1: /* let (calculate parameters) */
+ CASE(OP_LET1): /* let (calculate parameters) */
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code)) { /* continue */
if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
@@ -2819,15 +2842,15 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_LET1, sc->args, cdr(sc->code));
sc->code = cadar(sc->code);
sc->args = sc->NIL;
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
sc->code = car(sc->args);
sc->args = cdr(sc->args);
- s_goto(sc,OP_LET2);
+ s_thread_to(sc,OP_LET2);
}
- case OP_LET2: /* let */
+ CASE(OP_LET2): /* let */
new_frame_in_env(sc, sc->envir);
for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
y != sc->NIL; x = cdr(x), y = cdr(y)) {
@@ -2849,37 +2872,37 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
sc->code = cdr(sc->code);
sc->args = sc->NIL;
}
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
- case OP_LET0AST: /* let* */
+ CASE(OP_LET0AST): /* let* */
if (car(sc->code) == sc->NIL) {
new_frame_in_env(sc, sc->envir);
sc->code = cdr(sc->code);
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
}
if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
}
s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
sc->code = cadaar(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- case OP_LET1AST: /* let* (make new frame) */
+ CASE(OP_LET1AST): /* let* (make new frame) */
new_frame_in_env(sc, sc->envir);
- s_goto(sc,OP_LET2AST);
+ s_thread_to(sc,OP_LET2AST);
- case OP_LET2AST: /* let* (calculate parameters) */
+ CASE(OP_LET2AST): /* let* (calculate parameters) */
new_slot_in_env(sc, caar(sc->code), sc->value);
sc->code = cdr(sc->code);
if (is_pair(sc->code)) { /* continue */
s_save(sc,OP_LET2AST, sc->args, sc->code);
sc->code = cadar(sc->code);
sc->args = sc->NIL;
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->code = sc->args;
sc->args = sc->NIL;
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
}
default:
snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
@@ -2892,14 +2915,14 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
pointer x, y;
switch (op) {
- case OP_LET0REC: /* letrec */
+ CASE(OP_LET0REC): /* letrec */
new_frame_in_env(sc, sc->envir);
sc->args = sc->NIL;
sc->value = sc->code;
sc->code = car(sc->code);
- s_goto(sc,OP_LET1REC);
+ s_thread_to(sc,OP_LET1REC);
- case OP_LET1REC: /* letrec (calculate parameters) */
+ CASE(OP_LET1REC): /* letrec (calculate parameters) */
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code)) { /* continue */
if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
@@ -2914,10 +2937,10 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
sc->code = car(sc->args);
sc->args = cdr(sc->args);
- s_goto(sc,OP_LET2REC);
+ s_thread_to(sc,OP_LET2REC);
}
- case OP_LET2REC: /* letrec */
+ CASE(OP_LET2REC): /* letrec */
for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
new_slot_in_env(sc, caar(x), car(y));
}
@@ -2925,7 +2948,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
sc->args = sc->NIL;
s_goto(sc,OP_BEGIN);
- case OP_COND0: /* cond */
+ CASE(OP_COND0): /* cond */
if (!is_pair(sc->code)) {
Error_0(sc,"syntax error in cond");
}
@@ -2933,7 +2956,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
sc->code = caar(sc->code);
s_goto(sc,OP_EVAL);
- case OP_COND1: /* cond */
+ CASE(OP_COND1): /* cond */
if (is_true(sc->value)) {
if ((sc->code = cdar(sc->code)) == sc->NIL) {
s_return(sc,sc->value);
@@ -2957,12 +2980,12 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
}
}
- case OP_DELAY: /* delay */
+ CASE(OP_DELAY): /* delay */
x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
typeflag(x)=T_PROMISE;
s_return(sc,x);
- case OP_AND0: /* and */
+ CASE(OP_AND0): /* and */
if (sc->code == sc->NIL) {
s_return(sc,sc->T);
}
@@ -2970,7 +2993,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
- case OP_AND1: /* and */
+ CASE(OP_AND1): /* and */
if (is_false(sc->value)) {
s_return(sc,sc->value);
} else if (sc->code == sc->NIL) {
@@ -2981,7 +3004,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_EVAL);
}
- case OP_OR0: /* or */
+ CASE(OP_OR0): /* or */
if (sc->code == sc->NIL) {
s_return(sc,sc->F);
}
@@ -2989,7 +3012,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
- case OP_OR1: /* or */
+ CASE(OP_OR1): /* or */
if (is_true(sc->value)) {
s_return(sc,sc->value);
} else if (sc->code == sc->NIL) {
@@ -3000,18 +3023,18 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_EVAL);
}
- case OP_C0STREAM: /* cons-stream */
+ CASE(OP_C0STREAM): /* cons-stream */
s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
- case OP_C1STREAM: /* cons-stream */
+ CASE(OP_C1STREAM): /* cons-stream */
sc->args = sc->value; /* save sc->value to register sc->args for gc */
x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
typeflag(x)=T_PROMISE;
s_return(sc,cons(sc, sc->args, x));
- case OP_MACRO0: /* macro */
+ CASE(OP_MACRO0): /* macro */
if (is_pair(car(sc->code))) {
x = caar(sc->code);
sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
@@ -3025,7 +3048,7 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_MACRO1, sc->NIL, x);
s_goto(sc,OP_EVAL);
- case OP_MACRO1: /* macro */
+ CASE(OP_MACRO1): /* macro */
typeflag(sc->value) = T_MACRO;
x = find_slot_in_env(sc, sc->envir, sc->code, 0);
if (x != sc->NIL) {
@@ -3035,12 +3058,12 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,sc->code);
- case OP_CASE0: /* case */
+ CASE(OP_CASE0): /* case */
s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
s_goto(sc,OP_EVAL);
- case OP_CASE1: /* case */
+ CASE(OP_CASE1): /* case */
for (x = sc->code; x != sc->NIL; x = cdr(x)) {
if (!is_pair(y = caar(x))) {
break;
@@ -3067,27 +3090,27 @@ static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->NIL);
}
- case OP_CASE2: /* case */
+ CASE(OP_CASE2): /* case */
if (is_true(sc->value)) {
s_goto(sc,OP_BEGIN);
} else {
s_return(sc,sc->NIL);
}
- case OP_PAPPLY: /* apply */
+ CASE(OP_PAPPLY): /* apply */
sc->code = car(sc->args);
sc->args = list_star(sc,cdr(sc->args));
/*sc->args = cadr(sc->args);*/
s_goto(sc,OP_APPLY);
- case OP_PEVAL: /* eval */
+ CASE(OP_PEVAL): /* eval */
if(cdr(sc->args)!=sc->NIL) {
sc->envir=cadr(sc->args);
}
sc->code = car(sc->args);
s_goto(sc,OP_EVAL);
- case OP_CONTINUATION: /* call-with-current-continuation */
+ CASE(OP_CONTINUATION): /* call-with-current-continuation */
sc->code = car(sc->args);
sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
s_goto(sc,OP_APPLY);
@@ -3108,7 +3131,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
switch (op) {
#if USE_MATH
- case OP_INEX2EX: /* inexact->exact */
+ CASE(OP_INEX2EX): /* inexact->exact */
x=car(sc->args);
if(num_is_integer(x)) {
s_return(sc,x);
@@ -3118,35 +3141,35 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
Error_1(sc,"inexact->exact: not integral:",x);
}
- case OP_EXP:
+ CASE(OP_EXP):
x=car(sc->args);
s_return(sc, mk_real(sc, exp(rvalue(x))));
- case OP_LOG:
+ CASE(OP_LOG):
x=car(sc->args);
s_return(sc, mk_real(sc, log(rvalue(x))));
- case OP_SIN:
+ CASE(OP_SIN):
x=car(sc->args);
s_return(sc, mk_real(sc, sin(rvalue(x))));
- case OP_COS:
+ CASE(OP_COS):
x=car(sc->args);
s_return(sc, mk_real(sc, cos(rvalue(x))));
- case OP_TAN:
+ CASE(OP_TAN):
x=car(sc->args);
s_return(sc, mk_real(sc, tan(rvalue(x))));
- case OP_ASIN:
+ CASE(OP_ASIN):
x=car(sc->args);
s_return(sc, mk_real(sc, asin(rvalue(x))));
- case OP_ACOS:
+ CASE(OP_ACOS):
x=car(sc->args);
s_return(sc, mk_real(sc, acos(rvalue(x))));
- case OP_ATAN:
+ CASE(OP_ATAN):
x=car(sc->args);
if(cdr(sc->args)==sc->NIL) {
s_return(sc, mk_real(sc, atan(rvalue(x))));
@@ -3155,11 +3178,11 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
}
- case OP_SQRT:
+ CASE(OP_SQRT):
x=car(sc->args);
s_return(sc, mk_real(sc, sqrt(rvalue(x))));
- case OP_EXPT: {
+ CASE(OP_EXPT): {
double result;
int real_result=1;
pointer y=cadr(sc->args);
@@ -3188,15 +3211,15 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
}
- case OP_FLOOR:
+ CASE(OP_FLOOR):
x=car(sc->args);
s_return(sc, mk_real(sc, floor(rvalue(x))));
- case OP_CEILING:
+ CASE(OP_CEILING):
x=car(sc->args);
s_return(sc, mk_real(sc, ceil(rvalue(x))));
- case OP_TRUNCATE : {
+ CASE(OP_TRUNCATE ): {
double rvalue_of_x ;
x=car(sc->args);
rvalue_of_x = rvalue(x) ;
@@ -3207,28 +3230,28 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
}
- case OP_ROUND:
+ CASE(OP_ROUND):
x=car(sc->args);
if (num_is_integer(x))
s_return(sc, x);
s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
#endif
- case OP_ADD: /* + */
+ CASE(OP_ADD): /* + */
v=num_zero;
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
v=num_add(v,nvalue(car(x)));
}
s_return(sc,mk_number(sc, v));
- case OP_MUL: /* * */
+ CASE(OP_MUL): /* * */
v=num_one;
for (x = sc->args; x != sc->NIL; x = cdr(x)) {
v=num_mul(v,nvalue(car(x)));
}
s_return(sc,mk_number(sc, v));
- case OP_SUB: /* - */
+ CASE(OP_SUB): /* - */
if(cdr(sc->args)==sc->NIL) {
x=sc->args;
v=num_zero;
@@ -3241,7 +3264,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,mk_number(sc, v));
- case OP_DIV: /* / */
+ CASE(OP_DIV): /* / */
if(cdr(sc->args)==sc->NIL) {
x=sc->args;
v=num_one;
@@ -3258,7 +3281,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,mk_number(sc, v));
- case OP_INTDIV: /* quotient */
+ CASE(OP_INTDIV): /* quotient */
if(cdr(sc->args)==sc->NIL) {
x=sc->args;
v=num_one;
@@ -3275,7 +3298,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,mk_number(sc, v));
- case OP_REM: /* remainder */
+ CASE(OP_REM): /* remainder */
v = nvalue(car(sc->args));
if (ivalue(cadr(sc->args)) != 0)
v=num_rem(v,nvalue(cadr(sc->args)));
@@ -3284,7 +3307,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,mk_number(sc, v));
- case OP_MOD: /* modulo */
+ CASE(OP_MOD): /* modulo */
v = nvalue(car(sc->args));
if (ivalue(cadr(sc->args)) != 0)
v=num_mod(v,nvalue(cadr(sc->args)));
@@ -3293,17 +3316,17 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,mk_number(sc, v));
- case OP_CAR: /* car */
+ CASE(OP_CAR): /* car */
s_return(sc,caar(sc->args));
- case OP_CDR: /* cdr */
+ CASE(OP_CDR): /* cdr */
s_return(sc,cdar(sc->args));
- case OP_CONS: /* cons */
+ CASE(OP_CONS): /* cons */
cdr(sc->args) = cadr(sc->args);
s_return(sc,sc->args);
- case OP_SETCAR: /* set-car! */
+ CASE(OP_SETCAR): /* set-car! */
if(!is_immutable(car(sc->args))) {
caar(sc->args) = cadr(sc->args);
s_return(sc,car(sc->args));
@@ -3311,7 +3334,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
Error_0(sc,"set-car!: unable to alter immutable pair");
}
- case OP_SETCDR: /* set-cdr! */
+ CASE(OP_SETCDR): /* set-cdr! */
if(!is_immutable(car(sc->args))) {
cdar(sc->args) = cadr(sc->args);
s_return(sc,car(sc->args));
@@ -3319,36 +3342,36 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
Error_0(sc,"set-cdr!: unable to alter immutable pair");
}
- case OP_CHAR2INT: { /* char->integer */
+ CASE(OP_CHAR2INT): { /* char->integer */
char c;
c=(char)ivalue(car(sc->args));
s_return(sc,mk_integer(sc,(unsigned char)c));
}
- case OP_INT2CHAR: { /* integer->char */
+ CASE(OP_INT2CHAR): { /* integer->char */
unsigned char c;
c=(unsigned char)ivalue(car(sc->args));
s_return(sc,mk_character(sc,(char)c));
}
- case OP_CHARUPCASE: {
+ CASE(OP_CHARUPCASE): {
unsigned char c;
c=(unsigned char)ivalue(car(sc->args));
c=toupper(c);
s_return(sc,mk_character(sc,(char)c));
}
- case OP_CHARDNCASE: {
+ CASE(OP_CHARDNCASE): {
unsigned char c;
c=(unsigned char)ivalue(car(sc->args));
c=tolower(c);
s_return(sc,mk_character(sc,(char)c));
}
- case OP_STR2SYM: /* string->symbol */
+ CASE(OP_STR2SYM): /* string->symbol */
s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
- case OP_STR2ATOM: /* string->atom */ {
+ CASE(OP_STR2ATOM): /* string->atom */ {
char *s=strvalue(car(sc->args));
long pf = 0;
if(cdr(sc->args)!=sc->NIL) {
@@ -3383,12 +3406,12 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
}
- case OP_SYM2STR: /* symbol->string */
+ CASE(OP_SYM2STR): /* symbol->string */
x=mk_string(sc,symname(car(sc->args)));
setimmutable(x);
s_return(sc,x);
- case OP_ATOM2STR: /* atom->string */ {
+ CASE(OP_ATOM2STR): /* atom->string */ {
long pf = 0;
x=car(sc->args);
if(cdr(sc->args)!=sc->NIL) {
@@ -3414,7 +3437,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
}
}
- case OP_MKSTRING: { /* make-string */
+ CASE(OP_MKSTRING): { /* make-string */
int fill=' ';
int len;
@@ -3426,10 +3449,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc,mk_empty_string(sc,len,(char)fill));
}
- case OP_STRLEN: /* string-length */
+ CASE(OP_STRLEN): /* string-length */
s_return(sc,mk_integer(sc,strlength(car(sc->args))));
- case OP_STRREF: { /* string-ref */
+ CASE(OP_STRREF): { /* string-ref */
char *str;
int index;
@@ -3444,7 +3467,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
}
- case OP_STRSET: { /* string-set! */
+ CASE(OP_STRSET): { /* string-set! */
char *str;
int index;
int c;
@@ -3465,7 +3488,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc,car(sc->args));
}
- case OP_STRAPPEND: { /* string-append */
+ CASE(OP_STRAPPEND): { /* string-append */
/* in 1.29 string-append was in Scheme in init.scm but was too slow */
int len = 0;
pointer newstr;
@@ -3484,7 +3507,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc, newstr);
}
- case OP_SUBSTR: { /* substring */
+ CASE(OP_SUBSTR): { /* substring */
char *str;
int index0;
int index1;
@@ -3515,7 +3538,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc,x);
}
- case OP_VECTOR: { /* vector */
+ CASE(OP_VECTOR): { /* vector */
int i;
pointer vec;
int len=list_length(sc,sc->args);
@@ -3530,7 +3553,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc,vec);
}
- case OP_MKVECTOR: { /* make-vector */
+ CASE(OP_MKVECTOR): { /* make-vector */
pointer fill=sc->NIL;
int len;
pointer vec;
@@ -3548,10 +3571,10 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc,vec);
}
- case OP_VECLEN: /* vector-length */
+ CASE(OP_VECLEN): /* vector-length */
s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
- case OP_VECREF: { /* vector-ref */
+ CASE(OP_VECREF): { /* vector-ref */
int index;
index=ivalue(cadr(sc->args));
@@ -3563,7 +3586,7 @@ static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
s_return(sc,vector_elem(car(sc->args),index));
}
- case OP_VECSET: { /* vector-set! */
+ CASE(OP_VECSET): { /* vector-set! */
int index;
if(is_immutable(car(sc->args))) {
@@ -3634,19 +3657,19 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
int (*comp_func)(num,num)=0;
switch (op) {
- case OP_NOT: /* not */
+ CASE(OP_NOT): /* not */
s_retbool(is_false(car(sc->args)));
- case OP_BOOLP: /* boolean? */
+ CASE(OP_BOOLP): /* boolean? */
s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
- case OP_EOFOBJP: /* boolean? */
+ CASE(OP_EOFOBJP): /* boolean? */
s_retbool(car(sc->args) == sc->EOF_OBJ);
- case OP_NULLP: /* null? */
+ CASE(OP_NULLP): /* null? */
s_retbool(car(sc->args) == sc->NIL);
- case OP_NUMEQ: /* = */
- case OP_LESS: /* < */
- case OP_GRE: /* > */
- case OP_LEQ: /* <= */
- case OP_GEQ: /* >= */
+ CASE(OP_NUMEQ): /* = */
+ CASE(OP_LESS): /* < */
+ CASE(OP_GRE): /* > */
+ CASE(OP_LEQ): /* <= */
+ CASE(OP_GEQ): /* >= */
switch(op) {
case OP_NUMEQ: comp_func=num_eq; break;
case OP_LESS: comp_func=num_lt; break;
@@ -3666,37 +3689,37 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
v=nvalue(car(x));
}
s_retbool(1);
- case OP_SYMBOLP: /* symbol? */
+ CASE(OP_SYMBOLP): /* symbol? */
s_retbool(is_symbol(car(sc->args)));
- case OP_NUMBERP: /* number? */
+ CASE(OP_NUMBERP): /* number? */
s_retbool(is_number(car(sc->args)));
- case OP_STRINGP: /* string? */
+ CASE(OP_STRINGP): /* string? */
s_retbool(is_string(car(sc->args)));
- case OP_INTEGERP: /* integer? */
+ CASE(OP_INTEGERP): /* integer? */
s_retbool(is_integer(car(sc->args)));
- case OP_REALP: /* real? */
+ CASE(OP_REALP): /* real? */
s_retbool(is_number(car(sc->args))); /* All numbers are real */
- case OP_CHARP: /* char? */
+ CASE(OP_CHARP): /* char? */
s_retbool(is_character(car(sc->args)));
#if USE_CHAR_CLASSIFIERS
- case OP_CHARAP: /* char-alphabetic? */
+ CASE(OP_CHARAP): /* char-alphabetic? */
s_retbool(Cisalpha(ivalue(car(sc->args))));
- case OP_CHARNP: /* char-numeric? */
+ CASE(OP_CHARNP): /* char-numeric? */
s_retbool(Cisdigit(ivalue(car(sc->args))));
- case OP_CHARWP: /* char-whitespace? */
+ CASE(OP_CHARWP): /* char-whitespace? */
s_retbool(Cisspace(ivalue(car(sc->args))));
- case OP_CHARUP: /* char-upper-case? */
+ CASE(OP_CHARUP): /* char-upper-case? */
s_retbool(Cisupper(ivalue(car(sc->args))));
- case OP_CHARLP: /* char-lower-case? */
+ CASE(OP_CHARLP): /* char-lower-case? */
s_retbool(Cislower(ivalue(car(sc->args))));
#endif
- case OP_PORTP: /* port? */
+ CASE(OP_PORTP): /* port? */
s_retbool(is_port(car(sc->args)));
- case OP_INPORTP: /* input-port? */
+ CASE(OP_INPORTP): /* input-port? */
s_retbool(is_inport(car(sc->args)));
- case OP_OUTPORTP: /* output-port? */
+ CASE(OP_OUTPORTP): /* output-port? */
s_retbool(is_outport(car(sc->args)));
- case OP_PROCP: /* procedure? */
+ CASE(OP_PROCP): /* procedure? */
/*--
* continuation should be procedure by the example
* (call-with-current-continuation procedure?) ==> #t
@@ -3704,18 +3727,18 @@ static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
*/
s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
|| is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
- case OP_PAIRP: /* pair? */
+ CASE(OP_PAIRP): /* pair? */
s_retbool(is_pair(car(sc->args)));
- case OP_LISTP: /* list? */
+ CASE(OP_LISTP): /* list? */
s_retbool(list_length(sc,car(sc->args)) >= 0);
- case OP_ENVP: /* environment? */
+ CASE(OP_ENVP): /* environment? */
s_retbool(is_environment(car(sc->args)));
- case OP_VECTORP: /* vector? */
+ CASE(OP_VECTORP): /* vector? */
s_retbool(is_vector(car(sc->args)));
- case OP_EQ: /* eq? */
+ CASE(OP_EQ): /* eq? */
s_retbool(car(sc->args) == cadr(sc->args));
- case OP_EQV: /* eqv? */
+ CASE(OP_EQV): /* eqv? */
s_retbool(eqv(car(sc->args), cadr(sc->args)));
default:
snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
@@ -3728,7 +3751,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
pointer x, y;
switch (op) {
- case OP_FORCE: /* force */
+ CASE(OP_FORCE): /* force */
sc->code = car(sc->args);
if (is_promise(sc->code)) {
/* Should change type to closure here */
@@ -3739,13 +3762,13 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->code);
}
- case OP_SAVE_FORCED: /* Save forced value replacing promise */
+ CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */
memcpy(sc->code,sc->value,sizeof(struct cell));
s_return(sc,sc->value);
- case OP_WRITE: /* write */
- case OP_DISPLAY: /* display */
- case OP_WRITE_CHAR: /* write-char */
+ CASE(OP_WRITE): /* write */
+ CASE(OP_DISPLAY): /* display */
+ CASE(OP_WRITE_CHAR): /* write-char */
if(is_pair(cdr(sc->args))) {
if(cadr(sc->args)!=sc->outport) {
x=cons(sc,sc->outport,sc->NIL);
@@ -3761,7 +3784,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
}
s_goto(sc,OP_P0LIST);
- case OP_NEWLINE: /* newline */
+ CASE(OP_NEWLINE): /* newline */
if(is_pair(sc->args)) {
if(car(sc->args)!=sc->outport) {
x=cons(sc,sc->outport,sc->NIL);
@@ -3772,7 +3795,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
putstr(sc, "\n");
s_return(sc,sc->T);
- case OP_ERR0: /* error */
+ CASE(OP_ERR0): /* error */
sc->retcode=-1;
if (!is_string(car(sc->args))) {
sc->args=cons(sc,mk_string(sc," -- "),sc->args);
@@ -3781,9 +3804,9 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
putstr(sc, "Error: ");
putstr(sc, strvalue(car(sc->args)));
sc->args = cdr(sc->args);
- s_goto(sc,OP_ERR1);
+ s_thread_to(sc,OP_ERR1);
- case OP_ERR1: /* error */
+ CASE(OP_ERR1): /* error */
putstr(sc, " ");
if (sc->args != sc->NIL) {
s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
@@ -3799,13 +3822,13 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
}
}
- case OP_REVERSE: /* reverse */
+ CASE(OP_REVERSE): /* reverse */
s_return(sc,reverse(sc, car(sc->args)));
- case OP_LIST_STAR: /* list* */
+ CASE(OP_LIST_STAR): /* list* */
s_return(sc,list_star(sc,sc->args));
- case OP_APPEND: /* append */
+ CASE(OP_APPEND): /* append */
x = sc->NIL;
y = sc->args;
if (y == x) {
@@ -3825,7 +3848,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
s_return(sc, reverse_in_place(sc, car(y), x));
#if USE_PLIST
- case OP_PUT: /* put */
+ CASE(OP_PUT): /* put */
if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
Error_0(sc,"illegal use of put");
}
@@ -3841,7 +3864,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
symprop(car(sc->args)));
s_return(sc,sc->T);
- case OP_GET: /* get */
+ CASE(OP_GET): /* get */
if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
Error_0(sc,"illegal use of get");
}
@@ -3856,42 +3879,42 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
s_return(sc,sc->NIL);
}
#endif /* USE_PLIST */
- case OP_QUIT: /* quit */
+ CASE(OP_QUIT): /* quit */
if(is_pair(sc->args)) {
sc->retcode=ivalue(car(sc->args));
}
return (sc->NIL);
- case OP_GC: /* gc */
+ CASE(OP_GC): /* gc */
gc(sc, sc->NIL, sc->NIL);
s_return(sc,sc->T);
- case OP_GCVERB: /* gc-verbose */
+ CASE(OP_GCVERB): /* gc-verbose */
{ int was = sc->gc_verbose;
sc->gc_verbose = (car(sc->args) != sc->F);
s_retbool(was);
}
- case OP_NEWSEGMENT: /* new-segment */
+ CASE(OP_NEWSEGMENT): /* new-segment */
if (!is_pair(sc->args) || !is_number(car(sc->args))) {
Error_0(sc,"new-segment: argument must be a number");
}
alloc_cellseg(sc, (int) ivalue(car(sc->args)));
s_return(sc,sc->T);
- case OP_OBLIST: /* oblist */
+ CASE(OP_OBLIST): /* oblist */
s_return(sc, oblist_all_symbols(sc));
- case OP_CURR_INPORT: /* current-input-port */
+ CASE(OP_CURR_INPORT): /* current-input-port */
s_return(sc,sc->inport);
- case OP_CURR_OUTPORT: /* current-output-port */
+ CASE(OP_CURR_OUTPORT): /* current-output-port */
s_return(sc,sc->outport);
- case OP_OPEN_INFILE: /* open-input-file */
- case OP_OPEN_OUTFILE: /* open-output-file */
- case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
+ CASE(OP_OPEN_INFILE): /* open-input-file */
+ CASE(OP_OPEN_OUTFILE): /* open-output-file */
+ CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ {
int prop=0;
pointer p;
switch(op) {
@@ -3910,8 +3933,8 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
}
#if USE_STRING_PORTS
- case OP_OPEN_INSTRING: /* open-input-string */
- case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
+ CASE(OP_OPEN_INSTRING): /* open-input-string */
+ CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ {
int prop=0;
pointer p;
switch(op) {
@@ -3926,7 +3949,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,p);
}
- case OP_OPEN_OUTSTRING: /* open-output-string */ {
+ CASE(OP_OPEN_OUTSTRING): /* open-output-string */ {
pointer p;
if(car(sc->args)==sc->NIL) {
p=port_from_scratch(sc);
@@ -3943,7 +3966,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,p);
}
- case OP_GET_OUTSTRING: /* get-output-string */ {
+ CASE(OP_GET_OUTSTRING): /* get-output-string */ {
port *p;
if ((p=car(sc->args)->_object._port)->kind&port_string) {
@@ -3966,18 +3989,18 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
}
#endif
- case OP_CLOSE_INPORT: /* close-input-port */
+ CASE(OP_CLOSE_INPORT): /* close-input-port */
port_close(sc,car(sc->args),port_input);
s_return(sc,sc->T);
- case OP_CLOSE_OUTPORT: /* close-output-port */
+ CASE(OP_CLOSE_OUTPORT): /* close-output-port */
port_close(sc,car(sc->args),port_output);
s_return(sc,sc->T);
- case OP_INT_ENV: /* interaction-environment */
+ CASE(OP_INT_ENV): /* interaction-environment */
s_return(sc,sc->global_env);
- case OP_CURR_ENV: /* current-environment */
+ CASE(OP_CURR_ENV): /* current-environment */
s_return(sc,sc->envir);
}
@@ -3996,7 +4019,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
switch (op) {
/* ========== reading part ========== */
- case OP_READ:
+ CASE(OP_READ):
if(!is_pair(sc->args)) {
s_goto(sc,OP_READ_INTERNAL);
}
@@ -4012,8 +4035,8 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
s_save(sc,OP_SET_INPORT, x, sc->NIL);
s_goto(sc,OP_READ_INTERNAL);
- case OP_READ_CHAR: /* read-char */
- case OP_PEEK_CHAR: /* peek-char */ {
+ CASE(OP_READ_CHAR): /* read-char */
+ CASE(OP_PEEK_CHAR): /* peek-char */ {
int c;
if(is_pair(sc->args)) {
if(car(sc->args)!=sc->inport) {
@@ -4033,7 +4056,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
s_return(sc,mk_character(sc,c));
}
- case OP_CHAR_READY: /* char-ready? */ {
+ CASE(OP_CHAR_READY): /* char-ready? */ {
pointer p=sc->inport;
int res;
if(is_pair(sc->args)) {
@@ -4043,15 +4066,15 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
s_retbool(res);
}
- case OP_SET_INPORT: /* set-input-port */
+ CASE(OP_SET_INPORT): /* set-input-port */
sc->inport=car(sc->args);
s_return(sc,sc->value);
- case OP_SET_OUTPORT: /* set-output-port */
+ CASE(OP_SET_OUTPORT): /* set-output-port */
sc->outport=car(sc->args);
s_return(sc,sc->value);
- case OP_RDSEXPR:
+ CASE(OP_RDSEXPR):
switch (sc->tok) {
case TOK_EOF:
s_return(sc,sc->EOF_OBJ);
@@ -4068,30 +4091,30 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
} else {
sc->nesting_stack[sc->file_i]++;
s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
}
case TOK_QUOTE:
s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
sc->tok = token(sc);
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
case TOK_BQUOTE:
sc->tok = token(sc);
if(sc->tok==TOK_VEC) {
s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
sc->tok=TOK_LPAREN;
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
} else {
s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
}
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
case TOK_COMMA:
s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
sc->tok = token(sc);
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
case TOK_ATMARK:
s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
sc->tok = token(sc);
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
case TOK_ATOM:
s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
case TOK_DQUOTE:
@@ -4121,7 +4144,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
}
break;
- case OP_RDLIST: {
+ CASE(OP_RDLIST): {
sc->args = cons(sc, sc->value, sc->args);
sc->tok = token(sc);
if (sc->tok == TOK_EOF)
@@ -4139,14 +4162,14 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
} else if (sc->tok == TOK_DOT) {
s_save(sc,OP_RDDOT, sc->args, sc->NIL);
sc->tok = token(sc);
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
} else {
s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
}
}
- case OP_RDDOT:
+ CASE(OP_RDDOT):
if (token(sc) != TOK_RPAREN) {
Error_0(sc,"syntax error: illegal dot expression");
} else {
@@ -4154,26 +4177,26 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
s_return(sc,reverse_in_place(sc, sc->value, sc->args));
}
- case OP_RDQUOTE:
+ CASE(OP_RDQUOTE):
s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
- case OP_RDQQUOTE:
+ CASE(OP_RDQQUOTE):
s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
- case OP_RDQQUOTEVEC:
+ CASE(OP_RDQQUOTEVEC):
s_return(sc,cons(sc, mk_symbol(sc,"apply"),
cons(sc, mk_symbol(sc,"vector"),
cons(sc,cons(sc, sc->QQUOTE,
cons(sc,sc->value,sc->NIL)),
sc->NIL))));
- case OP_RDUNQUOTE:
+ CASE(OP_RDUNQUOTE):
s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
- case OP_RDUQTSP:
+ CASE(OP_RDUQTSP):
s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
- case OP_RDVEC:
+ CASE(OP_RDVEC):
/*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
s_goto(sc,OP_EVAL); Cannot be quoted*/
/*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
@@ -4185,11 +4208,11 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
s_goto(sc,OP_VECTOR);
/* ========== printing part ========== */
- case OP_P0LIST:
+ CASE(OP_P0LIST):
if(is_vector(sc->args)) {
putstr(sc,"#(");
sc->args=cons(sc,sc->args,mk_integer(sc,0));
- s_goto(sc,OP_PVECFROM);
+ s_thread_to(sc,OP_PVECFROM);
} else if(is_environment(sc->args)) {
putstr(sc,"#<ENVIRONMENT>");
s_return(sc,sc->T);
@@ -4199,36 +4222,36 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
} else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
putstr(sc, "'");
sc->args = cadr(sc->args);
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
putstr(sc, "`");
sc->args = cadr(sc->args);
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
putstr(sc, ",");
sc->args = cadr(sc->args);
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
putstr(sc, ",@");
sc->args = cadr(sc->args);
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else {
putstr(sc, "(");
s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
sc->args = car(sc->args);
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
}
- case OP_P1LIST:
+ CASE(OP_P1LIST):
if (is_pair(sc->args)) {
s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
putstr(sc, " ");
sc->args = car(sc->args);
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else if(is_vector(sc->args)) {
s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
putstr(sc, " . ");
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else {
if (sc->args != sc->NIL) {
putstr(sc, " . ");
@@ -4237,7 +4260,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
putstr(sc, ")");
s_return(sc,sc->T);
}
- case OP_PVECFROM: {
+ CASE(OP_PVECFROM): {
int i=ivalue_unchecked(cdr(sc->args));
pointer vec=car(sc->args);
int len=ivalue_unchecked(vec);
@@ -4251,7 +4274,7 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
sc->args=elem;
if (i > 0)
putstr(sc," ");
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
}
}
@@ -4268,14 +4291,14 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
long v;
switch (op) {
- case OP_LIST_LENGTH: /* length */ /* a.k */
+ CASE(OP_LIST_LENGTH): /* length */ /* a.k */
v=list_length(sc,car(sc->args));
if(v<0) {
Error_1(sc,"length: not a list:",car(sc->args));
}
s_return(sc,mk_integer(sc, v));
- case OP_ASSQ: /* assq */ /* a.k */
+ CASE(OP_ASSQ): /* assq */ /* a.k */
x = car(sc->args);
for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
if (!is_pair(car(y))) {
@@ -4291,7 +4314,7 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
}
- case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */
+ CASE(OP_GET_CLOSURE): /* get-closure-code */ /* a.k */
sc->args = car(sc->args);
if (sc->args == sc->NIL) {
s_return(sc,sc->F);
@@ -4302,13 +4325,13 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
} else {
s_return(sc,sc->F);
}
- case OP_CLOSUREP: /* closure? */
+ CASE(OP_CLOSUREP): /* closure? */
/*
* Note, macro object is also a closure.
* Therefore, (closure? <#MACRO>) ==> #t
*/
s_retbool(is_closure(car(sc->args)));
- case OP_MACROP: /* macro? */
+ CASE(OP_MACROP): /* macro? */
s_retbool(is_macro(car(sc->args)));
default:
snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index 8d6fb42..8e93177 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -90,6 +90,11 @@ extern "C" {
# define USE_COMPILE_HOOK 1
#endif
+/* Enable faster opcode dispatch. */
+#ifndef USE_THREADED_CODE
+# define USE_THREADED_CODE 1
+#endif
+
#ifndef USE_STRCASECMP /* stricmp for Unix */
# define USE_STRCASECMP 0
#endif
commit 568cfcde45a0d6c456d8f8be1ea0e408416badad
Author: Justus Winter <justus at g10code.com>
Date: Wed Nov 9 13:34:54 2016 +0100
gpgscm: Make the compile-hook configurable.
* tests/gpgscm/scheme-private.h (struct scheme): Make field
'COMPILE_HOOK' optional.
* tests/gpgscm/scheme.c (opexe_0): Fix guard.
(scheme_init_custom_alloc): Conditionally initialize 'COMPILE_HOOK'.
* tests/gpgscm/scheme.h (USE_COMPILE_HOOK): Define to 1 by default.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h
index f5e4b0a..884889c 100644
--- a/tests/gpgscm/scheme-private.h
+++ b/tests/gpgscm/scheme-private.h
@@ -115,7 +115,9 @@ pointer FEED_TO; /* => */
pointer COLON_HOOK; /* *colon-hook* */
pointer ERROR_HOOK; /* *error-hook* */
pointer SHARP_HOOK; /* *sharp-hook* */
+#if USE_COMPILE_HOOK
pointer COMPILE_HOOK; /* *compile-hook* */
+#endif
pointer free_cell; /* pointer to top of free cells */
long fcells; /* # of free cells */
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 6daa280..884ffd5 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2688,7 +2688,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
sc->code = sc->value;
s_goto(sc,OP_EVAL);
-#if 1
+#if USE_COMPILE_HOOK
case OP_LAMBDA: /* lambda */
/* If the hook is defined, apply it to sc->code, otherwise
set sc->value fall through */
@@ -4737,7 +4737,9 @@ int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
+#if USE_COMPILE_HOOK
sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
+#endif
return !sc->no_memory;
}
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index bd6cda5..8d6fb42 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -40,6 +40,7 @@ extern "C" {
# define USE_ERROR_HOOK 0
# define USE_TRACING 0
# define USE_COLON_HOOK 0
+# define USE_COMPILE_HOOK 0
# define USE_DL 0
# define USE_PLIST 0
#endif
@@ -83,6 +84,12 @@ extern "C" {
# define USE_COLON_HOOK 1
#endif
+/* Compile functions using *compile-hook*. The default hook expands
+ * macros. */
+#ifndef USE_COMPILE_HOOK
+# define USE_COMPILE_HOOK 1
+#endif
+
#ifndef USE_STRCASECMP /* stricmp for Unix */
# define USE_STRCASECMP 0
#endif
commit 9ee184bc0afaea06785d836ed175b851b9ae532f
Author: Justus Winter <justus at g10code.com>
Date: Tue Nov 8 18:35:42 2016 +0100
gpgscm: Drop obsolete commented-out code.
* tests/gpgscm/scheme.c (opexe_5): Drop obsolete code.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index c1340d7..6daa280 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -4056,17 +4056,6 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
case TOK_EOF:
s_return(sc,sc->EOF_OBJ);
/* NOTREACHED */
-/*
- * Commented out because we now skip comments in the scanner
- *
- case TOK_COMMENT: {
- int c;
- while ((c=inchar(sc)) != '\n' && c!=EOF)
- ;
- sc->tok = token(sc);
- s_goto(sc,OP_RDSEXPR);
- }
-*/
case TOK_VEC:
s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
/* fall through */
@@ -4135,14 +4124,6 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
case OP_RDLIST: {
sc->args = cons(sc, sc->value, sc->args);
sc->tok = token(sc);
-/* We now skip comments in the scanner
- while (sc->tok == TOK_COMMENT) {
- int c;
- while ((c=inchar(sc)) != '\n' && c!=EOF)
- ;
- sc->tok = token(sc);
- }
-*/
if (sc->tok == TOK_EOF)
{ s_return(sc,sc->EOF_OBJ); }
else if (sc->tok == TOK_RPAREN) {
commit d7c5799c282a03dcce0e3d327075233353cb76cc
Author: Justus Winter <justus at g10code.com>
Date: Tue Nov 8 18:08:42 2016 +0100
gpgscm: Remove dubious stack implementation.
* tests/gpgscm/scheme-private.h (struct scheme): Remove related fields.
* tests/gpgscm/scheme.c: Drop all !USE_SCHEME_STACK code.
* tests/gpgscm/scheme.h (USE_SCHEME_STACK): Remove macro.
Signed-off-by: Justus Winter <justus at g10code.com>
diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h
index 727e0c0..f5e4b0a 100644
--- a/tests/gpgscm/scheme-private.h
+++ b/tests/gpgscm/scheme-private.h
@@ -155,8 +155,6 @@ void *ext_data; /* For the benefit of foreign functions */
long gensym_cnt;
struct scheme_interface *vptr;
-void *dump_base; /* pointer to base of allocated dump stack */
-int dump_size; /* number of frames allocated for dump stack */
};
/* operator code */
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 44dd165..c1340d7 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2442,93 +2442,6 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
#define s_return(sc,a) return _s_return(sc,a)
-#ifndef USE_SCHEME_STACK
-
-/* this structure holds all the interpreter's registers */
-struct dump_stack_frame {
- enum scheme_opcodes op;
- pointer args;
- pointer envir;
- pointer code;
-};
-
-#define STACK_GROWTH 3
-
-static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
-{
- int nframes = (int)sc->dump;
- struct dump_stack_frame *next_frame;
-
- /* enough room for the next frame? */
- if (nframes >= sc->dump_size) {
- sc->dump_size += STACK_GROWTH;
- /* alas there is no sc->realloc */
- sc->dump_base = realloc(sc->dump_base,
- sizeof(struct dump_stack_frame) * sc->dump_size);
- }
- next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
- next_frame->op = op;
- next_frame->args = args;
- next_frame->envir = sc->envir;
- next_frame->code = code;
- sc->dump = (pointer)(nframes+1);
-}
-
-static pointer _s_return(scheme *sc, pointer a)
-{
- int nframes = (int)sc->dump;
- struct dump_stack_frame *frame;
-
- sc->value = (a);
- if (nframes <= 0) {
- return sc->NIL;
- }
- nframes--;
- frame = (struct dump_stack_frame *)sc->dump_base + nframes;
- sc->op = frame->op;
- sc->args = frame->args;
- sc->envir = frame->envir;
- sc->code = frame->code;
- sc->dump = (pointer)nframes;
- return sc->T;
-}
-
-static INLINE void dump_stack_reset(scheme *sc)
-{
- /* in this implementation, sc->dump is the number of frames on the stack */
- sc->dump = (pointer)0;
-}
-
-static INLINE void dump_stack_initialize(scheme *sc)
-{
- sc->dump_size = 0;
- sc->dump_base = NULL;
- dump_stack_reset(sc);
-}
-
-static void dump_stack_free(scheme *sc)
-{
- free(sc->dump_base);
- sc->dump_base = NULL;
- sc->dump = (pointer)0;
- sc->dump_size = 0;
-}
-
-static INLINE void dump_stack_mark(scheme *sc)
-{
- int nframes = (int)sc->dump;
- int i;
- for(i=0; i<nframes; i++) {
- struct dump_stack_frame *frame;
- frame = (struct dump_stack_frame *)sc->dump_base + i;
- mark(frame->args);
- mark(frame->envir);
- mark(frame->code);
- }
-}
-
-#else
-
static INLINE void dump_stack_reset(scheme *sc)
{
sc->dump = sc->NIL;
@@ -2565,7 +2478,6 @@ static INLINE void dump_stack_mark(scheme *sc)
{
mark(sc->dump);
}
-#endif
#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
index f4231c4..bd6cda5 100644
--- a/tests/gpgscm/scheme.h
+++ b/tests/gpgscm/scheme.h
@@ -44,11 +44,6 @@ extern "C" {
# define USE_PLIST 0
#endif
-/*
- * Leave it defined if you want continuations, and also for the Sharp Zaurus.
- * Undefine it if you only care about faster speed and not strict Scheme compatibility.
- */
-#define USE_SCHEME_STACK
#if USE_DL
# define USE_INTERFACE 1
-----------------------------------------------------------------------
Summary of changes:
tests/gpgscm/scheme-private.h | 4 +-
tests/gpgscm/scheme.c | 640 +++++++++++++++++++-----------------------
tests/gpgscm/scheme.h | 17 +-
3 files changed, 307 insertions(+), 354 deletions(-)
hooks/post-receive
--
The GNU Privacy Guard
http://git.gnupg.org
More information about the Gnupg-commits
mailing list