--- microscheme/scheme.c 2015/11/26 22:55:39 1.21 +++ microscheme/scheme.c 2015/11/28 10:31:06 1.29 @@ -30,6 +30,8 @@ # include #endif +#include "ecb.h" + #include #include #include @@ -67,16 +69,6 @@ #define S_SINK (&SCHEME_V->xsink) #define S_EOF (&SCHEME_V->xEOF_OBJ) -/* should use libecb */ -#if __GNUC__ >= 4 -# define ecb_expect(expr,value) __builtin_expect ((expr),(value)) -# define ecb_expect_false(expr) ecb_expect (!!(expr), 0) -# define ecb_expect_true(expr) ecb_expect (!!(expr), 1) -#else -# define ecb_expect_false(expr) !!(expr) -# define ecb_expect_true(expr) !!(expr) -#endif - #if !USE_MULTIPLICITY static scheme sc; #endif @@ -155,9 +147,9 @@ #define tolower(c) xtolower (c) #define isdigit(c) xisdigit (c) -#if USE_STRLWR +#if USE_IGNORECASE static const char * -strlwr (char *s) +xstrlwr (char *s) { const char *p = s; @@ -169,10 +161,14 @@ return p; } -#endif -#define stricmp(a,b) strcmp (a, b) -#define strlwr(s) (s) +#define stricmp(a,b) strcasecmp (a, b) +#define strlwr(s) xstrlwr (s) + +#else +# define stricmp(a,b) strcmp (a, b) +# define strlwr(s) (s) +#endif #ifndef prompt # define prompt "ts> " @@ -188,12 +184,12 @@ enum scheme_types { - T_FREE, + T_INTEGER, + T_REAL, T_STRING, - T_NUMBER, T_SYMBOL, T_PROC, - T_PAIR, + T_PAIR, /* also used for free cells */ T_CLOSURE, T_CONTINUATION, T_FOREIGN, @@ -213,6 +209,32 @@ #define T_ATOM 0x0040 /* only for gc */ #define T_MARK 0x0080 /* only for gc */ +/* num, for generic arithmetic */ +struct num +{ + IVALUE ivalue; +#if USE_REAL + RVALUE rvalue; + char is_fixnum; +#endif +}; + +#if USE_REAL +# define num_is_fixnum(n) (n).is_fixnum +# define num_set_fixnum(n,f) (n).is_fixnum = (f) +# define num_ivalue(n) (n).ivalue +# define num_rvalue(n) (n).rvalue +# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i) +# define num_set_rvalue(n,r) (n).rvalue = (r) +#else +# define num_is_fixnum(n) 1 +# define num_set_fixnum(n,f) 0 +# define num_ivalue(n) (n).ivalue +# define num_rvalue(n) (n).ivalue +# define num_set_ivalue(n,i) (n).ivalue = (i) +# define num_set_rvalue(n,r) (n).ivalue = (r) +#endif + enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV }; static num num_op (enum num_op op, num a, num b); @@ -225,12 +247,6 @@ #endif static int is_zero_rvalue (RVALUE x); -static INLINE int -num_is_integer (pointer p) -{ - return num_is_fixnum (p->object.number); -} - static num num_zero; static num num_one; @@ -239,7 +255,7 @@ #define set_typeflag(p,v) ((p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) -INTERFACE INLINE int +INTERFACE int is_string (pointer p) { return type (p) == T_STRING; @@ -248,9 +264,7 @@ #define strvalue(p) ((p)->object.string.svalue) #define strlength(p) ((p)->object.string.length) -INTERFACE int is_list (SCHEME_P_ pointer p); - -INTERFACE INLINE int +INTERFACE int is_vector (pointer p) { return type (p) == T_VECTOR; @@ -258,118 +272,77 @@ #define vecvalue(p) ((p)->object.vector.vvalue) #define veclength(p) ((p)->object.vector.length) -INTERFACE void fill_vector (pointer vec, pointer obj); -INTERFACE uint32_t vector_length (pointer vec); -INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); -INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); +INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); +INTERFACE pointer vector_get (pointer vec, uint32_t ielem); +INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); -INTERFACE uint32_t -vector_length (pointer vec) -{ - return vec->object.vector.length; -} - -INTERFACE INLINE int -is_number (pointer p) +INTERFACE int +is_integer (pointer p) { - return type (p) == T_NUMBER; + return type (p) == T_INTEGER; } -INTERFACE INLINE int -is_integer (pointer p) +/* not the same as in scheme, where integers are (correctly :) reals */ +INTERFACE int +is_real (pointer p) { - if (!is_number (p)) - return 0; - - if (num_is_integer (p) || ivalue (p) == rvalue (p)) - return 1; - - return 0; + return type (p) == T_REAL; } -INTERFACE INLINE int -is_real (pointer p) +INTERFACE int +is_number (pointer p) { - return is_number (p) && !num_is_fixnum (p->object.number); + return is_integer (p) || is_real (p); } -INTERFACE INLINE int +INTERFACE int is_character (pointer p) { return type (p) == T_CHARACTER; } -INTERFACE INLINE char * +INTERFACE char * string_value (pointer p) { return strvalue (p); } -INLINE num -nvalue (pointer p) -{ - return (p)->object.number; -} - -static IVALUE -num_get_ivalue (const num n) -{ - return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n); -} - -static RVALUE -num_get_rvalue (const num n) -{ - return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n); -} - -INTERFACE IVALUE -ivalue (pointer p) -{ - return num_get_ivalue (p->object.number); -} - -INTERFACE RVALUE -rvalue (pointer p) -{ - return num_get_rvalue (p->object.number); -} +#define ivalue_unchecked(p) (p)->object.ivalue +#define set_ivalue(p,v) (p)->object.ivalue = (v) -#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) #if USE_REAL -# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) -# define set_num_integer(p) (p)->object.number.is_fixnum=1; -# define set_num_real(p) (p)->object.number.is_fixnum=0; +#define rvalue_unchecked(p) (p)->object.rvalue +#define set_rvalue(p,v) (p)->object.rvalue = (v) #else -# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) -# define set_num_integer(p) 0 -# define set_num_real(p) 0 +#define rvalue_unchecked(p) (p)->object.ivalue +#define set_rvalue(p,v) (p)->object.ivalue = (v) #endif + INTERFACE long charvalue (pointer p) { return ivalue_unchecked (p); } -INTERFACE INLINE int +INTERFACE int is_port (pointer p) { return type (p) == T_PORT; } -INTERFACE INLINE int +INTERFACE int is_inport (pointer p) { return is_port (p) && p->object.port->kind & port_input; } -INTERFACE INLINE int +INTERFACE int is_outport (pointer p) { return is_port (p) && p->object.port->kind & port_output; } -INTERFACE INLINE int +INTERFACE int is_pair (pointer p) { return type (p) == T_PAIR; @@ -411,20 +384,20 @@ return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_symbol (pointer p) { return type (p) == T_SYMBOL; } -INTERFACE INLINE char * +INTERFACE char * symname (pointer p) { return strvalue (car (p)); } #if USE_PLIST -SCHEME_EXPORT INLINE int +SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; @@ -433,58 +406,58 @@ # define symprop(p) cdr(p) #endif -INTERFACE INLINE int +INTERFACE int is_syntax (pointer p) { return typeflag (p) & T_SYNTAX; } -INTERFACE INLINE int +INTERFACE int is_proc (pointer p) { return type (p) == T_PROC; } -INTERFACE INLINE int +INTERFACE int is_foreign (pointer p) { return type (p) == T_FOREIGN; } -INTERFACE INLINE char * +INTERFACE char * syntaxname (pointer p) { return strvalue (car (p)); } -#define procnum(p) ivalue (p) +#define procnum(p) ivalue_unchecked (p) static const char *procname (pointer x); -INTERFACE INLINE int +INTERFACE int is_closure (pointer p) { return type (p) == T_CLOSURE; } -INTERFACE INLINE int +INTERFACE int is_macro (pointer p) { return type (p) == T_MACRO; } -INTERFACE INLINE pointer +INTERFACE pointer closure_code (pointer p) { return car (p); } -INTERFACE INLINE pointer +INTERFACE pointer closure_env (pointer p) { return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_continuation (pointer p) { return type (p) == T_CONTINUATION; @@ -494,13 +467,13 @@ #define set_cont_dump(p,v) set_cdr ((p), (v)) /* To do: promise should be forced ONCE only */ -INTERFACE INLINE int +INTERFACE int is_promise (pointer p) { return type (p) == T_PROMISE; } -INTERFACE INLINE int +INTERFACE int is_environment (pointer p) { return type (p) == T_ENVIRONMENT; @@ -516,13 +489,13 @@ #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) -INTERFACE INLINE int +INTERFACE int is_immutable (pointer p) { return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; } -INTERFACE INLINE void +INTERFACE void setimmutable (pointer p) { #if USE_ERROR_CHECKING @@ -530,32 +503,86 @@ #endif } +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +INTERFACE int +list_length (SCHEME_P_ pointer a) +{ + int i = 0; + pointer slow, fast; + + slow = fast = a; + + while (1) + { + if (fast == NIL) + return i; + + if (!is_pair (fast)) + return -2 - i; + + fast = cdr (fast); + ++i; + + if (fast == 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; + } + } +} + +INTERFACE int +is_list (SCHEME_P_ pointer a) +{ + return list_length (SCHEME_A_ a) >= 0; +} + #if USE_CHAR_CLASSIFIERS -static INLINE int +ecb_inline int Cisalpha (int c) { return isascii (c) && isalpha (c); } -static INLINE int +ecb_inline int Cisdigit (int c) { return isascii (c) && isdigit (c); } -static INLINE int +ecb_inline int Cisspace (int c) { return isascii (c) && isspace (c); } -static INLINE int +ecb_inline int Cisupper (int c) { return isascii (c) && isupper (c); } -static INLINE int +ecb_inline int Cislower (int c) { return isascii (c) && islower (c); @@ -626,9 +653,9 @@ static int file_push (SCHEME_P_ const char *fname); static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); -static INLINE int is_one_of (char *s, int c); +ecb_inline int is_one_of (char *s, int c); static int alloc_cellseg (SCHEME_P_ int n); -static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); +ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); static void finalize_cell (SCHEME_P_ pointer a); static int count_consecutive_cells (pointer x, int needed); static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); @@ -655,7 +682,7 @@ static void backchar (SCHEME_P_ int c); static char *readstr_upto (SCHEME_P_ char *delim); static pointer readstrexp (SCHEME_P); -static INLINE int skipspace (SCHEME_P); +ecb_inline int skipspace (SCHEME_P); static int token (SCHEME_P); static void printslashstring (SCHEME_P_ char *s, int len); static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); @@ -681,6 +708,33 @@ static int syntaxnum (pointer p); static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); +static IVALUE +ivalue (pointer x) +{ + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); +} + +static RVALUE +rvalue (pointer x) +{ + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); +} + +INTERFACE num +nvalue (pointer x) +{ + num n; + + num_set_fixnum (n, is_integer (x)); + + if (num_is_fixnum (n)) + num_set_ivalue (n, ivalue_unchecked (x)); + else + num_set_rvalue (n, rvalue_unchecked (x)); + + return n; +} + static num num_op (enum num_op op, num a, num b) { @@ -690,34 +744,30 @@ if (num_is_fixnum (ret)) { - IVALUE av = num_get_ivalue (a); - IVALUE bv = num_get_ivalue (b); - switch (op) { - case NUM_ADD: av += bv; break; - case NUM_SUB: av -= bv; break; - case NUM_MUL: av *= bv; break; - case NUM_INTDIV: av /= bv; break; + case NUM_ADD: a.ivalue += b.ivalue; break; + case NUM_SUB: a.ivalue -= b.ivalue; break; + case NUM_MUL: a.ivalue *= b.ivalue; break; + case NUM_INTDIV: a.ivalue /= b.ivalue; break; } - num_set_ivalue (ret, av); + num_set_ivalue (ret, a.ivalue); } +#if USE_REAL else { - RVALUE av = num_get_rvalue (a); - RVALUE bv = num_get_rvalue (b); - switch (op) { - case NUM_ADD: av += bv; break; - case NUM_SUB: av -= bv; break; - case NUM_MUL: av *= bv; break; - case NUM_INTDIV: av /= bv; break; + case NUM_ADD: a.rvalue += b.rvalue; break; + case NUM_SUB: a.rvalue -= b.rvalue; break; + case NUM_MUL: a.rvalue *= b.rvalue; break; + case NUM_INTDIV: a.rvalue /= b.rvalue; break; } - num_set_rvalue (ret, av); + num_set_rvalue (ret, a.rvalue); } +#endif return ret; } @@ -727,12 +777,12 @@ { num ret; - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0); + num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0); if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); + num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b)); else - num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); + num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b)); return ret; } @@ -744,8 +794,8 @@ long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - e1 = num_get_ivalue (a); - e2 = num_get_ivalue (b); + e1 = num_ivalue (a); + e2 = num_ivalue (b); res = e1 % e2; /* remainder should have same sign as second operand */ @@ -771,8 +821,8 @@ long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - e1 = num_get_ivalue (a); - e2 = num_get_ivalue (b); + e1 = num_ivalue (a); + e2 = num_ivalue (b); res = e1 % e2; /* modulo should have same sign as second operand */ @@ -783,7 +833,7 @@ return ret; } -/* this completely disrespects NaNs */ +/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */ static int num_cmp (num a, num b) { @@ -792,15 +842,15 @@ if (is_fixnum) { - IVALUE av = num_get_ivalue (a); - IVALUE bv = num_get_ivalue (b); + IVALUE av = num_ivalue (a); + IVALUE bv = num_ivalue (b); ret = av == bv ? 0 : av < bv ? -1 : +1; } else { - RVALUE av = num_get_rvalue (a); - RVALUE bv = num_get_rvalue (b); + RVALUE av = num_rvalue (a); + RVALUE bv = num_rvalue (b); ret = av == bv ? 0 : av < bv ? -1 : +1; } @@ -836,11 +886,14 @@ static int is_zero_rvalue (RVALUE x) { + return x == 0; +#if 0 #if USE_REAL return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ #else return x == 0; #endif +#endif } /* allocate new cell segment */ @@ -870,58 +923,28 @@ i = ++SCHEME_V->last_cell_seg; SCHEME_V->alloc_seg[i] = cp; - /* insert new segment in address order */ newp = (pointer)cp; SCHEME_V->cell_seg[i] = newp; SCHEME_V->cell_segsize[i] = segsize; - - //TODO: insert, not swap - while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i]) - { - p = SCHEME_V->cell_seg[i]; - SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1]; - SCHEME_V->cell_seg[i - 1] = p; - - k = SCHEME_V->cell_segsize[i]; - SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1]; - SCHEME_V->cell_segsize[i - 1] = k; - - --i; - } - SCHEME_V->fcells += segsize; last = newp + segsize - 1; for (p = newp; p <= last; p++) { - set_typeflag (p, T_FREE); + set_typeflag (p, T_PAIR); set_car (p, NIL); set_cdr (p, p + 1); } - /* insert new cells in address order on free list */ - if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell) - { - set_cdr (last, SCHEME_V->free_cell); - SCHEME_V->free_cell = newp; - } - else - { - p = SCHEME_V->free_cell; - - while (cdr (p) != NIL && newp > cdr (p)) - p = cdr (p); - - set_cdr (last, cdr (p)); - set_cdr (p, newp); - } + set_cdr (last, SCHEME_V->free_cell); + SCHEME_V->free_cell = newp; } return n; } /* get new cell. parameter a, b is marked by gc. */ -static INLINE pointer +ecb_inline pointer get_cell_x (SCHEME_P_ pointer a, pointer b) { if (ecb_expect_false (SCHEME_V->free_cell == NIL)) @@ -1003,13 +1026,13 @@ v->object.vector.vvalue = e; v->object.vector.length = len; - fill_vector (v, init); + fill_vector (v, 0, init); push_recent_alloc (SCHEME_A_ v, NIL); return v; } -static INLINE void +ecb_inline void ok_to_freely_gc (SCHEME_P) { set_car (S_SINK, NIL); @@ -1079,11 +1102,11 @@ setimmutable (car (x)); location = hash_fn (name, veclength (SCHEME_V->oblist)); - set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); + vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); return x; } -static INLINE pointer +ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { int location; @@ -1092,7 +1115,7 @@ location = hash_fn (name, veclength (SCHEME_V->oblist)); - for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) + for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) { s = symname (car (x)); @@ -1112,7 +1135,7 @@ pointer ob_list = NIL; for (i = 0; i < veclength (SCHEME_V->oblist); i++) - for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) + for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) ob_list = cons (x, ob_list); return ob_list; @@ -1126,7 +1149,7 @@ return NIL; } -static INLINE pointer +ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; @@ -1195,41 +1218,48 @@ pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, (T_CHARACTER | T_ATOM)); - ivalue_unchecked (x) = c & 0xff; - set_num_integer (x); + set_ivalue (x, c & 0xff); + return x; } /* get number atom (integer) */ INTERFACE pointer -mk_integer (SCHEME_P_ long num) +mk_integer (SCHEME_P_ long n) { pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_NUMBER | T_ATOM)); - ivalue_unchecked (x) = num; - set_num_integer (x); + set_typeflag (x, (T_INTEGER | T_ATOM)); + set_ivalue (x, n); + return x; } INTERFACE pointer mk_real (SCHEME_P_ RVALUE n) { +#if USE_REAL pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_NUMBER | T_ATOM)); - rvalue_unchecked (x) = n; - set_num_real (x); + set_typeflag (x, (T_REAL | T_ATOM)); + set_rvalue (x, n); + return x; +#else + return mk_integer (SCHEME_A_ n); +#endif } static pointer mk_number (SCHEME_P_ const num n) { - if (num_is_fixnum (n)) - return mk_integer (SCHEME_A_ num_get_ivalue (n)); - else - return mk_real (SCHEME_A_ num_get_rvalue (n)); +#if USE_REAL + return num_is_fixnum (n) + ? mk_integer (SCHEME_A_ num_ivalue (n)) + : mk_real (SCHEME_A_ num_rvalue (n)); +#else + return mk_integer (SCHEME_A_ num_ivalue (n)); +#endif } /* allocate name to string area */ @@ -1298,22 +1328,22 @@ } INTERFACE void -fill_vector (pointer vec, pointer obj) +fill_vector (pointer vec, uint32_t start, pointer obj) { int i; - for (i = 0; i < vec->object.vector.length; i++) + for (i = start; i < veclength (vec); i++) vecvalue (vec)[i] = obj; } INTERFACE pointer -vector_elem (pointer vec, uint32_t ielem) +vector_get (pointer vec, uint32_t ielem) { return vecvalue(vec)[ielem]; } INTERFACE void -set_vector_elem (pointer vec, uint32_t ielem, pointer a) +vector_set (pointer vec, uint32_t ielem, pointer a) { vecvalue(vec)[ielem] = a; } @@ -1415,8 +1445,7 @@ { if (!has_fp_exp) { - has_dec_point = 1; /* decimal point illegal - from now on */ + has_dec_point = 1; /* decimal point illegal from now on */ p++; if ((*p == '-') || (*p == '+') || isdigit (*p)) @@ -1514,7 +1543,7 @@ { int i; - for (i = 0; i < p->object.vector.length; i++) + for (i = 0; i < veclength (p); i++) mark (vecvalue (p)[i]); } @@ -1622,10 +1651,10 @@ else { /* reclaim cell */ - if (typeflag (p) != T_FREE) + if (typeflag (p) != T_PAIR) { finalize_cell (SCHEME_A_ p); - set_typeflag (p, T_FREE); + set_typeflag (p, T_PAIR); set_car (p, NIL); } @@ -1637,7 +1666,9 @@ } if (SCHEME_V->gc_verbose) - xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); + { + xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); + } } static void @@ -2234,7 +2265,7 @@ } /* check c is in chars */ -static INLINE int +ecb_inline int is_one_of (char *s, int c) { if (c == EOF) @@ -2244,7 +2275,7 @@ } /* skip white characters */ -static INLINE int +ecb_inline int skipspace (SCHEME_P) { int c, curr_line = 0; @@ -2482,7 +2513,7 @@ if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { - if (num_is_integer (l)) + if (is_integer (l)) xnum (p, ivalue_unchecked (l)); #if USE_REAL else @@ -2747,8 +2778,7 @@ else if (is_number (a)) { if (is_number (b)) - if (num_is_integer (a) == num_is_integer (b)) - return num_cmp (nvalue (a), nvalue (b)) == 0; + return num_cmp (nvalue (a), nvalue (b)) == 0; return 0; } @@ -2825,7 +2855,7 @@ setenvironment (SCHEME_V->envir); } -static INLINE void +ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { pointer slot = immutable_cons (variable, value); @@ -2834,7 +2864,7 @@ { int location = hash_fn (symname (variable), veclength (car (env))); - set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); + vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); } else set_car (env, immutable_cons (slot, car (env))); @@ -2851,7 +2881,7 @@ if (is_vector (car (x))) { location = hash_fn (symname (hdl), veclength (car (x))); - y = vector_elem (car (x), location); + y = vector_get (car (x), location); } else y = car (x); @@ -2861,28 +2891,25 @@ break; if (y != NIL) - break; + return car (y); if (!all) - return NIL; + break; } - if (x != NIL) - return car (y); - return NIL; } #else /* USE_ALIST_ENV */ -static INLINE void +ecb_inline void new_frame_in_env (SCHEME_P_ pointer old_env) { SCHEME_V->envir = immutable_cons (NIL, old_env); setenvironment (SCHEME_V->envir); } -static INLINE void +ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); @@ -2914,19 +2941,19 @@ #endif /* USE_ALIST_ENV else */ -static INLINE void +ecb_inline void new_slot_in_env (SCHEME_P_ pointer variable, pointer value) { new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); } -static INLINE void +ecb_inline void set_slot_in_env (SCHEME_P_ pointer slot, pointer value) { set_cdr (slot, value); } -static INLINE pointer +ecb_inline pointer slot_value_in_env (pointer slot) { return cdr (slot); @@ -3064,14 +3091,14 @@ return 0; } -static INLINE void +ecb_inline void dump_stack_reset (SCHEME_P) { /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ SCHEME_V->dump = (pointer)+0; } -static INLINE void +ecb_inline void dump_stack_initialize (SCHEME_P) { SCHEME_V->dump_size = 0; @@ -3134,10 +3161,10 @@ while (cont != NIL) { - frame->op = ivalue (car (cont)); cont = cdr (cont); - frame->args = car (cont) ; cont = cdr (cont); - frame->envir = car (cont) ; cont = cdr (cont); - frame->code = car (cont) ; cont = cdr (cont); + frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont); + frame->args = car (cont) ; cont = cdr (cont); + frame->envir = car (cont) ; cont = cdr (cont); + frame->code = car (cont) ; cont = cdr (cont); ++frame; ++i; @@ -3148,13 +3175,13 @@ #else -static INLINE void +ecb_inline void dump_stack_reset (SCHEME_P) { SCHEME_V->dump = NIL; } -static INLINE void +ecb_inline void dump_stack_initialize (SCHEME_P) { dump_stack_reset (SCHEME_A); @@ -3176,10 +3203,10 @@ if (dump == NIL) return -1; - SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump); - SCHEME_V->args = car (dump) ; dump = cdr (dump); - SCHEME_V->envir = car (dump) ; dump = cdr (dump); - SCHEME_V->code = car (dump) ; dump = cdr (dump); + SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump); + SCHEME_V->args = car (dump) ; dump = cdr (dump); + SCHEME_V->envir = car (dump) ; dump = cdr (dump); + SCHEME_V->code = car (dump) ; dump = cdr (dump); SCHEME_V->dump = dump; @@ -3395,7 +3422,7 @@ { int tr = SCHEME_V->tracing; - SCHEME_V->tracing = ivalue (car (args)); + SCHEME_V->tracing = ivalue_unchecked (car (args)); s_return (mk_integer (SCHEME_A_ tr)); } @@ -3914,7 +3941,7 @@ s_goto (OP_APPLY); } - abort (); + if (USE_ERROR_CHECKING) abort (); } static int @@ -3924,20 +3951,21 @@ pointer x = car (args); num v; -#if USE_MATH - RVALUE dd; -#endif - switch (op) { #if USE_MATH case OP_INEX2EX: /* inexact->exact */ - if (num_is_integer (x)) - s_return (x); - else if (modf (rvalue_unchecked (x), &dd) == 0) - s_return (mk_integer (SCHEME_A_ ivalue (x))); - else - Error_1 ("inexact->exact: not integral:", x); + { + if (is_integer (x)) + s_return (x); + + RVALUE r = rvalue_unchecked (x); + + if (r == (RVALUE)(IVALUE)r) + s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); + else + Error_1 ("inexact->exact: not integral:", x); + } case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); @@ -3965,7 +3993,7 @@ int real_result = 1; pointer y = cadr (args); - if (num_is_integer (x) && num_is_integer (y)) + if (is_integer (x) && is_integer (y)) real_result = 0; /* This 'if' is an R5RS compatibility fix. */ @@ -3981,7 +4009,7 @@ { long result_as_long = result; - if (result != (RVALUE) result_as_long) + if (result != result_as_long) real_result = 1; } @@ -3996,18 +4024,12 @@ case OP_TRUNCATE: { - RVALUE rvalue_of_x; - - rvalue_of_x = rvalue (x); - - if (rvalue_of_x > 0) - s_return (mk_real (SCHEME_A_ floor (rvalue_of_x))); - else - s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x))); + RVALUE n = rvalue (x); + s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n))); } case OP_ROUND: - if (num_is_integer (x)) + if (is_integer (x)) s_return (x); s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); @@ -4017,7 +4039,7 @@ v = num_zero; for (x = args; x != NIL; x = cdr (x)) - v = num_op ('+', v, nvalue (car (x))); + v = num_op (NUM_ADD, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4025,7 +4047,7 @@ v = num_one; for (x = args; x != NIL; x = cdr (x)) - v = num_op ('+', v, nvalue (car (x))); + v = num_op (NUM_MUL, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4042,7 +4064,7 @@ } for (; x != NIL; x = cdr (x)) - v = num_op ('+', v, nvalue (car (x))); + v = num_op (NUM_SUB, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4059,12 +4081,10 @@ } for (; x != NIL; x = cdr (x)) - { - if (!is_zero_rvalue (rvalue (car (x)))) - v = num_div (v, nvalue (car (x))); - else - Error_0 ("/: division by zero"); - } + if (!is_zero_rvalue (rvalue (car (x)))) + v = num_div (v, nvalue (car (x))); + else + Error_0 ("/: division by zero"); s_return (mk_number (SCHEME_A_ v)); @@ -4083,7 +4103,7 @@ for (; x != NIL; x = cdr (x)) { if (ivalue (car (x)) != 0) - v = num_op ('/', v, nvalue (car (x))); + v = num_op (NUM_INTDIV, v, nvalue (car (x))); else Error_0 ("quotient: division by zero"); } @@ -4139,21 +4159,21 @@ Error_0 ("set-cdr!: unable to alter immutable pair"); case OP_CHAR2INT: /* char->integer */ - s_return (mk_integer (SCHEME_A_ ivalue (x))); + s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x))); case OP_INT2CHAR: /* integer->char */ - s_return (mk_character (SCHEME_A_ ivalue (x))); + s_return (mk_character (SCHEME_A_ ivalue_unchecked (x))); case OP_CHARUPCASE: { - unsigned char c = ivalue (x); + unsigned char c = ivalue_unchecked (x); c = toupper (c); s_return (mk_character (SCHEME_A_ c)); } case OP_CHARDNCASE: { - unsigned char c = ivalue (x); + unsigned char c = ivalue_unchecked (x); c = tolower (c); s_return (mk_character (SCHEME_A_ c)); } @@ -4240,13 +4260,8 @@ case OP_MKSTRING: /* make-string */ { - int fill = ' '; - int len; - - len = ivalue (x); - - if (cdr (args) != NIL) - fill = charvalue (cadr (args)); + int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' '; + int len = ivalue_unchecked (x); s_return (mk_empty_string (SCHEME_A_ len, fill)); } @@ -4256,12 +4271,8 @@ case OP_STRREF: /* string-ref */ { - char *str; - int index; - - str = strvalue (x); - - index = ivalue (cadr (args)); + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); if (index >= strlength (x)) Error_1 ("string-ref: out of bounds:", cadr (args)); @@ -4271,17 +4282,13 @@ case OP_STRSET: /* string-set! */ { - char *str; - int index; + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); int c; if (is_immutable (x)) Error_1 ("string-set!: unable to alter immutable string:", x); - str = strvalue (x); - - index = ivalue (cadr (args)); - if (index >= strlength (x)) Error_1 ("string-set!: out of bounds:", cadr (args)); @@ -4313,21 +4320,17 @@ case OP_SUBSTR: /* substring */ { - char *str; - int index0; + char *str = strvalue (x); + int index0 = ivalue_unchecked (cadr (args)); int index1; int len; - str = strvalue (x); - - index0 = ivalue (cadr (args)); - if (index0 > strlength (x)) Error_1 ("substring: start out of bounds:", cadr (args)); if (cddr (args) != NIL) { - index1 = ivalue (caddr (args)); + index1 = ivalue_unchecked (caddr (args)); if (index1 > strlength (x) || index1 < index0) Error_1 ("substring: end out of bounds:", caddr (args)); @@ -4360,7 +4363,7 @@ #endif for (x = args, i = 0; is_pair (x); x = cdr (x), i++) - set_vector_elem (vec, i, car (x)); + vector_set (vec, i, car (x)); s_return (vec); } @@ -4368,10 +4371,8 @@ case OP_MKVECTOR: /* make-vector */ { pointer fill = NIL; - int len; pointer vec; - - len = ivalue (x); + int len = ivalue_unchecked (x); if (cdr (args) != NIL) fill = cadr (args); @@ -4384,7 +4385,7 @@ #endif if (fill != NIL) - fill_vector (vec, fill); + fill_vector (vec, 0, fill); s_return (vec); } @@ -4394,88 +4395,30 @@ case OP_VECREF: /* vector-ref */ { - int index; - - index = ivalue (cadr (args)); + int index = ivalue_unchecked (cadr (args)); if (index >= veclength (car (args)) && USE_ERROR_CHECKING) Error_1 ("vector-ref: out of bounds:", cadr (args)); - s_return (vector_elem (x, index)); + s_return (vector_get (x, index)); } case OP_VECSET: /* vector-set! */ { - int index; + int index = ivalue_unchecked (cadr (args)); if (is_immutable (x)) Error_1 ("vector-set!: unable to alter immutable vector:", x); - index = ivalue (cadr (args)); - if (index >= veclength (car (args)) && USE_ERROR_CHECKING) Error_1 ("vector-set!: out of bounds:", cadr (args)); - set_vector_elem (x, index, caddr (args)); + vector_set (x, index, caddr (args)); s_return (x); } } - abort (); -} - -INTERFACE int -is_list (SCHEME_P_ pointer a) -{ - return list_length (SCHEME_A_ a) >= 0; -} - -/* Result is: - proper list: length - circular list: -1 - not even a pair: -2 - dotted list: -2 minus length before dot -*/ -INTERFACE int -list_length (SCHEME_P_ pointer a) -{ - int i = 0; - pointer slow, fast; - - slow = fast = a; - - while (1) - { - if (fast == NIL) - return i; - - if (!is_pair (fast)) - return -2 - i; - - fast = cdr (fast); - ++i; - - if (fast == 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; - } - } + if (USE_ERROR_CHECKING) abort (); } static int @@ -4531,11 +4474,11 @@ case OP_CHARP: /* char? */ r = is_character (a) ; break; #if USE_CHAR_CLASSIFIERS - case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break; - case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break; - case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break; - case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break; - case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break; + case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; + case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; + case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; + case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break; + case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break; #endif #if USE_PORTS @@ -4746,7 +4689,7 @@ if (!is_pair (args) || !is_number (a)) Error_0 ("new-segment: argument must be a number"); - alloc_cellseg (SCHEME_A_ (int)ivalue (a)); + alloc_cellseg (SCHEME_A_ ivalue (a)); s_return (S_T); @@ -4785,10 +4728,7 @@ p = port_from_filename (SCHEME_A_ strvalue (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } # if USE_STRING_PORTS @@ -4813,10 +4753,7 @@ p = port_from_string (SCHEME_A_ strvalue (a), strvalue (a) + strlength (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_OPEN_OUTSTRING: /* open-output-string */ @@ -4824,22 +4761,12 @@ pointer p; if (a == NIL) - { - p = port_from_scratch (SCHEME_A); - - if (p == NIL) - s_return (S_F); - } + p = port_from_scratch (SCHEME_A); else - { - p = port_from_string (SCHEME_A_ strvalue (a), - strvalue (a) + strlength (a), port_output); - - if (p == NIL) - s_return (S_F); - } + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), port_output); - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_GET_OUTSTRING: /* get-output-string */ @@ -4888,7 +4815,7 @@ } - abort (); + if (USE_ERROR_CHECKING) abort (); } static int @@ -5217,7 +5144,7 @@ } else { - pointer elem = vector_elem (vec, i); + pointer elem = vector_get (vec, i); ivalue_unchecked (cdr (args)) = i + 1; s_save (SCHEME_A_ OP_PVECFROM, args, NIL); @@ -5231,7 +5158,7 @@ } } - abort (); + if (USE_ERROR_CHECKING) abort (); } static int @@ -5294,7 +5221,7 @@ s_retbool (is_macro (a)); } - abort (); + if (USE_ERROR_CHECKING) abort (); } /* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ @@ -5302,19 +5229,19 @@ typedef int (*test_predicate)(pointer); static int -is_any (pointer p) +tst_any (pointer p) { return 1; } static int -is_nonneg (pointer p) +tst_inonneg (pointer p) { - return ivalue (p) >= 0 && is_integer (p); + return is_integer (p) && ivalue_unchecked (p) >= 0; } static int -tst_is_list (pointer p) +tst_is_list (SCHEME_P_ pointer p) { return p == NIL || is_pair (p); } @@ -5324,22 +5251,21 @@ { test_predicate fct; const char *kind; -} tests[] = -{ - { is_any, 0 }, - { is_string, "string" }, - { is_symbol, "symbol" }, - { is_port, "port" }, - { is_inport, "input port" }, - { is_outport, "output port" }, +} tests[] = { + { tst_any , 0 }, + { is_string , "string" }, + { is_symbol , "symbol" }, + { is_port , "port" }, + { is_inport , "input port" }, + { is_outport , "output port" }, { is_environment, "environment" }, - { is_pair, "pair" }, - { tst_is_list, "pair or '()" }, - { is_character, "character" }, - { is_vector, "vector" }, - { is_number, "number" }, - { is_integer, "integer" }, - { is_nonneg, "non-negative integer" } + { is_pair , "pair" }, + { 0 , "pair or '()" }, + { is_character , "character" }, + { is_vector , "vector" }, + { is_number , "number" }, + { is_integer , "integer" }, + { tst_inonneg , "non-negative integer" } }; #define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */ @@ -5390,20 +5316,26 @@ uint8_t func; /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */ uint8_t builtin; +#if USE_ERROR_CHECKING uint8_t min_arity; uint8_t max_arity; char arg_tests_encoding[3]; +#endif } op_code_info; static const op_code_info dispatch_table[] = { +#if USE_ERROR_CHECKING #define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest }, +#else +#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 }, +#endif #include "opdefines.h" #undef OP_DEF {0} }; /* kernel of this interpreter */ -static void +static void ecb_hot Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) { SCHEME_V->op = op; @@ -5448,10 +5380,19 @@ j = t[0]; - if (!tests[j - 1].fct (arg)) - break; + /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */ + if (j == TST_LIST[0]) + { + if (!tst_is_list (SCHEME_A_ arg)) + break; + } + else + { + if (!tests[j - 1].fct (arg)) + break; + } - if (t[1]) /* last test is replicated as necessary */ + if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */ t++; arglist = cdr (arglist); @@ -5516,7 +5457,6 @@ pointer y = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (y, (T_PROC | T_ATOM)); ivalue_unchecked (y) = op; - set_num_integer (y); return y; } @@ -5591,7 +5531,7 @@ } #if USE_MULTIPLICITY -scheme * +ecb_cold scheme * scheme_init_new () { scheme *sc = malloc (sizeof (scheme)); @@ -5606,7 +5546,7 @@ } #endif -int +ecb_cold int scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); @@ -5741,7 +5681,7 @@ SCHEME_V->ext_data = p; } -void +ecb_cold void scheme_deinit (SCHEME_P) { int i;