--- microscheme/scheme.c 2015/11/30 13:09:56 1.49 +++ microscheme/scheme.c 2015/12/02 07:43:46 1.61 @@ -18,10 +18,10 @@ * */ -#define EXPERIMENT 1 +#define _GNU_SOURCE 1 +#define _POSIX_C_SOURCE 200201 +#define _XOPEN_SOURCE 600 -#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ -#include "malloc.c" #define SCHEME_SOURCE #include "scheme-private.h" @@ -49,7 +49,14 @@ #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 \ @@ -81,17 +88,17 @@ #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) @@ -103,7 +110,7 @@ char *p = s; do { - *p++ = '0' + n % base; + *p++ = "0123456789abcdef"[n % base]; n /= base; } while (n); @@ -116,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) { @@ -165,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; @@ -196,28 +203,25 @@ # 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_NUM_SYSTEM_TYPES }; @@ -260,17 +264,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 @@ -279,8 +284,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) @@ -288,8 +293,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); @@ -325,15 +330,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 @@ -342,6 +347,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) { @@ -351,13 +358,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 @@ -366,8 +373,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)); } @@ -381,13 +388,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 @@ -527,7 +534,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; @@ -576,6 +583,7 @@ } #if USE_CHAR_CLASSIFIERS + ecb_inline int Cisalpha (int c) { @@ -643,7 +651,7 @@ "us" }; -static int +ecb_cold static int is_ascii_name (const char *name, int *pc) { int i; @@ -672,10 +680,9 @@ static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); ecb_inline int is_one_of (const char *s, int c); -static int alloc_cellseg (SCHEME_P_ int n); +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); @@ -683,8 +690,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); @@ -693,6 +701,7 @@ 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); @@ -876,31 +885,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) { @@ -915,12 +899,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; @@ -928,37 +912,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 = (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); - } + newp = (struct cell *)cp; + SCHEME_V->cell_seg[i] = newp; + SCHEME_V->cell_segsize[i] = segsize; + SCHEME_V->fcells += segsize; + last = newp + segsize - 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. */ @@ -972,14 +951,14 @@ if (SCHEME_V->free_cell == NIL) { - const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; + 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; @@ -1001,8 +980,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); @@ -1014,7 +992,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); @@ -1042,8 +1020,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); @@ -1062,10 +1040,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 @@ -1081,23 +1059,31 @@ /* 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; } -static pointer +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); @@ -1113,7 +1099,7 @@ static int hash_fn (const char *key, int table_size) { - const unsigned char *p = key; + const unsigned char *p = (unsigned char *)key; uint32_t hash = 2166136261; while (*p) @@ -1122,14 +1108,14 @@ return hash % table_size; } -static pointer +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) { pointer x = generate_symbol (SCHEME_A_ name); @@ -1138,7 +1124,7 @@ return x; } -ecb_inline pointer +ecb_cold static pointer oblist_find_by_name (SCHEME_P_ const char *name) { int location; @@ -1159,7 +1145,7 @@ return NIL; } -static pointer +ecb_cold static pointer oblist_all_symbols (SCHEME_P) { int i; @@ -1175,13 +1161,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; @@ -1200,7 +1186,7 @@ } /* returns the new symbol */ -static pointer +ecb_cold static pointer oblist_add_by_name (SCHEME_P_ const char *name) { pointer x = generate_symbol (SCHEME_A_ name); @@ -1208,7 +1194,7 @@ return x; } -static pointer +ecb_cold static pointer oblist_all_symbols (SCHEME_P) { return SCHEME_V->oblist; @@ -1216,26 +1202,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; + CELL(x)->object.ff = f; return x; } @@ -1404,7 +1388,7 @@ return x; } -INTERFACE pointer +ecb_cold INTERFACE pointer gensym (SCHEME_P) { pointer x; @@ -1421,7 +1405,7 @@ } /* make symbol or number atom from string */ -static pointer +ecb_cold static pointer mk_atom (SCHEME_P_ char *q) { char c, *p; @@ -1502,7 +1486,7 @@ } /* make constant */ -static pointer +ecb_cold static pointer mk_sharp_const (SCHEME_P_ char *name) { if (!strcmp (name, "t")) @@ -1513,6 +1497,7 @@ { int c; + // TODO: optimise if (stricmp (name + 1, "space") == 0) c = ' '; else if (stricmp (name + 1, "newline") == 0) @@ -1521,6 +1506,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); @@ -1556,6 +1551,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, @@ -1565,7 +1579,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; @@ -1632,11 +1646,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) @@ -1679,68 +1734,16 @@ SCHEME_V->free_cell = NIL; if (SCHEME_V->gc_verbose) - xwrstr ("freeing..."); - - uint32_t total = 0; - - /* Here we scan the cells to build the free-list. */ - for (i = SCHEME_V->last_cell_seg; i >= 0; i--) - { - pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; - total += SCHEME_V->cell_segsize [i]; - - for (p = SCHEME_V->cell_seg[i]; p < end; ++p) - { - 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 (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n"); - } -} - -static void -finalize_cell (SCHEME_P_ pointer a) -{ - /* TODO, fast bitmap check? */ - if (is_string (a) || is_symbol (a)) - free (strvalue (a)); - else if (is_vector (a)) - free (vecvalue (a)); -#if USE_PORTS - else if (is_port (a)) - { - if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) - 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) @@ -1756,7 +1759,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; @@ -1767,13 +1770,9 @@ } return fin >= 0; - -#else - return 1; -#endif } -static void +ecb_cold static void file_pop (SCHEME_P) { if (SCHEME_V->file_i != 0) @@ -1783,24 +1782,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; @@ -1833,7 +1832,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); @@ -1844,7 +1843,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); @@ -1859,7 +1858,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); @@ -1870,7 +1869,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)); @@ -1886,7 +1885,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); @@ -1899,7 +1898,7 @@ # define BLOCK_SIZE 256 -static port * +ecb_cold static port * port_rep_from_scratch (SCHEME_P) { char *start; @@ -1923,7 +1922,7 @@ return pt; } -static pointer +ecb_cold static pointer port_from_scratch (SCHEME_P) { port *pt = port_rep_from_scratch (SCHEME_A); @@ -1934,10 +1933,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; @@ -1964,13 +1963,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; @@ -1990,12 +1987,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; @@ -2003,6 +1997,7 @@ return r; } +#if USE_PORTS if (pt->kind & port_file) { char c; @@ -2020,45 +2015,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; @@ -2081,32 +2060,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 @@ -2121,37 +2080,26 @@ } #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 * +ecb_cold static char * readstr_upto (SCHEME_P_ int skip, const char *delim) { char *p = SCHEME_V->strbuff + skip; @@ -2170,7 +2118,7 @@ } /* read string expression "xxx...xxx" */ -static pointer +ecb_cold static pointer readstrexp (SCHEME_P_ char delim) { char *p = SCHEME_V->strbuff; @@ -2213,27 +2161,22 @@ 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; + + case '\\': + skipspace (SCHEME_A); + 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; - default: *p++ = c; state = st_ok; @@ -2293,14 +2236,14 @@ } /* check c is in chars */ -ecb_inline int +ecb_cold int is_one_of (const char *s, int c) { return c == EOF || !!strchr (s, c); } /* skip white characters */ -ecb_inline int +ecb_cold int skipspace (SCHEME_P) { int c, curr_line = 0; @@ -2330,7 +2273,7 @@ } /* get token */ -static int +ecb_cold static int token (SCHEME_P) { int c = skipspace (SCHEME_A); @@ -2438,7 +2381,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; @@ -2504,7 +2447,7 @@ } /* print atoms */ -static void +ecb_cold static void printatom (SCHEME_P_ pointer l, int f) { char *p; @@ -2515,7 +2458,7 @@ } /* 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; @@ -2732,20 +2675,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 */ @@ -2758,7 +2701,7 @@ } /* reverse list --- in-place */ -static pointer +ecb_hot static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list) { pointer result = term; @@ -2776,7 +2719,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; @@ -2795,7 +2738,7 @@ } /* equivalence of atoms */ -int +ecb_hot int eqv (pointer a, pointer b) { if (is_string (a)) @@ -2899,7 +2842,7 @@ 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; @@ -2930,20 +2873,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; @@ -2967,20 +2910,20 @@ #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); @@ -2988,7 +2931,7 @@ /* ========== Evaluation Cycle ========== */ -static int +ecb_cold static int xError_1 (SCHEME_P_ const char *s, pointer a) { #if USE_ERROR_HOOK @@ -3074,14 +3017,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); @@ -3097,7 +3040,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; @@ -3118,14 +3061,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; @@ -3133,7 +3076,7 @@ dump_stack_reset (SCHEME_A); } -static void +ecb_cold static void dump_stack_free (SCHEME_P) { free (SCHEME_V->dump_base); @@ -3142,7 +3085,7 @@ SCHEME_V->dump_size = 0; } -static void +ecb_cold static void dump_stack_mark (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3158,7 +3101,7 @@ } } -static pointer +ecb_cold static pointer ss_get_cont (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3180,7 +3123,7 @@ return cont; } -static void +ecb_cold static void ss_set_cont (SCHEME_P_ pointer cont) { int i = 0; @@ -3202,25 +3145,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; @@ -3240,7 +3183,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), @@ -3250,19 +3193,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; @@ -3273,8 +3216,142 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) #if EXPERIMENT + +typedef void *stream[1]; + +#define stream_init() { 0 } + +ecb_cold static void +stream_put (void **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; +} + +#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]) + +// 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 +static uint32_t +symbol_id (SCHEME_P_ pointer sym) +{ + struct cell *p = CELL (sym); + 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]) + { + printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D + return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG); + } + + abort (); +} + +static void +compile (SCHEME_P_ stream s, pointer x) +{ + if (x == NIL) + { + stream_put (s, 0); + return; + } + + if (is_syntax (x)) + { + stream_put (s, 1); + stream_put (s, syntaxnum (x)); + return; + } + + switch (type (x)) + { + case T_INTEGER: + stream_put (s, 2); + stream_put (s, 0); + stream_put (s, 0); + stream_put (s, 0); + stream_put (s, 0); + return; + + case T_SYMBOL: + { + uint32_t sym = symbol_id (SCHEME_A_ x); + printf ("sym %x\n", sym);//D + + stream_put (s, 3); + + while (sym > 0x7f) + { + stream_put (s, sym | 0x80); + sym >>= 8; + } + + stream_put (s, sym); + } + return; + + case T_PAIR: + stream_put (s, 4); + while (x != NIL) + { + compile (SCHEME_A_ s, car (x)); + x = cdr (x); + } + stream_put (s, 0xff); + return; + + default: + stream_put (s, 5); + stream_put (s, type (x)); + stream_put (s, 0); + stream_put (s, 0); + stream_put (s, 0); + stream_put (s, 0); + break; + } +} + +static int +compile_closure (SCHEME_P_ pointer p) +{ + stream s = stream_init (); + + printatom (SCHEME_A_ p, 1);//D + compile (SCHEME_A_ s, car (p)); + + FILE *xxd = popen ("xxd", "we"); + fwrite (stream_data (s), 1, stream_size (s), xxd); + fclose (xxd); + + return stream_size (s); +} + static int -debug (SCHEME_P_ int indent, pointer x) +dtree (SCHEME_P_ int indent, pointer x) { int c; @@ -3302,13 +3379,13 @@ 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)); + 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 = debug (SCHEME_A_ indent + 3, car (x)); - c += debug (SCHEME_A_ indent + 3, cdr (x)); + c = dtree (SCHEME_A_ indent + 3, car (x)); + c += dtree (SCHEME_A_ indent + 3, cdr (x)); return c + 1; case T_PORT: @@ -3321,7 +3398,7 @@ case T_ENVIRONMENT: printf ("%*sS<%s>\n", indent, "", "environment"); - return 0 + debug (SCHEME_A_ indent + 3, car (x)); + return 0 + dtree (SCHEME_A_ indent + 3, car (x)); default: printf ("unhandled type %d\n", type (x)); @@ -3330,7 +3407,8 @@ } #endif -static int +/* syntax, eval, core, ... */ +ecb_hot static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; @@ -3340,29 +3418,31 @@ { #if EXPERIMENT //D case OP_DEBUG: - printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); - printf ("\n"); - s_return (S_T); + { + uint32_t len = compile_closure (SCHEME_A_ car (args)); + printf ("len = %d\n", len); + 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))); + 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) { @@ -3383,7 +3463,7 @@ { SCHEME_V->envir = SCHEME_V->global_env; dump_stack_reset (SCHEME_A); - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); putstr (SCHEME_A_ prompt); } @@ -3428,8 +3508,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 @@ -3450,10 +3530,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)) { @@ -3472,8 +3552,8 @@ s_goto (OP_EVAL); } } - else - s_return (SCHEME_V->code); + + s_return (SCHEME_V->code); case OP_E0ARGS: /* eval arguments */ if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ @@ -3540,7 +3620,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); } @@ -3655,7 +3735,6 @@ s_return (SCHEME_V->code); - case OP_DEFP: /* defined? */ x = SCHEME_V->envir; @@ -3683,7 +3762,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); @@ -3704,6 +3782,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 */ @@ -3869,12 +3948,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 */ @@ -3895,12 +3972,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) @@ -3915,12 +3990,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)); @@ -3995,14 +4068,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); @@ -4026,7 +4099,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; @@ -4037,20 +4111,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)))); @@ -4058,16 +4139,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: { @@ -4100,21 +4175,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: /* + */ @@ -4426,30 +4486,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); } @@ -4533,7 +4591,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; @@ -4564,7 +4623,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; @@ -4621,7 +4681,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; @@ -4644,11 +4705,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 */ @@ -4671,6 +4735,7 @@ s_goto (OP_P0LIST); + //TODO: move to scheme case OP_NEWLINE: /* newline */ if (is_pair (args)) { @@ -4682,7 +4747,7 @@ } } - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); s_return (S_T); #endif @@ -4701,7 +4766,7 @@ s_goto (OP_ERR1); case OP_ERR1: /* error */ - putstr (SCHEME_A_ " "); + putcharacter (SCHEME_A_ ' '); if (args != NIL) { @@ -4712,7 +4777,7 @@ } else { - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); if (SCHEME_V->interactive_repl) s_goto (OP_T0LVL); @@ -4799,12 +4864,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)); @@ -4884,9 +4948,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; @@ -4931,7 +4995,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; @@ -5001,7 +5066,7 @@ if (is_pair (args)) p = car (args); - res = p->object.port->kind & port_string; + res = port (p)->kind & port_string; s_retbool (res); } @@ -5210,16 +5275,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; } @@ -5231,7 +5296,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); } @@ -5249,7 +5314,7 @@ printatom (SCHEME_A_ args, SCHEME_V->print_flag); } - putstr (SCHEME_A_ ")"); + putcharacter (SCHEME_A_ ')'); s_return (S_T); } @@ -5261,7 +5326,7 @@ if (i == len) { - putstr (SCHEME_A_ ")"); + putcharacter (SCHEME_A_ ')'); s_return (S_T); } else @@ -5273,7 +5338,7 @@ SCHEME_V->args = elem; if (i > 0) - putstr (SCHEME_A_ " "); + putcharacter (SCHEME_A_ ' '); s_goto (OP_P0LIST); } @@ -5283,7 +5348,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; @@ -5351,19 +5417,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); @@ -5416,7 +5483,7 @@ #undef OP_DEF ; -static const char * +ecb_cold static const char * opname (int idx) { const char *name = opnames; @@ -5428,7 +5495,7 @@ return *name ? name : "ILLEGAL"; } -static const char * +ecb_cold static const char * procname (pointer x) { return opname (procnum (x)); @@ -5458,7 +5525,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; @@ -5551,7 +5618,7 @@ if (SCHEME_V->no_memory && USE_ERROR_CHECKING) { - xwrstr ("No memory!\n"); + putstr (SCHEME_A_ "No memory!\n"); return; } } @@ -5559,14 +5626,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); @@ -5584,7 +5651,7 @@ } /* 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 (p); @@ -5701,7 +5768,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; @@ -5711,9 +5778,10 @@ 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 */ @@ -5779,32 +5847,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; @@ -5862,13 +5930,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); @@ -5877,15 +5945,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 @@ -5899,15 +5963,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; @@ -5915,9 +5981,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; @@ -5927,9 +5991,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; @@ -5944,13 +6011,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; @@ -5959,13 +6026,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), @@ -5979,7 +6046,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)); @@ -5990,7 +6057,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; @@ -6007,7 +6074,7 @@ return SCHEME_V->value; } -pointer +ecb_cold pointer scheme_eval (SCHEME_P_ pointer obj) { int old_repl = SCHEME_V->interactive_repl; @@ -6029,7 +6096,7 @@ #if STANDALONE -int +ecb_cold int main (int argc, char **argv) { # if USE_MULTIPLICITY @@ -6045,19 +6112,19 @@ 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; } @@ -6080,7 +6147,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) @@ -6108,11 +6174,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 { @@ -6121,18 +6188,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++;