--- microscheme/scheme.c 2015/11/25 10:49:29 1.4 +++ microscheme/scheme.c 2015/11/28 10:31:06 1.29 @@ -1,5 +1,10 @@ - -/* T I N Y S C H E M E 1 . 4 1 +/* + * µscheme + * + * Copyright (C) 2015 Marc Alexander Lehmann + * do as you want with this, attribution appreciated. + * + * Based opn tinyscheme-1.41 (original credits follow) * Dimitrios Souflis (dsouflis@acm.org) * Based on MiniScheme (original credits follow) * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) @@ -25,6 +30,8 @@ # include #endif +#include "ecb.h" + #include #include #include @@ -130,9 +137,19 @@ return c; } -#if USE_STRLWR +static int +xisdigit (char c) +{ + return c >= '0' && c <= '9'; +} + +#define toupper(c) xtoupper (c) +#define tolower(c) xtolower (c) +#define isdigit(c) xisdigit (c) + +#if USE_IGNORECASE static const char * -strlwr (char *s) +xstrlwr (char *s) { const char *p = s; @@ -144,12 +161,14 @@ return p; } -#endif -#define stricmp(a,b) strcmp (a, b) -#define strlwr(s) (s) -#define toupper(c) xtoupper(c) -#define tolower(c) xtolower(c) +#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> " @@ -165,12 +184,12 @@ enum scheme_types { - T_FREE, + T_INTEGER, + T_REAL, T_STRING, - T_NUMBER, T_SYMBOL, T_PROC, - T_PAIR, + T_PAIR, /* also used for free cells */ T_CLOSURE, T_CONTINUATION, T_FOREIGN, @@ -190,30 +209,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; @@ -222,7 +255,7 @@ #define set_typeflag(p,v) ((p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) -INTERFACE INLINE int +INTERFACE int is_string (pointer p) { return type (p) == T_STRING; @@ -231,141 +264,101 @@ #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; } -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 uint32_t -vector_length (pointer vec) -{ - return vec->object.vector.length; -} +#define vecvalue(p) ((p)->object.vector.vvalue) +#define veclength(p) ((p)->object.vector.length) +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 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); -} +#define ivalue_unchecked(p) (p)->object.ivalue +#define set_ivalue(p,v) (p)->object.ivalue = (v) -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.number.value.ivalue) -#if USE_FLOAT -# 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; +#if USE_REAL +#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; } #define car(p) ((p)->object.cons.car + 0) -#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ +#define cdr(p) ((p)->object.cons.cdr + 0) -#define caar(p) car (car (p)) -#define cadr(p) car (cdr (p)) -#define cdar(p) cdr (car (p)) -#define cddr(p) cdr (cdr (p)) - -#define cadar(p) car (cdr (car (p))) -#define caddr(p) car (cdr (cdr (p))) -#define cdaar(p) cdr (car (car (p))) +static pointer caar (pointer p) { return car (car (p)); } +static pointer cadr (pointer p) { return car (cdr (p)); } +static pointer cdar (pointer p) { return cdr (car (p)); } +static pointer cddr (pointer p) { return cdr (cdr (p)); } + +static pointer cadar (pointer p) { return car (cdr (car (p))); } +static pointer caddr (pointer p) { return car (cdr (cdr (p))); } +static pointer cdaar (pointer p) { return cdr (car (car (p))); } INTERFACE void set_car (pointer p, pointer q) @@ -391,20 +384,20 @@ return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_symbol (pointer p) { return type (p) == T_SYMBOL; } -INTERFACE INLINE char * +INTERFACE char * symname (pointer p) { return strvalue (car (p)); } #if USE_PLIST -SCHEME_EXPORT INLINE int +SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; @@ -413,58 +406,58 @@ # define symprop(p) cdr(p) #endif -INTERFACE INLINE int +INTERFACE int is_syntax (pointer p) { return typeflag (p) & T_SYNTAX; } -INTERFACE INLINE int +INTERFACE int is_proc (pointer p) { return type (p) == T_PROC; } -INTERFACE INLINE int +INTERFACE int is_foreign (pointer p) { return type (p) == T_FOREIGN; } -INTERFACE INLINE char * +INTERFACE char * syntaxname (pointer p) { return strvalue (car (p)); } -#define procnum(p) ivalue (p) +#define procnum(p) ivalue_unchecked (p) static const char *procname (pointer x); -INTERFACE INLINE int +INTERFACE int is_closure (pointer p) { return type (p) == T_CLOSURE; } -INTERFACE INLINE int +INTERFACE int is_macro (pointer p) { return type (p) == T_MACRO; } -INTERFACE INLINE pointer +INTERFACE pointer closure_code (pointer p) { return car (p); } -INTERFACE INLINE pointer +INTERFACE pointer closure_env (pointer p) { return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_continuation (pointer p) { return type (p) == T_CONTINUATION; @@ -474,13 +467,13 @@ #define set_cont_dump(p,v) set_cdr ((p), (v)) /* To do: promise should be forced ONCE only */ -INTERFACE INLINE int +INTERFACE int is_promise (pointer p) { return type (p) == T_PROMISE; } -INTERFACE INLINE int +INTERFACE int is_environment (pointer p) { return type (p) == T_ENVIRONMENT; @@ -488,7 +481,6 @@ #define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) -#define is_atom1(p) (TYPESET_ATOM & (1U << type (p))) #define is_atom(p) (typeflag (p) & T_ATOM) #define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) #define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) @@ -497,24 +489,13 @@ #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) -#if 0 -static int -is_atom(pointer p) -{ - if (!is_atom1(p) != !is_atom2(p)) - printf ("atoms disagree %x\n", typeflag(p)); - - return is_atom2(p); -} -#endif - -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 @@ -522,32 +503,86 @@ #endif } +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +INTERFACE int +list_length (SCHEME_P_ pointer a) +{ + int i = 0; + pointer slow, fast; + + slow = fast = a; + + while (1) + { + if (fast == NIL) + return i; + + if (!is_pair (fast)) + return -2 - i; + + fast = cdr (fast); + ++i; + + if (fast == NIL) + return i; + + if (!is_pair (fast)) + return -2 - i; + + ++i; + fast = cdr (fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr (slow); + + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + +INTERFACE int +is_list (SCHEME_P_ pointer a) +{ + return list_length (SCHEME_A_ a) >= 0; +} + #if USE_CHAR_CLASSIFIERS -static INLINE int +ecb_inline int Cisalpha (int c) { return isascii (c) && isalpha (c); } -static INLINE int +ecb_inline int Cisdigit (int c) { return isascii (c) && isdigit (c); } -static INLINE int +ecb_inline int Cisspace (int c) { return isascii (c) && isspace (c); } -static INLINE int +ecb_inline int Cisupper (int c) { return isascii (c) && isupper (c); } -static INLINE int +ecb_inline int Cislower (int c) { return isascii (c) && islower (c); @@ -618,10 +653,9 @@ static int file_push (SCHEME_P_ const char *fname); static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); -static INLINE int is_one_of (char *s, int c); +ecb_inline int is_one_of (char *s, int c); static int alloc_cellseg (SCHEME_P_ int n); -static long binary_decode (const char *s); -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); @@ -648,7 +682,7 @@ static void backchar (SCHEME_P_ int c); static char *readstr_upto (SCHEME_P_ char *delim); static pointer readstrexp (SCHEME_P); -static INLINE int skipspace (SCHEME_P); +ecb_inline int skipspace (SCHEME_P); static int token (SCHEME_P); static void printslashstring (SCHEME_P_ char *s, int len); static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); @@ -662,88 +696,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; } @@ -755,8 +794,8 @@ long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - e1 = num_get_ivalue (a); - e2 = num_get_ivalue (b); + e1 = num_ivalue (a); + e2 = num_ivalue (b); res = e1 % e2; /* remainder should have same sign as second operand */ @@ -782,8 +821,8 @@ long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - e1 = num_get_ivalue (a); - e2 = num_get_ivalue (b); + e1 = num_ivalue (a); + e2 = num_ivalue (b); res = e1 % e2; /* modulo should have same sign as second operand */ @@ -794,59 +833,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 @@ -866,7 +875,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; @@ -877,26 +886,14 @@ static int is_zero_rvalue (RVALUE x) { -#if USE_FLOAT + 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 -} - -static long -binary_decode (const char *s) -{ - long x = 0; - - while (*s != 0 && (*s == '1' || *s == '0')) - { - x <<= 1; - x += *s - '0'; - s++; - } - - return x; +#endif } /* allocate new cell segment */ @@ -926,61 +923,31 @@ 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 (SCHEME_V->free_cell == NIL) + if (ecb_expect_false (SCHEME_V->free_cell == NIL)) { if (SCHEME_V->no_memory && USE_ERROR_CHECKING) return S_SINK; @@ -1059,13 +1026,13 @@ v->object.vector.vvalue = e; v->object.vector.length = len; - fill_vector (v, init); + fill_vector (v, 0, init); push_recent_alloc (SCHEME_A_ v, NIL); return v; } -static INLINE void +ecb_inline void ok_to_freely_gc (SCHEME_P) { set_car (S_SINK, NIL); @@ -1134,21 +1101,21 @@ set_typeflag (x, T_SYMBOL); setimmutable (car (x)); - location = hash_fn (name, vector_length (SCHEME_V->oblist)); - set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); + 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; pointer x; char *s; - location = hash_fn (name, vector_length (SCHEME_V->oblist)); + 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)); @@ -1167,8 +1134,8 @@ pointer x; pointer ob_list = NIL; - for (i = 0; i < vector_length (SCHEME_V->oblist); i++) - for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) + for (i = 0; i < veclength (SCHEME_V->oblist); i++) + for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) ob_list = cons (x, ob_list); return ob_list; @@ -1182,7 +1149,7 @@ return NIL; } -static INLINE pointer +ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; @@ -1251,41 +1218,48 @@ pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, (T_CHARACTER | T_ATOM)); - ivalue_unchecked (x) = c & 0xff; - set_num_integer (x); + set_ivalue (x, c & 0xff); + return x; } /* get number atom (integer) */ INTERFACE pointer -mk_integer (SCHEME_P_ long num) +mk_integer (SCHEME_P_ long n) { pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_NUMBER | T_ATOM)); - ivalue_unchecked (x) = num; - set_num_integer (x); + set_typeflag (x, (T_INTEGER | T_ATOM)); + set_ivalue (x, n); + return x; } INTERFACE pointer mk_real (SCHEME_P_ RVALUE n) { +#if USE_REAL pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_NUMBER | T_ATOM)); - rvalue_unchecked (x) = n; - set_num_real (x); + set_typeflag (x, (T_REAL | T_ATOM)); + set_rvalue (x, n); + return x; +#else + return mk_integer (SCHEME_A_ n); +#endif } static pointer mk_number (SCHEME_P_ const num n) { - if (num_is_fixnum (n)) - return mk_integer (SCHEME_A_ num_get_ivalue (n)); - else - return mk_real (SCHEME_A_ num_get_rvalue (n)); +#if USE_REAL + return num_is_fixnum (n) + ? mk_integer (SCHEME_A_ num_ivalue (n)) + : mk_real (SCHEME_A_ num_rvalue (n)); +#else + return mk_integer (SCHEME_A_ num_ivalue (n)); +#endif } /* allocate name to string area */ @@ -1319,11 +1293,15 @@ return q; } -/* get new string */ INTERFACE pointer -mk_string (SCHEME_P_ const char *str) +mk_empty_string (SCHEME_P_ uint32_t len, char fill) { - return mk_counted_string (SCHEME_A_ str, strlen (str)); + pointer x = get_cell (SCHEME_A_ NIL, NIL); + + set_typeflag (x, T_STRING | T_ATOM); + strvalue (x) = store_string (SCHEME_A_ len, 0, fill); + strlength (x) = len; + return x; } INTERFACE pointer @@ -1338,14 +1316,9 @@ } INTERFACE pointer -mk_empty_string (SCHEME_P_ uint32_t len, char fill) +mk_string (SCHEME_P_ const char *str) { - pointer x = get_cell (SCHEME_A_ NIL, NIL); - - set_typeflag (x, T_STRING | T_ATOM); - strvalue (x) = store_string (SCHEME_A_ len, 0, fill); - strlength (x) = len; - return x; + return mk_counted_string (SCHEME_A_ str, strlen (str)); } INTERFACE pointer @@ -1355,24 +1328,24 @@ } 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++) - vec->object.vector.vvalue[i] = obj; + for (i = start; i < veclength (vec); i++) + vecvalue (vec)[i] = obj; } INTERFACE pointer -vector_elem (pointer vec, uint32_t ielem) +vector_get (pointer vec, uint32_t ielem) { - return vec->object.vector.vvalue[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) { - vec->object.vector.vvalue[ielem] = a; + vecvalue(vec)[ielem] = a; } /* get new symbol */ @@ -1392,19 +1365,16 @@ gensym (SCHEME_P) { pointer x; - char name[40]; for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) { - strcpy (name, "gensym-"); + 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) - continue; - else + if (x == NIL) { x = oblist_add_by_name (SCHEME_A_ name); return x; @@ -1423,7 +1393,6 @@ int has_fp_exp = 0; #if USE_COLON_HOOK - if ((p = strstr (q, "::")) != 0) { *p = 0; @@ -1431,7 +1400,6 @@ cons (cons (SCHEME_V->QUOTE, cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); } - #endif p = q; @@ -1477,8 +1445,7 @@ { if (!has_fp_exp) { - has_dec_point = 1; /* decimal point illegal - from now on */ + has_dec_point = 1; /* decimal point illegal from now on */ p++; if ((*p == '-') || (*p == '+') || isdigit (*p)) @@ -1490,7 +1457,7 @@ } } -#if USE_FLOAT +#if USE_REAL if (has_dec_point) return mk_real (SCHEME_A_ atof (q)); #endif @@ -1502,36 +1469,13 @@ static pointer mk_sharp_const (SCHEME_P_ char *name) { - long x; - char tmp[STRBUFFSIZE]; - if (!strcmp (name, "t")) return S_T; else if (!strcmp (name, "f")) return S_F; - else if (*name == 'o') /* #o (octal) */ - { - x = strtol (name + 1, 0, 8); - return mk_integer (SCHEME_A_ x); - } - else if (*name == 'd') /* #d (decimal) */ - { - x = strtol (name + 1, 0, 10); - return mk_integer (SCHEME_A_ x); - } - else if (*name == 'x') /* #x (hex) */ - { - x = strtol (name + 1, 0, 16); - return mk_integer (SCHEME_A_ x); - } - else if (*name == 'b') /* #b (binary) */ - { - x = binary_decode (name + 1); - return mk_integer (SCHEME_A_ x); - } else if (*name == '\\') /* #\w (character) */ { - int c = 0; + int c; if (stricmp (name + 1, "space") == 0) c = ' '; @@ -1543,20 +1487,17 @@ c = '\t'; else if (name[1] == 'x' && name[2] != 0) { - int c1 = strtol (name + 2, 0, 16); + long c1 = strtol (name + 2, 0, 16); - if (c1 <= UCHAR_MAX) + if (0 <= c1 && c1 <= UCHAR_MAX) c = c1; else return NIL; - -#if USE_ASCII_NAMES } +#if USE_ASCII_NAMES else if (is_ascii_name (name + 1, &c)) - { - /* nothing */ + /* nothing */; #endif - } else if (name[2] == 0) c = name[1]; else @@ -1565,7 +1506,16 @@ return mk_character (SCHEME_A_ c); } else - return NIL; + { + /* identify base by string index */ + const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x"; + char *base = strchr (baseidx, *name); + + if (base) + return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx)); + + return NIL; + } } /* ========== garbage collector ========== */ @@ -1574,6 +1524,10 @@ * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, * for marking. + * + * The exception is vectors - vectors are currently marked recursively, + * which is inherited form tinyscheme and could be fixed by having another + * word of context in the vector */ static void mark (pointer a) @@ -1585,12 +1539,12 @@ E2: setmark (p); - if (is_vector (p)) + if (ecb_expect_false (is_vector (p))) { int i; - for (i = 0; i < p->object.vector.length; i++) - mark (p->object.vector.vvalue[i]); + for (i = 0; i < veclength (p); i++) + mark (vecvalue (p)[i]); } if (is_atom (p)) @@ -1697,10 +1651,10 @@ else { /* reclaim cell */ - if (typeflag (p) != T_FREE) + if (typeflag (p) != T_PAIR) { finalize_cell (SCHEME_A_ p); - set_typeflag (p, T_FREE); + set_typeflag (p, T_PAIR); set_car (p, NIL); } @@ -1712,16 +1666,19 @@ } 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)) free (strvalue (a)); else if (is_vector (a)) - free (a->object.vector.vvalue); + free (vecvalue (a)); #if USE_PORTS else if (is_port (a)) { @@ -2308,7 +2265,7 @@ } /* check c is in chars */ -static INLINE int +ecb_inline int is_one_of (char *s, int c) { if (c == EOF) @@ -2318,7 +2275,7 @@ } /* skip white characters */ -static INLINE int +ecb_inline int skipspace (SCHEME_P) { int c, curr_line = 0; @@ -2556,9 +2513,9 @@ 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_FLOAT +#if USE_REAL else { snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); @@ -2821,8 +2778,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; } @@ -2899,16 +2855,16 @@ setenvironment (SCHEME_V->envir); } -static INLINE void +ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { pointer slot = immutable_cons (variable, value); if (is_vector (car (env))) { - int location = hash_fn (symname (variable), vector_length (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))); + vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); } else set_car (env, immutable_cons (slot, car (env))); @@ -2924,8 +2880,8 @@ { if (is_vector (car (x))) { - location = hash_fn (symname (hdl), vector_length (car (x))); - y = vector_elem (car (x), location); + location = hash_fn (symname (hdl), veclength (car (x))); + y = vector_get (car (x), location); } else y = car (x); @@ -2935,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))); @@ -2988,19 +2941,19 @@ #endif /* USE_ALIST_ENV else */ -static INLINE void +ecb_inline void new_slot_in_env (SCHEME_P_ pointer variable, pointer value) { new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); } -static INLINE void +ecb_inline void set_slot_in_env (SCHEME_P_ pointer slot, pointer value) { set_cdr (slot, value); } -static INLINE pointer +ecb_inline pointer slot_value_in_env (pointer slot) { return cdr (slot); @@ -3008,7 +2961,7 @@ /* ========== Evaluation Cycle ========== */ -static pointer +static int xError_1 (SCHEME_P_ const char *s, pointer a) { #if USE_ERROR_HOOK @@ -3044,17 +2997,16 @@ if (x != NIL) { - if (a) - SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); - else - SCHEME_V->code = NIL; - - SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); - setimmutable (car (SCHEME_V->code)); - SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); + pointer code = a + ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) + : NIL; + + code = cons (mk_string (SCHEME_A_ s), code); + setimmutable (car (code)); + SCHEME_V->code = cons (slot_value_in_env (x), code); SCHEME_V->op = OP_EVAL; - return S_T; + return 0; } #endif @@ -3066,7 +3018,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) @@ -3077,7 +3030,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) @@ -3112,12 +3065,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; @@ -3126,7 +3079,7 @@ SCHEME_V->value = a; if (nframes <= 0) - return NIL; + return -1; frame = &SCHEME_V->dump_base[--nframes]; SCHEME_V->op = frame->op; @@ -3135,17 +3088,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; @@ -3208,10 +3161,10 @@ while (cont != NIL) { - frame->op = ivalue (car (cont)); cont = cdr (cont); - frame->args = car (cont) ; cont = cdr (cont); - frame->envir = car (cont) ; cont = cdr (cont); - frame->code = car (cont) ; cont = cdr (cont); + frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont); + frame->args = car (cont) ; cont = cdr (cont); + frame->envir = car (cont) ; cont = cdr (cont); + frame->code = car (cont) ; cont = cdr (cont); ++frame; ++i; @@ -3222,13 +3175,13 @@ #else -static INLINE void +ecb_inline void dump_stack_reset (SCHEME_P) { SCHEME_V->dump = NIL; } -static INLINE void +ecb_inline void dump_stack_initialize (SCHEME_P) { dump_stack_reset (SCHEME_A); @@ -3240,7 +3193,7 @@ SCHEME_V->dump = NIL; } -static pointer +static int xs_return (SCHEME_P_ pointer a) { pointer dump = SCHEME_V->dump; @@ -3248,16 +3201,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 @@ -3292,9 +3245,10 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) -static pointer +static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; pointer x, y; switch (op) @@ -3302,12 +3256,12 @@ 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); @@ -3352,7 +3306,7 @@ s_goto (OP_READ_INTERNAL); case OP_T1LVL: /* top level */ - SCHEME_V->code = SCHEME_V->value; + SCHEME_V->code = SCHEME_V->value; SCHEME_V->inport = SCHEME_V->save_inport; s_goto (OP_EVAL); @@ -3391,7 +3345,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); @@ -3412,7 +3366,9 @@ } else if (is_pair (SCHEME_V->code)) { - if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ + x = car (SCHEME_V->code); + + if (is_syntax (x)) /* SYNTAX */ { SCHEME_V->code = cdr (SCHEME_V->code); s_goto (syntaxnum (x)); @@ -3421,7 +3377,7 @@ { s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ - SCHEME_V->code = car (SCHEME_V->code); + SCHEME_V->code = x; s_goto (OP_EVAL); } } @@ -3443,20 +3399,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); } @@ -3466,7 +3422,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)); } @@ -3476,9 +3432,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); } @@ -3488,14 +3444,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); } @@ -3505,7 +3459,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"); @@ -3533,7 +3487,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"); @@ -3552,7 +3506,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); @@ -3573,15 +3527,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)); @@ -3623,10 +3577,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))) @@ -3667,9 +3621,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 */ @@ -3679,36 +3631,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); @@ -3716,22 +3668,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* */ @@ -3759,14 +3709,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); } @@ -3779,28 +3729,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); @@ -3896,10 +3846,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))) @@ -3942,10 +3892,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; @@ -3975,110 +3923,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->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL); + 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); - - x = car (SCHEME_V->args); + pointer y = cadr (args); - if (num_is_integer (x) && num_is_integer (y)) + if (is_integer (x) && is_integer (y)) real_result = 0; /* This 'if' is an R5RS compatibility fix. */ /* 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)); @@ -4086,9 +4007,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; } @@ -4098,31 +4019,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)))); @@ -4131,74 +4038,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"); } @@ -4206,86 +4111,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) { @@ -4296,7 +4201,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 @@ -4317,7 +4222,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); @@ -4325,13 +4230,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)) { @@ -4342,7 +4245,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; @@ -4357,55 +4260,42 @@ case OP_MKSTRING: /* make-string */ { - int fill = ' '; - int len; + int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' '; + int len = ivalue_unchecked (x); - len = ivalue (car (SCHEME_V->args)); - - 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)); + if (is_immutable (x)) + Error_1 ("string-set!: unable to alter immutable string:", x); - str = strvalue (car (SCHEME_V->args)); + if (index >= strlength (x)) + Error_1 ("string-set!: out of bounds:", cadr (args)); - index = ivalue (cadr (SCHEME_V->args)); + c = charvalue (caddr (args)); - if (index >= strlength (car (SCHEME_V->args))) - Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args)); - - c = charvalue (caddr (SCHEME_V->args)); - - str[index] = (char) c; - s_return (car (SCHEME_V->args)); + str[index] = c; + s_return (car (args)); } case OP_STRAPPEND: /* string-append */ @@ -4416,13 +4306,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); @@ -4430,27 +4320,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)); - - index0 = ivalue (cadr (SCHEME_V->args)); + if (index0 > strlength (x)) + Error_1 ("substring: start out of bounds:", cadr (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, ' '); @@ -4464,10 +4350,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); @@ -4476,8 +4362,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); } @@ -4485,13 +4371,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); @@ -4501,250 +4385,140 @@ #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_ vector_length (car (SCHEME_V->args)))); + s_return (mk_integer (SCHEME_A_ veclength (x))); case OP_VECREF: /* vector-ref */ { - int index; - - index = ivalue (cadr (SCHEME_V->args)); + int index = ivalue_unchecked (cadr (args)); - if (index >= vector_length (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 >= vector_length (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; + num v = nvalue (car (x)); + x = cdr (x); - if (fast == NIL) - return i; - - 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_NUMBERP: /* number? */ - s_retbool (is_number (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_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)) { @@ -4775,7 +4549,7 @@ } } - SCHEME_V->args = car (SCHEME_V->args); + SCHEME_V->args = a; if (op == OP_WRITE) SCHEME_V->print_flag = 1; @@ -4785,13 +4559,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; } } @@ -4802,24 +4576,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); } @@ -4830,18 +4604,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); @@ -4862,27 +4636,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; @@ -4894,10 +4668,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); @@ -4907,15 +4681,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); @@ -4952,12 +4726,9 @@ break; } - p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop); + p = port_from_filename (SCHEME_A_ strvalue (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } # if USE_STRING_PORTS @@ -4979,43 +4750,30 @@ break; } - p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), - strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop); - - if (p == NIL) - s_return (S_F); + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), prop); - 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); - - if (p == NIL) - s_return (S_F); - } + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), port_output); - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_GET_OUTSTRING: /* get-output-string */ { 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; @@ -5041,11 +4799,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 @@ -5057,12 +4815,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) @@ -5079,17 +4838,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); @@ -5099,14 +4858,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); } } @@ -5126,8 +4885,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; @@ -5135,11 +4894,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 @@ -5235,7 +4994,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) @@ -5273,7 +5032,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))); @@ -5305,63 +5064,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_ " . "); @@ -5369,10 +5121,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_ ")"); @@ -5381,9 +5133,9 @@ case OP_PVECFROM: { - int i = ivalue_unchecked (cdr (SCHEME_V->args)); - pointer vec = car (SCHEME_V->args); - int len = vector_length (vec); + int i = ivalue_unchecked (cdr (args)); + pointer vec = car (args); + int len = veclength (vec); if (i == len) { @@ -5392,10 +5144,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) @@ -5406,30 +5158,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"); @@ -5445,7 +5199,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); @@ -5461,28 +5215,35 @@ * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t */ - 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 is_integer (p) && ivalue_unchecked (p) >= 0; +} + +static int +tst_is_list (SCHEME_P_ pointer p) { - return ivalue (p) >= 0 && is_integer (p); + return p == NIL || is_pair (p); } /* Correspond carefully with following defines! */ @@ -5490,105 +5251,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 (n < pcd->min_arity) + 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; } - - if (ok && 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 (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; @@ -5599,20 +5378,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); @@ -5622,34 +5402,35 @@ 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 (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 USE_ERROR_CHECKING - if (SCHEME_V->no_memory) + if (SCHEME_V->no_memory && USE_ERROR_CHECKING) { xwrstr ("No memory!\n"); return; } -#endif } } @@ -5676,7 +5457,6 @@ pointer y = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (y, (T_PROC | T_ATOM)); ivalue_unchecked (y) = op; - set_num_integer (y); return y; } @@ -5710,7 +5490,7 @@ return OP_COND0; /* cond */ case '*': - return OP_LET0AST; /* let* */ + return OP_LET0AST;/* let* */ default: return OP_SET0; /* set! */ @@ -5742,7 +5522,7 @@ return OP_DEF0; /* define */ default: - return OP_LET0REC; /* letrec */ + return OP_LET0REC;/* letrec */ } default: @@ -5751,7 +5531,7 @@ } #if USE_MULTIPLICITY -scheme * +ecb_cold scheme * scheme_init_new () { scheme *sc = malloc (sizeof (scheme)); @@ -5766,7 +5546,7 @@ } #endif -int +ecb_cold int scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); @@ -5819,9 +5599,14 @@ set_typeflag (S_F, T_ATOM | T_MARK); set_car (S_F, S_F); set_cdr (S_F, S_F); + /* init EOF_OBJ */ + set_typeflag (S_EOF, T_ATOM | T_MARK); + set_car (S_EOF, S_EOF); + set_cdr (S_EOF, S_EOF); /* init sink */ set_typeflag (S_SINK, T_PAIR | T_MARK); set_car (S_SINK, NIL); + /* init c_nest */ SCHEME_V->c_nest = NIL; @@ -5844,20 +5629,21 @@ 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"); - SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); - SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); - SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); - SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); - SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); - SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); - SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); - SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); + SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); + SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); + SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); + SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); + SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); + SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); + SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); + SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); + SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); return !SCHEME_V->no_memory; @@ -5895,7 +5681,7 @@ SCHEME_V->ext_data = p; } -void +ecb_cold void scheme_deinit (SCHEME_P) { int i; @@ -5997,9 +5783,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 @@ -6114,26 +5900,9 @@ #if STANDALONE -# if defined(__APPLE__) && !defined (OSX) -int -main () -{ - extern MacTS_main (int argc, char **argv); - char **argv; - int argc = ccommand (&argv); - - MacTS_main (argc, argv); - return 0; -} - -int -MacTS_main (int argc, char **argv) -{ -# else int main (int argc, char **argv) { -# endif # if USE_MULTIPLICITY scheme ssc; scheme *const SCHEME_V = &ssc;