--- microscheme/scheme.c 2015/11/28 10:31:06 1.29 +++ microscheme/scheme.c 2015/12/07 21:12:56 1.68 @@ -18,8 +18,9 @@ * */ -#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ -#include "malloc.c" +#define _POSIX_C_SOURCE 200201 +#define _XOPEN_SOURCE 600 +#define _GNU_SOURCE 1 /* for malloc mremap */ #define SCHEME_SOURCE #include "scheme-private.h" @@ -30,19 +31,40 @@ # include #endif +#define ECB_NO_THREADS 1 #include "ecb.h" #include #include #include -#include +#if !USE_ERROR_CHECKING +# define NDEBUG +#endif + +#include #include +#include #include #include #include -//#include + +#if !USE_SYSTEM_MALLOC +# define PAGE_SIZE 4096 /* does not work on sparc/alpha */ +# include "malloc.c" +# define malloc(n) tiny_malloc (n) +# define realloc(p,n) tiny_realloc (p, n) +# define free(p) tiny_free (p) +#endif + +#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, @@ -50,6 +72,8 @@ 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 +85,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 +110,7 @@ char *p = s; do { - *p++ = '0' + n % base; + *p++ = "0123456789abcdef"[n % base]; n /= base; } while (n); @@ -98,27 +123,25 @@ } } -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); } +#if USE_CHAR_CLASSIFIERS +#include +#else + static char xtoupper (char c) { @@ -147,8 +170,10 @@ #define tolower(c) xtolower (c) #define isdigit(c) xisdigit (c) +#endif + #if USE_IGNORECASE -static const char * +ecb_cold static const char * xstrlwr (char *s) { const char *p = s; @@ -171,43 +196,41 @@ #endif #ifndef prompt -# define prompt "ts> " +# define prompt "ms> " #endif #ifndef InitFile # 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_BYTECODE, // temp + T_MACRO, T_CONTINUATION, T_FOREIGN, - T_CHARACTER, T_PORT, T_VECTOR, - T_MACRO, T_PROMISE, T_ENVIRONMENT, - /* one more... */ + T_SPECIAL, // #t, #f, '(), eof-object + T_NUM_SYSTEM_TYPES }; -#define T_MASKTYPE 0x000f -#define T_SYNTAX 0x0010 -#define T_IMMUTABLE 0x0020 -#define T_ATOM 0x0040 /* only for gc */ -#define T_MARK 0x0080 /* only for gc */ +#define T_MASKTYPE 0x001f +#define T_SYNTAX 0x0020 +#define T_IMMUTABLE 0x0040 +#define T_ATOM 0x0080 /* only for gc */ +//#define T_MARK 0x0080 /* only for gc */ /* num, for generic arithmetic */ struct num @@ -242,17 +265,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 +285,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 +294,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 +331,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 + 0) +#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 +348,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 +359,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 +374,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)); } @@ -360,16 +386,18 @@ static pointer caddr (pointer p) { return car (cdr (cdr (p))); } static pointer cdaar (pointer p) { return cdr (car (car (p))); } +static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); } + 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 +421,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 +455,7 @@ INTERFACE char * syntaxname (pointer p) { - return strvalue (car (p)); + return strvalue (p); } #define procnum(p) ivalue_unchecked (p) @@ -485,9 +513,15 @@ #define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) #define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) +#if 1 +#define is_mark(p) (CELL(p)->mark) +#define setmark(p) (CELL(p)->mark = 1) +#define clrmark(p) (CELL(p)->mark = 0) +#else #define is_mark(p) (typeflag (p) & T_MARK) #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) +#endif INTERFACE int is_immutable (pointer p) @@ -509,7 +543,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; @@ -558,6 +592,7 @@ } #if USE_CHAR_CLASSIFIERS + ecb_inline int Cisalpha (int c) { @@ -625,7 +660,7 @@ "us" }; -static int +ecb_cold static int is_ascii_name (const char *name, int *pc) { int i; @@ -653,11 +688,10 @@ 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); static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); static pointer mk_number (SCHEME_P_ const num n); static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); @@ -665,8 +699,9 @@ static pointer mk_atom (SCHEME_P_ char *q); static pointer mk_sharp_const (SCHEME_P_ char *name); -#if USE_PORTS static pointer mk_port (SCHEME_P_ port *p); + +#if USE_PORTS static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); static pointer port_from_file (SCHEME_P_ int, int prop); static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); @@ -675,14 +710,15 @@ static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); static void port_close (SCHEME_P_ pointer p, int flag); #endif + static void mark (pointer a); static void gc (SCHEME_P_ pointer a, pointer b); 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); -ecb_inline int skipspace (SCHEME_P); +static char *readstr_upto (SCHEME_P_ int skip, const char *delim); +static pointer readstrexp (SCHEME_P_ char delim); +static 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); @@ -858,31 +894,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 +908,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 +921,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; - newp = (pointer)cp; - SCHEME_V->cell_seg[i] = newp; - SCHEME_V->cell_segsize[i] = segsize; - SCHEME_V->fcells += segsize; - last = newp + segsize - 1; + newp = (struct cell *)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); + clrmark (cp); + 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 +960,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] >> 2; 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 +989,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 +1001,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 +1020,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 +1029,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 +1049,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,50 +1068,72 @@ /* Medium level cell allocation */ /* get new cons cell */ -pointer -xcons (SCHEME_P_ pointer a, pointer b, int immutable) +ecb_hot static pointer +xcons (SCHEME_P_ pointer a, pointer b) { pointer x = get_cell (SCHEME_A_ a, b); set_typeflag (x, T_PAIR); - if (immutable) - setimmutable (x); - set_car (x, a); set_cdr (x, b); return x; } +ecb_hot static pointer +ximmutable_cons (SCHEME_P_ pointer a, pointer b) +{ + pointer x = xcons (SCHEME_A_ a, b); + setimmutable (x); + return x; +} + +#define cons(a,b) xcons (SCHEME_A_ a, b) +#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b) + +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 = (unsigned char *)key; + uint32_t hash = 2166136261U; + + 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 +1154,7 @@ return NIL; } -static pointer +ecb_cold static pointer oblist_all_symbols (SCHEME_P) { int i; @@ -1143,13 +1170,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 +1195,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; @@ -1188,26 +1211,24 @@ #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 +1238,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 +1248,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 anything, doesn't cost anything */ + set_ivalue (x, n); + + *pp = x; + } + + return *pp; } INTERFACE pointer @@ -1241,7 +1276,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 +1310,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 +1338,7 @@ set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, str, 0); strlength (x) = len; + return x; } @@ -1336,6 +1363,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 +1397,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 +1495,7 @@ } /* make constant */ -static pointer +ecb_cold static pointer mk_sharp_const (SCHEME_P_ char *name) { if (!strcmp (name, "t")) @@ -1477,6 +1506,7 @@ { int c; + // TODO: optimise if (stricmp (name + 1, "space") == 0) c = ' '; else if (stricmp (name + 1, "newline") == 0) @@ -1485,6 +1515,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); @@ -1508,10 +1548,10 @@ else { /* identify base by string index */ - const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x"; + const char baseidx[18] = "ffbf" "ffff" "ofdf" "ffff" "x"; char *base = strchr (baseidx, *name); - if (base) + if (base && *base) return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx)); return NIL; @@ -1520,6 +1560,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 +1588,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 +1655,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 +1726,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,67 +1742,17 @@ 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 int fin; if (SCHEME_V->file_i == MAXFIL - 1) @@ -1711,7 +1768,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; @@ -1722,13 +1779,9 @@ } return fin >= 0; - -#else - return 1; -#endif } -static void +ecb_cold static void file_pop (SCHEME_P) { if (SCHEME_V->file_i != 0) @@ -1738,24 +1791,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 +1841,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 +1852,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 +1867,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 +1878,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 +1894,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 +1907,7 @@ # define BLOCK_SIZE 256 -static port * +ecb_cold static port * port_rep_from_scratch (SCHEME_P) { char *start; @@ -1878,7 +1931,7 @@ return pt; } -static pointer +ecb_cold static pointer port_from_scratch (SCHEME_P) { port *pt = port_rep_from_scratch (SCHEME_A); @@ -1889,10 +1942,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; @@ -1919,13 +1972,11 @@ #endif /* get new character from input file */ -static int +ecb_cold static int 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; @@ -1945,12 +1996,9 @@ return c; } -static int ungot = -1; - -static int +ecb_cold static int basic_inchar (port *pt) { -#if USE_PORTS if (pt->unget != -1) { int r = pt->unget; @@ -1958,6 +2006,7 @@ return r; } +#if USE_PORTS if (pt->kind & port_file) { char c; @@ -1975,45 +2024,29 @@ return *pt->rep.string.curr++; } #else - if (ungot == -1) - { - char c; - if (!read (0, &c, 1)) - return EOF; + char c; - ungot = c; - } + if (!read (pt->rep.stdio.file, &c, 1)) + return EOF; - { - int r = ungot; - ungot = -1; - return r; - } + return c; #endif } /* back character to input buffer */ -static void +ecb_cold static void backchar (SCHEME_P_ int c) { -#if USE_PORTS - port *pt; + port *pt = port (SCHEME_V->inport); if (c == EOF) return; - pt = SCHEME_V->inport->object.port; pt->unget = c; -#else - if (c == EOF) - return; - - ungot = c; -#endif } #if USE_PORTS -static int +ecb_cold static int realloc_port_string (SCHEME_P_ port *p) { char *start = p->rep.string.start; @@ -2036,32 +2069,12 @@ } #endif -INTERFACE void -putstr (SCHEME_P_ const char *s) -{ -#if USE_PORTS - port *pt = SCHEME_V->outport->object.port; - - if (pt->kind & port_file) - write (pt->rep.stdio.file, s, strlen (s)); - else - for (; *s; s++) - if (pt->rep.string.curr != pt->rep.string.past_the_end) - *pt->rep.string.curr++ = *s; - else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) - *pt->rep.string.curr++ = *s; - -#else - xwrstr (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 USE_PORTS if (pt->kind & port_file) write (pt->rep.stdio.file, s, len); else @@ -2076,40 +2089,29 @@ } #else - write (1, s, len); + write (1, s, len); // output not initialised #endif } INTERFACE void -putcharacter (SCHEME_P_ int c) +putstr (SCHEME_P_ const char *s) { -#if USE_PORTS - port *pt = SCHEME_V->outport->object.port; - - if (pt->kind & port_file) - { - char cc = c; - write (pt->rep.stdio.file, &cc, 1); - } - else - { - if (pt->rep.string.curr != pt->rep.string.past_the_end) - *pt->rep.string.curr++ = c; - else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) - *pt->rep.string.curr++ = c; - } + putchars (SCHEME_A_ s, strlen (s)); +} -#else +INTERFACE void +putcharacter (SCHEME_P_ int c) +{ char cc = c; - write (1, &c, 1); -#endif + + putchars (SCHEME_A_ &cc, 1); } /* 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 +2127,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 +2145,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 +2170,27 @@ 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; + + // this overshoots the minimum requirements of r7rs + case ' ': + case '\t': + case '\r': + case '\n': + skipspace (SCHEME_A); + state = st_ok; + break; + + //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 +2201,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 +2230,7 @@ } else { - if (state == st_oct2 && c1 >= 32) + if (state == st_oct2 && c1 >= ' ') return S_F; c1 = (c1 << 3) + (c - '0'); @@ -2259,23 +2245,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 +2265,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 +2282,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 +2309,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 +2395,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 +2460,8 @@ putcharacter (SCHEME_A_ '"'); } - /* print atoms */ -static void +ecb_cold static void printatom (SCHEME_P_ pointer l, int f) { char *p; @@ -2490,9 +2471,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; @@ -2635,12 +2615,15 @@ p = symname (l); else if (is_proc (l)) { + p = (char *)procname (l); // ok with r7rs display, but not r7rs write +#if 0 #if USE_PRINTF p = SCHEME_V->strbuff; - snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l)); + snprintf (p, STRBUFFSIZE, " PROCEDURE %ld>", procname (l), procnum (l)); #else p = "#"; #endif +#endif } else if (is_macro (l)) p = "#"; @@ -2660,7 +2643,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 +2692,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 +2718,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 +2736,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 +2755,7 @@ } /* equivalence of atoms */ -int +ecb_hot int eqv (pointer a, pointer b) { if (is_string (a)) @@ -2815,21 +2805,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 +2830,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 +2852,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 +2890,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 +2915,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,14 +2948,9 @@ /* ========== Evaluation Cycle ========== */ -static int +ecb_cold static int xError_1 (SCHEME_P_ const char *s, pointer a) { -#if USE_ERROR_HOOK - pointer x; - pointer hdl = SCHEME_V->ERROR_HOOK; -#endif - #if USE_PRINTF #if SHOW_ERROR_LINE char sbuf[STRBUFFSIZE]; @@ -2993,7 +2975,7 @@ #endif #if USE_ERROR_HOOK - x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); + pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1); if (x != NIL) { @@ -3047,14 +3029,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 +3052,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 +3073,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 +3088,7 @@ dump_stack_reset (SCHEME_A); } -static void +ecb_cold static void dump_stack_free (SCHEME_P) { free (SCHEME_V->dump_base); @@ -3115,7 +3097,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 +3113,7 @@ } } -static pointer +ecb_cold static pointer ss_get_cont (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3153,7 +3135,7 @@ return cont; } -static void +ecb_cold static void ss_set_cont (SCHEME_P_ pointer cont) { int i = 0; @@ -3175,25 +3157,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 +3195,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 +3205,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 +3227,490 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) +#if EXPERIMENT + static int +dtree (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"); + dtree (SCHEME_A_ indent + 3, cdr(x)); + return 32 + dtree (SCHEME_A_ indent + 3, car (x)); + + case T_PAIR: + printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); + c = dtree (SCHEME_A_ indent + 3, car (x)); + c += dtree (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 + dtree (SCHEME_A_ indent + 3, car (x)); + + default: + printf ("unhandled type %d\n", type (x)); + break; + } +} + +#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0) + +typedef void *stream[1]; + +#define stream_init() { 0 } +#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2) +#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2) +#define stream_free(s) free (s[0]) + +ecb_cold static void +stream_put (stream s, uint8_t byte) +{ + uint32_t *sp = *s; + uint32_t size = sizeof (uint32_t) * 2; + uint32_t offs = size; + + if (ecb_expect_true (sp)) + { + offs = sp[0]; + size = sp[1]; + } + + if (ecb_expect_false (offs == size)) + { + size *= 2; + sp = realloc (sp, size); + *s = sp; + sp[1] = size; + + } + + ((uint8_t *)sp)[offs++] = byte; + sp[0] = offs; +} + +ecb_cold static void +stream_put_v (stream s, uint32_t v) +{ + while (v > 0x7f) + { + stream_put (s, v | 0x80); + v >>= 7; + } + + stream_put (s, v); +} + +ecb_cold static void +stream_put_tv (stream s, int bop, uint32_t v) +{ + printf ("put tv %d %d\n", bop, v);//D + stream_put (s, bop); + stream_put_v (s, v); +} + +ecb_cold static void +stream_put_stream (stream s, stream o) +{ + uint32_t i; + + for (i = 0; i < stream_size (o); ++i) + stream_put (s, stream_data (o)[i]); + + stream_free (o); +} + +ecb_cold static uint32_t +cell_id (SCHEME_P_ pointer x) +{ + struct cell *p = CELL (x); + int i; + + for (i = SCHEME_V->last_cell_seg; i >= 0; --i) + if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i]) + return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG); + + abort (); +} + +// calculates a (preferably small) integer that makes it possible to find +// the symbol again. if pointers were offsets into a memory area... until +// then, we return segment number in the low bits, and offset in the high +// bits. +// also, this function must never return 0. +ecb_cold static uint32_t +symbol_id (SCHEME_P_ pointer sym) +{ + return cell_id (SCHEME_A_ sym); +} + +enum byteop +{ + BOP_NIL, + BOP_INTEGER, + BOP_SYMBOL, + BOP_DATUM, + BOP_LIST_BEG, + BOP_LIST_END, + BOP_IF, + BOP_AND, + BOP_OR, + BOP_CASE, + BOP_COND, + BOP_LET, + BOP_LETAST, + BOP_LETREC, + BOP_DEFINE, + BOP_MACRO, + BOP_SET, + BOP_BEGIN, + BOP_LAMBDA, + BOP_DELAY, + BOP_OP, +}; + +ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x); + +ecb_cold static void +compile_list (SCHEME_P_ stream s, pointer x) +{ + // TODO: improper list + + for (; x != NIL; x = cdr (x)) + { + stream t = stream_init (); + compile_expr (SCHEME_A_ t, car (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); + } + + stream_put_v (s, 0); +} + +static void +compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff) +{ + stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift); + + stream_put (s, BOP_IF); + compile_expr (SCHEME_A_ s, cond); + stream_put_v (s, stream_size (sift)); + stream_put_stream (s, sift); + compile_expr (SCHEME_A_ s, iff); +} + +typedef uint32_t stream_fixup; + +static stream_fixup +stream_put_fixup (stream s) +{ + stream_put (s, 0); + stream_put (s, 0); + + return stream_size (s); +} + +static void +stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target) +{ + target -= fixup; + assert (target < (1 << 14)); + stream_data (s)[fixup - 2] = target | 0x80; + stream_data (s)[fixup - 1] = target >> 7; +} + +static void +compile_and_or (SCHEME_P_ stream s, int and, pointer x) +{ + for (; cdr (x) != NIL; x = cdr (x)) + { + stream t = stream_init (); + compile_expr (SCHEME_A_ t, car (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); + } + + stream_put_v (s, 0); +} + +static void +compile_case (SCHEME_P_ stream s, pointer x) +{ + compile_expr (SCHEME_A_ s, caar (x)); + + for (;;) + { + x = cdr (x); + + if (x == NIL) + break; + + compile_expr (SCHEME_A_ s, caar (x)); + stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); + } + + stream_put_v (s, 0); +} + +static void +compile_cond (SCHEME_P_ stream s, pointer x) +{ + for ( ; x != NIL; x = cdr (x)) + { + compile_expr (SCHEME_A_ s, caar (x)); + stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x)); + stream_put_v (s, stream_size (t)); + stream_put_stream (s, t); + } + + stream_put_v (s, 0); +} + +static pointer +lookup (SCHEME_P_ pointer x) +{ + x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1); + + if (x != NIL) + x = slot_value_in_env (x); + + return x; +} + +ecb_cold static void +compile_expr (SCHEME_P_ stream s, pointer x) +{ + if (x == NIL) + { + stream_put (s, BOP_NIL); + return; + } + + if (is_pair (x)) + { + pointer head = car (x); + + if (is_syntax (head)) + { + int syn = syntaxnum (head); + x = cdr (x); + + switch (syntaxnum (head)) + { + case OP_IF0: /* if */ + stream_put_v (s, BOP_IF); + compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x)); + break; + + case OP_OR0: /* or */ + stream_put_v (s, BOP_OR); + compile_and_or (SCHEME_A_ s, 0, x); + break; + + case OP_AND0: /* and */ + stream_put_v (s, BOP_AND); + compile_and_or (SCHEME_A_ s, 1, x); + break; + + case OP_CASE0: /* case */ + stream_put_v (s, BOP_CASE); + compile_case (SCHEME_A_ s, x); + break; + + case OP_COND0: /* cond */ + stream_put_v (s, BOP_COND); + compile_cond (SCHEME_A_ s, x); + break; + + case OP_LET0: /* let */ + case OP_LET0AST: /* let* */ + case OP_LET0REC: /* letrec */ + switch (syn) + { + case OP_LET0: stream_put (s, BOP_LET ); break; + case OP_LET0AST: stream_put (s, BOP_LETAST); break; + case OP_LET0REC: stream_put (s, BOP_LETREC); break; + } + + { + pointer bindings = car (x); + pointer body = cadr (x); + + for (x = bindings; x != NIL; x = cdr (x)) + { + pointer init = NIL; + pointer var = car (x); + + if (is_pair (var)) + { + init = cdr (var); + var = car (var); + } + + stream_put_v (s, symbol_id (SCHEME_A_ var)); + compile_expr (SCHEME_A_ s, init); + } + + stream_put_v (s, 0); + compile_expr (SCHEME_A_ s, body); + } + break; + + case OP_DEF0: /* define */ + case OP_MACRO0: /* macro */ + stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO); + stream_put_v (s, cell_id (SCHEME_A_ car (x))); + compile_expr (SCHEME_A_ s, cadr (x)); + break; + + case OP_SET0: /* set! */ + stream_put (s, BOP_SET); + stream_put_v (s, symbol_id (SCHEME_A_ car (x))); + compile_expr (SCHEME_A_ s, cadr (x)); + break; + + case OP_BEGIN: /* begin */ + stream_put (s, BOP_BEGIN); + compile_list (SCHEME_A_ s, x); + return; + + case OP_QUOTE: /* quote */ + stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x)); + break; + + case OP_DELAY: /* delay */ + case OP_LAMBDA: /* lambda */ + { + pointer formals = car (x); + pointer body = cadr (x); + + stream_put (s, syn == OP_LAMBDA ? BOP_LAMBDA : BOP_DELAY); + + for (; is_pair (formals); formals = cdr (formals)) + stream_put_v (s, symbol_id (SCHEME_A_ car (formals))); + + stream_put_v (s, 0); + stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals)); + + compile_expr (SCHEME_A_ s, body); + } + break; + + case OP_C0STREAM:/* cons-stream */ + abort (); + break; + } + + return; + } + + pointer m = lookup (SCHEME_A_ head); + + if (is_macro (m)) + { + s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code); + SCHEME_V->code = m; + SCHEME_V->args = cons (x, NIL); + Eval_Cycle (SCHEME_A_ OP_APPLY); + x = SCHEME_V->value; + compile_expr (SCHEME_A_ s, SCHEME_V->value); + return; + } + + stream_put (s, BOP_LIST_BEG); + + for (; x != NIL; x = cdr (x)) + compile_expr (SCHEME_A_ s, car (x)); + + stream_put (s, BOP_LIST_END); + return; + } + + switch (type (x)) + { + case T_INTEGER: + { + IVALUE iv = ivalue_unchecked (x); + iv = iv < 0 ? ((~(uint32_t)iv) << 1) | 1 : (uint32_t)iv << 1; + stream_put_tv (s, BOP_INTEGER, iv); + } + return; + + case T_SYMBOL: + if (0) + { + // no can do without more analysis + pointer m = lookup (SCHEME_A_ x); + + if (is_proc (m)) + { + printf ("compile proc %s %d\n", procname(m), procnum(m)); + stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m)); + } + else + stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x)); + } + + stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x)); + return; + + default: + stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x)); + break; + } +} + +ecb_cold static int +compile_closure (SCHEME_P_ pointer p) +{ + stream s = stream_init (); + + compile_list (SCHEME_A_ s, cdar (p)); + + FILE *xxd = popen ("xxd", "we"); + fwrite (stream_data (s), 1, stream_size (s), xxd); + fclose (xxd); + + return stream_size (s); +} + +#endif + +/* syntax, eval, core, ... */ +ecb_hot static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -3253,25 +3718,37 @@ switch (op) { +#if EXPERIMENT //D + case OP_DEBUG: + { + uint32_t len = compile_closure (SCHEME_A_ car (args)); + printf ("len = %d\n", len); + printf ("\n"); + s_return (S_T); + } + + case OP_DEBUG2: + return -1; +#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))); + putcharacter (SCHEME_A_ '\n'); } if (!file_push (SCHEME_A_ strvalue (car (args)))) Error_1 ("unable to open", car (args)); - else - { - SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); - s_goto (OP_T0LVL); - } + + SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); + s_goto (OP_T0LVL); 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) { @@ -3292,7 +3769,10 @@ { SCHEME_V->envir = SCHEME_V->global_env; dump_stack_reset (SCHEME_A); - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); +#if EXPERIMENT + system ("ps v $PPID"); +#endif putstr (SCHEME_A_ prompt); } @@ -3337,8 +3817,8 @@ SCHEME_V->args = SCHEME_V->value; s_goto (OP_P0LIST); } - else - s_return (SCHEME_V->value); + + s_return (SCHEME_V->value); case OP_EVAL: /* main part of evaluation */ #if USE_TRACING @@ -3359,10 +3839,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)) { @@ -3381,22 +3861,20 @@ s_goto (OP_EVAL); } } - else - s_return (SCHEME_V->code); + + 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); SCHEME_V->code = SCHEME_V->value; s_goto (OP_APPLY); } - else - { - SCHEME_V->code = cdr (SCHEME_V->code); - s_goto (OP_E1ARGS); - } + + SCHEME_V->code = cdr (SCHEME_V->code); + s_goto (OP_E1ARGS); case OP_E1ARGS: /* eval arguments */ args = cons (SCHEME_V->value, args); @@ -3417,7 +3895,6 @@ } #if USE_TRACING - case OP_TRACING: { int tr = SCHEME_V->tracing; @@ -3425,7 +3902,6 @@ SCHEME_V->tracing = ivalue_unchecked (car (args)); s_return (mk_integer (SCHEME_A_ tr)); } - #endif case OP_APPLY: /* apply 'code' to 'args' */ @@ -3449,7 +3925,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); } @@ -3489,15 +3965,13 @@ ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); s_return (args != NIL ? car (args) : NIL); } - else - Error_0 ("illegal function"); + + Error_0 ("illegal function"); case OP_DOMACRO: /* do macro */ 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 +3987,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); @@ -3573,7 +4040,6 @@ s_return (SCHEME_V->code); - case OP_DEFP: /* defined? */ x = SCHEME_V->envir; @@ -3601,7 +4067,6 @@ else Error_1 ("set!: unbound variable:", SCHEME_V->code); - case OP_BEGIN: /* begin */ if (!is_pair (SCHEME_V->code)) s_return (SCHEME_V->code); @@ -3622,6 +4087,7 @@ SCHEME_V->code = car (SCHEME_V->code); else SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ + s_goto (OP_EVAL); case OP_LET0: /* let */ @@ -3631,25 +4097,25 @@ s_goto (OP_LET1); case OP_LET1: /* let (calculate parameters) */ + case OP_LET1REC: /* letrec (calculate parameters) */ args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) - Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); + Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code)); - s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); + s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } - else /* end */ - { - args = reverse_in_place (SCHEME_A_ NIL, args); - SCHEME_V->code = car (args); - SCHEME_V->args = cdr (args); - s_goto (OP_LET2); - } + + /* end */ + args = reverse_in_place (SCHEME_A_ NIL, args); + SCHEME_V->code = car (args); + SCHEME_V->args = cdr (args); + s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC); case OP_LET2: /* let */ new_frame_in_env (SCHEME_A_ SCHEME_V->envir); @@ -3663,10 +4129,10 @@ for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) { if (!is_pair (x)) - Error_1 ("Bad syntax of binding in let :", x); + Error_1 ("Bad syntax of binding in let:", x); if (!is_list (SCHEME_A_ car (x))) - Error_1 ("Bad syntax of binding in let :", car (x)); + Error_1 ("Bad syntax of binding in let:", car (x)); args = cons (caar (x), args); } @@ -3693,7 +4159,7 @@ } if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) - Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); + Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code)); s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); SCHEME_V->code = car (cdaar (SCHEME_V->code)); @@ -3714,12 +4180,12 @@ SCHEME_V->args = NIL; s_goto (OP_EVAL); } - else /* end */ - { - SCHEME_V->code = args; - SCHEME_V->args = NIL; - s_goto (OP_BEGIN); - } + + /* end */ + + SCHEME_V->code = args; + SCHEME_V->args = NIL; + s_goto (OP_BEGIN); case OP_LET0REC: /* letrec */ new_frame_in_env (SCHEME_A_ SCHEME_V->envir); @@ -3728,26 +4194,7 @@ SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_LET1REC); - case OP_LET1REC: /* letrec (calculate parameters) */ - args = cons (SCHEME_V->value, args); - - if (is_pair (SCHEME_V->code)) /* continue */ - { - if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) - Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); - - s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code)); - SCHEME_V->code = cadar (SCHEME_V->code); - SCHEME_V->args = NIL; - s_goto (OP_EVAL); - } - else /* end */ - { - args = reverse_in_place (SCHEME_A_ NIL, args); - SCHEME_V->code = car (args); - SCHEME_V->args = cdr (args); - s_goto (OP_LET2REC); - } + /* OP_LET1REC handled by OP_LET1 */ case OP_LET2REC: /* letrec */ for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) @@ -3787,12 +4234,10 @@ { if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) s_return (NIL); - else - { - s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); - SCHEME_V->code = caar (SCHEME_V->code); - s_goto (OP_EVAL); - } + + s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); + SCHEME_V->code = caar (SCHEME_V->code); + s_goto (OP_EVAL); } case OP_DELAY: /* delay */ @@ -3813,12 +4258,10 @@ s_return (SCHEME_V->value); else if (SCHEME_V->code == NIL) s_return (SCHEME_V->value); - else - { - s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); - SCHEME_V->code = car (SCHEME_V->code); - s_goto (OP_EVAL); - } + + s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); + SCHEME_V->code = car (SCHEME_V->code); + s_goto (OP_EVAL); case OP_OR0: /* or */ if (SCHEME_V->code == NIL) @@ -3833,12 +4276,10 @@ s_return (SCHEME_V->value); else if (SCHEME_V->code == NIL) s_return (SCHEME_V->value); - else - { - s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); - SCHEME_V->code = car (SCHEME_V->code); - s_goto (OP_EVAL); - } + + s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); + SCHEME_V->code = car (SCHEME_V->code); + s_goto (OP_EVAL); case OP_C0STREAM: /* cons-stream */ s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); @@ -3913,14 +4354,14 @@ s_goto (OP_EVAL); } } - else - s_return (NIL); + + s_return (NIL); case OP_CASE2: /* case */ if (is_true (SCHEME_V->value)) s_goto (OP_BEGIN); - else - s_return (NIL); + + s_return (NIL); case OP_PAPPLY: /* apply */ SCHEME_V->code = car (args); @@ -3944,7 +4385,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 +4397,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); - 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); + } - if (r == (RVALUE)(IVALUE)r) - s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); - else - Error_1 ("inexact->exact: not integral:", x); - } + s_return (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 +4425,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 +4461,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 +4558,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 +4772,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 +4845,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 +4877,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 +4909,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 +4920,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 +4967,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 +4991,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 */ @@ -4558,6 +5021,7 @@ s_goto (OP_P0LIST); + //TODO: move to scheme case OP_NEWLINE: /* newline */ if (is_pair (args)) { @@ -4569,7 +5033,7 @@ } } - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); s_return (S_T); #endif @@ -4588,7 +5052,7 @@ s_goto (OP_ERR1); case OP_ERR1: /* error */ - putstr (SCHEME_A_ " "); + putcharacter (SCHEME_A_ ' '); if (args != NIL) { @@ -4599,7 +5063,7 @@ } else { - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); if (SCHEME_V->interactive_repl) s_goto (OP_T0LVL); @@ -4686,12 +5150,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 +5234,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 +5281,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 +5352,7 @@ if (is_pair (args)) p = car (args); - res = p->object.port->kind & port_string; + res = port (p)->kind & port_string; s_retbool (res); } @@ -4907,7 +5371,6 @@ { case TOK_EOF: s_return (S_EOF); - /* NOTREACHED */ case TOK_VEC: s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); @@ -4920,12 +5383,10 @@ s_return (NIL); else if (SCHEME_V->tok == TOK_DOT) Error_0 ("syntax error: illegal dot expression"); - else - { - SCHEME_V->nesting_stack[SCHEME_V->file_i]++; - s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); - s_goto (OP_RDSEXPR); - } + + SCHEME_V->nesting_stack[SCHEME_V->file_i]++; + s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); + s_goto (OP_RDSEXPR); case TOK_QUOTE: s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); @@ -4941,9 +5402,8 @@ SCHEME_V->tok = TOK_LPAREN; s_goto (OP_RDSEXPR); } - else - s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); + s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); s_goto (OP_RDSEXPR); case TOK_COMMA: @@ -4957,10 +5417,20 @@ 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: + //TODO: haven't checked whether the garbage collector could interfere and free x + gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded + x = readstrexp (SCHEME_A_ '|'); + 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"); @@ -4974,18 +5444,16 @@ if (f == NIL) Error_0 ("undefined sharp expression"); - else - { - SCHEME_V->code = cons (slot_value_in_env (f), NIL); - s_goto (OP_EVAL); - } + + SCHEME_V->code = cons (slot_value_in_env (f), NIL); + s_goto (OP_EVAL); } 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); + + s_return (x); default: Error_0 ("syntax error: illegal token"); @@ -5088,16 +5556,16 @@ SCHEME_V->args = car (b); if (a == SCHEME_V->QUOTE && ok_abbr) - putstr (SCHEME_A_ "'"); + putcharacter (SCHEME_A_ '\''); else if (a == SCHEME_V->QQUOTE && ok_abbr) - putstr (SCHEME_A_ "`"); + putcharacter (SCHEME_A_ '`'); else if (a == SCHEME_V->UNQUOTE && ok_abbr) - putstr (SCHEME_A_ ","); + putcharacter (SCHEME_A_ ','); else if (a == SCHEME_V->UNQUOTESP && ok_abbr) putstr (SCHEME_A_ ",@"); else { - putstr (SCHEME_A_ "("); + putcharacter (SCHEME_A_ '('); s_save (SCHEME_A_ OP_P1LIST, b, NIL); SCHEME_V->args = a; } @@ -5109,7 +5577,7 @@ if (is_pair (args)) { s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); - putstr (SCHEME_A_ " "); + putcharacter (SCHEME_A_ ' '); SCHEME_V->args = car (args); s_goto (OP_P0LIST); } @@ -5127,31 +5595,31 @@ printatom (SCHEME_A_ args, SCHEME_V->print_flag); } - putstr (SCHEME_A_ ")"); + putcharacter (SCHEME_A_ ')'); s_return (S_T); } case OP_PVECFROM: { - int i = ivalue_unchecked (cdr (args)); + IVALUE i = ivalue_unchecked (cdr (args)); pointer vec = car (args); - int len = veclength (vec); + uint32_t len = veclength (vec); if (i == len) { - putstr (SCHEME_A_ ")"); + putcharacter (SCHEME_A_ ')'); s_return (S_T); } else { pointer elem = vector_get (vec, i); - ivalue_unchecked (cdr (args)) = i + 1; + set_cdr (args, mk_integer (SCHEME_A_ i + 1)); s_save (SCHEME_A_ OP_PVECFROM, args, NIL); SCHEME_V->args = elem; if (i > 0) - putstr (SCHEME_A_ " "); + putcharacter (SCHEME_A_ ' '); s_goto (OP_P0LIST); } @@ -5161,7 +5629,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; @@ -5194,26 +5663,24 @@ if (is_pair (y)) s_return (car (y)); - else - s_return (S_F); + s_return (S_F); case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ SCHEME_V->args = a; if (SCHEME_V->args == NIL) s_return (S_F); - else if (is_closure (SCHEME_V->args)) - s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); - else if (is_macro (SCHEME_V->args)) + else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args)) s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); - else - s_return (S_F); + + s_return (S_F); case OP_CLOSUREP: /* closure? */ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t + * (schmorp) well, obviously not, fix? TODO */ s_retbool (is_closure (a)); @@ -5228,19 +5695,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 +5761,7 @@ #undef OP_DEF ; -static const char * +ecb_cold static const char * opname (int idx) { const char *name = opnames; @@ -5305,7 +5773,7 @@ return *name ? name : "ILLEGAL"; } -static const char * +ecb_cold static const char * procname (pointer x) { return opname (procnum (x)); @@ -5335,7 +5803,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 +5896,7 @@ if (SCHEME_V->no_memory && USE_ERROR_CHECKING) { - xwrstr ("No memory!\n"); + putstr (SCHEME_A_ "No memory!\n"); return; } } @@ -5436,14 +5904,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); @@ -5456,17 +5924,17 @@ { pointer y = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (y, (T_PROC | T_ATOM)); - ivalue_unchecked (y) = op; + set_ivalue (y, op); return y; } /* 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') @@ -5550,7 +6018,12 @@ 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); @@ -5572,7 +6045,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; @@ -5582,29 +6055,30 @@ SCHEME_V->gc_verbose = 0; dump_stack_initialize (SCHEME_A); - SCHEME_V->code = NIL; - SCHEME_V->args = NIL; + SCHEME_V->code = NIL; + SCHEME_V->args = NIL; SCHEME_V->envir = NIL; + SCHEME_V->value = NIL; SCHEME_V->tracing = 0; /* init NIL */ - set_typeflag (NIL, T_ATOM | T_MARK); + set_typeflag (NIL, T_SPECIAL | T_ATOM); set_car (NIL, NIL); set_cdr (NIL, NIL); /* init T */ - set_typeflag (S_T, T_ATOM | T_MARK); + set_typeflag (S_T, T_SPECIAL | T_ATOM); set_car (S_T, S_T); set_cdr (S_T, S_T); /* init F */ - set_typeflag (S_F, T_ATOM | T_MARK); + set_typeflag (S_F, T_SPECIAL | T_ATOM); set_car (S_F, S_F); set_cdr (S_F, S_F); /* init EOF_OBJ */ - set_typeflag (S_EOF, T_ATOM | T_MARK); + set_typeflag (S_EOF, T_SPECIAL | T_ATOM); set_car (S_EOF, S_EOF); set_cdr (S_EOF, S_EOF); /* init sink */ - set_typeflag (S_SINK, T_PAIR | T_MARK); + set_typeflag (S_SINK, T_PAIR); set_car (S_SINK, NIL); /* init c_nest */ @@ -5615,8 +6089,7 @@ new_frame_in_env (SCHEME_A_ NIL); SCHEME_V->global_env = SCHEME_V->envir; /* init else */ - x = mk_symbol (SCHEME_A_ "else"); - new_slot_in_env (SCHEME_A_ x, S_T); + new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T); { static const char *syntax_names[] = { @@ -5650,32 +6123,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; @@ -5717,29 +6190,27 @@ gc (SCHEME_A_ NIL, NIL); for (i = 0; i <= SCHEME_V->last_cell_seg; i++) - free (SCHEME_V->alloc_seg[i]); + free (SCHEME_V->cell_seg[i]); #if SHOW_ERROR_LINE for (i = 0; i <= SCHEME_V->file_i; i++) - { - if (SCHEME_V->load_stack[i].kind & port_file) - { - fname = SCHEME_V->load_stack[i].rep.stdio.filename; - - if (fname) - free (fname); - } - } + if (SCHEME_V->load_stack[i].kind & port_file) + { + fname = SCHEME_V->load_stack[i].rep.stdio.filename; + + if (fname) + free (fname); + } #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); @@ -5748,15 +6219,11 @@ SCHEME_V->load_stack[0].unget = -1; SCHEME_V->load_stack[0].kind = port_input | port_file; SCHEME_V->load_stack[0].rep.stdio.file = fin; -#if USE_PORTS SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); -#endif SCHEME_V->retcode = 0; -#if USE_PORTS if (fin == STDIN_FILENO) SCHEME_V->interactive_repl = 1; -#endif #if USE_PORTS #if SHOW_ERROR_LINE @@ -5770,15 +6237,17 @@ SCHEME_V->inport = SCHEME_V->loadport; SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); Eval_Cycle (SCHEME_A_ OP_T0LVL); + set_typeflag (SCHEME_V->loadport, T_ATOM); if (SCHEME_V->retcode == 0) SCHEME_V->retcode = SCHEME_V->nesting != 0; } -void +ecb_cold void scheme_load_string (SCHEME_P_ const char *cmd) { +#if USE_PORTs dump_stack_reset (SCHEME_A); SCHEME_V->envir = SCHEME_V->global_env; SCHEME_V->file_i = 0; @@ -5786,9 +6255,7 @@ SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; -#if USE_PORTS SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); -#endif SCHEME_V->retcode = 0; SCHEME_V->interactive_repl = 0; SCHEME_V->inport = SCHEME_V->loadport; @@ -5798,9 +6265,12 @@ if (SCHEME_V->retcode == 0) SCHEME_V->retcode = SCHEME_V->nesting != 0; +#else + abort (); +#endif } -void +ecb_cold void scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) { pointer x; @@ -5815,13 +6285,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 +6300,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 +6320,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 +6331,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 +6348,7 @@ return SCHEME_V->value; } -pointer +ecb_cold pointer scheme_eval (SCHEME_P_ pointer obj) { int old_repl = SCHEME_V->interactive_repl; @@ -5900,7 +6370,7 @@ #if STANDALONE -int +ecb_cold int main (int argc, char **argv) { # if USE_MULTIPLICITY @@ -5912,22 +6382,25 @@ char *file_name = InitFile; int retcode; int isfile = 1; +#if EXPERIMENT + system ("ps v $PPID"); +#endif 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; } @@ -5950,7 +6423,6 @@ do { -#if USE_PORTS if (strcmp (file_name, "-") == 0) fin = STDIN_FILENO; else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) @@ -5978,11 +6450,12 @@ } else fin = open (file_name, O_RDONLY); -#endif 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); + putcharacter (SCHEME_A_ '\n'); } else { @@ -5991,18 +6464,18 @@ else scheme_load_string (SCHEME_A_ file_name); -#if USE_PORTS if (!isfile || fin != STDIN_FILENO) { 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); + putcharacter (SCHEME_A_ '\n'); } if (isfile) close (fin); } -#endif } file_name = *argv++;