--- microscheme/scheme.c 2015/11/28 10:31:06 1.29 +++ microscheme/scheme.c 2015/12/02 02:59:36 1.60 @@ -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" @@ -36,20 +40,35 @@ #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, @@ -61,19 +80,20 @@ }; #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) +#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; #endif -static void +ecb_cold static void xbase (char *s, long n, int base) { if (n < 0) @@ -85,7 +105,7 @@ char *p = s; do { - *p++ = '0' + n % base; + *p++ = "0123456789abcdef"[n % base]; n /= base; } while (n); @@ -98,28 +118,22 @@ } } -static void +ecb_cold static void xnum (char *s, long n) { xbase (s, n, 10); } -static void -xwrstr (const char *s) -{ - write (1, s, strlen (s)); -} - -static void -xwrnum (long n) +ecb_cold static void +putnum (SCHEME_P_ long n) { char buf[64]; xnum (buf, n); - xwrstr (buf); + putstr (SCHEME_A_ buf); } -static char +ecb_cold static char xtoupper (char c) { if (c >= 'a' && c <= 'z') @@ -128,7 +142,7 @@ return c; } -static char +ecb_cold static char xtolower (char c) { if (c >= 'A' && c <= 'Z') @@ -137,7 +151,7 @@ return c; } -static int +ecb_cold static int xisdigit (char c) { return c >= '0' && c <= '9'; @@ -148,7 +162,7 @@ #define isdigit(c) xisdigit (c) #if USE_IGNORECASE -static const char * +ecb_cold static const char * xstrlwr (char *s) { const char *p = s; @@ -178,25 +192,21 @@ # define InitFile "init.scm" #endif -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - enum scheme_types { T_INTEGER, + T_CHARACTER, T_REAL, T_STRING, T_SYMBOL, T_PROC, T_PAIR, /* also used for free cells */ T_CLOSURE, + T_MACRO, T_CONTINUATION, T_FOREIGN, - T_CHARACTER, T_PORT, T_VECTOR, - T_MACRO, T_PROMISE, T_ENVIRONMENT, /* one more... */ @@ -242,17 +252,18 @@ static num num_rem (num a, num b); static num num_mod (num a, num b); -#if USE_MATH -static double round_per_R5RS (double x); -#endif static int is_zero_rvalue (RVALUE x); 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 int @@ -261,8 +272,8 @@ 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_vector (pointer p) @@ -270,8 +281,8 @@ return type (p) == T_VECTOR; } -#define vecvalue(p) ((p)->object.vector.vvalue) -#define veclength(p) ((p)->object.vector.length) +#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); @@ -307,15 +318,15 @@ return strvalue (p); } -#define ivalue_unchecked(p) (p)->object.ivalue -#define set_ivalue(p,v) (p)->object.ivalue = (v) +#define ivalue_unchecked(p) CELL(p)->object.ivalue +#define set_ivalue(p,v) CELL(p)->object.ivalue = (v) #if USE_REAL -#define rvalue_unchecked(p) (p)->object.rvalue -#define set_rvalue(p,v) (p)->object.rvalue = (v) +#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.ivalue -#define set_rvalue(p,v) (p)->object.ivalue = (v) +#define rvalue_unchecked(p) CELL(p)->object.ivalue +#define set_rvalue(p,v) CELL(p)->object.ivalue = (v) #endif INTERFACE long @@ -324,6 +335,8 @@ return ivalue_unchecked (p); } +#define port(p) CELL(p)->object.port +#define set_port(p,v) port(p) = (v) INTERFACE int is_port (pointer p) { @@ -333,13 +346,13 @@ 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 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 int @@ -348,8 +361,8 @@ 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)); } @@ -363,13 +376,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 @@ -393,17 +406,17 @@ INTERFACE char * symname (pointer p) { - return strvalue (car (p)); + return strvalue (p); } #if USE_PLIST +#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 int @@ -427,7 +440,7 @@ INTERFACE char * syntaxname (pointer p) { - return strvalue (car (p)); + return strvalue (p); } #define procnum(p) ivalue_unchecked (p) @@ -509,7 +522,7 @@ not even a pair: -2 dotted list: -2 minus length before dot */ -INTERFACE int +ecb_hot INTERFACE int list_length (SCHEME_P_ pointer a) { int i = 0; @@ -625,7 +638,7 @@ "us" }; -static int +ecb_cold static int is_ascii_name (const char *name, int *pc) { int i; @@ -653,8 +666,8 @@ static int file_push (SCHEME_P_ const char *fname); static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); -ecb_inline int is_one_of (char *s, int c); -static int alloc_cellseg (SCHEME_P_ int n); +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); @@ -680,8 +693,8 @@ 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 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); @@ -858,31 +871,6 @@ return ret; } -#if USE_MATH - -/* Round to nearest. Round to even if midway */ -static double -round_per_R5RS (double x) -{ - double fl = floor (x); - double ce = ceil (x); - double dfl = x - fl; - double dce = ce - x; - - if (dfl > dce) - return ce; - else if (dfl < dce) - return fl; - else - { - if (fmod (fl, 2) == 0) /* I imagine this holds */ - return fl; - else - return ce; - } -} -#endif - static int is_zero_rvalue (RVALUE x) { @@ -897,12 +885,12 @@ } /* allocate new cell segment */ -static int -alloc_cellseg (SCHEME_P_ int n) +ecb_cold static int +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; @@ -910,37 +898,32 @@ 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; - newp = (pointer)cp; - SCHEME_V->cell_seg[i] = newp; - SCHEME_V->cell_segsize[i] = segsize; - SCHEME_V->fcells += segsize; - last = newp + segsize - 1; - - for (p = newp; p <= last; p++) - { - set_typeflag (p, T_PAIR); - set_car (p, NIL); - set_cdr (p, p + 1); - } - - set_cdr (last, SCHEME_V->free_cell); - SCHEME_V->free_cell = 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. */ @@ -954,14 +937,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; @@ -983,8 +966,7 @@ /* To retain recent allocs before interpreter knows about them - Tehom */ - -static void +ecb_hot static void push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) { pointer holder = get_cell_x (SCHEME_A_ recent, extra); @@ -996,7 +978,7 @@ set_car (S_SINK, holder); } -static pointer +ecb_hot static pointer get_cell (SCHEME_P_ pointer a, pointer b) { pointer cell = get_cell_x (SCHEME_A_ a, b); @@ -1015,7 +997,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) @@ -1024,8 +1006,8 @@ /* 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; + CELL(v)->object.vector.vvalue = e; + CELL(v)->object.vector.length = len; fill_vector (v, 0, init); push_recent_alloc (SCHEME_A_ v, NIL); @@ -1044,10 +1026,10 @@ { /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ if (typeflag (p) & !expect_alloced) - xwrstr ("Cell is already allocated!\n"); + putstr (SCHEME_A_ "Cell is already allocated!\n"); if (!(typeflag (p)) & expect_alloced) - xwrstr ("Cell is not allocated!\n"); + putstr (SCHEME_A_ "Cell is not allocated!\n"); } static void @@ -1063,7 +1045,7 @@ /* Medium level cell allocation */ /* get new cons cell */ -pointer +ecb_hot pointer xcons (SCHEME_P_ pointer a, pointer b, int immutable) { pointer x = get_cell (SCHEME_A_ a, b); @@ -1079,34 +1061,48 @@ return x; } +ecb_cold 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; -static pointer + return hash % table_size; +} + +ecb_cold static pointer oblist_initial_value (SCHEME_P) { return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ } /* returns the new symbol */ -static pointer +ecb_cold 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)); + 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; } -ecb_inline pointer +ecb_cold static pointer oblist_find_by_name (SCHEME_P_ const char *name) { int location; @@ -1127,7 +1123,7 @@ return NIL; } -static pointer +ecb_cold static pointer oblist_all_symbols (SCHEME_P) { int i; @@ -1143,13 +1139,13 @@ #else -static pointer +ecb_cold static pointer oblist_initial_value (SCHEME_P) { return NIL; } -ecb_inline pointer +ecb_cold static pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; @@ -1168,19 +1164,15 @@ } /* returns the new symbol */ -static pointer +ecb_cold 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; } -static pointer +ecb_cold static pointer oblist_all_symbols (SCHEME_P) { return SCHEME_V->oblist; @@ -1189,25 +1181,25 @@ #endif #if USE_PORTS -static pointer +ecb_cold static pointer mk_port (SCHEME_P_ port *p) { 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; } #endif -pointer +ecb_cold pointer mk_foreign_func (SCHEME_P_ foreign_func f) { 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; } @@ -1217,7 +1209,7 @@ { pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_CHARACTER | T_ATOM)); + set_typeflag (x, T_CHARACTER | T_ATOM); set_ivalue (x, c & 0xff); return x; @@ -1227,12 +1219,26 @@ INTERFACE pointer mk_integer (SCHEME_P_ long n) { - pointer x = get_cell (SCHEME_A_ NIL, NIL); + pointer p = 0; + pointer *pp = &p; - set_typeflag (x, (T_INTEGER | T_ATOM)); - set_ivalue (x, n); +#if USE_INTCACHE + if (n >= INTCACHE_MIN && n <= INTCACHE_MAX) + pp = &SCHEME_V->intcache[n - INTCACHE_MIN]; +#endif - return x; + 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 @@ -1241,7 +1247,7 @@ #if USE_REAL pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_REAL | T_ATOM)); + set_typeflag (x, T_REAL | T_ATOM); set_rvalue (x, n); return x; @@ -1275,20 +1281,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; } @@ -1312,6 +1309,7 @@ set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, str, 0); strlength (x) = len; + return x; } @@ -1336,6 +1334,15 @@ 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_get (pointer vec, uint32_t ielem) { @@ -1361,31 +1368,24 @@ return x; } -INTERFACE pointer +ecb_cold INTERFACE pointer 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 */ -static pointer +ecb_cold static pointer mk_atom (SCHEME_P_ char *q) { char c, *p; @@ -1466,7 +1466,7 @@ } /* make constant */ -static pointer +ecb_cold static pointer mk_sharp_const (SCHEME_P_ char *name) { if (!strcmp (name, "t")) @@ -1477,6 +1477,7 @@ { int c; + // TODO: optimise if (stricmp (name + 1, "space") == 0) c = ' '; else if (stricmp (name + 1, "newline") == 0) @@ -1485,6 +1486,16 @@ c = '\r'; else if (stricmp (name + 1, "tab") == 0) c = '\t'; + else if (stricmp (name + 1, "alarm") == 0) + c = 0x07; + else if (stricmp (name + 1, "backspace") == 0) + c = 0x08; + else if (stricmp (name + 1, "escape") == 0) + c = 0x1b; + else if (stricmp (name + 1, "delete") == 0) + c = 0x7f; + else if (stricmp (name + 1, "null") == 0) + c = 0; else if (name[1] == 'x' && name[2] != 0) { long c1 = strtol (name + 2, 0, 16); @@ -1520,6 +1531,25 @@ /* ========== garbage collector ========== */ +static void +finalize_cell (SCHEME_P_ pointer a) +{ + /* TODO, fast bitmap check? */ + 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 (port(a)->kind & port_file && port (a)->rep.stdio.closeit) + port_close (SCHEME_A_ a, port_input | port_output); + + free (port (a)); + } +#endif +} + /*-- * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, @@ -1529,7 +1559,7 @@ * which is inherited form tinyscheme and could be fixed by having another * word of context in the vector */ -static void +ecb_hot static void mark (pointer a) { pointer t, q, p; @@ -1596,11 +1626,52 @@ } } +ecb_hot static void +gc_free (SCHEME_P) +{ + int i; + uint32_t total = 0; + + /* Here we scan the cells to build the free-list. */ + for (i = SCHEME_V->last_cell_seg; i >= 0; i--) + { + struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; + struct cell *p; + total += SCHEME_V->cell_segsize [i]; + + for (p = SCHEME_V->cell_seg[i]; p < end; ++p) + { + pointer c = POINTER (p); + + if (is_mark (c)) + clrmark (c); + else + { + /* reclaim cell */ + if (typeflag (c) != T_PAIR) + { + finalize_cell (SCHEME_A_ c); + set_typeflag (c, T_PAIR); + set_car (c, NIL); + } + + ++SCHEME_V->fcells; + set_cdr (c, SCHEME_V->free_cell); + SCHEME_V->free_cell = c; + } + } + } + + if (SCHEME_V->gc_verbose) + { + putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n"); + } +} + /* garbage collection. parameter a, b is marked. */ -static void +ecb_cold static void gc (SCHEME_P_ pointer a, pointer b) { - pointer p; int i; if (SCHEME_V->gc_verbose) @@ -1626,6 +1697,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); @@ -1635,64 +1713,15 @@ 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. - */ - for (i = SCHEME_V->last_cell_seg; i >= 0; i--) - { - p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; - - while (--p >= SCHEME_V->cell_seg[i]) - { - if (is_mark (p)) - clrmark (p); - else - { - /* reclaim cell */ - if (typeflag (p) != T_PAIR) - { - finalize_cell (SCHEME_A_ p); - set_typeflag (p, T_PAIR); - set_car (p, NIL); - } - - ++SCHEME_V->fcells; - set_cdr (p, SCHEME_V->free_cell); - SCHEME_V->free_cell = p; - } - } - } - if (SCHEME_V->gc_verbose) - { - 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 (vecvalue (a)); -#if USE_PORTS - else if (is_port (a)) - { - if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) - port_close (SCHEME_A_ a, port_input | port_output); + putstr (SCHEME_A_ "freeing..."); - free (a->object.port); - } -#endif + gc_free (SCHEME_A); } /* ========== Routines for Reading ========== */ -static int +ecb_cold static int file_push (SCHEME_P_ const char *fname) { #if USE_PORTS @@ -1711,7 +1740,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; @@ -1728,7 +1757,7 @@ #endif } -static void +ecb_cold static void file_pop (SCHEME_P) { if (SCHEME_V->file_i != 0) @@ -1738,24 +1767,24 @@ 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); } } -static int +ecb_cold static int file_interactive (SCHEME_P) { #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 } #if USE_PORTS -static port * +ecb_cold static port * port_rep_from_filename (SCHEME_P_ const char *fn, int prop) { int fd; @@ -1788,7 +1817,7 @@ return pt; } -static pointer +ecb_cold static pointer port_from_filename (SCHEME_P_ const char *fn, int prop) { port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); @@ -1799,7 +1828,7 @@ return mk_port (SCHEME_A_ pt); } -static port * +ecb_cold static port * port_rep_from_file (SCHEME_P_ int f, int prop) { port *pt = malloc (sizeof *pt); @@ -1814,7 +1843,7 @@ return pt; } -static pointer +ecb_cold static pointer port_from_file (SCHEME_P_ int f, int prop) { port *pt = port_rep_from_file (SCHEME_A_ f, prop); @@ -1825,7 +1854,7 @@ return mk_port (SCHEME_A_ pt); } -static port * +ecb_cold static port * port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) { port *pt = malloc (sizeof (port)); @@ -1841,7 +1870,7 @@ return pt; } -static pointer +ecb_cold static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) { port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); @@ -1854,7 +1883,7 @@ # define BLOCK_SIZE 256 -static port * +ecb_cold static port * port_rep_from_scratch (SCHEME_P) { char *start; @@ -1878,7 +1907,7 @@ return pt; } -static pointer +ecb_cold static pointer port_from_scratch (SCHEME_P) { port *pt = port_rep_from_scratch (SCHEME_A); @@ -1889,10 +1918,10 @@ return mk_port (SCHEME_A_ pt); } -static void +ecb_cold static void port_close (SCHEME_P_ pointer p, int flag) { - port *pt = p->object.port; + port *pt = port (p); pt->kind &= ~flag; @@ -1923,9 +1952,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; @@ -2002,7 +2029,7 @@ if (c == EOF) return; - pt = SCHEME_V->inport->object.port; + pt = port (SCHEME_V->inport); pt->unget = c; #else if (c == EOF) @@ -2013,7 +2040,7 @@ } #if USE_PORTS -static int +ecb_cold static int realloc_port_string (SCHEME_P_ port *p) { char *start = p->rep.string.start; @@ -2036,11 +2063,11 @@ } #endif -INTERFACE void +ecb_cold INTERFACE void 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)); @@ -2052,15 +2079,15 @@ *pt->rep.string.curr++ = *s; #else - xwrstr (s); + write (pt->rep.stdio.file, s, strlen (s)); #endif } -static void +ecb_cold static void 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); @@ -2080,11 +2107,11 @@ #endif } -INTERFACE void +ecb_cold INTERFACE void 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) { @@ -2106,10 +2133,10 @@ } /* read characters up to delimiter, but cater to character constants */ -static char * -readstr_upto (SCHEME_P_ char *delim) +ecb_cold static char * +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)))); @@ -2125,14 +2152,13 @@ } /* read string expression "xxx...xxx" */ -static pointer -readstrexp (SCHEME_P) +ecb_cold static pointer +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 (;;) { @@ -2144,20 +2170,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; @@ -2176,32 +2195,20 @@ c1 = c - '0'; break; + case 'a': *p++ = '\a'; state = st_ok; break; + case 'n': *p++ = '\n'; state = st_ok; break; + case 'r': *p++ = '\r'; state = st_ok; break; + case 't': *p++ = '\t'; state = st_ok; break; + + //TODO: \whitespace eol whitespace + + //TODO: x should end in ;, not two-digit hex case 'x': case 'X': state = st_x1; c1 = 0; break; - case 'n': - *p++ = '\n'; - state = st_ok; - break; - - case 't': - *p++ = '\t'; - state = st_ok; - break; - - case 'r': - *p++ = '\r'; - state = st_ok; - break; - - case '"': - *p++ = '"'; - state = st_ok; - break; - default: *p++ = c; state = st_ok; @@ -2212,26 +2219,23 @@ case st_x1: case st_x2: - c = toupper (c); - - if (c >= '0' && c <= 'F') - { - if (c <= '9') - c1 = (c1 << 4) + c - '0'; - else - c1 = (c1 << 4) + c - 'A' + 10; + c = tolower (c); - 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: @@ -2244,7 +2248,7 @@ } else { - if (state == st_oct2 && c1 >= 32) + if (state == st_oct2 && c1 >= ' ') return S_F; c1 = (c1 << 3) + (c - '0'); @@ -2259,23 +2263,19 @@ } break; - } } } /* check c is in chars */ -ecb_inline int -is_one_of (char *s, int c) +ecb_cold 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 */ -ecb_inline int +ecb_cold int skipspace (SCHEME_P) { int c, curr_line = 0; @@ -2283,12 +2283,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 @@ -2296,17 +2300,12 @@ 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 */ -static int +ecb_cold static int token (SCHEME_P) { int c = skipspace (SCHEME_A); @@ -2328,16 +2327,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; @@ -2413,7 +2413,7 @@ /* ========== Routines for Printing ========== */ #define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) -static void +ecb_cold static void printslashstring (SCHEME_P_ char *p, int len) { int i; @@ -2478,9 +2478,8 @@ putcharacter (SCHEME_A_ '"'); } - /* print atoms */ -static void +ecb_cold static void printatom (SCHEME_P_ pointer l, int f) { char *p; @@ -2490,9 +2489,8 @@ putchars (SCHEME_A_ p, len); } - /* Uses internal buffer unless string pointer is already available */ -static void +ecb_cold static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) { char *p; @@ -2660,7 +2658,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); @@ -2702,20 +2707,20 @@ p = cons (car (d), cdr (d)); q = p; - while (cdr (cdr (p)) != NIL) + while (cddr (p) != NIL) { d = cons (car (p), cdr (p)); - if (cdr (cdr (p)) != NIL) + if (cddr (p) != NIL) p = cdr (d); } - set_cdr (p, car (cdr (p))); + set_cdr (p, cadr (p)); return q; } /* reverse list -- produce new list */ -static pointer +ecb_hot static pointer reverse (SCHEME_P_ pointer a) { /* a must be checked by gc */ @@ -2728,7 +2733,7 @@ } /* reverse list --- in-place */ -static pointer +ecb_hot static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list) { pointer result = term; @@ -2746,7 +2751,7 @@ } /* append list -- produce new list (in reverse order) */ -static pointer +ecb_hot static pointer revappend (SCHEME_P_ pointer a, pointer b) { pointer result = a; @@ -2765,7 +2770,7 @@ } /* equivalence of atoms */ -int +ecb_hot int eqv (pointer a, pointer b) { if (is_string (a)) @@ -2815,21 +2820,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 /* @@ -2855,6 +2845,21 @@ setenvironment (SCHEME_V->envir); } +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) { @@ -2862,25 +2867,23 @@ if (is_vector (car (env))) { - int location = hash_fn (symname (variable), veclength (car (env))); - + 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))); } -static pointer +ecb_hot static pointer 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))); + int location = sym_hash (hdl, veclength (car (x))); y = vector_get (car (x), location); } else @@ -2902,20 +2905,20 @@ #else /* USE_ALIST_ENV */ -ecb_inline void +static void new_frame_in_env (SCHEME_P_ pointer old_env) { SCHEME_V->envir = immutable_cons (NIL, old_env); setenvironment (SCHEME_V->envir); } -ecb_inline void +static 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))); } -static pointer +ecb_hot static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) { pointer x, y; @@ -2927,33 +2930,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 */ -ecb_inline void +static 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); } -ecb_inline void +static void set_slot_in_env (SCHEME_P_ pointer slot, pointer value) { set_cdr (slot, value); } -ecb_inline pointer +static pointer slot_value_in_env (pointer slot) { return cdr (slot); @@ -2961,7 +2963,7 @@ /* ========== Evaluation Cycle ========== */ -static int +ecb_cold static int xError_1 (SCHEME_P_ const char *s, pointer a) { #if USE_ERROR_HOOK @@ -3047,14 +3049,14 @@ # define STACK_GROWTH 3 -static void +ecb_hot static void s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) { int nframes = (uintptr_t)SCHEME_V->dump; 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); @@ -3070,7 +3072,7 @@ SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); } -static int +static ecb_hot int xs_return (SCHEME_P_ pointer a) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3091,14 +3093,14 @@ return 0; } -ecb_inline void +ecb_cold 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; } -ecb_inline void +ecb_cold void dump_stack_initialize (SCHEME_P) { SCHEME_V->dump_size = 0; @@ -3106,7 +3108,7 @@ dump_stack_reset (SCHEME_A); } -static void +ecb_cold static void dump_stack_free (SCHEME_P) { free (SCHEME_V->dump_base); @@ -3115,7 +3117,7 @@ SCHEME_V->dump_size = 0; } -static void +ecb_cold static void dump_stack_mark (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3131,7 +3133,7 @@ } } -static pointer +ecb_cold static pointer ss_get_cont (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3153,7 +3155,7 @@ return cont; } -static void +ecb_cold static void ss_set_cont (SCHEME_P_ pointer cont) { int i = 0; @@ -3175,25 +3177,25 @@ #else -ecb_inline void +ecb_cold void dump_stack_reset (SCHEME_P) { SCHEME_V->dump = NIL; } -ecb_inline void +ecb_cold void dump_stack_initialize (SCHEME_P) { dump_stack_reset (SCHEME_A); } -static void +ecb_cold static void dump_stack_free (SCHEME_P) { SCHEME_V->dump = NIL; } -static int +ecb_hot static int xs_return (SCHEME_P_ pointer a) { pointer dump = SCHEME_V->dump; @@ -3213,7 +3215,7 @@ return 0; } -static void +ecb_hot static void s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) { SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), @@ -3223,19 +3225,19 @@ SCHEME_V->dump)))); } -static void +ecb_cold static void dump_stack_mark (SCHEME_P) { mark (SCHEME_V->dump); } -static pointer +ecb_cold static pointer ss_get_cont (SCHEME_P) { return SCHEME_V->dump; } -static void +ecb_cold static void ss_set_cont (SCHEME_P_ pointer cont) { SCHEME_V->dump = cont; @@ -3245,7 +3247,66 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) +#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 + +/* syntax, eval, core, ... */ +ecb_hot static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -3253,11 +3314,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))); + putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n"); + //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); } if (!file_push (SCHEME_A_ strvalue (car (args)))) @@ -3271,7 +3338,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) { @@ -3359,10 +3426,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)) { @@ -3385,7 +3452,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); @@ -3449,7 +3516,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); } @@ -3496,8 +3563,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 */ @@ -3513,19 +3578,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); @@ -3944,7 +4002,8 @@ if (USE_ERROR_CHECKING) abort (); } -static int +/* math, cxr */ +ecb_hot static int opexe_1 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -3955,20 +4014,27 @@ { #if USE_MATH case OP_INEX2EX: /* inexact->exact */ - { - if (is_integer (x)) - s_return (x); + if (!is_integer (x)) + { + RVALUE r = rvalue_unchecked (x); + + if (r == (RVALUE)(IVALUE)r) + x = mk_integer (SCHEME_A_ rvalue_unchecked (x)); + else + Error_1 ("inexact->exact: not integral:", x); + } - RVALUE r = rvalue_unchecked (x); + s_return (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_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: s_return (mk_real (SCHEME_A_ trunc (rvalue (x)))); + case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x)))); + case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (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)))); + case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)) + / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args)))))); 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)))); @@ -3976,16 +4042,10 @@ case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); case OP_ATAN: - if (cdr (args) == NIL) - s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); - else - { - pointer y = cadr (args); - s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y)))); - } - - case OP_SQRT: - s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); + s_return (mk_real (SCHEME_A_ + cdr (args) == NIL + ? atan (rvalue (x)) + : atan2 (rvalue (x), rvalue (cadr (args))))); case OP_EXPT: { @@ -4018,21 +4078,6 @@ else s_return (mk_integer (SCHEME_A_ result)); } - - 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 n = rvalue (x); - s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n))); - } - - case OP_ROUND: - if (is_integer (x)) - s_return (x); - - s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); #endif case OP_ADD: /* + */ @@ -4130,11 +4175,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)); @@ -4318,30 +4389,28 @@ s_return (newstr); } - case OP_SUBSTR: /* substring */ + case OP_STRING_COPY: /* substring/string-copy */ { char *str = strvalue (x); - int index0 = ivalue_unchecked (cadr (args)); + int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args)); int index1; int len; if (index0 > strlength (x)) - Error_1 ("substring: start out of bounds:", cadr (args)); + Error_1 ("string->copy: start out of bounds:", cadr (args)); if (cddr (args) != NIL) { index1 = ivalue_unchecked (caddr (args)); if (index1 > strlength (x) || index1 < index0) - Error_1 ("substring: end out of bounds:", caddr (args)); + Error_1 ("string->copy: end out of bounds:", caddr (args)); } else index1 = strlength (x); len = index1 - index0; - x = mk_empty_string (SCHEME_A_ len, ' '); - memcpy (strvalue (x), str + index0, len); - strvalue (x)[len] = 0; + x = mk_counted_string (SCHEME_A_ str + index0, len); s_return (x); } @@ -4393,6 +4462,10 @@ 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 = ivalue_unchecked (cadr (args)); @@ -4421,7 +4494,8 @@ if (USE_ERROR_CHECKING) abort (); } -static int +/* relational ops */ +ecb_hot static int opexe_2 (SCHEME_P_ enum scheme_opcodes op) { pointer x = SCHEME_V->args; @@ -4452,7 +4526,8 @@ s_return (S_T); } -static int +/* predicates */ +ecb_hot static int opexe_3 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -4462,16 +4537,17 @@ 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_unchecked (a)); break; @@ -4508,7 +4584,8 @@ s_retbool (r); } -static int +/* promises, list ops, ports */ +ecb_hot static int opexe_4 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -4531,11 +4608,14 @@ 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 + case OP_EOF_OBJECT: /* eof-object */ + s_return (S_EOF); + case OP_WRITE: /* write */ case OP_DISPLAY: /* display */ case OP_WRITE_CHAR: /* write-char */ @@ -4686,12 +4766,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_ ivalue (a)); - - s_return (S_T); +#endif + s_retbool (alloc_cellseg (SCHEME_A)); case OP_OBLIST: /* oblist */ s_return (oblist_all_symbols (SCHEME_A)); @@ -4771,9 +4850,9 @@ 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; @@ -4818,7 +4897,8 @@ if (USE_ERROR_CHECKING) abort (); } -static int +/* reading */ +ecb_cold static int opexe_5 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -4888,7 +4968,7 @@ if (is_pair (args)) p = car (args); - res = p->object.port->kind & port_string; + res = port (p)->kind & port_string; s_retbool (res); } @@ -4957,10 +5037,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"); @@ -4982,7 +5071,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); @@ -5161,7 +5250,8 @@ if (USE_ERROR_CHECKING) abort (); } -static int +/* list ops */ +ecb_hot static int opexe_6 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -5214,6 +5304,7 @@ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t + * (schmorp) well, obviously not, fix? TODO */ s_retbool (is_closure (a)); @@ -5228,19 +5319,20 @@ typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); typedef int (*test_predicate)(pointer); -static int + +ecb_hot static int tst_any (pointer p) { return 1; } -static int +ecb_hot static int tst_inonneg (pointer p) { return is_integer (p) && ivalue_unchecked (p) >= 0; } -static int +ecb_hot static int tst_is_list (SCHEME_P_ pointer p) { return p == NIL || is_pair (p); @@ -5293,7 +5385,7 @@ #undef OP_DEF ; -static const char * +ecb_cold static const char * opname (int idx) { const char *name = opnames; @@ -5305,7 +5397,7 @@ return *name ? name : "ILLEGAL"; } -static const char * +ecb_cold static const char * procname (pointer x) { return opname (procnum (x)); @@ -5335,7 +5427,7 @@ }; /* kernel of this interpreter */ -static void ecb_hot +ecb_hot static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) { SCHEME_V->op = op; @@ -5428,7 +5520,7 @@ if (SCHEME_V->no_memory && USE_ERROR_CHECKING) { - xwrstr ("No memory!\n"); + putstr (SCHEME_A_ "No memory!\n"); return; } } @@ -5436,14 +5528,14 @@ /* ========== Initialization of internal keywords ========== */ -static void +ecb_cold static void assign_syntax (SCHEME_P_ const char *name) { pointer x = oblist_add_by_name (SCHEME_A_ name); set_typeflag (x, typeflag (x) | T_SYNTAX); } -static void +ecb_cold static void assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) { pointer x = mk_symbol (SCHEME_A_ name); @@ -5461,12 +5553,12 @@ } /* Hard-coded for the given keywords. Remember to rewrite if more are added! */ -static int +ecb_hot 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') @@ -5552,6 +5644,12 @@ 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); @@ -5572,7 +5670,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; @@ -5650,32 +5748,32 @@ } #if USE_PORTS -void +ecb_cold void scheme_set_input_port_file (SCHEME_P_ int fin) { SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); } -void +ecb_cold void scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) { SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); } -void +ecb_cold void scheme_set_output_port_file (SCHEME_P_ int fout) { SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); } -void +ecb_cold void scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) { SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); } #endif -void +ecb_cold void scheme_set_external_data (SCHEME_P_ void *p) { SCHEME_V->ext_data = p; @@ -5733,13 +5831,13 @@ #endif } -void +ecb_cold void scheme_load_file (SCHEME_P_ int fin) { scheme_load_named_file (SCHEME_A_ fin, 0); } -void +ecb_cold void scheme_load_named_file (SCHEME_P_ int fin, const char *filename) { dump_stack_reset (SCHEME_A); @@ -5776,7 +5874,7 @@ SCHEME_V->retcode = SCHEME_V->nesting != 0; } -void +ecb_cold void scheme_load_string (SCHEME_P_ const char *cmd) { dump_stack_reset (SCHEME_A); @@ -5800,7 +5898,7 @@ SCHEME_V->retcode = SCHEME_V->nesting != 0; } -void +ecb_cold void scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) { pointer x; @@ -5815,13 +5913,13 @@ #if !STANDALONE -void +ecb_cold void scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) { scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); } -void +ecb_cold void scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) { int i; @@ -5830,13 +5928,13 @@ scheme_register_foreign_func (SCHEME_A_ list + i); } -pointer +ecb_cold pointer scheme_apply0 (SCHEME_P_ const char *procname) { return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); } -void +ecb_cold void save_from_C_call (SCHEME_P) { pointer saved_data = cons (car (S_SINK), @@ -5850,7 +5948,7 @@ dump_stack_reset (SCHEME_A); } -void +ecb_cold void restore_from_C_call (SCHEME_P) { set_car (S_SINK, caar (SCHEME_V->c_nest)); @@ -5861,7 +5959,7 @@ } /* "func" and "args" are assumed to be already eval'ed. */ -pointer +ecb_cold pointer scheme_call (SCHEME_P_ pointer func, pointer args) { int old_repl = SCHEME_V->interactive_repl; @@ -5878,7 +5976,7 @@ return SCHEME_V->value; } -pointer +ecb_cold pointer scheme_eval (SCHEME_P_ pointer obj) { int old_repl = SCHEME_V->interactive_repl; @@ -5900,7 +5998,7 @@ #if STANDALONE -int +ecb_cold int main (int argc, char **argv) { # if USE_MULTIPLICITY @@ -5912,22 +6010,23 @@ char *file_name = InitFile; int retcode; int isfile = 1; + system ("ps v $PPID");//D if (argc == 2 && strcmp (argv[1], "-?") == 0) { - xwrstr ("Usage: tinyscheme -?\n"); - xwrstr ("or: tinyscheme [ ...]\n"); - xwrstr ("followed by\n"); - xwrstr (" -1 [ ...]\n"); - xwrstr (" -c [ ...]\n"); - xwrstr ("assuming that the executable is named tinyscheme.\n"); - xwrstr ("Use - as filename for stdin.\n"); + putstr (SCHEME_A_ "Usage: tinyscheme -?\n"); + putstr (SCHEME_A_ "or: tinyscheme [ ...]\n"); + putstr (SCHEME_A_ "followed by\n"); + putstr (SCHEME_A_ " -1 [ ...]\n"); + putstr (SCHEME_A_ " -c [ ...]\n"); + putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n"); + putstr (SCHEME_A_ "Use - as filename for stdin.\n"); return 1; } if (!scheme_init (SCHEME_A)) { - xwrstr ("Could not initialize!\n"); + putstr (SCHEME_A_ "Could not initialize!\n"); return 2; } @@ -5982,7 +6081,7 @@ if (isfile && fin < 0) { - xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); + putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); } else { @@ -5996,7 +6095,7 @@ { if (SCHEME_V->retcode != 0) { - xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); + putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); } if (isfile)