diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h index affc7889c..bb99698f5 100644 --- a/tests/gpgscm/opdefines.h +++ b/tests/gpgscm/opdefines.h @@ -59,53 +59,53 @@ _OP_DEF(opexe_0, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) _OP_DEF(opexe_0, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) #if USE_MATH - _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) - _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP ) - _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG ) - _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN ) - _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS ) - _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN ) - _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN ) - _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS ) - _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN ) - _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) - _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT ) - _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) - _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) - _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) - _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND ) + _OP_DEF(opexe_0, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) + _OP_DEF(opexe_0, "exp", 1, 1, TST_NUMBER, OP_EXP ) + _OP_DEF(opexe_0, "log", 1, 1, TST_NUMBER, OP_LOG ) + _OP_DEF(opexe_0, "sin", 1, 1, TST_NUMBER, OP_SIN ) + _OP_DEF(opexe_0, "cos", 1, 1, TST_NUMBER, OP_COS ) + _OP_DEF(opexe_0, "tan", 1, 1, TST_NUMBER, OP_TAN ) + _OP_DEF(opexe_0, "asin", 1, 1, TST_NUMBER, OP_ASIN ) + _OP_DEF(opexe_0, "acos", 1, 1, TST_NUMBER, OP_ACOS ) + _OP_DEF(opexe_0, "atan", 1, 2, TST_NUMBER, OP_ATAN ) + _OP_DEF(opexe_0, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) + _OP_DEF(opexe_0, "expt", 2, 2, TST_NUMBER, OP_EXPT ) + _OP_DEF(opexe_0, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) + _OP_DEF(opexe_0, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) + _OP_DEF(opexe_0, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) + _OP_DEF(opexe_0, "round", 1, 1, TST_NUMBER, OP_ROUND ) #endif - _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) - _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) - _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) - _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) - _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) - _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM ) - _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD ) - _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR ) - _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR ) - _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS ) - _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) - _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) - _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) - _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) - _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) - _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) - _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) - _OP_DEF(opexe_2, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) - _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) - _OP_DEF(opexe_2, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) - _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) - _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN ) - _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) - _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) - _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) - _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) - _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) - _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) - _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) - _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) - _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) + _OP_DEF(opexe_0, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) + _OP_DEF(opexe_0, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) + _OP_DEF(opexe_0, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) + _OP_DEF(opexe_0, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) + _OP_DEF(opexe_0, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) + _OP_DEF(opexe_0, "remainder", 2, 2, TST_INTEGER, OP_REM ) + _OP_DEF(opexe_0, "modulo", 2, 2, TST_INTEGER, OP_MOD ) + _OP_DEF(opexe_0, "car", 1, 1, TST_PAIR, OP_CAR ) + _OP_DEF(opexe_0, "cdr", 1, 1, TST_PAIR, OP_CDR ) + _OP_DEF(opexe_0, "cons", 2, 2, TST_NONE, OP_CONS ) + _OP_DEF(opexe_0, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) + _OP_DEF(opexe_0, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) + _OP_DEF(opexe_0, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) + _OP_DEF(opexe_0, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) + _OP_DEF(opexe_0, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) + _OP_DEF(opexe_0, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) + _OP_DEF(opexe_0, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) + _OP_DEF(opexe_0, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) + _OP_DEF(opexe_0, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) + _OP_DEF(opexe_0, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) + _OP_DEF(opexe_0, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) + _OP_DEF(opexe_0, "string-length", 1, 1, TST_STRING, OP_STRLEN ) + _OP_DEF(opexe_0, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) + _OP_DEF(opexe_0, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) + _OP_DEF(opexe_0, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) + _OP_DEF(opexe_0, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) + _OP_DEF(opexe_0, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) + _OP_DEF(opexe_0, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) + _OP_DEF(opexe_0, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) + _OP_DEF(opexe_0, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) + _OP_DEF(opexe_0, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c index c3c88d03c..31baed235 100644 --- a/tests/gpgscm/scheme.c +++ b/tests/gpgscm/scheme.c @@ -438,7 +438,6 @@ static pointer reverse_in_place(scheme *sc, pointer term, pointer list); static pointer revappend(scheme *sc, pointer a, pointer b); static void dump_stack_mark(scheme *); static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_2(scheme *sc, enum scheme_opcodes op); static pointer opexe_3(scheme *sc, enum scheme_opcodes op); static pointer opexe_4(scheme *sc, enum scheme_opcodes op); static pointer opexe_5(scheme *sc, enum scheme_opcodes op); @@ -3276,11 +3275,63 @@ history_flatten(scheme *sc) +#if USE_PLIST +static pointer +get_property(scheme *sc, pointer obj, pointer key) +{ + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + return cdar(x); + + return sc->NIL; +} + +static pointer +set_property(scheme *sc, pointer obj, pointer key, pointer value) +{ +#define set_property_allocates 2 + pointer x; + + assert (is_symbol(obj)); + assert (is_symbol(key)); + + for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { + if (caar(x) == key) + break; + } + + if (x != sc->NIL) + cdar(x) = value; + else { + gc_disable(sc, gc_reservations(set_property)); + symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); + gc_enable(sc); + } + + return sc->T; +} +#endif + + + #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { pointer x, y; pointer callsite; + num v; +#if USE_MATH + double dd; +#endif switch (op) { CASE(OP_LOAD): /* load */ @@ -3968,67 +4019,6 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { gc_enable(sc); s_goto(sc,OP_APPLY); - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -#if USE_PLIST -static pointer -get_property(scheme *sc, pointer obj, pointer key) -{ - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - return cdar(x); - - return sc->NIL; -} - -static pointer -set_property(scheme *sc, pointer obj, pointer key, pointer value) -{ -#define set_property_allocates 2 - pointer x; - - assert (is_symbol(obj)); - assert (is_symbol(key)); - - for (x = symprop(obj); x != sc->NIL; x = cdr(x)) { - if (caar(x) == key) - break; - } - - if (x != sc->NIL) - cdar(x) = value; - else { - gc_disable(sc, gc_reservations(set_property)); - symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj)); - gc_enable(sc); - } - - return sc->T; -} -#endif - -static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; -#if USE_MATH - double dd; -#endif - - switch (op) { #if USE_MATH CASE(OP_INEX2EX): /* inexact->exact */ x=car(sc->args);