diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h index bb99698f5..f4e5280e9 100644 --- a/tests/gpgscm/opdefines.h +++ b/tests/gpgscm/opdefines.h @@ -106,38 +106,38 @@ _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 ) - _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP ) - _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) - _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) - _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) - _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) - _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) - _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) - _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP ) - _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP ) - _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) - _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP ) - _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP ) + _OP_DEF(opexe_0, "not", 1, 1, TST_NONE, OP_NOT ) + _OP_DEF(opexe_0, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) + _OP_DEF(opexe_0, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) + _OP_DEF(opexe_0, "null?", 1, 1, TST_NONE, OP_NULLP ) + _OP_DEF(opexe_0, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) + _OP_DEF(opexe_0, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) + _OP_DEF(opexe_0, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) + _OP_DEF(opexe_0, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) + _OP_DEF(opexe_0, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) + _OP_DEF(opexe_0, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) + _OP_DEF(opexe_0, "number?", 1, 1, TST_ANY, OP_NUMBERP ) + _OP_DEF(opexe_0, "string?", 1, 1, TST_ANY, OP_STRINGP ) + _OP_DEF(opexe_0, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) + _OP_DEF(opexe_0, "real?", 1, 1, TST_ANY, OP_REALP ) + _OP_DEF(opexe_0, "char?", 1, 1, TST_ANY, OP_CHARP ) #if USE_CHAR_CLASSIFIERS - _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) - _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) - _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) - _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) - _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) + _OP_DEF(opexe_0, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) + _OP_DEF(opexe_0, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) + _OP_DEF(opexe_0, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) + _OP_DEF(opexe_0, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) + _OP_DEF(opexe_0, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) #endif - _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP ) - _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) - _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) - _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP ) - _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP ) - _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP ) - _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP ) - _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) - _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) - _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV ) + _OP_DEF(opexe_0, "port?", 1, 1, TST_ANY, OP_PORTP ) + _OP_DEF(opexe_0, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) + _OP_DEF(opexe_0, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) + _OP_DEF(opexe_0, "procedure?", 1, 1, TST_ANY, OP_PROCP ) + _OP_DEF(opexe_0, "pair?", 1, 1, TST_ANY, OP_PAIRP ) + _OP_DEF(opexe_0, "list?", 1, 1, TST_ANY, OP_LISTP ) + _OP_DEF(opexe_0, "environment?", 1, 1, TST_ANY, OP_ENVP ) + _OP_DEF(opexe_0, "vector?", 1, 1, TST_ANY, OP_VECTORP ) + _OP_DEF(opexe_0, "eq?", 2, 2, TST_ANY, OP_EQ ) + _OP_DEF(opexe_0, "eqv?", 2, 2, TST_ANY, OP_EQV ) _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE ) _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED ) _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c index 31baed235..e3f06de25 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_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); static pointer opexe_6(scheme *sc, enum scheme_opcodes op); @@ -3323,6 +3322,50 @@ set_property(scheme *sc, pointer obj, pointer key, pointer value) +static int is_list(scheme *sc, pointer a) +{ return list_length(sc,a) >= 0; } + +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +int list_length(scheme *sc, pointer a) { + int i=0; + pointer slow, fast; + + slow = fast = a; + while (1) + { + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + fast = cdr(fast); + ++i; + if (fast == sc->NIL) + return i; + if (!is_pair(fast)) + return -2 - i; + ++i; + fast = cdr(fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr(slow); + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + + + #define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { @@ -3332,6 +3375,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { #if USE_MATH double dd; #endif + int (*comp_func)(num, num) = NULL; switch (op) { CASE(OP_LOAD): /* load */ @@ -4506,61 +4550,6 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { s_return(sc,car(sc->args)); } - default: - snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static int is_list(scheme *sc, pointer a) -{ return list_length(sc,a) >= 0; } - -/* Result is: - proper list: length - circular list: -1 - not even a pair: -2 - dotted list: -2 minus length before dot -*/ -int list_length(scheme *sc, pointer a) { - int i=0; - pointer slow, fast; - - slow = fast = a; - while (1) - { - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - fast = cdr(fast); - ++i; - if (fast == sc->NIL) - return i; - if (!is_pair(fast)) - return -2 - i; - ++i; - fast = cdr(fast); - - /* Safe because we would have already returned if `fast' - encountered a non-pair. */ - slow = cdr(slow); - if (fast == slow) - { - /* the fast pointer has looped back around and caught up - with the slow pointer, hence the structure is circular, - not of finite length, and therefore not a list */ - return -1; - } - } -} - -static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; - int (*comp_func)(num,num)=0; - - switch (op) { CASE(OP_NOT): /* not */ s_retbool(is_false(car(sc->args))); CASE(OP_BOOLP): /* boolean? */