--- microscheme/scheme.c 2015/11/26 07:30:25 1.12 +++ microscheme/scheme.c 2015/11/30 05:19:01 1.40 @@ -30,24 +30,41 @@ # include #endif +#include "ecb.h" + #include #include #include -#include +#if !USE_ERROR_CHECKING +# define NDEBUG +#endif + +#include #include +#include #include #include #include //#include +#if '1' != '0' + 1 \ + || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ + || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ + || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ + || 'f' != 'a' + 5 +# error "execution character set digits not consecutive" +#endif + enum { TOK_EOF, TOK_LPAREN, TOK_RPAREN, TOK_DOT, TOK_ATOM, + TOK_DOTATOM, /* atom name starting with '.' */ + TOK_STRATOM, /* atom name enclosed in | */ TOK_QUOTE, TOK_DQUOTE, TOK_BQUOTE, @@ -59,7 +76,8 @@ }; #define BACKQUOTE '`' -#define DELIMITERS "()\";\f\t\v\n\r " +#define WHITESPACE " \t\r\n\v\f" +#define DELIMITERS "()\";" WHITESPACE #define NIL (&SCHEME_V->xNIL) //TODO: make this 0? #define S_T (&SCHEME_V->xT) //TODO: magic ptr value? @@ -67,13 +85,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) -#endif - #if !USE_MULTIPLICITY static scheme sc; #endif @@ -152,9 +163,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; @@ -166,10 +177,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> " @@ -185,12 +200,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, @@ -210,30 +225,44 @@ #define T_ATOM 0x0040 /* only for gc */ #define T_MARK 0x0080 /* only for gc */ -static num num_add (num a, num b); -static num num_mul (num a, num b); -static num num_div (num a, num b); +/* 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); static num num_intdiv (num a, num b); -static num num_sub (num a, num b); static num num_rem (num a, num b); static num num_mod (num a, num b); -static int num_eq (num a, num b); -static int num_gt (num a, num b); -static int num_ge (num a, num b); -static int num_lt (num a, num b); -static int num_le (num a, num b); #if USE_MATH static double round_per_R5RS (double x); #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; @@ -242,7 +271,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; @@ -251,8 +280,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; @@ -260,118 +288,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; @@ -413,20 +400,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)); + return strvalue (p); } #if USE_PLIST -SCHEME_EXPORT INLINE int +SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; @@ -435,58 +422,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)); + return strvalue (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; @@ -496,13 +483,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; @@ -518,13 +505,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 @@ -532,32 +519,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); @@ -628,9 +669,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 (const 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,9 +696,9 @@ static int basic_inchar (port *pt); static int inchar (SCHEME_P); 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); +static char *readstr_upto (SCHEME_P_ int skip, const char *delim); +static pointer readstrexp (SCHEME_P_ char delim); +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); @@ -671,88 +712,93 @@ static pointer ss_get_cont (SCHEME_P); static void ss_set_cont (SCHEME_P_ pointer cont); static void dump_stack_mark (SCHEME_P); -static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_0 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_1 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_2 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_3 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_4 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_5 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_6 (SCHEME_P_ enum scheme_opcodes op); static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); static void assign_syntax (SCHEME_P_ const char *name); static int syntaxnum (pointer p); static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); -static num -num_add (num a, num b) +static IVALUE +ivalue (pointer x) { - num ret; - - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - - if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b)); - else - num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b)); - - return ret; + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); } -static num -num_mul (num a, num b) +static RVALUE +rvalue (pointer x) { - num ret; - - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - - if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b)); - else - num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b)); - - return ret; + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); } -static num -num_div (num a, num b) +INTERFACE num +nvalue (pointer x) { - num ret; + num n; - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0); + num_set_fixnum (n, is_integer (x)); - if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); + if (num_is_fixnum (n)) + num_set_ivalue (n, ivalue_unchecked (x)); else - num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); + num_set_rvalue (n, rvalue_unchecked (x)); - return ret; + return n; } static num -num_intdiv (num a, num b) +num_op (enum num_op op, num a, num b) { num ret; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); + { + switch (op) + { + 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, a.ivalue); + } +#if USE_REAL else - num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); + { + switch (op) + { + 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, a.rvalue); + } +#endif return ret; } static num -num_sub (num a, num b) +num_div (num a, num b) { num ret; - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); + 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; } @@ -764,8 +810,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 */ @@ -791,8 +837,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 */ @@ -803,59 +849,29 @@ return ret; } +/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */ static int -num_eq (num a, num b) +num_cmp (num a, num b) { - int ret; int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); - - if (is_fixnum) - ret = num_get_ivalue (a) == num_get_ivalue (b); - else - ret = num_get_rvalue (a) == num_get_rvalue (b); - - return ret; -} - - -static int -num_gt (num a, num b) -{ int ret; - int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); if (is_fixnum) - ret = num_get_ivalue (a) > num_get_ivalue (b); - else - ret = num_get_rvalue (a) > num_get_rvalue (b); - - return ret; -} - -static int -num_ge (num a, num b) -{ - return !num_lt (a, b); -} - -static int -num_lt (num a, num b) -{ - int ret; - int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); + { + IVALUE av = num_ivalue (a); + IVALUE bv = num_ivalue (b); - if (is_fixnum) - ret = num_get_ivalue (a) < num_get_ivalue (b); + ret = av == bv ? 0 : av < bv ? -1 : +1; + } else - ret = num_get_rvalue (a) < num_get_rvalue (b); + { + RVALUE av = num_rvalue (a); + RVALUE bv = num_rvalue (b); - return ret; -} + ret = av == bv ? 0 : av < bv ? -1 : +1; + } -static int -num_le (num a, num b) -{ - return !num_gt (a, b); + return ret; } #if USE_MATH @@ -875,7 +891,7 @@ return fl; else { - if (fmod (fl, 2.0) == 0.0) /* I imagine this holds */ + if (fmod (fl, 2) == 0) /* I imagine this holds */ return fl; else return ce; @@ -886,11 +902,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 */ @@ -920,58 +939,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)) @@ -1053,13 +1042,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); @@ -1108,9 +1097,28 @@ /* ========== oblist implementation ========== */ +static pointer +generate_symbol (SCHEME_P_ const char *name) +{ + pointer x = mk_string (SCHEME_A_ name); + setimmutable (x); + set_typeflag (x, T_SYMBOL | T_ATOM); + return x; +} + #ifndef USE_OBJECT_LIST -static int hash_fn (const char *key, int table_size); +static int +hash_fn (const char *key, int table_size) +{ + const unsigned char *p = key; + uint32_t hash = 2166136261; + + while (*p) + hash = (hash ^ *p++) * 16777619; + + return hash % table_size; +} static pointer oblist_initial_value (SCHEME_P) @@ -1122,18 +1130,13 @@ static pointer oblist_add_by_name (SCHEME_P_ const char *name) { - int location; - - pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); - set_typeflag (x, T_SYMBOL); - 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))); + pointer x = generate_symbol (SCHEME_A_ name); + int location = hash_fn (name, veclength (SCHEME_V->oblist)); + 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; @@ -1142,7 +1145,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)); @@ -1162,7 +1165,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; @@ -1176,7 +1179,7 @@ return NIL; } -static INLINE pointer +ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; @@ -1198,11 +1201,9 @@ static pointer oblist_add_by_name (SCHEME_P_ const char *name) { - pointer x; - - x = immutable_cons (mk_string (SCHEME_A_ name), NIL); + pointer x = mk_string (SCHEME_A_ name); set_typeflag (x, T_SYMBOL); - setimmutable (car (x)); + setimmutable (x); SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); return x; } @@ -1245,41 +1246,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 */ @@ -1295,20 +1303,11 @@ } if (str) - { - int l = strlen (str); - - if (l > len_str) - l = len_str; - - memcpy (q, str, l); - q[l] = 0; - } + memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */ else - { - memset (q, fill, len_str); - q[len_str] = 0; - } + memset (q, fill, len_str); + + q[len_str] = 0; return q; } @@ -1332,6 +1331,7 @@ set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, str, 0); strlength (x) = len; + return x; } @@ -1348,22 +1348,31 @@ } 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 void +vector_resize (pointer vec, uint32_t newsize, pointer fill) +{ + uint32_t oldsize = veclength (vec); + vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer)); + veclength (vec) = newsize; + fill_vector (vec, oldsize, fill); +} + 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; } @@ -1385,23 +1394,10 @@ gensym (SCHEME_P) { pointer x; + char name[40] = "gensym-"; + xnum (name + 7, SCHEME_V->gensym_cnt); - for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) - { - char name[40] = "gensym-"; - xnum (name + 7, SCHEME_V->gensym_cnt); - - /* first check oblist */ - x = oblist_find_by_name (SCHEME_A_ name); - - if (x == NIL) - { - x = oblist_add_by_name (SCHEME_A_ name); - return x; - } - } - - return NIL; + return generate_symbol (SCHEME_A_ name); } /* make symbol or number atom from string */ @@ -1465,8 +1461,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)) @@ -1564,7 +1559,7 @@ { int i; - for (i = 0; i < p->object.vector.length; i++) + for (i = 0; i < veclength (p); i++) mark (vecvalue (p)[i]); } @@ -1672,10 +1667,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); } @@ -1687,14 +1682,16 @@ } 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 finalize_cell (SCHEME_P_ pointer a) { /* TODO, fast bitmap check? */ - if (is_string (a)) + if (is_string (a) || is_symbol (a)) free (strvalue (a)); else if (is_vector (a)) free (vecvalue (a)); @@ -2126,9 +2123,9 @@ /* read characters up to delimiter, but cater to character constants */ static char * -readstr_upto (SCHEME_P_ char *delim) +readstr_upto (SCHEME_P_ int skip, const char *delim) { - char *p = SCHEME_V->strbuff; + char *p = SCHEME_V->strbuff + skip; while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); @@ -2145,13 +2142,12 @@ /* read string expression "xxx...xxx" */ static pointer -readstrexp (SCHEME_P) +readstrexp (SCHEME_P_ char delim) { char *p = SCHEME_V->strbuff; int c; int c1 = 0; - enum - { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; + enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; for (;;) { @@ -2163,20 +2159,13 @@ switch (state) { case st_ok: - switch (c) - { - case '\\': - state = st_bsl; - break; - - case '"': - *p = 0; - return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); + if (ecb_expect_false (c == delim)) + return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); - default: - *p++ = c; - break; - } + if (ecb_expect_false (c == '\\')) + state = st_bsl; + else + *p++ = c; break; @@ -2216,11 +2205,6 @@ state = st_ok; break; - case '"': - *p++ = '"'; - state = st_ok; - break; - default: *p++ = c; state = st_ok; @@ -2231,26 +2215,23 @@ case st_x1: case st_x2: - c = toupper (c); + c = tolower (c); - if (c >= '0' && c <= 'F') - { - if (c <= '9') - c1 = (c1 << 4) + c - '0'; - else - c1 = (c1 << 4) + c - 'A' + 10; - - if (state == st_x1) - state = st_x2; - else - { - *p++ = c1; - state = st_ok; - } - } + if (c >= '0' && c <= '9') + c1 = (c1 << 4) + c - '0'; + else if (c >= 'a' && c <= 'f') + c1 = (c1 << 4) + c - 'a' + 10; else return S_F; + if (state == st_x1) + state = st_x2; + else + { + *p++ = c1; + state = st_ok; + } + break; case st_oct1: @@ -2263,7 +2244,7 @@ } else { - if (state == st_oct2 && c1 >= 32) + if (state == st_oct2 && c1 >= ' ') return S_F; c1 = (c1 << 3) + (c - '0'); @@ -2278,23 +2259,19 @@ } break; - } } } /* check c is in chars */ -static INLINE int -is_one_of (char *s, int c) +ecb_inline int +is_one_of (const char *s, int c) { - if (c == EOF) - return 1; - - return !!strchr (s, c); + return c == EOF || !!strchr (s, c); } /* skip white characters */ -static INLINE int +ecb_inline int skipspace (SCHEME_P) { int c, curr_line = 0; @@ -2307,7 +2284,7 @@ curr_line++; #endif } - while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); + while (is_one_of (WHITESPACE, c)); /* record it */ #if SHOW_ERROR_LINE @@ -2347,16 +2324,17 @@ case '.': c = inchar (SCHEME_A); - if (is_one_of (" \n\t", c)) + if (is_one_of (WHITESPACE, c)) return TOK_DOT; else { - //TODO: ungetc twice in a row is not supported in C backchar (SCHEME_A_ c); - backchar (SCHEME_A_ '.'); - return TOK_ATOM; + return TOK_DOTATOM; } + case '|': + return TOK_STRATOM; + case '\'': return TOK_QUOTE; @@ -2497,7 +2475,6 @@ putcharacter (SCHEME_A_ '"'); } - /* print atoms */ static void printatom (SCHEME_P_ pointer l, int f) @@ -2509,7 +2486,6 @@ putchars (SCHEME_A_ p, len); } - /* Uses internal buffer unless string pointer is already available */ static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) @@ -2532,7 +2508,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 @@ -2679,7 +2655,14 @@ else if (is_continuation (l)) p = "#"; else - p = "#"; + { +#if USE_PRINTF + p = SCHEME_V->strbuff; + snprintf (p, STRBUFFSIZE, "#", (int)typeflag (l)); +#else + p = "#"; +#endif + } *pp = p; *plen = strlen (p); @@ -2797,8 +2780,7 @@ else if (is_number (a)) { if (is_number (b)) - if (num_is_integer (a) == num_is_integer (b)) - return num_eq (nvalue (a), nvalue (b)); + return num_cmp (nvalue (a), nvalue (b)) == 0; return 0; } @@ -2835,21 +2817,6 @@ /* ========== Environment implementation ========== */ -#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) - -static int -hash_fn (const char *key, int table_size) -{ - const unsigned char *p = key; - uint32_t hash = 2166136261; - - while (*p) - hash = (hash ^ *p++) * 16777619; - - return hash % table_size; -} -#endif - #ifndef USE_ALIST_ENV /* @@ -2875,16 +2842,30 @@ setenvironment (SCHEME_V->envir); } -static INLINE void +static uint32_t +sym_hash (pointer sym, uint32_t size) +{ + uintptr_t ptr = (uintptr_t)sym; + +#if 0 + /* table size is prime, so why mix */ + ptr += ptr >> 32; + ptr += ptr >> 16; + ptr += ptr >> 8; +#endif + + return ptr % size; +} + +ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { pointer slot = immutable_cons (variable, value); if (is_vector (car (env))) { - int location = hash_fn (symname (variable), veclength (car (env))); - - set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); + int location = sym_hash (variable, veclength (car (env))); + vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); } else set_car (env, immutable_cons (slot, car (env))); @@ -2894,14 +2875,13 @@ find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) { pointer x, y; - int location; for (x = env; x != NIL; x = cdr (x)) { if (is_vector (car (x))) { - location = hash_fn (symname (hdl), veclength (car (x))); - y = vector_elem (car (x), location); + int location = sym_hash (hdl, veclength (car (x))); + y = vector_get (car (x), location); } else y = car (x); @@ -2911,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))); @@ -2950,33 +2927,32 @@ break; if (y != NIL) + return car (y); break; if (!all) - return NIL; + break; } - if (x != NIL) - return car (y); - return NIL; } #endif /* USE_ALIST_ENV else */ -static INLINE void +ecb_inline void new_slot_in_env (SCHEME_P_ pointer variable, pointer value) { + assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 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); @@ -2984,7 +2960,7 @@ /* ========== Evaluation Cycle ========== */ -static pointer +static int xError_1 (SCHEME_P_ const char *s, pointer a) { #if USE_ERROR_HOOK @@ -3029,7 +3005,7 @@ SCHEME_V->code = cons (slot_value_in_env (x), code); SCHEME_V->op = OP_EVAL; - return S_T; + return 0; } #endif @@ -3041,7 +3017,8 @@ SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); setimmutable (car (SCHEME_V->args)); SCHEME_V->op = OP_ERR0; - return S_T; + + return 0; } #define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) @@ -3052,7 +3029,7 @@ #define END } while (0) #define s_goto(a) BEGIN \ SCHEME_V->op = a; \ - return S_T; END + return 0; END #define s_return(a) return xs_return (SCHEME_A_ a) @@ -3087,12 +3064,12 @@ next_frame->op = op; next_frame->args = args; next_frame->envir = SCHEME_V->envir; - next_frame->code = code; + next_frame->code = code; SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); } -static pointer +static int xs_return (SCHEME_P_ pointer a) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3101,7 +3078,7 @@ SCHEME_V->value = a; if (nframes <= 0) - return NIL; + return -1; frame = &SCHEME_V->dump_base[--nframes]; SCHEME_V->op = frame->op; @@ -3110,17 +3087,17 @@ SCHEME_V->code = frame->code; SCHEME_V->dump = (pointer)(uintptr_t)nframes; - return S_T; + 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; @@ -3183,10 +3160,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; @@ -3197,13 +3174,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); @@ -3215,7 +3192,7 @@ SCHEME_V->dump = NIL; } -static pointer +static int xs_return (SCHEME_P_ pointer a) { pointer dump = SCHEME_V->dump; @@ -3223,16 +3200,16 @@ SCHEME_V->value = a; if (dump == NIL) - return 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; - return S_T; + return 0; } static void @@ -3267,22 +3244,87 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) -static pointer +#if 1 +static int +debug (SCHEME_P_ int indent, pointer x) +{ + int c; + + if (is_syntax (x)) + { + printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x)); + return 8 + 8; + } + + if (x == NIL) + { + printf ("%*sNIL\n", indent, ""); + return 3; + } + + switch (type (x)) + { + case T_INTEGER: + printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x); + return 32+8; + + case T_SYMBOL: + printf ("%*sS<%s>\n", indent, "", symname (x)); + return 24+8; + + case T_CLOSURE: + printf ("%*sS<%s>\n", indent, "", "closure"); + debug (SCHEME_A_ indent + 3, cdr(x)); + return 32 + debug (SCHEME_A_ indent + 3, car (x)); + + case T_PAIR: + printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); + c = debug (SCHEME_A_ indent + 3, car (x)); + c += debug (SCHEME_A_ indent + 3, cdr (x)); + return c + 1; + + case T_PORT: + printf ("%*sS<%s>\n", indent, "", "port"); + return 24+8; + + case T_VECTOR: + printf ("%*sS<%s>\n", indent, "", "vector"); + return 24+8; + + case T_ENVIRONMENT: + printf ("%*sS<%s>\n", indent, "", "environment"); + return 0 + debug (SCHEME_A_ indent + 3, car (x)); + + default: + printf ("unhandled type %d\n", type (x)); + break; + } +} +#endif + +static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; pointer x, y; switch (op) { +#if 1 //D + case OP_DEBUG: + printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); + printf ("\n"); + s_return (S_T); +#endif case OP_LOAD: /* load */ if (file_interactive (SCHEME_A)) { - xwrstr ("Loading "); xwrstr (strvalue (car (SCHEME_V->args))); xwrstr ("\n"); - //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (SCHEME_V->args))); + xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); + //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); } - if (!file_push (SCHEME_A_ strvalue (car (SCHEME_V->args)))) - Error_1 ("unable to open", car (SCHEME_V->args)); + if (!file_push (SCHEME_A_ strvalue (car (args)))) + Error_1 ("unable to open", car (args)); else { SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); @@ -3366,7 +3408,7 @@ if (SCHEME_V->tracing) { /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */ - s_save (SCHEME_A_ OP_REAL_EVAL, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code); SCHEME_V->args = SCHEME_V->code; putstr (SCHEME_A_ "\nEval: "); s_goto (OP_P0LIST); @@ -3406,7 +3448,7 @@ s_return (SCHEME_V->code); case OP_E0ARGS: /* eval arguments */ - if (is_macro (SCHEME_V->value)) /* macro expansion */ + if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ { s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); SCHEME_V->args = cons (SCHEME_V->code, NIL); @@ -3420,20 +3462,20 @@ } case OP_E1ARGS: /* eval arguments */ - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { - s_save (SCHEME_A_ OP_E1ARGS, SCHEME_V->args, cdr (SCHEME_V->code)); + s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); - SCHEME_V->code = car (SCHEME_V->args); - SCHEME_V->args = cdr (SCHEME_V->args); + args = reverse_in_place (SCHEME_A_ NIL, args); + SCHEME_V->code = car (args); + SCHEME_V->args = cdr (args); s_goto (OP_APPLY); } @@ -3443,7 +3485,7 @@ { int tr = SCHEME_V->tracing; - SCHEME_V->tracing = ivalue (car (SCHEME_V->args)); + SCHEME_V->tracing = ivalue_unchecked (car (args)); s_return (mk_integer (SCHEME_A_ tr)); } @@ -3453,9 +3495,9 @@ #if USE_TRACING if (SCHEME_V->tracing) { - s_save (SCHEME_A_ OP_REAL_APPLY, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code); SCHEME_V->print_flag = 1; - /* SCHEME_V->args=cons(SCHEME_V->code,SCHEME_V->args); */ + /* args=cons(SCHEME_V->code,args); */ putstr (SCHEME_A_ "\nApply to: "); s_goto (OP_P0LIST); } @@ -3465,14 +3507,12 @@ case OP_REAL_APPLY: #endif if (is_proc (SCHEME_V->code)) - { - s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ - } + s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ else if (is_foreign (SCHEME_V->code)) { /* Keep nested calls from GC'ing the arglist */ - push_recent_alloc (SCHEME_A_ SCHEME_V->args, NIL); - x = SCHEME_V->code->object.ff (SCHEME_A_ SCHEME_V->args); + push_recent_alloc (SCHEME_A_ args, NIL); + x = SCHEME_V->code->object.ff (SCHEME_A_ args); s_return (x); } @@ -3482,7 +3522,7 @@ /* make environment */ new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); - for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y)) + for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y)) { if (y == NIL) Error_0 ("not enough arguments"); @@ -3510,7 +3550,7 @@ else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ { ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); - s_return (SCHEME_V->args != NIL ? car (SCHEME_V->args) : NIL); + s_return (args != NIL ? car (args) : NIL); } else Error_0 ("illegal function"); @@ -3529,7 +3569,7 @@ if (f != NIL) { - s_save (SCHEME_A_ OP_LAMBDA1, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code); SCHEME_V->args = cons (SCHEME_V->code, NIL); SCHEME_V->code = slot_value_in_env (f); s_goto (OP_APPLY); @@ -3550,15 +3590,15 @@ #endif case OP_MKCLOSURE: /* make-closure */ - x = car (SCHEME_V->args); + x = car (args); if (car (x) == SCHEME_V->LAMBDA) x = cdr (x); - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) y = SCHEME_V->envir; else - y = cadr (SCHEME_V->args); + y = cadr (args); s_return (mk_closure (SCHEME_A_ x, y)); @@ -3600,10 +3640,10 @@ case OP_DEFP: /* defined? */ x = SCHEME_V->envir; - if (cdr (SCHEME_V->args) != NIL) - x = cadr (SCHEME_V->args); + if (cdr (args) != NIL) + x = cadr (args); - s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL); + s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL); case OP_SET0: /* set! */ if (is_immutable (car (SCHEME_V->code))) @@ -3644,9 +3684,7 @@ if (is_true (SCHEME_V->value)) SCHEME_V->code = car (SCHEME_V->code); else - SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because - - * car(NIL) = NIL */ + SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ s_goto (OP_EVAL); case OP_LET0: /* let */ @@ -3656,36 +3694,36 @@ s_goto (OP_LET1); case OP_LET1: /* let (calculate parameters) */ - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); - s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code)); + s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); - SCHEME_V->code = car (SCHEME_V->args); - SCHEME_V->args = cdr (SCHEME_V->args); + args = reverse_in_place (SCHEME_A_ NIL, args); + SCHEME_V->code = car (args); + SCHEME_V->args = cdr (args); s_goto (OP_LET2); } case OP_LET2: /* let */ new_frame_in_env (SCHEME_A_ SCHEME_V->envir); - for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args; + for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) new_slot_in_env (SCHEME_A_ caar (x), car (y)); if (is_symbol (car (SCHEME_V->code))) /* named let */ { - for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x)) + for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) { if (!is_pair (x)) Error_1 ("Bad syntax of binding in let :", x); @@ -3693,22 +3731,20 @@ if (!is_list (SCHEME_A_ car (x))) Error_1 ("Bad syntax of binding in let :", car (x)); - SCHEME_V->args = cons (caar (x), SCHEME_V->args); + args = cons (caar (x), args); } - x = - mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args), cddr (SCHEME_V->code)), - SCHEME_V->envir); + x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), + SCHEME_V->envir); new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x); SCHEME_V->code = cddr (SCHEME_V->code); - SCHEME_V->args = NIL; } else { SCHEME_V->code = cdr (SCHEME_V->code); - SCHEME_V->args = NIL; } + SCHEME_V->args = NIL; s_goto (OP_BEGIN); case OP_LET0AST: /* let* */ @@ -3736,14 +3772,14 @@ if (is_pair (SCHEME_V->code)) /* continue */ { - s_save (SCHEME_A_ OP_LET2AST, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->code = SCHEME_V->args; + SCHEME_V->code = args; SCHEME_V->args = NIL; s_goto (OP_BEGIN); } @@ -3756,28 +3792,28 @@ s_goto (OP_LET1REC); case OP_LET1REC: /* letrec (calculate parameters) */ - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); - s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code)); + s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); - SCHEME_V->code = car (SCHEME_V->args); - SCHEME_V->args = cdr (SCHEME_V->args); + args = reverse_in_place (SCHEME_A_ NIL, args); + SCHEME_V->code = car (args); + SCHEME_V->args = cdr (args); s_goto (OP_LET2REC); } case OP_LET2REC: /* letrec */ - for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y)) + for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) new_slot_in_env (SCHEME_A_ caar (x), car (y)); SCHEME_V->code = cdr (SCHEME_V->code); @@ -3873,10 +3909,10 @@ s_goto (OP_EVAL); case OP_C1STREAM: /* cons-stream */ - SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register SCHEME_V->args for gc */ + SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */ x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); set_typeflag (x, T_PROMISE); - s_return (cons (SCHEME_V->args, x)); + s_return (cons (args, x)); case OP_MACRO0: /* macro */ if (is_pair (car (SCHEME_V->code))) @@ -3919,10 +3955,8 @@ break; for (; y != NIL; y = cdr (y)) - { - if (eqv (car (y), SCHEME_V->value)) + if (eqv (car (y), SCHEME_V->value)) break; - } if (y != NIL) break; @@ -3952,110 +3986,83 @@ s_return (NIL); case OP_PAPPLY: /* apply */ - SCHEME_V->code = car (SCHEME_V->args); - SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args)); - /*SCHEME_V->args = cadr(SCHEME_V->args); */ + SCHEME_V->code = car (args); + SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); + /*SCHEME_V->args = cadr(args); */ s_goto (OP_APPLY); case OP_PEVAL: /* eval */ - if (cdr (SCHEME_V->args) != NIL) - SCHEME_V->envir = cadr (SCHEME_V->args); + if (cdr (args) != NIL) + SCHEME_V->envir = cadr (args); - SCHEME_V->code = car (SCHEME_V->args); + SCHEME_V->code = car (args); s_goto (OP_EVAL); case OP_CONTINUATION: /* call-with-current-continuation */ - SCHEME_V->code = car (SCHEME_V->args); + SCHEME_V->code = car (args); SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); s_goto (OP_APPLY); } - return S_T; + if (USE_ERROR_CHECKING) abort (); } -static pointer -opexe_2 (SCHEME_P_ enum scheme_opcodes op) +static int +opexe_1 (SCHEME_P_ enum scheme_opcodes op) { - pointer x; + pointer args = SCHEME_V->args; + pointer x = car (args); num v; -#if USE_MATH - RVALUE dd; -#endif - switch (op) { #if USE_MATH - case OP_INEX2EX: /* inexact->exact */ - x = car (SCHEME_V->args); + { + if (is_integer (x)) + s_return (x); - if (num_is_integer (x)) - s_return (x); - else if (modf (rvalue_unchecked (x), &dd) == 0.0) - s_return (mk_integer (SCHEME_A_ ivalue (x))); - else - Error_1 ("inexact->exact: not integral:", x); + RVALUE r = rvalue_unchecked (x); - case OP_EXP: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); - - case OP_LOG: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ log (rvalue (x)))); - - case OP_SIN: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); - - case OP_COS: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); - - case OP_TAN: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); - - case OP_ASIN: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); - - case OP_ACOS: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ acos (rvalue (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_ATAN: - x = car (SCHEME_V->args); + case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); + case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); + case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); + case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); + case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); + case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); + case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); - if (cdr (SCHEME_V->args) == NIL) + case OP_ATAN: + if (cdr (args) == NIL) s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); else { - pointer y = cadr (SCHEME_V->args); - + pointer y = cadr (args); s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y)))); } case OP_SQRT: - x = car (SCHEME_V->args); s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); case OP_EXPT: { RVALUE result; int real_result = 1; - pointer y = cadr (SCHEME_V->args); + pointer y = cadr (args); - x = car (SCHEME_V->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. */ /* NOTE: Remove this 'if' fix for R6RS. */ if (rvalue (x) == 0 && rvalue (y) < 0) - result = 0.0; + result = 0; else result = pow (rvalue (x), rvalue (y)); @@ -4063,9 +4070,9 @@ /* If the test fails, result is too big for integer. */ if (!real_result) { - long result_as_long = (long) result; + long result_as_long = result; - if (result != (RVALUE) result_as_long) + if (result != result_as_long) real_result = 1; } @@ -4075,31 +4082,17 @@ s_return (mk_integer (SCHEME_A_ result)); } - case OP_FLOOR: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); - - case OP_CEILING: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); + case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); + case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); case OP_TRUNCATE: { - RVALUE rvalue_of_x; - - x = car (SCHEME_V->args); - 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: - x = car (SCHEME_V->args); - - if (num_is_integer (x)) + if (is_integer (x)) s_return (x); s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); @@ -4108,74 +4101,72 @@ case OP_ADD: /* + */ v = num_zero; - for (x = SCHEME_V->args; x != NIL; x = cdr (x)) - v = num_add (v, nvalue (car (x))); + for (x = args; x != NIL; x = cdr (x)) + v = num_op (NUM_ADD, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_MUL: /* * */ v = num_one; - for (x = SCHEME_V->args; x != NIL; x = cdr (x)) - v = num_mul (v, nvalue (car (x))); + for (x = args; x != NIL; x = cdr (x)) + v = num_op (NUM_MUL, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_SUB: /* - */ - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) { - x = SCHEME_V->args; + x = args; v = num_zero; } else { - x = cdr (SCHEME_V->args); - v = nvalue (car (SCHEME_V->args)); + x = cdr (args); + v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) - v = num_sub (v, nvalue (car (x))); + v = num_op (NUM_SUB, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_DIV: /* / */ - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) { - x = SCHEME_V->args; + x = args; v = num_one; } else { - x = cdr (SCHEME_V->args); - v = nvalue (car (SCHEME_V->args)); + x = cdr (args); + v = nvalue (car (args)); } 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)); case OP_INTDIV: /* quotient */ - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) { - x = SCHEME_V->args; + x = args; v = num_one; } else { - x = cdr (SCHEME_V->args); - v = nvalue (car (SCHEME_V->args)); + x = cdr (args); + v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) { if (ivalue (car (x)) != 0) - v = num_intdiv (v, nvalue (car (x))); + v = num_op (NUM_INTDIV, v, nvalue (car (x))); else Error_0 ("quotient: division by zero"); } @@ -4183,86 +4174,86 @@ s_return (mk_number (SCHEME_A_ v)); case OP_REM: /* remainder */ - v = nvalue (car (SCHEME_V->args)); + v = nvalue (x); - if (ivalue (cadr (SCHEME_V->args)) != 0) - v = num_rem (v, nvalue (cadr (SCHEME_V->args))); + if (ivalue (cadr (args)) != 0) + v = num_rem (v, nvalue (cadr (args))); else Error_0 ("remainder: division by zero"); s_return (mk_number (SCHEME_A_ v)); case OP_MOD: /* modulo */ - v = nvalue (car (SCHEME_V->args)); + v = nvalue (x); - if (ivalue (cadr (SCHEME_V->args)) != 0) - v = num_mod (v, nvalue (cadr (SCHEME_V->args))); + if (ivalue (cadr (args)) != 0) + v = num_mod (v, nvalue (cadr (args))); else Error_0 ("modulo: division by zero"); s_return (mk_number (SCHEME_A_ v)); case OP_CAR: /* car */ - s_return (caar (SCHEME_V->args)); + s_return (caar (args)); case OP_CDR: /* cdr */ - s_return (cdar (SCHEME_V->args)); + s_return (cdar (args)); case OP_CONS: /* cons */ - set_cdr (SCHEME_V->args, cadr (SCHEME_V->args)); - s_return (SCHEME_V->args); + set_cdr (args, cadr (args)); + s_return (args); case OP_SETCAR: /* set-car! */ - if (!is_immutable (car (SCHEME_V->args))) + if (!is_immutable (x)) { - set_car (car (SCHEME_V->args), cadr (SCHEME_V->args)); - s_return (car (SCHEME_V->args)); + set_car (x, cadr (args)); + s_return (car (args)); } else Error_0 ("set-car!: unable to alter immutable pair"); case OP_SETCDR: /* set-cdr! */ - if (!is_immutable (car (SCHEME_V->args))) + if (!is_immutable (x)) { - set_cdr (car (SCHEME_V->args), cadr (SCHEME_V->args)); - s_return (car (SCHEME_V->args)); + set_cdr (x, cadr (args)); + s_return (car (args)); } else Error_0 ("set-cdr!: unable to alter immutable pair"); case OP_CHAR2INT: /* char->integer */ - s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args)))); + s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x))); case OP_INT2CHAR: /* integer->char */ - s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args)))); + s_return (mk_character (SCHEME_A_ ivalue_unchecked (x))); case OP_CHARUPCASE: { - unsigned char c = ivalue (car (SCHEME_V->args)); + unsigned char c = ivalue_unchecked (x); c = toupper (c); s_return (mk_character (SCHEME_A_ c)); } case OP_CHARDNCASE: { - unsigned char c = ivalue (car (SCHEME_V->args)); + unsigned char c = ivalue_unchecked (x); c = tolower (c); s_return (mk_character (SCHEME_A_ c)); } case OP_STR2SYM: /* string->symbol */ - s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args)))); + s_return (mk_symbol (SCHEME_A_ strvalue (x))); case OP_STR2ATOM: /* string->atom */ { - char *s = strvalue (car (SCHEME_V->args)); + char *s = strvalue (x); long pf = 0; - if (cdr (SCHEME_V->args) != NIL) + if (cdr (args) != NIL) { - /* we know cadr(SCHEME_V->args) is a natural number */ + /* we know cadr(args) is a natural number */ /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked (cadr (SCHEME_V->args)); + pf = ivalue_unchecked (cadr (args)); if (pf == 16 || pf == 10 || pf == 8 || pf == 2) { @@ -4273,7 +4264,7 @@ } if (pf < 0) - Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args)); + Error_1 ("string->atom: bad base:", cadr (args)); else if (*s == '#') /* no use of base! */ s_return (mk_sharp_const (SCHEME_A_ s + 1)); else @@ -4294,7 +4285,7 @@ } case OP_SYM2STR: /* symbol->string */ - x = mk_string (SCHEME_A_ symname (car (SCHEME_V->args))); + x = mk_string (SCHEME_A_ symname (x)); setimmutable (x); s_return (x); @@ -4302,13 +4293,11 @@ { long pf = 0; - x = car (SCHEME_V->args); - - if (cdr (SCHEME_V->args) != NIL) + if (cdr (args) != NIL) { - /* we know cadr(SCHEME_V->args) is a natural number */ + /* we know cadr(args) is a natural number */ /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked (cadr (SCHEME_V->args)); + pf = ivalue_unchecked (cadr (args)); if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { @@ -4319,7 +4308,7 @@ } if (pf < 0) - Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args)); + Error_1 ("atom->string: bad base:", cadr (args)); else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x)) { char *p; @@ -4334,55 +4323,42 @@ case OP_MKSTRING: /* make-string */ { - int fill = ' '; - int len; - - len = ivalue (car (SCHEME_V->args)); + int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' '; + int len = ivalue_unchecked (x); - if (cdr (SCHEME_V->args) != NIL) - fill = charvalue (cadr (SCHEME_V->args)); - - s_return (mk_empty_string (SCHEME_A_ len, (char) fill)); + s_return (mk_empty_string (SCHEME_A_ len, fill)); } case OP_STRLEN: /* string-length */ - s_return (mk_integer (SCHEME_A_ strlength (car (SCHEME_V->args)))); + s_return (mk_integer (SCHEME_A_ strlength (x))); case OP_STRREF: /* string-ref */ { - char *str; - int index; - - str = strvalue (car (SCHEME_V->args)); - - index = ivalue (cadr (SCHEME_V->args)); + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); - if (index >= strlength (car (SCHEME_V->args))) - Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args)); + if (index >= strlength (x)) + Error_1 ("string-ref: out of bounds:", cadr (args)); - s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index])); + s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index])); } case OP_STRSET: /* string-set! */ { - char *str; - int index; + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); int c; - if (is_immutable (car (SCHEME_V->args))) - Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args)); - - str = strvalue (car (SCHEME_V->args)); - - index = ivalue (cadr (SCHEME_V->args)); + if (is_immutable (x)) + Error_1 ("string-set!: unable to alter immutable string:", x); - if (index >= strlength (car (SCHEME_V->args))) - Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args)); + if (index >= strlength (x)) + Error_1 ("string-set!: out of bounds:", cadr (args)); - c = charvalue (caddr (SCHEME_V->args)); + c = charvalue (caddr (args)); - str[index] = (char) c; - s_return (car (SCHEME_V->args)); + str[index] = c; + s_return (car (args)); } case OP_STRAPPEND: /* string-append */ @@ -4393,13 +4369,13 @@ char *pos; /* compute needed length for new string */ - for (x = SCHEME_V->args; x != NIL; x = cdr (x)) + for (x = args; x != NIL; x = cdr (x)) len += strlength (car (x)); newstr = mk_empty_string (SCHEME_A_ len, ' '); /* store the contents of the argument strings into the new string */ - for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x)) + for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x)) memcpy (pos, strvalue (car (x)), strlength (car (x))); s_return (newstr); @@ -4407,27 +4383,23 @@ case OP_SUBSTR: /* substring */ { - char *str; - int index0; + char *str = strvalue (x); + int index0 = ivalue_unchecked (cadr (args)); int index1; int len; - str = strvalue (car (SCHEME_V->args)); + if (index0 > strlength (x)) + Error_1 ("substring: start out of bounds:", cadr (args)); - index0 = ivalue (cadr (SCHEME_V->args)); - - if (index0 > strlength (car (SCHEME_V->args))) - Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args)); - - if (cddr (SCHEME_V->args) != NIL) + if (cddr (args) != NIL) { - index1 = ivalue (caddr (SCHEME_V->args)); + index1 = ivalue_unchecked (caddr (args)); - if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0) - Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args)); + if (index1 > strlength (x) || index1 < index0) + Error_1 ("substring: end out of bounds:", caddr (args)); } else - index1 = strlength (car (SCHEME_V->args)); + index1 = strlength (x); len = index1 - index0; x = mk_empty_string (SCHEME_A_ len, ' '); @@ -4441,10 +4413,10 @@ { int i; pointer vec; - int len = list_length (SCHEME_A_ SCHEME_V->args); + int len = list_length (SCHEME_A_ args); if (len < 0) - Error_1 ("vector: not a proper list:", SCHEME_V->args); + Error_1 ("vector: not a proper list:", args); vec = mk_vector (SCHEME_A_ len); @@ -4453,8 +4425,8 @@ s_return (S_SINK); #endif - for (x = SCHEME_V->args, i = 0; is_pair (x); x = cdr (x), i++) - set_vector_elem (vec, i, car (x)); + for (x = args, i = 0; is_pair (x); x = cdr (x), i++) + vector_set (vec, i, car (x)); s_return (vec); } @@ -4462,13 +4434,11 @@ case OP_MKVECTOR: /* make-vector */ { pointer fill = NIL; - int len; pointer vec; + int len = ivalue_unchecked (x); - len = ivalue (car (SCHEME_V->args)); - - if (cdr (SCHEME_V->args) != NIL) - fill = cadr (SCHEME_V->args); + if (cdr (args) != NIL) + fill = cadr (args); vec = mk_vector (SCHEME_A_ len); @@ -4478,250 +4448,144 @@ #endif if (fill != NIL) - fill_vector (vec, fill); + fill_vector (vec, 0, fill); s_return (vec); } case OP_VECLEN: /* vector-length */ - s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args)))); + s_return (mk_integer (SCHEME_A_ veclength (x))); + + case OP_VECRESIZE: + vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args)); + s_return (x); case OP_VECREF: /* vector-ref */ { - int index; - - index = ivalue (cadr (SCHEME_V->args)); + int index = ivalue_unchecked (cadr (args)); - if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) - Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); + if (index >= veclength (car (args)) && USE_ERROR_CHECKING) + Error_1 ("vector-ref: out of bounds:", cadr (args)); - s_return (vector_elem (car (SCHEME_V->args), index)); + s_return (vector_get (x, index)); } case OP_VECSET: /* vector-set! */ { - int index; + int index = ivalue_unchecked (cadr (args)); - if (is_immutable (car (SCHEME_V->args))) - Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); + if (is_immutable (x)) + Error_1 ("vector-set!: unable to alter immutable vector:", x); - index = ivalue (cadr (SCHEME_V->args)); + if (index >= veclength (car (args)) && USE_ERROR_CHECKING) + Error_1 ("vector-set!: out of bounds:", cadr (args)); - if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) - Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); - - set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); - s_return (car (SCHEME_V->args)); + vector_set (x, index, caddr (args)); + s_return (x); } } - return S_T; + if (USE_ERROR_CHECKING) 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) +static int +opexe_2 (SCHEME_P_ enum scheme_opcodes op) { - int i = 0; - pointer slow, fast; - - slow = fast = a; + pointer x = SCHEME_V->args; - while (1) + for (;;) { - if (fast == NIL) - return i; - - if (!is_pair (fast)) - return -2 - i; - - fast = cdr (fast); - ++i; - - if (fast == NIL) - return i; + num v = nvalue (car (x)); + x = cdr (x); - if (!is_pair (fast)) - return -2 - i; - - ++i; - fast = cdr (fast); + if (x == NIL) + break; - /* Safe because we would have already returned if `fast' - encountered a non-pair. */ - slow = cdr (slow); + int r = num_cmp (v, nvalue (car (x))); - if (fast == slow) + switch (op) { - /* 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; + case OP_NUMEQ: r = r == 0; break; + case OP_LESS: r = r < 0; break; + case OP_GRE: r = r > 0; break; + case OP_LEQ: r = r <= 0; break; + case OP_GEQ: r = r >= 0; break; } + + if (!r) + s_return (S_F); } + + s_return (S_T); } -static pointer +static int opexe_3 (SCHEME_P_ enum scheme_opcodes op) { - pointer x; - num v; - int (*comp_func) (num, num); + pointer args = SCHEME_V->args; + pointer a = car (args); + pointer d = cdr (args); + int r; switch (op) { - case OP_NOT: /* not */ - s_retbool (is_false (car (SCHEME_V->args))); - - case OP_BOOLP: /* boolean? */ - s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T); - - case OP_EOFOBJP: /* boolean? */ - s_retbool (car (SCHEME_V->args) == S_EOF); - - case OP_NULLP: /* null? */ - s_retbool (car (SCHEME_V->args) == NIL); - - 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; - - case OP_GRE: - comp_func = num_gt; - break; - - case OP_LEQ: - comp_func = num_le; - break; - - case OP_GEQ: - comp_func = num_ge; - break; - } - - x = SCHEME_V->args; - v = nvalue (car (x)); - x = cdr (x); - - for (; x != NIL; x = cdr (x)) - { - if (!comp_func (v, nvalue (car (x)))) - s_retbool (0); - - v = nvalue (car (x)); - } - - s_retbool (1); - - case OP_SYMBOLP: /* symbol? */ - s_retbool (is_symbol (car (SCHEME_V->args))); + case OP_NOT: /* not */ r = is_false (a) ; break; + case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; + case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; + case OP_NULLP: /* null? */ r = a == NIL ; break; + case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; + case OP_NUMBERP: /* number? */ r = is_number (a) ; break; + case OP_STRINGP: /* string? */ r = is_string (a) ; break; + case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; + case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ + case OP_CHARP: /* char? */ r = is_character (a) ; break; - case OP_NUMBERP: /* number? */ - s_retbool (is_number (car (SCHEME_V->args))); - - case OP_STRINGP: /* string? */ - s_retbool (is_string (car (SCHEME_V->args))); - - case OP_INTEGERP: /* integer? */ - s_retbool (is_integer (car (SCHEME_V->args))); - - case OP_REALP: /* real? */ - s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */ - - case OP_CHARP: /* char? */ - s_retbool (is_character (car (SCHEME_V->args))); #if USE_CHAR_CLASSIFIERS - - case OP_CHARAP: /* char-alphabetic? */ - s_retbool (Cisalpha (ivalue (car (SCHEME_V->args)))); - - case OP_CHARNP: /* char-numeric? */ - s_retbool (Cisdigit (ivalue (car (SCHEME_V->args)))); - - case OP_CHARWP: /* char-whitespace? */ - s_retbool (Cisspace (ivalue (car (SCHEME_V->args)))); - - case OP_CHARUP: /* char-upper-case? */ - s_retbool (Cisupper (ivalue (car (SCHEME_V->args)))); - - case OP_CHARLP: /* char-lower-case? */ - s_retbool (Cislower (ivalue (car (SCHEME_V->args)))); + 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 - case OP_PORTP: /* port? */ - s_retbool (is_port (car (SCHEME_V->args))); - - case OP_INPORTP: /* input-port? */ - s_retbool (is_inport (car (SCHEME_V->args))); - - case OP_OUTPORTP: /* output-port? */ - s_retbool (is_outport (car (SCHEME_V->args))); +#if USE_PORTS + case OP_PORTP: /* port? */ r = is_port (a) ; break; + case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break; + case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break; #endif case OP_PROCP: /* procedure? */ - /*-- - * continuation should be procedure by the example - * (call-with-current-continuation procedure?) ==> #t - * in R^3 report sec. 6.9 - */ - s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args)) - || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args))); - - case OP_PAIRP: /* pair? */ - s_retbool (is_pair (car (SCHEME_V->args))); - - case OP_LISTP: /* list? */ - s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0); - - case OP_ENVP: /* environment? */ - s_retbool (is_environment (car (SCHEME_V->args))); - - case OP_VECTORP: /* vector? */ - s_retbool (is_vector (car (SCHEME_V->args))); - - case OP_EQ: /* eq? */ - s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args)); + /*-- + * continuation should be procedure by the example + * (call-with-current-continuation procedure?) ==> #t + * in R^3 report sec. 6.9 + */ + r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a); + break; - case OP_EQV: /* eqv? */ - s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args))); + case OP_PAIRP: /* pair? */ r = is_pair (a) ; break; + case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break; + case OP_ENVP: /* environment? */ r = is_environment (a) ; break; + case OP_VECTORP: /* vector? */ r = is_vector (a) ; break; + case OP_EQ: /* eq? */ r = a == cadr (args) ; break; + case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break; } - return S_T; + s_retbool (r); } -static pointer +static int opexe_4 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; + pointer a = car (args); pointer x, y; switch (op) { case OP_FORCE: /* force */ - SCHEME_V->code = car (SCHEME_V->args); + SCHEME_V->code = a; if (is_promise (SCHEME_V->code)) { @@ -4752,7 +4616,7 @@ } } - SCHEME_V->args = car (SCHEME_V->args); + SCHEME_V->args = a; if (op == OP_WRITE) SCHEME_V->print_flag = 1; @@ -4762,13 +4626,13 @@ s_goto (OP_P0LIST); case OP_NEWLINE: /* newline */ - if (is_pair (SCHEME_V->args)) + if (is_pair (args)) { - if (car (SCHEME_V->args) != SCHEME_V->outport) + if (a != SCHEME_V->outport) { x = cons (SCHEME_V->outport, NIL); s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); - SCHEME_V->outport = car (SCHEME_V->args); + SCHEME_V->outport = a; } } @@ -4779,24 +4643,24 @@ case OP_ERR0: /* error */ SCHEME_V->retcode = -1; - if (!is_string (car (SCHEME_V->args))) + if (!is_string (a)) { - SCHEME_V->args = cons (mk_string (SCHEME_A_ " -- "), SCHEME_V->args); - setimmutable (car (SCHEME_V->args)); + args = cons (mk_string (SCHEME_A_ " -- "), args); + setimmutable (car (args)); } putstr (SCHEME_A_ "Error: "); - putstr (SCHEME_A_ strvalue (car (SCHEME_V->args))); - SCHEME_V->args = cdr (SCHEME_V->args); + putstr (SCHEME_A_ strvalue (car (args))); + SCHEME_V->args = cdr (args); s_goto (OP_ERR1); case OP_ERR1: /* error */ putstr (SCHEME_A_ " "); - if (SCHEME_V->args != NIL) + if (args != NIL) { - s_save (SCHEME_A_ OP_ERR1, cdr (SCHEME_V->args), NIL); - SCHEME_V->args = car (SCHEME_V->args); + s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); + SCHEME_V->args = a; SCHEME_V->print_flag = 1; s_goto (OP_P0LIST); } @@ -4807,18 +4671,18 @@ if (SCHEME_V->interactive_repl) s_goto (OP_T0LVL); else - return NIL; + return -1; } case OP_REVERSE: /* reverse */ - s_return (reverse (SCHEME_A_ car (SCHEME_V->args))); + s_return (reverse (SCHEME_A_ a)); case OP_LIST_STAR: /* list* */ s_return (list_star (SCHEME_A_ SCHEME_V->args)); case OP_APPEND: /* append */ x = NIL; - y = SCHEME_V->args; + y = args; if (y == x) s_return (x); @@ -4839,27 +4703,27 @@ #if USE_PLIST case OP_PUT: /* put */ - if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) + if (!hasprop (a) || !hasprop (cadr (args))) Error_0 ("illegal use of put"); - for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) + for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x)) { if (caar (x) == y) break; } if (x != NIL) - cdar (x) = caddr (SCHEME_V->args); + cdar (x) = caddr (args); else - symprop (car (SCHEME_V->args)) = cons (cons (y, caddr (SCHEME_V->args)), symprop (car (SCHEME_V->args))); + symprop (a) = cons (cons (y, caddr (args)), symprop (a)); s_return (S_T); case OP_GET: /* get */ - if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) + if (!hasprop (a) || !hasprop (cadr (args))) Error_0 ("illegal use of get"); - for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) + for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x)) if (caar (x) == y) break; @@ -4871,10 +4735,10 @@ #endif /* USE_PLIST */ case OP_QUIT: /* quit */ - if (is_pair (SCHEME_V->args)) - SCHEME_V->retcode = ivalue (car (SCHEME_V->args)); + if (is_pair (args)) + SCHEME_V->retcode = ivalue (a); - return NIL; + return -1; case OP_GC: /* gc */ gc (SCHEME_A_ NIL, NIL); @@ -4884,15 +4748,15 @@ { int was = SCHEME_V->gc_verbose; - SCHEME_V->gc_verbose = (car (SCHEME_V->args) != S_F); + SCHEME_V->gc_verbose = (a != S_F); s_retbool (was); } case OP_NEWSEGMENT: /* new-segment */ - if (!is_pair (SCHEME_V->args) || !is_number (car (SCHEME_V->args))) + if (!is_pair (args) || !is_number (a)) Error_0 ("new-segment: argument must be a number"); - alloc_cellseg (SCHEME_A_ (int)ivalue (car (SCHEME_V->args))); + alloc_cellseg (SCHEME_A_ ivalue (a)); s_return (S_T); @@ -4929,12 +4793,9 @@ break; } - p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop); - - if (p == NIL) - s_return (S_F); + p = port_from_filename (SCHEME_A_ strvalue (a), prop); - s_return (p); + s_return (p == NIL ? S_F : p); } # if USE_STRING_PORTS @@ -4956,43 +4817,30 @@ break; } - p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), - strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop); + 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 */ { pointer p; - if (car (SCHEME_V->args) == NIL) - { - p = port_from_scratch (SCHEME_A); - - if (p == NIL) - s_return (S_F); - } + if (a == NIL) + p = port_from_scratch (SCHEME_A); else - { - p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), - strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output); + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), port_output); - if (p == NIL) - s_return (S_F); - } - - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_GET_OUTSTRING: /* get-output-string */ { port *p; - if ((p = car (SCHEME_V->args)->object.port)->kind & port_string) + if ((p = a->object.port)->kind & port_string) { off_t size; char *str; @@ -5018,11 +4866,11 @@ # endif case OP_CLOSE_INPORT: /* close-input-port */ - port_close (SCHEME_A_ car (SCHEME_V->args), port_input); + port_close (SCHEME_A_ a, port_input); s_return (S_T); case OP_CLOSE_OUTPORT: /* close-output-port */ - port_close (SCHEME_A_ car (SCHEME_V->args), port_output); + port_close (SCHEME_A_ a, port_output); s_return (S_T); #endif @@ -5034,12 +4882,13 @@ } - return S_T; + if (USE_ERROR_CHECKING) abort (); } -static pointer +static int opexe_5 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; pointer x; if (SCHEME_V->nesting != 0) @@ -5056,17 +4905,17 @@ /* ========== reading part ========== */ #if USE_PORTS case OP_READ: - if (!is_pair (SCHEME_V->args)) + if (!is_pair (args)) s_goto (OP_READ_INTERNAL); - if (!is_inport (car (SCHEME_V->args))) - Error_1 ("read: not an input port:", car (SCHEME_V->args)); + if (!is_inport (car (args))) + Error_1 ("read: not an input port:", car (args)); - if (car (SCHEME_V->args) == SCHEME_V->inport) + if (car (args) == SCHEME_V->inport) s_goto (OP_READ_INTERNAL); x = SCHEME_V->inport; - SCHEME_V->inport = car (SCHEME_V->args); + SCHEME_V->inport = car (args); x = cons (x, NIL); s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); s_goto (OP_READ_INTERNAL); @@ -5076,14 +4925,14 @@ { int c; - if (is_pair (SCHEME_V->args)) + if (is_pair (args)) { - if (car (SCHEME_V->args) != SCHEME_V->inport) + if (car (args) != SCHEME_V->inport) { x = SCHEME_V->inport; x = cons (x, NIL); s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); - SCHEME_V->inport = car (SCHEME_V->args); + SCHEME_V->inport = car (args); } } @@ -5103,8 +4952,8 @@ pointer p = SCHEME_V->inport; int res; - if (is_pair (SCHEME_V->args)) - p = car (SCHEME_V->args); + if (is_pair (args)) + p = car (args); res = p->object.port->kind & port_string; @@ -5112,11 +4961,11 @@ } case OP_SET_INPORT: /* set-input-port */ - SCHEME_V->inport = car (SCHEME_V->args); + SCHEME_V->inport = car (args); s_return (SCHEME_V->value); case OP_SET_OUTPORT: /* set-output-port */ - SCHEME_V->outport = car (SCHEME_V->args); + SCHEME_V->outport = car (args); s_return (SCHEME_V->value); #endif @@ -5175,10 +5024,19 @@ s_goto (OP_RDSEXPR); case TOK_ATOM: - s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); + s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))); + + case TOK_DOTATOM: + SCHEME_V->strbuff[0] = '.'; + s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); + + case TOK_STRATOM: + x = readstrexp (SCHEME_A_ '|'); + //TODO: haven't checked whether the garbage collector could interfere + s_return (mk_atom (SCHEME_A_ strvalue (x))); case TOK_DQUOTE: - x = readstrexp (SCHEME_A); + x = readstrexp (SCHEME_A_ '"'); if (x == S_F) Error_0 ("Error reading string"); @@ -5200,7 +5058,7 @@ } case TOK_SHARP_CONST: - if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) + if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) Error_0 ("undefined sharp expression"); else s_return (x); @@ -5212,7 +5070,7 @@ break; case OP_RDLIST: - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + SCHEME_V->args = cons (SCHEME_V->value, args); SCHEME_V->tok = token (SCHEME_A); switch (SCHEME_V->tok) @@ -5250,7 +5108,7 @@ Error_0 ("syntax error: illegal dot expression"); SCHEME_V->nesting_stack[SCHEME_V->file_i]--; - s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args)); + s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args)); case OP_RDQUOTE: s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); @@ -5282,63 +5140,56 @@ /* ========== printing part ========== */ case OP_P0LIST: - if (is_vector (SCHEME_V->args)) + if (is_vector (args)) { putstr (SCHEME_A_ "#("); - SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0)); + SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0)); s_goto (OP_PVECFROM); } - else if (is_environment (SCHEME_V->args)) + else if (is_environment (args)) { putstr (SCHEME_A_ "#"); s_return (S_T); } - else if (!is_pair (SCHEME_V->args)) + else if (!is_pair (args)) { - printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); + printatom (SCHEME_A_ args, SCHEME_V->print_flag); s_return (S_T); } - else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ "'"); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } - else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ "`"); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } - else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ ","); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } - else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ ",@"); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } else { - putstr (SCHEME_A_ "("); - s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL); - SCHEME_V->args = car (SCHEME_V->args); + pointer a = car (args); + pointer b = cdr (args); + int ok_abbr = ok_abbrev (b); + SCHEME_V->args = car (b); + + if (a == SCHEME_V->QUOTE && ok_abbr) + putstr (SCHEME_A_ "'"); + else if (a == SCHEME_V->QQUOTE && ok_abbr) + putstr (SCHEME_A_ "`"); + else if (a == SCHEME_V->UNQUOTE && ok_abbr) + putstr (SCHEME_A_ ","); + else if (a == SCHEME_V->UNQUOTESP && ok_abbr) + putstr (SCHEME_A_ ",@"); + else + { + putstr (SCHEME_A_ "("); + s_save (SCHEME_A_ OP_P1LIST, b, NIL); + SCHEME_V->args = a; + } + s_goto (OP_P0LIST); } case OP_P1LIST: - if (is_pair (SCHEME_V->args)) + if (is_pair (args)) { - s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL); + s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); putstr (SCHEME_A_ " "); - SCHEME_V->args = car (SCHEME_V->args); + SCHEME_V->args = car (args); s_goto (OP_P0LIST); } - else if (is_vector (SCHEME_V->args)) + else if (is_vector (args)) { s_save (SCHEME_A_ OP_P1LIST, NIL, NIL); putstr (SCHEME_A_ " . "); @@ -5346,10 +5197,10 @@ } else { - if (SCHEME_V->args != NIL) + if (args != NIL) { putstr (SCHEME_A_ " . "); - printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); + printatom (SCHEME_A_ args, SCHEME_V->print_flag); } putstr (SCHEME_A_ ")"); @@ -5358,8 +5209,8 @@ case OP_PVECFROM: { - int i = ivalue_unchecked (cdr (SCHEME_V->args)); - pointer vec = car (SCHEME_V->args); + int i = ivalue_unchecked (cdr (args)); + pointer vec = car (args); int len = veclength (vec); if (i == len) @@ -5369,10 +5220,10 @@ } else { - pointer elem = vector_elem (vec, i); + pointer elem = vector_get (vec, i); - ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1; - s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL); + ivalue_unchecked (cdr (args)) = i + 1; + s_save (SCHEME_A_ OP_PVECFROM, args, NIL); SCHEME_V->args = elem; if (i > 0) @@ -5383,30 +5234,32 @@ } } - return S_T; + if (USE_ERROR_CHECKING) abort (); } -static pointer +static int opexe_6 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; + pointer a = car (args); pointer x, y; switch (op) { case OP_LIST_LENGTH: /* length *//* a.k */ { - long v = list_length (SCHEME_A_ car (SCHEME_V->args)); + long v = list_length (SCHEME_A_ a); if (v < 0) - Error_1 ("length: not a list:", car (SCHEME_V->args)); + Error_1 ("length: not a list:", a); s_return (mk_integer (SCHEME_A_ v)); } case OP_ASSQ: /* assq *//* a.k */ - x = car (SCHEME_V->args); + x = a; - for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y)) + for (y = cadr (args); is_pair (y); y = cdr (y)) { if (!is_pair (car (y))) Error_0 ("unable to handle non pair element"); @@ -5422,7 +5275,7 @@ case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ - SCHEME_V->args = car (SCHEME_V->args); + SCHEME_V->args = a; if (SCHEME_V->args == NIL) s_return (S_F); @@ -5437,29 +5290,37 @@ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t + * (schmorp) well, obviously not, fix? TODO */ - s_retbool (is_closure (car (SCHEME_V->args))); + s_retbool (is_closure (a)); case OP_MACROP: /* macro? */ - s_retbool (is_macro (car (SCHEME_V->args))); + s_retbool (is_macro (a)); } - return S_T; /* NOTREACHED */ + if (USE_ERROR_CHECKING) abort (); } -typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); +/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ +typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); -typedef int (*test_predicate) (pointer); +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 (SCHEME_P_ pointer p) +{ + return p == NIL || is_pair (p); } /* Correspond carefully with following defines! */ @@ -5467,104 +5328,123 @@ { test_predicate fct; const char *kind; -} tests[] = -{ - { 0, 0}, /* unused */ - { is_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" }, - { 0, "pair or '()" }, - { is_character, "character" }, - { is_vector, "vector" }, - { is_number, "number" }, - { is_integer, "integer" }, - { is_nonneg, "non-negative integer" } +} 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" }, + { 0 , "pair or '()" }, + { is_character , "character" }, + { is_vector , "vector" }, + { is_number , "number" }, + { is_integer , "integer" }, + { tst_inonneg , "non-negative integer" } }; -#define TST_NONE 0 -#define TST_ANY "\001" -#define TST_STRING "\002" -#define TST_SYMBOL "\003" -#define TST_PORT "\004" -#define TST_INPORT "\005" -#define TST_OUTPORT "\006" +#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */ +#define TST_ANY "\001" +#define TST_STRING "\002" +#define TST_SYMBOL "\003" +#define TST_PORT "\004" +#define TST_INPORT "\005" +#define TST_OUTPORT "\006" #define TST_ENVIRONMENT "\007" -#define TST_PAIR "\010" -#define TST_LIST "\011" -#define TST_CHAR "\012" -#define TST_VECTOR "\013" -#define TST_NUMBER "\014" -#define TST_INTEGER "\015" -#define TST_NATURAL "\016" +#define TST_PAIR "\010" +#define TST_LIST "\011" +#define TST_CHAR "\012" +#define TST_VECTOR "\013" +#define TST_NUMBER "\014" +#define TST_INTEGER "\015" +#define TST_NATURAL "\016" -typedef struct +#define INF_ARG 0xff +#define UNNAMED_OP "" + +static const char opnames[] = +#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" +#include "opdefines.h" +#undef OP_DEF +; + +static const char * +opname (int idx) { - dispatch_func func; - char *name; - int min_arity; - int max_arity; - char *arg_tests_encoding; -} op_code_info; + const char *name = opnames; -#define INF_ARG 0xffff + /* should do this at compile time, but would require external program, right? */ + while (idx--) + name += strlen (name) + 1; -static op_code_info dispatch_table[] = { -#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, -#include "opdefines.h" - {0} -}; + return *name ? name : "ILLEGAL"; +} static const char * procname (pointer x) { - int n = procnum (x); - const char *name = dispatch_table[n].name; + return opname (procnum (x)); +} - if (name == 0) - name = "ILLEGAL!"; +typedef struct +{ + 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; - return name; -} +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; for (;;) { - op_code_info *pcd = dispatch_table + SCHEME_V->op; + const op_code_info *pcd = dispatch_table + SCHEME_V->op; #if USE_ERROR_CHECKING - if (pcd->name) /* if built-in function, check arguments */ + if (pcd->builtin) /* if built-in function, check arguments */ { - int ok = 1; char msg[STRBUFFSIZE]; int n = list_length (SCHEME_A_ SCHEME_V->args); /* Check number of arguments */ if (ecb_expect_false (n < pcd->min_arity)) { - ok = 0; snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); + opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); + xError_1 (SCHEME_A_ msg, 0); + continue; } - else if (ecb_excpect_false (n > pcd->max_arity)) + else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG)) { - ok = 0; snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); + opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); + xError_1 (SCHEME_A_ msg, 0); + continue; } - - if (ecb_expect_false (ok)) + else { - if (pcd->arg_tests_encoding) + if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */ { int i = 0; int j; @@ -5575,20 +5455,21 @@ { pointer arg = car (arglist); - j = (int) t[0]; + j = t[0]; + /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */ if (j == TST_LIST[0]) { - if (arg != NIL && !is_pair (arg)) + if (!tst_is_list (SCHEME_A_ arg)) break; } else { - if (!tests[j].fct (arg)) + if (!tests[j - 1].fct (arg)) break; } - if (t[1] != 0) /* 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); @@ -5598,25 +5479,28 @@ if (i < n) { - ok = 0; - snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind); + snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind); + xError_1 (SCHEME_A_ msg, 0); + continue; } } } - - if (!ok) - { - if (xError_1 (SCHEME_A_ msg, 0) == NIL) - return; - - pcd = dispatch_table + SCHEME_V->op; - } } #endif ok_to_freely_gc (SCHEME_A); - if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)) + static const dispatch_func dispatch_funcs[] = { + opexe_0, + opexe_1, + opexe_2, + opexe_3, + opexe_4, + opexe_5, + opexe_6, + }; + + if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) return; if (SCHEME_V->no_memory && USE_ERROR_CHECKING) @@ -5650,7 +5534,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; } @@ -5658,9 +5541,9 @@ static int syntaxnum (pointer p) { - const char *s = strvalue (car (p)); + const char *s = strvalue (p); - switch (strlength (car (p))) + switch (strlength (p)) { case 2: if (s[0] == 'i') @@ -5725,7 +5608,7 @@ } #if USE_MULTIPLICITY -scheme * +ecb_cold scheme * scheme_init_new () { scheme *sc = malloc (sizeof (scheme)); @@ -5740,7 +5623,7 @@ } #endif -int +ecb_cold int scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); @@ -5823,9 +5706,10 @@ assign_syntax (SCHEME_A_ syntax_names[i]); } + // TODO: should iterate via strlen, to avoid n² complexity for (i = 0; i < n; i++) - if (dispatch_table[i].name != 0) - assign_proc (SCHEME_A_ i, dispatch_table[i].name); + if (dispatch_table[i].builtin) + assign_proc (SCHEME_A_ i, opname (i)); /* initialization of global pointers to special symbols */ SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); @@ -5874,7 +5758,7 @@ SCHEME_V->ext_data = p; } -void +ecb_cold void scheme_deinit (SCHEME_P) { int i; @@ -5976,9 +5860,9 @@ SCHEME_V->envir = SCHEME_V->global_env; SCHEME_V->file_i = 0; SCHEME_V->load_stack[0].kind = port_input | port_string; - SCHEME_V->load_stack[0].rep.string.start = (char *) cmd; /* This func respects const */ - SCHEME_V->load_stack[0].rep.string.past_the_end = (char *) cmd + strlen (cmd); - SCHEME_V->load_stack[0].rep.string.curr = (char *) cmd; + SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ + SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); + SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; #if USE_PORTS SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); #endif @@ -6105,6 +5989,7 @@ char *file_name = InitFile; int retcode; int isfile = 1; + system ("ps v $PPID");//D if (argc == 2 && strcmp (argv[1], "-?") == 0) {