--- microscheme/scheme.c 2015/11/26 21:32:16 1.18 +++ microscheme/scheme.c 2015/12/01 01:56:22 1.52 @@ -18,8 +18,12 @@ * */ +#define EXPERIMENT 1 + +#if 1 #define PAGE_SIZE 4096 /* does not work on sparc/alpha */ #include "malloc.c" +#endif #define SCHEME_SOURCE #include "scheme-private.h" @@ -30,24 +34,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,23 +80,14 @@ }; #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? -#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? -#define S_SINK (&SCHEME_V->xsink) -#define S_EOF (&SCHEME_V->xEOF_OBJ) - -/* should use libecb */ -#if __GNUC__ >= 4 -# define ecb_expect(expr,value) __builtin_expect ((expr),(value)) -# define ecb_expect_false(expr) ecb_expect (!!(expr), 0) -# define ecb_expect_true(expr) ecb_expect (!!(expr), 1) -#else -# define ecb_expect_false(expr) !!(expr) -# define ecb_expect_true(expr) !!(expr) -#endif +#define NIL POINTER (&SCHEME_V->xNIL) +#define S_T POINTER (&SCHEME_V->xT) +#define S_F POINTER (&SCHEME_V->xF) +#define S_SINK POINTER (&SCHEME_V->xsink) +#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ) #if !USE_MULTIPLICITY static scheme sc; @@ -155,9 +167,9 @@ #define tolower(c) xtolower (c) #define isdigit(c) xisdigit (c) -#if USE_STRLWR +#if USE_IGNORECASE static const char * -strlwr (char *s) +xstrlwr (char *s) { const char *p = s; @@ -169,10 +181,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> " @@ -182,18 +198,14 @@ # define InitFile "init.scm" #endif -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - enum scheme_types { - T_FREE, + T_INTEGER, + T_REAL, T_STRING, - T_NUMBER, T_SYMBOL, T_PROC, - T_PAIR, + T_PAIR, /* also used for free cells */ T_CLOSURE, T_CONTINUATION, T_FOREIGN, @@ -213,6 +225,32 @@ #define T_ATOM 0x0040 /* only for gc */ #define T_MARK 0x0080 /* only for gc */ +/* num, for generic arithmetic */ +struct num +{ + IVALUE ivalue; +#if USE_REAL + RVALUE rvalue; + char is_fixnum; +#endif +}; + +#if USE_REAL +# define num_is_fixnum(n) (n).is_fixnum +# define num_set_fixnum(n,f) (n).is_fixnum = (f) +# define num_ivalue(n) (n).ivalue +# define num_rvalue(n) (n).rvalue +# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i) +# define num_set_rvalue(n,r) (n).rvalue = (r) +#else +# define num_is_fixnum(n) 1 +# define num_set_fixnum(n,f) 0 +# define num_ivalue(n) (n).ivalue +# define num_rvalue(n) (n).ivalue +# define num_set_ivalue(n,i) (n).ivalue = (i) +# define num_set_rvalue(n,r) (n).ivalue = (r) +#endif + enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV }; static num num_op (enum num_op op, num a, num b); @@ -225,157 +263,115 @@ #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; +/* convert "pointer" to cell* / cell* to pointer */ +#define CELL(p) ((struct cell *)(p) + 0) +#define POINTER(c) ((void *)((c) - 0)) + /* macros for cell operations */ -#define typeflag(p) ((p)->flag + 0) -#define set_typeflag(p,v) ((p)->flag = (v)) +#define typeflag(p) (CELL(p)->flag + 0) +#define set_typeflag(p,v) (CELL(p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) -INTERFACE INLINE int +INTERFACE int is_string (pointer p) { return type (p) == T_STRING; } -#define strvalue(p) ((p)->object.string.svalue) -#define strlength(p) ((p)->object.string.length) +#define strvalue(p) (CELL(p)->object.string.svalue) +#define strlength(p) (CELL(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; } -#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); +#define vecvalue(p) (CELL(p)->object.vector.vvalue) +#define veclength(p) (CELL(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 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); -} +#define ivalue_unchecked(p) CELL(p)->object.ivalue +#define set_ivalue(p,v) CELL(p)->object.ivalue = (v) -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.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) CELL(p)->object.rvalue +#define set_rvalue(p,v) CELL(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) CELL(p)->object.ivalue +#define set_rvalue(p,v) CELL(p)->object.ivalue = (v) #endif + INTERFACE long charvalue (pointer p) { return ivalue_unchecked (p); } -INTERFACE INLINE int +#define port(p) CELL(p)->object.port +#define set_port(p,v) port(p) = (v) +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; + return is_port (p) && port (p)->kind & port_input; } -INTERFACE INLINE int +INTERFACE int is_outport (pointer p) { - return is_port (p) && p->object.port->kind & port_output; + return is_port (p) && port (p)->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 + 0) +#define car(p) (POINTER (CELL(p)->object.cons.car)) +#define cdr(p) (POINTER (CELL(p)->object.cons.cdr)) static pointer caar (pointer p) { return car (car (p)); } static pointer cadr (pointer p) { return car (cdr (p)); } @@ -389,13 +385,13 @@ INTERFACE void set_car (pointer p, pointer q) { - p->object.cons.car = q; + CELL(p)->object.cons.car = CELL (q); } INTERFACE void set_cdr (pointer p, pointer q) { - p->object.cons.cdr = q; + CELL(p)->object.cons.cdr = CELL (q); } INTERFACE pointer @@ -410,80 +406,80 @@ 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 +#error plists are broken because symbols are no longer pairs +#define symprop(p) cdr(p) +SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; } - -# 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; @@ -493,13 +489,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; @@ -515,13 +511,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 @@ -529,32 +525,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); @@ -625,9 +675,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); -static int alloc_cellseg (SCHEME_P_ int n); -static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); +ecb_inline int is_one_of (const char *s, int c); +static int alloc_cellseg (SCHEME_P); +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); @@ -652,9 +702,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); @@ -668,18 +718,45 @@ 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_r (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 IVALUE +ivalue (pointer x) +{ + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); +} + +static RVALUE +rvalue (pointer x) +{ + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); +} + +INTERFACE num +nvalue (pointer x) +{ + num n; + + num_set_fixnum (n, is_integer (x)); + + if (num_is_fixnum (n)) + num_set_ivalue (n, ivalue_unchecked (x)); + else + num_set_rvalue (n, rvalue_unchecked (x)); + + return n; +} + static num num_op (enum num_op op, num a, num b) { @@ -689,34 +766,30 @@ if (num_is_fixnum (ret)) { - IVALUE av = num_get_ivalue (a); - IVALUE bv = num_get_ivalue (b); - switch (op) { - case NUM_ADD: av += bv; break; - case NUM_SUB: av -= bv; break; - case NUM_MUL: av *= bv; break; - case NUM_INTDIV: av /= bv; break; + case NUM_ADD: a.ivalue += b.ivalue; break; + case NUM_SUB: a.ivalue -= b.ivalue; break; + case NUM_MUL: a.ivalue *= b.ivalue; break; + case NUM_INTDIV: a.ivalue /= b.ivalue; break; } - num_set_ivalue (ret, av); + num_set_ivalue (ret, a.ivalue); } +#if USE_REAL else { - RVALUE av = num_get_rvalue (a); - RVALUE bv = num_get_rvalue (b); - switch (op) { - case NUM_ADD: av += bv; break; - case NUM_SUB: av -= bv; break; - case NUM_MUL: av *= bv; break; - case NUM_INTDIV: av /= bv; break; + case NUM_ADD: a.rvalue += b.rvalue; break; + case NUM_SUB: a.rvalue -= b.rvalue; break; + case NUM_MUL: a.rvalue *= b.rvalue; break; + case NUM_INTDIV: a.rvalue /= b.rvalue; break; } - num_set_rvalue (ret, av); + num_set_rvalue (ret, a.rvalue); } +#endif return ret; } @@ -726,12 +799,12 @@ { num ret; - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0); + num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0); if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); + num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b)); else - num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); + num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b)); return ret; } @@ -743,8 +816,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 */ @@ -770,8 +843,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 */ @@ -782,7 +855,7 @@ return ret; } -/* this completely disrespects NaNs */ +/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */ static int num_cmp (num a, num b) { @@ -791,15 +864,15 @@ if (is_fixnum) { - IVALUE av = num_get_ivalue (a); - IVALUE bv = num_get_ivalue (b); + IVALUE av = num_ivalue (a); + IVALUE bv = num_ivalue (b); ret = av == bv ? 0 : av < bv ? -1 : +1; } else { - RVALUE av = num_get_rvalue (a); - RVALUE bv = num_get_rvalue (b); + RVALUE av = num_rvalue (a); + RVALUE bv = num_rvalue (b); ret = av == bv ? 0 : av < bv ? -1 : +1; } @@ -835,20 +908,23 @@ 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 */ static int -alloc_cellseg (SCHEME_P_ int n) +alloc_cellseg (SCHEME_P) { - pointer newp; - pointer last; - pointer p; + struct cell *newp; + struct cell *last; + struct cell *p; char *cp; long i; int k; @@ -856,71 +932,36 @@ static int segsize = CELL_SEGSIZE >> 1; segsize <<= 1; - for (k = 0; k < n; k++) - { - if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1) - return k; + cp = malloc (segsize * sizeof (struct cell)); - cp = malloc (segsize * sizeof (struct cell)); + if (!cp && USE_ERROR_CHECKING) + return k; - if (!cp && USE_ERROR_CHECKING) - return k; + i = ++SCHEME_V->last_cell_seg; + SCHEME_V->alloc_seg[i] = cp; - i = ++SCHEME_V->last_cell_seg; - SCHEME_V->alloc_seg[i] = cp; + newp = (struct cell *)cp; + SCHEME_V->cell_seg[i] = newp; + SCHEME_V->cell_segsize[i] = segsize; + SCHEME_V->fcells += segsize; + last = newp + segsize - 1; - /* 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_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); - } + for (p = newp; p <= last; p++) + { + pointer cp = POINTER (p); + set_typeflag (cp, T_PAIR); + set_car (cp, NIL); + set_cdr (cp, POINTER (p + 1)); } - return n; + set_cdr (POINTER (last), SCHEME_V->free_cell); + SCHEME_V->free_cell = POINTER (newp); + + return 1; } /* 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)) @@ -930,14 +971,14 @@ if (SCHEME_V->free_cell == NIL) { - const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; + const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; gc (SCHEME_A_ a, b); if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) { /* if only a few recovered, get more to avoid fruitless gc's */ - if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) + if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL) { #if USE_ERROR_CHECKING SCHEME_V->no_memory = 1; @@ -959,7 +1000,6 @@ /* To retain recent allocs before interpreter knows about them - Tehom */ - static void push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) { @@ -991,7 +1031,7 @@ static pointer get_vector_object (SCHEME_P_ uint32_t len, pointer init) { - pointer v = get_cell_x (SCHEME_A_ 0, 0); + pointer v = get_cell_x (SCHEME_A_ NIL, NIL); pointer *e = malloc (len * sizeof (pointer)); if (!e && USE_ERROR_CHECKING) @@ -1000,15 +1040,15 @@ /* Record it as a vector so that gc understands it. */ set_typeflag (v, T_VECTOR | T_ATOM); - v->object.vector.vvalue = e; - v->object.vector.length = len; - fill_vector (v, init); + CELL(v)->object.vector.vvalue = e; + CELL(v)->object.vector.length = len; + 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); @@ -1055,11 +1095,30 @@ return x; } +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; +} + /* ========== oblist implementation ========== */ #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) @@ -1071,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; @@ -1091,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)); @@ -1111,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; @@ -1125,7 +1179,7 @@ return NIL; } -static INLINE pointer +ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; @@ -1147,11 +1201,7 @@ static pointer oblist_add_by_name (SCHEME_P_ const char *name) { - pointer x; - - x = immutable_cons (mk_string (SCHEME_A_ name), NIL); - set_typeflag (x, T_SYMBOL); - setimmutable (car (x)); + pointer x = generate_symbol (SCHEME_A_ name); SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); return x; } @@ -1171,7 +1221,7 @@ pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_PORT | T_ATOM); - x->object.port = p; + set_port (x, p); return x; } @@ -1182,8 +1232,8 @@ { pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_FOREIGN | T_ATOM)); - x->object.ff = f; + set_typeflag (x, T_FOREIGN | T_ATOM); + CELL(x)->object.ff = f; return x; } @@ -1193,42 +1243,63 @@ { 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_typeflag (x, T_CHARACTER | T_ATOM); + 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); + pointer p = 0; + pointer *pp = &p; - set_typeflag (x, (T_NUMBER | T_ATOM)); - ivalue_unchecked (x) = num; - set_num_integer (x); - return x; +#if USE_INTCACHE + if (n >= INTCACHE_MIN && n <= INTCACHE_MAX) + pp = &SCHEME_V->intcache[n - INTCACHE_MIN]; +#endif + + if (!*pp) + { + pointer x = get_cell (SCHEME_A_ NIL, NIL); + + set_typeflag (x, T_INTEGER | T_ATOM); + setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */ + set_ivalue (x, n); + + *pp = x; + } + + return *pp; } 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 */ @@ -1244,20 +1315,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; } @@ -1281,6 +1343,7 @@ set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, str, 0); strlength (x) = len; + return x; } @@ -1297,22 +1360,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; } @@ -1334,23 +1406,16 @@ 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 generate_symbol (SCHEME_A_ name); +} - return NIL; +static int +is_gensym (SCHEME_P_ pointer x) +{ + return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; } /* make symbol or number atom from string */ @@ -1414,8 +1479,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)) @@ -1513,7 +1577,7 @@ { int i; - for (i = 0; i < p->object.vector.length; i++) + for (i = 0; i < veclength (p); i++) mark (vecvalue (p)[i]); } @@ -1570,7 +1634,6 @@ static void gc (SCHEME_P_ pointer a, pointer b) { - pointer p; int i; if (SCHEME_V->gc_verbose) @@ -1596,6 +1659,13 @@ /* Mark any older stuff above nested C calls */ mark (SCHEME_V->c_nest); +#if USE_INTCACHE + /* mark intcache */ + for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i) + if (SCHEME_V->intcache[i - INTCACHE_MIN]) + mark (SCHEME_V->intcache[i - INTCACHE_MIN]); +#endif + /* mark variables a, b */ mark (a); mark (b); @@ -1605,55 +1675,62 @@ SCHEME_V->fcells = 0; SCHEME_V->free_cell = NIL; - /* free-list is kept sorted by address so as to maintain consecutive - ranges, if possible, for use with vectors. Here we scan the cells - (which are also kept sorted by address) downwards to build the - free-list in sorted order. - */ + if (SCHEME_V->gc_verbose) + xwrstr ("freeing..."); + + uint32_t total = 0; + + /* Here we scan the cells to build the free-list. */ for (i = SCHEME_V->last_cell_seg; i >= 0; i--) { - p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; + struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; + struct cell *p; + total += SCHEME_V->cell_segsize [i]; - while (--p >= SCHEME_V->cell_seg[i]) + for (p = SCHEME_V->cell_seg[i]; p < end; ++p) { - if (is_mark (p)) - clrmark (p); + pointer c = POINTER (p); + + if (is_mark (c)) + clrmark (c); else { /* reclaim cell */ - if (typeflag (p) != T_FREE) + if (typeflag (c) != T_PAIR) { - finalize_cell (SCHEME_A_ p); - set_typeflag (p, T_FREE); - set_car (p, NIL); + finalize_cell (SCHEME_A_ c); + set_typeflag (c, T_PAIR); + set_car (c, NIL); } ++SCHEME_V->fcells; - set_cdr (p, SCHEME_V->free_cell); - SCHEME_V->free_cell = p; + set_cdr (c, SCHEME_V->free_cell); + SCHEME_V->free_cell = c; } } } if (SCHEME_V->gc_verbose) - xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); + { + xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); 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)); #if USE_PORTS else if (is_port (a)) { - if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) + if (port(a)->kind & port_file && port (a)->rep.stdio.closeit) port_close (SCHEME_A_ a, port_input | port_output); - free (a->object.port); + free (port (a)); } #endif } @@ -1679,7 +1756,7 @@ SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; - SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; + set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); #if SHOW_ERROR_LINE SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; @@ -1706,7 +1783,7 @@ port_close (SCHEME_A_ SCHEME_V->loadport, port_input); #endif SCHEME_V->file_i--; - SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; + set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); } } @@ -1716,7 +1793,7 @@ #if USE_PORTS return SCHEME_V->file_i == 0 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO - && (SCHEME_V->inport->object.port->kind & port_file); + && (port (SCHEME_V->inport)->kind & port_file); #else return 0; #endif @@ -1860,7 +1937,7 @@ static void port_close (SCHEME_P_ pointer p, int flag) { - port *pt = p->object.port; + port *pt = port (p); pt->kind &= ~flag; @@ -1891,9 +1968,7 @@ inchar (SCHEME_P) { int c; - port *pt; - - pt = SCHEME_V->inport->object.port; + port *pt = port (SCHEME_V->inport); if (pt->kind & port_saw_EOF) return EOF; @@ -1970,7 +2045,7 @@ if (c == EOF) return; - pt = SCHEME_V->inport->object.port; + pt = port (SCHEME_V->inport); pt->unget = c; #else if (c == EOF) @@ -2008,7 +2083,7 @@ putstr (SCHEME_P_ const char *s) { #if USE_PORTS - port *pt = SCHEME_V->outport->object.port; + port *pt = port (SCHEME_V->outport); if (pt->kind & port_file) write (pt->rep.stdio.file, s, strlen (s)); @@ -2028,7 +2103,7 @@ putchars (SCHEME_P_ const char *s, int len) { #if USE_PORTS - port *pt = SCHEME_V->outport->object.port; + port *pt = port (SCHEME_V->outport); if (pt->kind & port_file) write (pt->rep.stdio.file, s, len); @@ -2052,7 +2127,7 @@ putcharacter (SCHEME_P_ int c) { #if USE_PORTS - port *pt = SCHEME_V->outport->object.port; + port *pt = port (SCHEME_V->outport); if (pt->kind & port_file) { @@ -2075,9 +2150,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)))); @@ -2094,13 +2169,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 (;;) { @@ -2112,20 +2186,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; @@ -2165,11 +2232,6 @@ state = st_ok; break; - case '"': - *p++ = '"'; - state = st_ok; - break; - default: *p++ = c; state = st_ok; @@ -2180,26 +2242,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: @@ -2212,7 +2271,7 @@ } else { - if (state == st_oct2 && c1 >= 32) + if (state == st_oct2 && c1 >= ' ') return S_F; c1 = (c1 << 3) + (c - '0'); @@ -2227,23 +2286,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; @@ -2251,12 +2306,16 @@ do { c = inchar (SCHEME_A); + #if SHOW_ERROR_LINE - if (c == '\n') + if (ecb_expect_false (c == '\n')) curr_line++; #endif + + if (ecb_expect_false (c == EOF)) + return c; } - while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); + while (is_one_of (WHITESPACE, c)); /* record it */ #if SHOW_ERROR_LINE @@ -2264,13 +2323,8 @@ SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; #endif - if (c != EOF) - { - backchar (SCHEME_A_ c); - return 1; - } - else - return EOF; + backchar (SCHEME_A_ c); + return 1; } /* get token */ @@ -2296,16 +2350,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; @@ -2446,7 +2501,6 @@ putcharacter (SCHEME_A_ '"'); } - /* print atoms */ static void printatom (SCHEME_P_ pointer l, int f) @@ -2458,7 +2512,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) @@ -2481,7 +2534,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 @@ -2628,7 +2681,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); @@ -2746,8 +2806,7 @@ else if (is_number (a)) { if (is_number (b)) - if (num_is_integer (a) == num_is_integer (b)) - return num_cmp (nvalue (a), nvalue (b)) == 0; + return num_cmp (nvalue (a), nvalue (b)) == 0; return 0; } @@ -2784,21 +2843,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 /* @@ -2824,16 +2868,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))); @@ -2843,14 +2901,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); @@ -2860,28 +2917,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))); @@ -2899,33 +2953,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); @@ -2933,7 +2986,7 @@ /* ========== Evaluation Cycle ========== */ -static pointer +static int xError_1 (SCHEME_P_ const char *s, pointer a) { #if USE_ERROR_HOOK @@ -2978,7 +3031,7 @@ SCHEME_V->code = cons (slot_value_in_env (x), code); SCHEME_V->op = OP_EVAL; - return S_T; + return 0; } #endif @@ -2990,7 +3043,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) @@ -3001,7 +3055,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) @@ -3025,7 +3079,7 @@ struct dump_stack_frame *next_frame; /* enough room for the next frame? */ - if (nframes >= SCHEME_V->dump_size) + if (ecb_expect_false (nframes >= SCHEME_V->dump_size)) { SCHEME_V->dump_size += STACK_GROWTH; SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); @@ -3041,7 +3095,7 @@ 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; @@ -3050,7 +3104,7 @@ SCHEME_V->value = a; if (nframes <= 0) - return NIL; + return -1; frame = &SCHEME_V->dump_base[--nframes]; SCHEME_V->op = frame->op; @@ -3059,17 +3113,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; @@ -3132,10 +3186,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; @@ -3146,13 +3200,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); @@ -3164,7 +3218,7 @@ SCHEME_V->dump = NIL; } -static pointer +static int xs_return (SCHEME_P_ pointer a) { pointer dump = SCHEME_V->dump; @@ -3172,16 +3226,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 @@ -3216,7 +3270,65 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) -static pointer +#if EXPERIMENT +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; @@ -3224,11 +3336,17 @@ switch (op) { +#if EXPERIMENT //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 (args))); xwrstr ("\n"); - //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); + //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); } if (!file_push (SCHEME_A_ strvalue (car (args)))) @@ -3242,7 +3360,7 @@ case OP_T0LVL: /* top level */ /* If we reached the end of file, this loop is done. */ - if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) + if (port (SCHEME_V->loadport)->kind & port_saw_EOF) { if (SCHEME_V->file_i == 0) { @@ -3330,10 +3448,10 @@ { x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); - if (x != NIL) - s_return (slot_value_in_env (x)); - else + if (x == NIL) Error_1 ("eval: unbound variable:", SCHEME_V->code); + + s_return (slot_value_in_env (x)); } else if (is_pair (SCHEME_V->code)) { @@ -3356,7 +3474,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); @@ -3393,7 +3511,7 @@ { int tr = SCHEME_V->tracing; - SCHEME_V->tracing = ivalue (car (args)); + SCHEME_V->tracing = ivalue_unchecked (car (args)); s_return (mk_integer (SCHEME_A_ tr)); } @@ -3420,7 +3538,7 @@ { /* Keep nested calls from GC'ing the arglist */ push_recent_alloc (SCHEME_A_ args, NIL); - x = SCHEME_V->code->object.ff (SCHEME_A_ args); + x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args); s_return (x); } @@ -3467,8 +3585,6 @@ SCHEME_V->code = SCHEME_V->value; s_goto (OP_EVAL); -#if 1 - case OP_LAMBDA: /* lambda */ /* If the hook is defined, apply it to SCHEME_V->code, otherwise set SCHEME_V->value fall thru */ @@ -3484,19 +3600,12 @@ } SCHEME_V->value = SCHEME_V->code; - /* Fallthru */ } + /* Fallthru */ case OP_LAMBDA1: s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); -#else - - case OP_LAMBDA: /* lambda */ - s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir)); - -#endif - case OP_MKCLOSURE: /* make-closure */ x = car (args); @@ -3912,30 +4021,31 @@ s_goto (OP_APPLY); } - abort (); + 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 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 */ - if (num_is_integer (x)) - s_return (x); - else if (modf (rvalue_unchecked (x), &dd) == 0) - s_return (mk_integer (SCHEME_A_ ivalue (x))); - else - Error_1 ("inexact->exact: not integral:", x); + { + if (is_integer (x)) + s_return (x); + + RVALUE r = rvalue_unchecked (x); + + if (r == (RVALUE)(IVALUE)r) + s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); + else + Error_1 ("inexact->exact: not integral:", x); + } case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); @@ -3963,7 +4073,7 @@ int real_result = 1; pointer y = cadr (args); - if (num_is_integer (x) && num_is_integer (y)) + if (is_integer (x) && is_integer (y)) real_result = 0; /* This 'if' is an R5RS compatibility fix. */ @@ -3979,7 +4089,7 @@ { long result_as_long = result; - if (result != (RVALUE) result_as_long) + if (result != result_as_long) real_result = 1; } @@ -3994,18 +4104,12 @@ case OP_TRUNCATE: { - RVALUE rvalue_of_x; - - rvalue_of_x = rvalue (x); - - if (rvalue_of_x > 0) - s_return (mk_real (SCHEME_A_ floor (rvalue_of_x))); - else - s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x))); + RVALUE n = rvalue (x); + s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n))); } case OP_ROUND: - if (num_is_integer (x)) + if (is_integer (x)) s_return (x); s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); @@ -4015,7 +4119,7 @@ v = num_zero; for (x = args; x != NIL; x = cdr (x)) - v = num_op ('+', v, nvalue (car (x))); + v = num_op (NUM_ADD, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4023,7 +4127,7 @@ v = num_one; for (x = args; x != NIL; x = cdr (x)) - v = num_op ('+', v, nvalue (car (x))); + v = num_op (NUM_MUL, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4040,7 +4144,7 @@ } for (; x != NIL; x = cdr (x)) - v = num_op ('+', v, nvalue (car (x))); + v = num_op (NUM_SUB, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); @@ -4057,12 +4161,10 @@ } for (; x != NIL; x = cdr (x)) - { - if (!is_zero_rvalue (rvalue (car (x)))) - v = num_div (v, nvalue (car (x))); - else - Error_0 ("/: division by zero"); - } + if (!is_zero_rvalue (rvalue (car (x)))) + v = num_div (v, nvalue (car (x))); + else + Error_0 ("/: division by zero"); s_return (mk_number (SCHEME_A_ v)); @@ -4081,7 +4183,7 @@ for (; x != NIL; x = cdr (x)) { if (ivalue (car (x)) != 0) - v = num_op ('/', v, nvalue (car (x))); + v = num_op (NUM_INTDIV, v, nvalue (car (x))); else Error_0 ("quotient: division by zero"); } @@ -4108,11 +4210,37 @@ s_return (mk_number (SCHEME_A_ v)); - case OP_CAR: /* car */ - s_return (caar (args)); - - case OP_CDR: /* cdr */ - s_return (cdar (args)); + /* the compiler will optimize this mess... */ + case OP_CAR: op_car: s_return (car (x)); + case OP_CDR: op_cdr: s_return (cdr (x)); + case OP_CAAR: op_caar: x = car (x); goto op_car; + case OP_CADR: op_cadr: x = cdr (x); goto op_car; + case OP_CDAR: op_cdar: x = car (x); goto op_cdr; + case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr; + case OP_CAAAR: op_caaar: x = car (x); goto op_caar; + case OP_CAADR: op_caadr: x = cdr (x); goto op_caar; + case OP_CADAR: op_cadar: x = car (x); goto op_cadr; + case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr; + case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar; + case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar; + case OP_CDDAR: op_cddar: x = car (x); goto op_cddr; + case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr; + case OP_CAAAAR: x = car (x); goto op_caaar; + case OP_CAAADR: x = cdr (x); goto op_caaar; + case OP_CAADAR: x = car (x); goto op_caadr; + case OP_CAADDR: x = cdr (x); goto op_caadr; + case OP_CADAAR: x = car (x); goto op_cadar; + case OP_CADADR: x = cdr (x); goto op_cadar; + case OP_CADDAR: x = car (x); goto op_caddr; + case OP_CADDDR: x = cdr (x); goto op_caddr; + case OP_CDAAAR: x = car (x); goto op_cdaar; + case OP_CDAADR: x = cdr (x); goto op_cdaar; + case OP_CDADAR: x = car (x); goto op_cdadr; + case OP_CDADDR: x = cdr (x); goto op_cdadr; + case OP_CDDAAR: x = car (x); goto op_cddar; + case OP_CDDADR: x = cdr (x); goto op_cddar; + case OP_CDDDAR: x = car (x); goto op_cdddr; + case OP_CDDDDR: x = cdr (x); goto op_cdddr; case OP_CONS: /* cons */ set_cdr (args, cadr (args)); @@ -4137,21 +4265,21 @@ Error_0 ("set-cdr!: unable to alter immutable pair"); case OP_CHAR2INT: /* char->integer */ - s_return (mk_integer (SCHEME_A_ ivalue (x))); + s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x))); case OP_INT2CHAR: /* integer->char */ - s_return (mk_character (SCHEME_A_ ivalue (x))); + s_return (mk_character (SCHEME_A_ ivalue_unchecked (x))); case OP_CHARUPCASE: { - unsigned char c = ivalue (x); + unsigned char c = ivalue_unchecked (x); c = toupper (c); s_return (mk_character (SCHEME_A_ c)); } case OP_CHARDNCASE: { - unsigned char c = ivalue (x); + unsigned char c = ivalue_unchecked (x); c = tolower (c); s_return (mk_character (SCHEME_A_ c)); } @@ -4238,13 +4366,8 @@ case OP_MKSTRING: /* make-string */ { - int fill = ' '; - int len; - - len = ivalue (x); - - if (cdr (args) != NIL) - fill = charvalue (cadr (args)); + int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' '; + int len = ivalue_unchecked (x); s_return (mk_empty_string (SCHEME_A_ len, fill)); } @@ -4254,12 +4377,8 @@ case OP_STRREF: /* string-ref */ { - char *str; - int index; - - str = strvalue (x); - - index = ivalue (cadr (args)); + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); if (index >= strlength (x)) Error_1 ("string-ref: out of bounds:", cadr (args)); @@ -4269,17 +4388,13 @@ case OP_STRSET: /* string-set! */ { - char *str; - int index; + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); int c; if (is_immutable (x)) Error_1 ("string-set!: unable to alter immutable string:", x); - str = strvalue (x); - - index = ivalue (cadr (args)); - if (index >= strlength (x)) Error_1 ("string-set!: out of bounds:", cadr (args)); @@ -4311,21 +4426,17 @@ case OP_SUBSTR: /* substring */ { - char *str; - int index0; + char *str = strvalue (x); + int index0 = ivalue_unchecked (cadr (args)); int index1; int len; - str = strvalue (x); - - index0 = ivalue (cadr (args)); - if (index0 > strlength (x)) Error_1 ("substring: start out of bounds:", cadr (args)); if (cddr (args) != NIL) { - index1 = ivalue (caddr (args)); + index1 = ivalue_unchecked (caddr (args)); if (index1 > strlength (x) || index1 < index0) Error_1 ("substring: end out of bounds:", caddr (args)); @@ -4358,7 +4469,7 @@ #endif for (x = args, i = 0; is_pair (x); x = cdr (x), i++) - set_vector_elem (vec, i, car (x)); + vector_set (vec, i, car (x)); s_return (vec); } @@ -4366,10 +4477,8 @@ case OP_MKVECTOR: /* make-vector */ { pointer fill = NIL; - int len; pointer vec; - - len = ivalue (x); + int len = ivalue_unchecked (x); if (cdr (args) != NIL) fill = cadr (args); @@ -4382,7 +4491,7 @@ #endif if (fill != NIL) - fill_vector (vec, fill); + fill_vector (vec, 0, fill); s_return (vec); } @@ -4390,94 +4499,40 @@ case OP_VECLEN: /* vector-length */ 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 (args)); + int index = ivalue_unchecked (cadr (args)); if (index >= veclength (car (args)) && USE_ERROR_CHECKING) Error_1 ("vector-ref: out of bounds:", cadr (args)); - s_return (vector_elem (x, index)); + s_return (vector_get (x, index)); } case OP_VECSET: /* vector-set! */ { - int index; + int index = ivalue_unchecked (cadr (args)); if (is_immutable (x)) Error_1 ("vector-set!: unable to alter immutable vector:", x); - index = ivalue (cadr (args)); - if (index >= veclength (car (args)) && USE_ERROR_CHECKING) Error_1 ("vector-set!: out of bounds:", cadr (args)); - set_vector_elem (x, index, caddr (args)); + vector_set (x, index, caddr (args)); s_return (x); } } - 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) -{ - 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; - } - } -} - -static pointer -opexe_r (SCHEME_P_ enum scheme_opcodes op) +static int +opexe_2 (SCHEME_P_ enum scheme_opcodes op) { pointer x = SCHEME_V->args; @@ -4507,7 +4562,7 @@ s_return (S_T); } -static pointer +static int opexe_3 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -4517,23 +4572,24 @@ switch (op) { - 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_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_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ 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; #if USE_CHAR_CLASSIFIERS - case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break; - case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break; - case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break; - case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break; - case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break; + case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; + case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; + case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; + case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break; + case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break; #endif #if USE_PORTS @@ -4563,7 +4619,7 @@ s_retbool (r); } -static pointer +static int opexe_4 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -4586,7 +4642,7 @@ s_return (SCHEME_V->code); case OP_SAVE_FORCED: /* Save forced value replacing promise */ - memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); + *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); s_return (SCHEME_V->value); #if USE_PORTS @@ -4659,7 +4715,7 @@ if (SCHEME_V->interactive_repl) s_goto (OP_T0LVL); else - return NIL; + return -1; } case OP_REVERSE: /* reverse */ @@ -4726,7 +4782,7 @@ if (is_pair (args)) SCHEME_V->retcode = ivalue (a); - return NIL; + return -1; case OP_GC: /* gc */ gc (SCHEME_A_ NIL, NIL); @@ -4741,12 +4797,11 @@ } case OP_NEWSEGMENT: /* new-segment */ +#if 0 if (!is_pair (args) || !is_number (a)) Error_0 ("new-segment: argument must be a number"); - - alloc_cellseg (SCHEME_A_ (int)ivalue (a)); - - s_return (S_T); +#endif + s_retbool (alloc_cellseg (SCHEME_A)); case OP_OBLIST: /* oblist */ s_return (oblist_all_symbols (SCHEME_A)); @@ -4783,10 +4838,7 @@ p = port_from_filename (SCHEME_A_ strvalue (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } # if USE_STRING_PORTS @@ -4811,10 +4863,7 @@ p = port_from_string (SCHEME_A_ strvalue (a), strvalue (a) + strlength (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_OPEN_OUTSTRING: /* open-output-string */ @@ -4822,29 +4871,19 @@ pointer p; if (a == NIL) - { - p = port_from_scratch (SCHEME_A); - - if (p == NIL) - s_return (S_F); - } + p = port_from_scratch (SCHEME_A); else - { - p = port_from_string (SCHEME_A_ strvalue (a), - strvalue (a) + strlength (a), port_output); - - if (p == NIL) - s_return (S_F); - } + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), port_output); - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_GET_OUTSTRING: /* get-output-string */ { - port *p; + port *p = port (a); - if ((p = a->object.port)->kind & port_string) + if (p->kind & port_string) { off_t size; char *str; @@ -4886,10 +4925,10 @@ } - abort (); + if (USE_ERROR_CHECKING) abort (); } -static pointer +static int opexe_5 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -4959,7 +4998,7 @@ if (is_pair (args)) p = car (args); - res = p->object.port->kind & port_string; + res = port (p)->kind & port_string; s_retbool (res); } @@ -5028,10 +5067,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"); @@ -5053,7 +5101,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); @@ -5215,7 +5263,7 @@ } else { - pointer elem = vector_elem (vec, i); + pointer elem = vector_get (vec, i); ivalue_unchecked (cdr (args)) = i + 1; s_save (SCHEME_A_ OP_PVECFROM, args, NIL); @@ -5229,10 +5277,10 @@ } } - abort (); + if (USE_ERROR_CHECKING) abort (); } -static pointer +static int opexe_6 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -5285,6 +5333,7 @@ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t + * (schmorp) well, obviously not, fix? TODO */ s_retbool (is_closure (a)); @@ -5292,22 +5341,29 @@ s_retbool (is_macro (a)); } - abort (); + 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! */ @@ -5315,26 +5371,24 @@ { 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 /* TST_NONE used for standard procedures, for internal ops, 0 is used */ +#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" @@ -5350,70 +5404,90 @@ #define TST_INTEGER "\015" #define TST_NATURAL "\016" -typedef struct -{ - dispatch_func func; - char *name; - int min_arity; - int max_arity; - char arg_tests_encoding[3]; -} op_code_info; - -#define INF_ARG 0xffff +#define INF_ARG 0xff +#define UNNAMED_OP "" -static op_code_info dispatch_table[] = { -#define OP_DEF(func,name,minarity,maxarity,argtest,op) { opexe_ ## func, name, minarity, maxarity, argtest }, +static const char opnames[] = +#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" #include "opdefines.h" #undef OP_DEF - {0} -}; +; static const char * -procname (pointer x) +opname (int idx) { - int n = procnum (x); - const char *name = dispatch_table[n].name; + const char *name = opnames; - if (name == 0) - name = "ILLEGAL!"; + /* should do this at compile time, but would require external program, right? */ + while (idx--) + name += strlen (name) + 1; - return name; + return *name ? name : "ILLEGAL"; } +static const char * +procname (pointer x) +{ + return opname (procnum (x)); +} + +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; + +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_expect_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; @@ -5426,18 +5500,19 @@ 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]) /* 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); @@ -5447,25 +5522,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) @@ -5499,7 +5577,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; } @@ -5507,9 +5584,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') @@ -5574,7 +5651,7 @@ } #if USE_MULTIPLICITY -scheme * +ecb_cold scheme * scheme_init_new () { scheme *sc = malloc (sizeof (scheme)); @@ -5589,12 +5666,18 @@ } #endif -int +ecb_cold int scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); pointer x; + /* this memset is not strictly correct, as we assume (intcache) + * that memset 0 will also set pointers to 0, but memset does + * of course not guarantee that. screw such systems. + */ + memset (SCHEME_V, 0, sizeof (*SCHEME_V)); + num_set_fixnum (num_zero, 1); num_set_ivalue (num_zero, 0); num_set_fixnum (num_one, 1); @@ -5615,7 +5698,7 @@ SCHEME_V->nesting = 0; SCHEME_V->interactive_repl = 0; - if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) + if (!alloc_cellseg (SCHEME_A)) { #if USE_ERROR_CHECKING SCHEME_V->no_memory = 1; @@ -5672,9 +5755,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"); @@ -5723,7 +5807,7 @@ SCHEME_V->ext_data = p; } -void +ecb_cold void scheme_deinit (SCHEME_P) { int i; @@ -5954,6 +6038,7 @@ char *file_name = InitFile; int retcode; int isfile = 1; + system ("ps v $PPID");//D if (argc == 2 && strcmp (argv[1], "-?") == 0) {