--- microscheme/scheme.c 2015/11/26 07:30:25 1.12 +++ microscheme/scheme.c 2015/12/02 07:43:46 1.61 @@ -18,8 +18,10 @@ * */ -#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ -#include "malloc.c" +#define _GNU_SOURCE 1 +#define _POSIX_C_SOURCE 200201 +#define _XOPEN_SOURCE 600 + #define SCHEME_SOURCE #include "scheme-private.h" @@ -30,17 +32,39 @@ # include #endif +#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, @@ -48,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, @@ -59,26 +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) - -/* should use libecb */ -#if __GNUC__ >= 4 -# define ecb_expect(expr,value) __builtin_expect ((expr),(value)) -# define ecb_expect_false(expr) ecb_expect (!!(expr), 0) -# define ecb_expect_true(expr) ecb_expect (!!(expr), 1) -#endif +#define NIL POINTER (&SCHEME_V->xNIL) +#define S_T POINTER (&SCHEME_V->xT) +#define S_F POINTER (&SCHEME_V->xF) +#define S_SINK POINTER (&SCHEME_V->xsink) +#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ) #if !USE_MULTIPLICITY static scheme sc; #endif -static void +ecb_cold static void xbase (char *s, long n, int base) { if (n < 0) @@ -90,7 +110,7 @@ char *p = s; do { - *p++ = '0' + n % base; + *p++ = "0123456789abcdef"[n % base]; n /= base; } while (n); @@ -103,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) { @@ -152,9 +170,11 @@ #define tolower(c) xtolower (c) #define isdigit(c) xisdigit (c) -#if USE_STRLWR -static const char * -strlwr (char *s) +#endif + +#if USE_IGNORECASE +ecb_cold static const char * +xstrlwr (char *s) { const char *p = s; @@ -166,10 +186,14 @@ return p; } -#endif -#define stricmp(a,b) strcmp (a, b) -#define strlwr(s) (s) +#define stricmp(a,b) strcasecmp (a, b) +#define strlwr(s) xstrlwr (s) + +#else +# define stricmp(a,b) strcmp (a, b) +# define strlwr(s) (s) +#endif #ifndef prompt # define prompt "ts> " @@ -179,28 +203,25 @@ # define InitFile "init.scm" #endif -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - enum scheme_types { - T_FREE, + T_INTEGER, + T_CHARACTER, + T_REAL, T_STRING, - T_NUMBER, T_SYMBOL, T_PROC, - T_PAIR, + 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 }; @@ -210,175 +231,150 @@ #define T_ATOM 0x0040 /* only for gc */ #define T_MARK 0x0080 /* only for gc */ -static num num_add (num a, num b); -static num num_mul (num a, num b); -static num num_div (num a, num b); +/* num, for generic arithmetic */ +struct num +{ + IVALUE ivalue; +#if USE_REAL + RVALUE rvalue; + char is_fixnum; +#endif +}; + +#if USE_REAL +# define num_is_fixnum(n) (n).is_fixnum +# define num_set_fixnum(n,f) (n).is_fixnum = (f) +# define num_ivalue(n) (n).ivalue +# define num_rvalue(n) (n).rvalue +# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i) +# define num_set_rvalue(n,r) (n).rvalue = (r) +#else +# define num_is_fixnum(n) 1 +# define num_set_fixnum(n,f) 0 +# define num_ivalue(n) (n).ivalue +# define num_rvalue(n) (n).ivalue +# define num_set_ivalue(n,i) (n).ivalue = (i) +# define num_set_rvalue(n,r) (n).ivalue = (r) +#endif + +enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV }; + +static num num_op (enum num_op op, num a, num b); static num num_intdiv (num a, num b); -static num num_sub (num a, num b); static num num_rem (num a, num b); static num num_mod (num a, num b); -static int num_eq (num a, num b); -static int num_gt (num a, num b); -static int num_ge (num a, num b); -static int num_lt (num a, num b); -static int num_le (num a, num b); -#if USE_MATH -static double round_per_R5RS (double x); -#endif static int is_zero_rvalue (RVALUE x); -static INLINE int -num_is_integer (pointer p) -{ - return num_is_fixnum (p->object.number); -} - static num num_zero; static num num_one; +/* convert "pointer" to cell* / cell* to pointer */ +#define CELL(p) ((struct cell *)(p) + 0) +#define POINTER(c) ((void *)((c) - 0)) + /* macros for cell operations */ -#define typeflag(p) ((p)->flag + 0) -#define set_typeflag(p,v) ((p)->flag = (v)) +#define typeflag(p) (CELL(p)->flag + 0) +#define set_typeflag(p,v) (CELL(p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) -INTERFACE INLINE int +INTERFACE int is_string (pointer p) { return type (p) == T_STRING; } -#define strvalue(p) ((p)->object.string.svalue) -#define strlength(p) ((p)->object.string.length) +#define strvalue(p) (CELL(p)->object.string.svalue) +#define strlength(p) (CELL(p)->object.string.length) -INTERFACE int is_list (SCHEME_P_ pointer p); -INTERFACE INLINE int +INTERFACE int is_vector (pointer p) { return type (p) == T_VECTOR; } -#define vecvalue(p) ((p)->object.vector.vvalue) -#define veclength(p) ((p)->object.vector.length) -INTERFACE void fill_vector (pointer vec, pointer obj); -INTERFACE uint32_t vector_length (pointer vec); -INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); -INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); +#define vecvalue(p) (CELL(p)->object.vector.vvalue) +#define veclength(p) (CELL(p)->object.vector.length) +INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); +INTERFACE pointer vector_get (pointer vec, uint32_t ielem); +INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); -INTERFACE uint32_t -vector_length (pointer vec) -{ - return vec->object.vector.length; -} - -INTERFACE INLINE int -is_number (pointer p) +INTERFACE int +is_integer (pointer p) { - return type (p) == T_NUMBER; + return type (p) == T_INTEGER; } -INTERFACE INLINE int -is_integer (pointer p) +/* not the same as in scheme, where integers are (correctly :) reals */ +INTERFACE int +is_real (pointer p) { - if (!is_number (p)) - return 0; - - if (num_is_integer (p) || ivalue (p) == rvalue (p)) - return 1; - - return 0; + return type (p) == T_REAL; } -INTERFACE INLINE int -is_real (pointer p) +INTERFACE int +is_number (pointer p) { - return is_number (p) && !num_is_fixnum (p->object.number); + return is_integer (p) || is_real (p); } -INTERFACE INLINE int +INTERFACE int is_character (pointer p) { return type (p) == T_CHARACTER; } -INTERFACE INLINE char * +INTERFACE char * string_value (pointer p) { return strvalue (p); } -INLINE num -nvalue (pointer p) -{ - return (p)->object.number; -} - -static IVALUE -num_get_ivalue (const num n) -{ - return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n); -} - -static RVALUE -num_get_rvalue (const num n) -{ - return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n); -} - -INTERFACE IVALUE -ivalue (pointer p) -{ - return num_get_ivalue (p->object.number); -} - -INTERFACE RVALUE -rvalue (pointer p) -{ - return num_get_rvalue (p->object.number); -} +#define ivalue_unchecked(p) CELL(p)->object.ivalue +#define set_ivalue(p,v) CELL(p)->object.ivalue = (v) -#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) #if USE_REAL -# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) -# define set_num_integer(p) (p)->object.number.is_fixnum=1; -# define set_num_real(p) (p)->object.number.is_fixnum=0; +#define rvalue_unchecked(p) CELL(p)->object.rvalue +#define set_rvalue(p,v) CELL(p)->object.rvalue = (v) #else -# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) -# define set_num_integer(p) 0 -# define set_num_real(p) 0 +#define rvalue_unchecked(p) CELL(p)->object.ivalue +#define set_rvalue(p,v) CELL(p)->object.ivalue = (v) #endif + INTERFACE long charvalue (pointer p) { return ivalue_unchecked (p); } -INTERFACE INLINE int +#define port(p) CELL(p)->object.port +#define set_port(p,v) port(p) = (v) +INTERFACE int is_port (pointer p) { return type (p) == T_PORT; } -INTERFACE INLINE int +INTERFACE int is_inport (pointer p) { - return is_port (p) && p->object.port->kind & port_input; + return is_port (p) && port (p)->kind & port_input; } -INTERFACE INLINE int +INTERFACE int is_outport (pointer p) { - return is_port (p) && p->object.port->kind & port_output; + return is_port (p) && port (p)->kind & port_output; } -INTERFACE INLINE int +INTERFACE int is_pair (pointer p) { return type (p) == T_PAIR; } -#define car(p) ((p)->object.cons.car + 0) -#define cdr(p) ((p)->object.cons.cdr + 0) +#define car(p) (POINTER (CELL(p)->object.cons.car)) +#define cdr(p) (POINTER (CELL(p)->object.cons.cdr)) static pointer caar (pointer p) { return car (car (p)); } static pointer cadr (pointer p) { return car (cdr (p)); } @@ -392,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 @@ -413,80 +409,80 @@ return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_symbol (pointer p) { return type (p) == T_SYMBOL; } -INTERFACE INLINE char * +INTERFACE char * symname (pointer p) { - return strvalue (car (p)); + return strvalue (p); } #if USE_PLIST -SCHEME_EXPORT INLINE int +#error plists are broken because symbols are no longer pairs +#define symprop(p) cdr(p) +SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; } - -# define symprop(p) cdr(p) #endif -INTERFACE INLINE int +INTERFACE int is_syntax (pointer p) { return typeflag (p) & T_SYNTAX; } -INTERFACE INLINE int +INTERFACE int is_proc (pointer p) { return type (p) == T_PROC; } -INTERFACE INLINE int +INTERFACE int is_foreign (pointer p) { return type (p) == T_FOREIGN; } -INTERFACE INLINE char * +INTERFACE char * syntaxname (pointer p) { - return strvalue (car (p)); + return strvalue (p); } -#define procnum(p) ivalue (p) +#define procnum(p) ivalue_unchecked (p) static const char *procname (pointer x); -INTERFACE INLINE int +INTERFACE int is_closure (pointer p) { return type (p) == T_CLOSURE; } -INTERFACE INLINE int +INTERFACE int is_macro (pointer p) { return type (p) == T_MACRO; } -INTERFACE INLINE pointer +INTERFACE pointer closure_code (pointer p) { return car (p); } -INTERFACE INLINE pointer +INTERFACE pointer closure_env (pointer p) { return cdr (p); } -INTERFACE INLINE int +INTERFACE int is_continuation (pointer p) { return type (p) == T_CONTINUATION; @@ -496,13 +492,13 @@ #define set_cont_dump(p,v) set_cdr ((p), (v)) /* To do: promise should be forced ONCE only */ -INTERFACE INLINE int +INTERFACE int is_promise (pointer p) { return type (p) == T_PROMISE; } -INTERFACE INLINE int +INTERFACE int is_environment (pointer p) { return type (p) == T_ENVIRONMENT; @@ -518,13 +514,13 @@ #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) -INTERFACE INLINE int +INTERFACE int is_immutable (pointer p) { return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; } -INTERFACE INLINE void +INTERFACE void setimmutable (pointer p) { #if USE_ERROR_CHECKING @@ -532,32 +528,87 @@ #endif } +/* Result is: + proper list: length + circular list: -1 + not even a pair: -2 + dotted list: -2 minus length before dot +*/ +ecb_hot INTERFACE int +list_length (SCHEME_P_ pointer a) +{ + int i = 0; + pointer slow, fast; + + slow = fast = a; + + while (1) + { + if (fast == NIL) + return i; + + if (!is_pair (fast)) + return -2 - i; + + fast = cdr (fast); + ++i; + + if (fast == NIL) + return i; + + if (!is_pair (fast)) + return -2 - i; + + ++i; + fast = cdr (fast); + + /* Safe because we would have already returned if `fast' + encountered a non-pair. */ + slow = cdr (slow); + + if (fast == slow) + { + /* the fast pointer has looped back around and caught up + with the slow pointer, hence the structure is circular, + not of finite length, and therefore not a list */ + return -1; + } + } +} + +INTERFACE int +is_list (SCHEME_P_ pointer a) +{ + return list_length (SCHEME_A_ a) >= 0; +} + #if USE_CHAR_CLASSIFIERS -static INLINE int + +ecb_inline int Cisalpha (int c) { return isascii (c) && isalpha (c); } -static INLINE int +ecb_inline int Cisdigit (int c) { return isascii (c) && isdigit (c); } -static INLINE int +ecb_inline int Cisspace (int c) { return isascii (c) && isspace (c); } -static INLINE int +ecb_inline int Cisupper (int c) { return isascii (c) && isupper (c); } -static INLINE int +ecb_inline int Cislower (int c) { return isascii (c) && islower (c); @@ -600,7 +651,7 @@ "us" }; -static int +ecb_cold static int is_ascii_name (const char *name, int *pc) { int i; @@ -628,11 +679,10 @@ static int file_push (SCHEME_P_ const char *fname); static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); -static INLINE int is_one_of (char *s, int c); -static int alloc_cellseg (SCHEME_P_ int n); -static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); +ecb_inline int is_one_of (const char *s, int c); +static int alloc_cellseg (SCHEME_P); +ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); static void finalize_cell (SCHEME_P_ pointer a); -static int count_consecutive_cells (pointer x, int needed); static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); static pointer mk_number (SCHEME_P_ const num n); static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); @@ -640,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); @@ -650,14 +701,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); -static INLINE int skipspace (SCHEME_P); +static char *readstr_upto (SCHEME_P_ int skip, const char *delim); +static pointer readstrexp (SCHEME_P_ char delim); +ecb_inline int skipspace (SCHEME_P); static int token (SCHEME_P); static void printslashstring (SCHEME_P_ char *s, int len); static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); @@ -671,88 +723,93 @@ static pointer ss_get_cont (SCHEME_P); static void ss_set_cont (SCHEME_P_ pointer cont); static void dump_stack_mark (SCHEME_P); -static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); -static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_0 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_1 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_2 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_3 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_4 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_5 (SCHEME_P_ enum scheme_opcodes op); +static int opexe_6 (SCHEME_P_ enum scheme_opcodes op); static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); static void assign_syntax (SCHEME_P_ const char *name); static int syntaxnum (pointer p); static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); -static num -num_add (num a, num b) +static IVALUE +ivalue (pointer x) { - num ret; - - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - - if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b)); - else - num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b)); - - return ret; + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); } -static num -num_mul (num a, num b) +static RVALUE +rvalue (pointer x) { - num ret; - - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - - if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b)); - else - num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b)); - - return ret; + return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); } -static num -num_div (num a, num b) +INTERFACE num +nvalue (pointer x) { - num ret; + num n; - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0); + num_set_fixnum (n, is_integer (x)); - if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); + if (num_is_fixnum (n)) + num_set_ivalue (n, ivalue_unchecked (x)); else - num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); + num_set_rvalue (n, rvalue_unchecked (x)); - return ret; + return n; } static num -num_intdiv (num a, num b) +num_op (enum num_op op, num a, num b) { num ret; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); + { + switch (op) + { + case NUM_ADD: a.ivalue += b.ivalue; break; + case NUM_SUB: a.ivalue -= b.ivalue; break; + case NUM_MUL: a.ivalue *= b.ivalue; break; + case NUM_INTDIV: a.ivalue /= b.ivalue; break; + } + + num_set_ivalue (ret, a.ivalue); + } +#if USE_REAL else - num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); + { + switch (op) + { + case NUM_ADD: a.rvalue += b.rvalue; break; + case NUM_SUB: a.rvalue -= b.rvalue; break; + case NUM_MUL: a.rvalue *= b.rvalue; break; + case NUM_INTDIV: a.rvalue /= b.rvalue; break; + } + + num_set_rvalue (ret, a.rvalue); + } +#endif return ret; } static num -num_sub (num a, num b) +num_div (num a, num b) { num ret; - num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); + num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0); if (num_is_fixnum (ret)) - num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b)); + num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b)); else - num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b)); + num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b)); return ret; } @@ -764,8 +821,8 @@ long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - e1 = num_get_ivalue (a); - e2 = num_get_ivalue (b); + e1 = num_ivalue (a); + e2 = num_ivalue (b); res = e1 % e2; /* remainder should have same sign as second operand */ @@ -791,8 +848,8 @@ long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); - e1 = num_get_ivalue (a); - e2 = num_get_ivalue (b); + e1 = num_ivalue (a); + e2 = num_ivalue (b); res = e1 % e2; /* modulo should have same sign as second operand */ @@ -803,103 +860,51 @@ return ret; } +/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */ static int -num_eq (num a, num b) +num_cmp (num a, num b) { - int ret; int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); - - if (is_fixnum) - ret = num_get_ivalue (a) == num_get_ivalue (b); - else - ret = num_get_rvalue (a) == num_get_rvalue (b); - - return ret; -} - - -static int -num_gt (num a, num b) -{ int ret; - int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); if (is_fixnum) - ret = num_get_ivalue (a) > num_get_ivalue (b); - else - ret = num_get_rvalue (a) > num_get_rvalue (b); - - return ret; -} - -static int -num_ge (num a, num b) -{ - return !num_lt (a, b); -} - -static int -num_lt (num a, num b) -{ - int ret; - int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); - - if (is_fixnum) - ret = num_get_ivalue (a) < num_get_ivalue (b); - else - ret = num_get_rvalue (a) < num_get_rvalue (b); - - return ret; -} - -static int -num_le (num a, num b) -{ - return !num_gt (a, b); -} - -#if USE_MATH + { + IVALUE av = num_ivalue (a); + IVALUE bv = num_ivalue (b); -/* 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; + ret = av == bv ? 0 : av < bv ? -1 : +1; + } else { - if (fmod (fl, 2.0) == 0.0) /* I imagine this holds */ - return fl; - else - return ce; + RVALUE av = num_rvalue (a); + RVALUE bv = num_rvalue (b); + + ret = av == bv ? 0 : av < bv ? -1 : +1; } + + return ret; } -#endif static int is_zero_rvalue (RVALUE x) { + return x == 0; +#if 0 #if USE_REAL return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ #else return x == 0; #endif +#endif } /* allocate new cell segment */ -static int -alloc_cellseg (SCHEME_P_ int n) +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; @@ -907,71 +912,36 @@ static int segsize = CELL_SEGSIZE >> 1; segsize <<= 1; - for (k = 0; k < n; k++) - { - if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1) - return k; + cp = malloc (segsize * sizeof (struct cell)); - cp = malloc (segsize * sizeof (struct cell)); + if (!cp && USE_ERROR_CHECKING) + return k; - if (!cp && USE_ERROR_CHECKING) - return k; + i = ++SCHEME_V->last_cell_seg; + SCHEME_V->alloc_seg[i] = cp; - i = ++SCHEME_V->last_cell_seg; - SCHEME_V->alloc_seg[i] = cp; + newp = (struct cell *)cp; + SCHEME_V->cell_seg[i] = newp; + SCHEME_V->cell_segsize[i] = segsize; + SCHEME_V->fcells += segsize; + last = newp + segsize - 1; - /* insert new segment in address order */ - newp = (pointer)cp; - SCHEME_V->cell_seg[i] = newp; - SCHEME_V->cell_segsize[i] = segsize; - - //TODO: insert, not swap - while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i]) - { - p = SCHEME_V->cell_seg[i]; - SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1]; - SCHEME_V->cell_seg[i - 1] = p; - - k = SCHEME_V->cell_segsize[i]; - SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1]; - SCHEME_V->cell_segsize[i - 1] = k; - - --i; - } - - SCHEME_V->fcells += segsize; - last = newp + segsize - 1; - - for (p = newp; p <= last; p++) - { - set_typeflag (p, T_FREE); - set_car (p, NIL); - set_cdr (p, p + 1); - } - - /* insert new cells in address order on free list */ - if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell) - { - set_cdr (last, SCHEME_V->free_cell); - SCHEME_V->free_cell = newp; - } - else - { - p = SCHEME_V->free_cell; - - while (cdr (p) != NIL && newp > cdr (p)) - p = cdr (p); - - set_cdr (last, cdr (p)); - set_cdr (p, newp); - } + for (p = newp; p <= last; p++) + { + pointer cp = POINTER (p); + set_typeflag (cp, T_PAIR); + set_car (cp, NIL); + set_cdr (cp, POINTER (p + 1)); } - return n; + set_cdr (POINTER (last), SCHEME_V->free_cell); + SCHEME_V->free_cell = POINTER (newp); + + return 1; } /* get new cell. parameter a, b is marked by gc. */ -static INLINE pointer +ecb_inline pointer get_cell_x (SCHEME_P_ pointer a, pointer b) { if (ecb_expect_false (SCHEME_V->free_cell == NIL)) @@ -981,14 +951,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; @@ -1010,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); @@ -1023,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,7 +1011,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) @@ -1051,15 +1020,15 @@ /* Record it as a vector so that gc understands it. */ set_typeflag (v, T_VECTOR | T_ATOM); - v->object.vector.vvalue = e; - v->object.vector.length = len; - fill_vector (v, init); + CELL(v)->object.vector.vvalue = e; + CELL(v)->object.vector.length = len; + fill_vector (v, 0, init); push_recent_alloc (SCHEME_A_ v, NIL); return v; } -static INLINE void +ecb_inline void ok_to_freely_gc (SCHEME_P) { set_car (S_SINK, NIL); @@ -1071,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 @@ -1090,50 +1059,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 = 2166136261; -static pointer + while (*p) + hash = (hash ^ *p++) * 16777619; + + 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)); - set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); + pointer x = generate_symbol (SCHEME_A_ name); + int location = hash_fn (name, veclength (SCHEME_V->oblist)); + vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); return x; } -static INLINE pointer +ecb_cold static pointer oblist_find_by_name (SCHEME_P_ const char *name) { int location; @@ -1142,7 +1133,7 @@ location = hash_fn (name, veclength (SCHEME_V->oblist)); - for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) + for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) { s = symname (car (x)); @@ -1154,7 +1145,7 @@ return NIL; } -static pointer +ecb_cold static pointer oblist_all_symbols (SCHEME_P) { int i; @@ -1162,7 +1153,7 @@ pointer ob_list = NIL; for (i = 0; i < veclength (SCHEME_V->oblist); i++) - for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) + for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) ob_list = cons (x, ob_list); return ob_list; @@ -1170,13 +1161,13 @@ #else -static pointer +ecb_cold static pointer oblist_initial_value (SCHEME_P) { return NIL; } -static INLINE pointer +ecb_cold static pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; @@ -1195,19 +1186,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; @@ -1215,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; + set_typeflag (x, T_FOREIGN | T_ATOM); + CELL(x)->object.ff = f; return x; } @@ -1244,42 +1229,63 @@ { pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_CHARACTER | T_ATOM)); - ivalue_unchecked (x) = c & 0xff; - set_num_integer (x); + set_typeflag (x, T_CHARACTER | T_ATOM); + set_ivalue (x, c & 0xff); + return x; } /* get number atom (integer) */ INTERFACE pointer -mk_integer (SCHEME_P_ long num) +mk_integer (SCHEME_P_ long n) { - pointer x = get_cell (SCHEME_A_ NIL, NIL); + pointer p = 0; + pointer *pp = &p; - set_typeflag (x, (T_NUMBER | T_ATOM)); - ivalue_unchecked (x) = num; - set_num_integer (x); - return x; +#if USE_INTCACHE + if (n >= INTCACHE_MIN && n <= INTCACHE_MAX) + pp = &SCHEME_V->intcache[n - INTCACHE_MIN]; +#endif + + if (!*pp) + { + pointer x = get_cell (SCHEME_A_ NIL, NIL); + + set_typeflag (x, T_INTEGER | T_ATOM); + setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */ + set_ivalue (x, n); + + *pp = x; + } + + return *pp; } INTERFACE pointer mk_real (SCHEME_P_ RVALUE n) { +#if USE_REAL pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_NUMBER | T_ATOM)); - rvalue_unchecked (x) = n; - set_num_real (x); + set_typeflag (x, T_REAL | T_ATOM); + set_rvalue (x, n); + return x; +#else + return mk_integer (SCHEME_A_ n); +#endif } static pointer mk_number (SCHEME_P_ const num n) { - if (num_is_fixnum (n)) - return mk_integer (SCHEME_A_ num_get_ivalue (n)); - else - return mk_real (SCHEME_A_ num_get_rvalue (n)); +#if USE_REAL + return num_is_fixnum (n) + ? mk_integer (SCHEME_A_ num_ivalue (n)) + : mk_real (SCHEME_A_ num_rvalue (n)); +#else + return mk_integer (SCHEME_A_ num_ivalue (n)); +#endif } /* allocate name to string area */ @@ -1295,20 +1301,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; } @@ -1332,6 +1329,7 @@ set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, str, 0); strlength (x) = len; + return x; } @@ -1348,22 +1346,31 @@ } INTERFACE void -fill_vector (pointer vec, pointer obj) +fill_vector (pointer vec, uint32_t start, pointer obj) { int i; - for (i = 0; i < vec->object.vector.length; i++) + for (i = start; i < veclength (vec); i++) vecvalue (vec)[i] = obj; } +INTERFACE void +vector_resize (pointer vec, uint32_t newsize, pointer fill) +{ + uint32_t oldsize = veclength (vec); + vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer)); + veclength (vec) = newsize; + fill_vector (vec, oldsize, fill); +} + INTERFACE pointer -vector_elem (pointer vec, uint32_t ielem) +vector_get (pointer vec, uint32_t ielem) { return vecvalue(vec)[ielem]; } INTERFACE void -set_vector_elem (pointer vec, uint32_t ielem, pointer a) +vector_set (pointer vec, uint32_t ielem, pointer a) { vecvalue(vec)[ielem] = a; } @@ -1381,31 +1388,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; @@ -1465,8 +1465,7 @@ { if (!has_fp_exp) { - has_dec_point = 1; /* decimal point illegal - from now on */ + has_dec_point = 1; /* decimal point illegal from now on */ p++; if ((*p == '-') || (*p == '+') || isdigit (*p)) @@ -1487,7 +1486,7 @@ } /* make constant */ -static pointer +ecb_cold static pointer mk_sharp_const (SCHEME_P_ char *name) { if (!strcmp (name, "t")) @@ -1498,6 +1497,7 @@ { int c; + // TODO: optimise if (stricmp (name + 1, "space") == 0) c = ' '; else if (stricmp (name + 1, "newline") == 0) @@ -1506,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); @@ -1541,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, @@ -1550,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; @@ -1564,7 +1593,7 @@ { int i; - for (i = 0; i < p->object.vector.length; i++) + for (i = 0; i < veclength (p); i++) mark (vecvalue (p)[i]); } @@ -1617,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) @@ -1647,6 +1717,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); @@ -1656,65 +1733,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_FREE) - { - finalize_cell (SCHEME_A_ p); - set_typeflag (p, T_FREE); - 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) @@ -1730,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; @@ -1741,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) @@ -1757,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; @@ -1807,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); @@ -1818,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); @@ -1833,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); @@ -1844,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)); @@ -1860,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); @@ -1873,7 +1898,7 @@ # define BLOCK_SIZE 256 -static port * +ecb_cold static port * port_rep_from_scratch (SCHEME_P) { char *start; @@ -1897,7 +1922,7 @@ return pt; } -static pointer +ecb_cold static pointer port_from_scratch (SCHEME_P) { port *pt = port_rep_from_scratch (SCHEME_A); @@ -1908,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; @@ -1938,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; @@ -1964,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; @@ -1977,6 +1997,7 @@ return r; } +#if USE_PORTS if (pt->kind & port_file) { char c; @@ -1994,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; @@ -2055,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 @@ -2095,40 +2080,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)))); @@ -2144,14 +2118,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 (;;) { @@ -2163,20 +2136,13 @@ switch (state) { case st_ok: - switch (c) - { - case '\\': - state = st_bsl; - break; + if (ecb_expect_false (c == delim)) + return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); - case '"': - *p = 0; - 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; @@ -2195,32 +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; - - case '"': - *p++ = '"'; - state = st_ok; - break; - default: *p++ = c; state = st_ok; @@ -2231,26 +2187,23 @@ case st_x1: case st_x2: - c = toupper (c); + c = tolower (c); - if (c >= '0' && c <= 'F') - { - if (c <= '9') - c1 = (c1 << 4) + c - '0'; - else - c1 = (c1 << 4) + c - 'A' + 10; - - if (state == st_x1) - state = st_x2; - else - { - *p++ = c1; - state = st_ok; - } - } + if (c >= '0' && c <= '9') + c1 = (c1 << 4) + c - '0'; + else if (c >= 'a' && c <= 'f') + c1 = (c1 << 4) + c - 'a' + 10; else return S_F; + if (state == st_x1) + state = st_x2; + else + { + *p++ = c1; + state = st_ok; + } + break; case st_oct1: @@ -2263,7 +2216,7 @@ } else { - if (state == st_oct2 && c1 >= 32) + if (state == st_oct2 && c1 >= ' ') return S_F; c1 = (c1 << 3) + (c - '0'); @@ -2278,23 +2231,19 @@ } break; - } } } /* check c is in chars */ -static 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 */ -static INLINE int +ecb_cold int skipspace (SCHEME_P) { int c, curr_line = 0; @@ -2302,12 +2251,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 @@ -2315,17 +2268,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); @@ -2347,16 +2295,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; @@ -2432,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; @@ -2497,9 +2446,8 @@ putcharacter (SCHEME_A_ '"'); } - /* print atoms */ -static void +ecb_cold static void printatom (SCHEME_P_ pointer l, int f) { char *p; @@ -2509,9 +2457,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; @@ -2532,7 +2479,7 @@ if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { - if (num_is_integer (l)) + if (is_integer (l)) xnum (p, ivalue_unchecked (l)); #if USE_REAL else @@ -2679,7 +2626,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); @@ -2721,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 */ @@ -2747,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; @@ -2765,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; @@ -2784,7 +2738,7 @@ } /* equivalence of atoms */ -int +ecb_hot int eqv (pointer a, pointer b) { if (is_string (a)) @@ -2797,8 +2751,7 @@ else if (is_number (a)) { if (is_number (b)) - if (num_is_integer (a) == num_is_integer (b)) - return num_eq (nvalue (a), nvalue (b)); + return num_cmp (nvalue (a), nvalue (b)) == 0; return 0; } @@ -2835,21 +2788,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 /* @@ -2875,33 +2813,46 @@ setenvironment (SCHEME_V->envir); } -static INLINE void +static uint32_t +sym_hash (pointer sym, uint32_t size) +{ + uintptr_t ptr = (uintptr_t)sym; + +#if 0 + /* table size is prime, so why mix */ + ptr += ptr >> 32; + ptr += ptr >> 16; + ptr += ptr >> 8; +#endif + + return ptr % size; +} + +ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { pointer slot = immutable_cons (variable, value); if (is_vector (car (env))) { - int location = hash_fn (symname (variable), veclength (car (env))); - - set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); + int location = sym_hash (variable, veclength (car (env))); + vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); } else set_car (env, immutable_cons (slot, car (env))); } -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))); - y = vector_elem (car (x), location); + int location = sym_hash (hdl, veclength (car (x))); + y = vector_get (car (x), location); } else y = car (x); @@ -2911,34 +2862,31 @@ break; if (y != NIL) - break; + return car (y); if (!all) - return NIL; + break; } - if (x != NIL) - return car (y); - return NIL; } #else /* USE_ALIST_ENV */ -static INLINE void +static void new_frame_in_env (SCHEME_P_ pointer old_env) { SCHEME_V->envir = immutable_cons (NIL, old_env); setenvironment (SCHEME_V->envir); } -static INLINE void +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; @@ -2950,33 +2898,32 @@ break; if (y != NIL) + return car (y); break; if (!all) - return NIL; + break; } - if (x != NIL) - return car (y); - return NIL; } #endif /* USE_ALIST_ENV else */ -static INLINE void +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); } -static INLINE void +static void set_slot_in_env (SCHEME_P_ pointer slot, pointer value) { set_cdr (slot, value); } -static INLINE pointer +static pointer slot_value_in_env (pointer slot) { return cdr (slot); @@ -2984,7 +2931,7 @@ /* ========== Evaluation Cycle ========== */ -static pointer +ecb_cold static int xError_1 (SCHEME_P_ const char *s, pointer a) { #if USE_ERROR_HOOK @@ -3029,7 +2976,7 @@ SCHEME_V->code = cons (slot_value_in_env (x), code); SCHEME_V->op = OP_EVAL; - return S_T; + return 0; } #endif @@ -3041,7 +2988,8 @@ SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); setimmutable (car (SCHEME_V->args)); SCHEME_V->op = OP_ERR0; - return S_T; + + return 0; } #define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) @@ -3052,7 +3000,7 @@ #define END } while (0) #define s_goto(a) BEGIN \ SCHEME_V->op = a; \ - return S_T; END + return 0; END #define s_return(a) return xs_return (SCHEME_A_ a) @@ -3069,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); @@ -3087,12 +3035,12 @@ next_frame->op = op; next_frame->args = args; next_frame->envir = SCHEME_V->envir; - next_frame->code = code; + next_frame->code = code; SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); } -static pointer +static ecb_hot int xs_return (SCHEME_P_ pointer a) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3101,7 +3049,7 @@ SCHEME_V->value = a; if (nframes <= 0) - return NIL; + return -1; frame = &SCHEME_V->dump_base[--nframes]; SCHEME_V->op = frame->op; @@ -3110,17 +3058,17 @@ SCHEME_V->code = frame->code; SCHEME_V->dump = (pointer)(uintptr_t)nframes; - return S_T; + return 0; } -static 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; } -static INLINE void +ecb_cold void dump_stack_initialize (SCHEME_P) { SCHEME_V->dump_size = 0; @@ -3128,7 +3076,7 @@ dump_stack_reset (SCHEME_A); } -static void +ecb_cold static void dump_stack_free (SCHEME_P) { free (SCHEME_V->dump_base); @@ -3137,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; @@ -3153,7 +3101,7 @@ } } -static pointer +ecb_cold static pointer ss_get_cont (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; @@ -3175,7 +3123,7 @@ return cont; } -static void +ecb_cold static void ss_set_cont (SCHEME_P_ pointer cont) { int i = 0; @@ -3183,10 +3131,10 @@ while (cont != NIL) { - frame->op = ivalue (car (cont)); cont = cdr (cont); - frame->args = car (cont) ; cont = cdr (cont); - frame->envir = car (cont) ; cont = cdr (cont); - frame->code = car (cont) ; cont = cdr (cont); + frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont); + frame->args = car (cont) ; cont = cdr (cont); + frame->envir = car (cont) ; cont = cdr (cont); + frame->code = car (cont) ; cont = cdr (cont); ++frame; ++i; @@ -3197,25 +3145,25 @@ #else -static INLINE void +ecb_cold void dump_stack_reset (SCHEME_P) { SCHEME_V->dump = NIL; } -static 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 pointer +ecb_hot static int xs_return (SCHEME_P_ pointer a) { pointer dump = SCHEME_V->dump; @@ -3223,19 +3171,19 @@ SCHEME_V->value = a; if (dump == NIL) - return NIL; + return -1; - SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump); - SCHEME_V->args = car (dump) ; dump = cdr (dump); - SCHEME_V->envir = car (dump) ; dump = cdr (dump); - SCHEME_V->code = car (dump) ; dump = cdr (dump); + SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump); + SCHEME_V->args = car (dump) ; dump = cdr (dump); + SCHEME_V->envir = car (dump) ; dump = cdr (dump); + SCHEME_V->code = car (dump) ; dump = cdr (dump); SCHEME_V->dump = dump; - return S_T; + return 0; } -static void +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), @@ -3245,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; @@ -3267,32 +3215,234 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) -static pointer +#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 +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; + } +} +#endif + +/* syntax, eval, core, ... */ +ecb_hot static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; pointer x, y; 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); + } +#endif case OP_LOAD: /* load */ if (file_interactive (SCHEME_A)) { - xwrstr ("Loading "); xwrstr (strvalue (car (SCHEME_V->args))); xwrstr ("\n"); - //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (SCHEME_V->args))); + putstr (SCHEME_A_ "Loading "); + putstr (SCHEME_A_ strvalue (car (args))); + putcharacter (SCHEME_A_ '\n'); } - if (!file_push (SCHEME_A_ strvalue (car (SCHEME_V->args)))) - Error_1 ("unable to open", car (SCHEME_V->args)); - else - { - SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); - s_goto (OP_T0LVL); - } + if (!file_push (SCHEME_A_ strvalue (car (args)))) + Error_1 ("unable to open", car (args)); + + 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) { @@ -3313,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); } @@ -3358,15 +3508,15 @@ 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 if (SCHEME_V->tracing) { /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */ - s_save (SCHEME_A_ OP_REAL_EVAL, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code); SCHEME_V->args = SCHEME_V->code; putstr (SCHEME_A_ "\nEval: "); s_goto (OP_P0LIST); @@ -3380,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)) { @@ -3402,11 +3552,11 @@ 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); @@ -3420,20 +3570,20 @@ } case OP_E1ARGS: /* eval arguments */ - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { - s_save (SCHEME_A_ OP_E1ARGS, SCHEME_V->args, cdr (SCHEME_V->code)); + s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); - SCHEME_V->code = car (SCHEME_V->args); - SCHEME_V->args = cdr (SCHEME_V->args); + args = reverse_in_place (SCHEME_A_ NIL, args); + SCHEME_V->code = car (args); + SCHEME_V->args = cdr (args); s_goto (OP_APPLY); } @@ -3443,7 +3593,7 @@ { int tr = SCHEME_V->tracing; - SCHEME_V->tracing = ivalue (car (SCHEME_V->args)); + SCHEME_V->tracing = ivalue_unchecked (car (args)); s_return (mk_integer (SCHEME_A_ tr)); } @@ -3453,9 +3603,9 @@ #if USE_TRACING if (SCHEME_V->tracing) { - s_save (SCHEME_A_ OP_REAL_APPLY, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code); SCHEME_V->print_flag = 1; - /* SCHEME_V->args=cons(SCHEME_V->code,SCHEME_V->args); */ + /* args=cons(SCHEME_V->code,args); */ putstr (SCHEME_A_ "\nApply to: "); s_goto (OP_P0LIST); } @@ -3465,14 +3615,12 @@ case OP_REAL_APPLY: #endif if (is_proc (SCHEME_V->code)) - { - s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ - } + s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ else if (is_foreign (SCHEME_V->code)) { /* Keep nested calls from GC'ing the arglist */ - push_recent_alloc (SCHEME_A_ SCHEME_V->args, NIL); - x = SCHEME_V->code->object.ff (SCHEME_A_ SCHEME_V->args); + push_recent_alloc (SCHEME_A_ args, NIL); + x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args); s_return (x); } @@ -3482,7 +3630,7 @@ /* make environment */ new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); - for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y)) + for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y)) { if (y == NIL) Error_0 ("not enough arguments"); @@ -3510,7 +3658,7 @@ else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ { ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); - s_return (SCHEME_V->args != NIL ? car (SCHEME_V->args) : NIL); + s_return (args != NIL ? car (args) : NIL); } else Error_0 ("illegal function"); @@ -3519,8 +3667,6 @@ SCHEME_V->code = SCHEME_V->value; s_goto (OP_EVAL); -#if 1 - case OP_LAMBDA: /* lambda */ /* If the hook is defined, apply it to SCHEME_V->code, otherwise set SCHEME_V->value fall thru */ @@ -3529,36 +3675,29 @@ if (f != NIL) { - s_save (SCHEME_A_ OP_LAMBDA1, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code); SCHEME_V->args = cons (SCHEME_V->code, NIL); SCHEME_V->code = slot_value_in_env (f); s_goto (OP_APPLY); } 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 (SCHEME_V->args); + x = car (args); if (car (x) == SCHEME_V->LAMBDA) x = cdr (x); - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) y = SCHEME_V->envir; else - y = cadr (SCHEME_V->args); + y = cadr (args); s_return (mk_closure (SCHEME_A_ x, y)); @@ -3596,14 +3735,13 @@ s_return (SCHEME_V->code); - case OP_DEFP: /* defined? */ x = SCHEME_V->envir; - if (cdr (SCHEME_V->args) != NIL) - x = cadr (SCHEME_V->args); + if (cdr (args) != NIL) + x = cadr (args); - s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL); + s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL); case OP_SET0: /* set! */ if (is_immutable (car (SCHEME_V->code))) @@ -3624,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); @@ -3644,9 +3781,8 @@ if (is_true (SCHEME_V->value)) SCHEME_V->code = car (SCHEME_V->code); else - SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because + SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ - * car(NIL) = NIL */ s_goto (OP_EVAL); case OP_LET0: /* let */ @@ -3656,36 +3792,36 @@ s_goto (OP_LET1); case OP_LET1: /* let (calculate parameters) */ - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); - s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code)); + s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); - SCHEME_V->code = car (SCHEME_V->args); - SCHEME_V->args = cdr (SCHEME_V->args); + args = reverse_in_place (SCHEME_A_ NIL, args); + SCHEME_V->code = car (args); + SCHEME_V->args = cdr (args); s_goto (OP_LET2); } case OP_LET2: /* let */ new_frame_in_env (SCHEME_A_ SCHEME_V->envir); - for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args; + for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) new_slot_in_env (SCHEME_A_ caar (x), car (y)); if (is_symbol (car (SCHEME_V->code))) /* named let */ { - for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x)) + for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) { if (!is_pair (x)) Error_1 ("Bad syntax of binding in let :", x); @@ -3693,22 +3829,20 @@ if (!is_list (SCHEME_A_ car (x))) Error_1 ("Bad syntax of binding in let :", car (x)); - SCHEME_V->args = cons (caar (x), SCHEME_V->args); + args = cons (caar (x), args); } - x = - mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args), cddr (SCHEME_V->code)), - SCHEME_V->envir); + x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), + SCHEME_V->envir); new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x); SCHEME_V->code = cddr (SCHEME_V->code); - SCHEME_V->args = NIL; } else { SCHEME_V->code = cdr (SCHEME_V->code); - SCHEME_V->args = NIL; } + SCHEME_V->args = NIL; s_goto (OP_BEGIN); case OP_LET0AST: /* let* */ @@ -3736,14 +3870,14 @@ if (is_pair (SCHEME_V->code)) /* continue */ { - s_save (SCHEME_A_ OP_LET2AST, SCHEME_V->args, SCHEME_V->code); + s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->code = SCHEME_V->args; + SCHEME_V->code = args; SCHEME_V->args = NIL; s_goto (OP_BEGIN); } @@ -3756,28 +3890,28 @@ s_goto (OP_LET1REC); case OP_LET1REC: /* letrec (calculate parameters) */ - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); - s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code)); + s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { - SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); - SCHEME_V->code = car (SCHEME_V->args); - SCHEME_V->args = cdr (SCHEME_V->args); + args = reverse_in_place (SCHEME_A_ NIL, args); + SCHEME_V->code = car (args); + SCHEME_V->args = cdr (args); s_goto (OP_LET2REC); } case OP_LET2REC: /* letrec */ - for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y)) + for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) new_slot_in_env (SCHEME_A_ caar (x), car (y)); SCHEME_V->code = cdr (SCHEME_V->code); @@ -3814,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 */ @@ -3840,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) @@ -3860,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)); @@ -3873,10 +4001,10 @@ s_goto (OP_EVAL); case OP_C1STREAM: /* cons-stream */ - SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register SCHEME_V->args for gc */ + SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */ x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); set_typeflag (x, T_PROMISE); - s_return (cons (SCHEME_V->args, x)); + s_return (cons (args, x)); case OP_MACRO0: /* macro */ if (is_pair (car (SCHEME_V->code))) @@ -3919,10 +4047,8 @@ break; for (; y != NIL; y = cdr (y)) - { - if (eqv (car (y), SCHEME_V->value)) + if (eqv (car (y), SCHEME_V->value)) break; - } if (y != NIL) break; @@ -3942,120 +4068,95 @@ 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 (SCHEME_V->args); - SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args)); - /*SCHEME_V->args = cadr(SCHEME_V->args); */ + SCHEME_V->code = car (args); + SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); + /*SCHEME_V->args = cadr(args); */ s_goto (OP_APPLY); case OP_PEVAL: /* eval */ - if (cdr (SCHEME_V->args) != NIL) - SCHEME_V->envir = cadr (SCHEME_V->args); + if (cdr (args) != NIL) + SCHEME_V->envir = cadr (args); - SCHEME_V->code = car (SCHEME_V->args); + SCHEME_V->code = car (args); s_goto (OP_EVAL); case OP_CONTINUATION: /* call-with-current-continuation */ - SCHEME_V->code = car (SCHEME_V->args); + SCHEME_V->code = car (args); SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); s_goto (OP_APPLY); } - return S_T; + if (USE_ERROR_CHECKING) abort (); } -static pointer -opexe_2 (SCHEME_P_ enum scheme_opcodes op) +/* math, cxr */ +ecb_hot static int +opexe_1 (SCHEME_P_ enum scheme_opcodes op) { - pointer x; + pointer args = SCHEME_V->args; + pointer x = car (args); num v; -#if USE_MATH - RVALUE dd; -#endif - switch (op) { #if USE_MATH - case OP_INEX2EX: /* inexact->exact */ - x = car (SCHEME_V->args); - - if (num_is_integer (x)) - s_return (x); - else if (modf (rvalue_unchecked (x), &dd) == 0.0) - s_return (mk_integer (SCHEME_A_ ivalue (x))); - else - Error_1 ("inexact->exact: not integral:", x); - - case OP_EXP: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); - - case OP_LOG: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ log (rvalue (x)))); - - case OP_SIN: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); - - case OP_COS: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); - - case OP_TAN: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); - - case OP_ASIN: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); - - case OP_ACOS: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); - - case OP_ATAN: - x = car (SCHEME_V->args); - - if (cdr (SCHEME_V->args) == NIL) - s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); - else + if (!is_integer (x)) { - pointer y = cadr (SCHEME_V->args); + RVALUE r = rvalue_unchecked (x); - s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y)))); + if (r == (RVALUE)(IVALUE)r) + x = mk_integer (SCHEME_A_ rvalue_unchecked (x)); + else + Error_1 ("inexact->exact: not integral:", x); } - case OP_SQRT: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ sqrt (rvalue (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)) + / (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)))); + case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); + case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); + + case OP_ATAN: + s_return (mk_real (SCHEME_A_ + cdr (args) == NIL + ? atan (rvalue (x)) + : atan2 (rvalue (x), rvalue (cadr (args))))); case OP_EXPT: { RVALUE result; int real_result = 1; - pointer y = cadr (SCHEME_V->args); + pointer y = cadr (args); - x = car (SCHEME_V->args); - - if (num_is_integer (x) && num_is_integer (y)) + if (is_integer (x) && is_integer (y)) real_result = 0; /* This 'if' is an R5RS compatibility fix. */ /* NOTE: Remove this 'if' fix for R6RS. */ if (rvalue (x) == 0 && rvalue (y) < 0) - result = 0.0; + result = 0; else result = pow (rvalue (x), rvalue (y)); @@ -4063,9 +4164,9 @@ /* If the test fails, result is too big for integer. */ if (!real_result) { - long result_as_long = (long) result; + long result_as_long = result; - if (result != (RVALUE) result_as_long) + if (result != result_as_long) real_result = 1; } @@ -4074,108 +4175,77 @@ else s_return (mk_integer (SCHEME_A_ result)); } - - case OP_FLOOR: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); - - case OP_CEILING: - x = car (SCHEME_V->args); - s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); - - case OP_TRUNCATE: - { - RVALUE rvalue_of_x; - - x = car (SCHEME_V->args); - rvalue_of_x = rvalue (x); - - if (rvalue_of_x > 0) - s_return (mk_real (SCHEME_A_ floor (rvalue_of_x))); - else - s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x))); - } - - case OP_ROUND: - x = car (SCHEME_V->args); - - if (num_is_integer (x)) - s_return (x); - - s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); #endif case OP_ADD: /* + */ v = num_zero; - for (x = SCHEME_V->args; x != NIL; x = cdr (x)) - v = num_add (v, nvalue (car (x))); + for (x = args; x != NIL; x = cdr (x)) + v = num_op (NUM_ADD, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_MUL: /* * */ v = num_one; - for (x = SCHEME_V->args; x != NIL; x = cdr (x)) - v = num_mul (v, nvalue (car (x))); + for (x = args; x != NIL; x = cdr (x)) + v = num_op (NUM_MUL, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_SUB: /* - */ - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) { - x = SCHEME_V->args; + x = args; v = num_zero; } else { - x = cdr (SCHEME_V->args); - v = nvalue (car (SCHEME_V->args)); + x = cdr (args); + v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) - v = num_sub (v, nvalue (car (x))); + v = num_op (NUM_SUB, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_DIV: /* / */ - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) { - x = SCHEME_V->args; + x = args; v = num_one; } else { - x = cdr (SCHEME_V->args); - v = nvalue (car (SCHEME_V->args)); + x = cdr (args); + v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) - { - if (!is_zero_rvalue (rvalue (car (x)))) - v = num_div (v, nvalue (car (x))); - else - Error_0 ("/: division by zero"); - } + if (!is_zero_rvalue (rvalue (car (x)))) + v = num_div (v, nvalue (car (x))); + else + Error_0 ("/: division by zero"); s_return (mk_number (SCHEME_A_ v)); case OP_INTDIV: /* quotient */ - if (cdr (SCHEME_V->args) == NIL) + if (cdr (args) == NIL) { - x = SCHEME_V->args; + x = args; v = num_one; } else { - x = cdr (SCHEME_V->args); - v = nvalue (car (SCHEME_V->args)); + x = cdr (args); + v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) { if (ivalue (car (x)) != 0) - v = num_intdiv (v, nvalue (car (x))); + v = num_op (NUM_INTDIV, v, nvalue (car (x))); else Error_0 ("quotient: division by zero"); } @@ -4183,86 +4253,112 @@ s_return (mk_number (SCHEME_A_ v)); case OP_REM: /* remainder */ - v = nvalue (car (SCHEME_V->args)); + v = nvalue (x); - if (ivalue (cadr (SCHEME_V->args)) != 0) - v = num_rem (v, nvalue (cadr (SCHEME_V->args))); + if (ivalue (cadr (args)) != 0) + v = num_rem (v, nvalue (cadr (args))); else Error_0 ("remainder: division by zero"); s_return (mk_number (SCHEME_A_ v)); case OP_MOD: /* modulo */ - v = nvalue (car (SCHEME_V->args)); + v = nvalue (x); - if (ivalue (cadr (SCHEME_V->args)) != 0) - v = num_mod (v, nvalue (cadr (SCHEME_V->args))); + if (ivalue (cadr (args)) != 0) + v = num_mod (v, nvalue (cadr (args))); else Error_0 ("modulo: division by zero"); s_return (mk_number (SCHEME_A_ v)); - case OP_CAR: /* car */ - s_return (caar (SCHEME_V->args)); - - case OP_CDR: /* cdr */ - s_return (cdar (SCHEME_V->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 (SCHEME_V->args, cadr (SCHEME_V->args)); - s_return (SCHEME_V->args); + set_cdr (args, cadr (args)); + s_return (args); case OP_SETCAR: /* set-car! */ - if (!is_immutable (car (SCHEME_V->args))) + if (!is_immutable (x)) { - set_car (car (SCHEME_V->args), cadr (SCHEME_V->args)); - s_return (car (SCHEME_V->args)); + set_car (x, cadr (args)); + s_return (car (args)); } else Error_0 ("set-car!: unable to alter immutable pair"); case OP_SETCDR: /* set-cdr! */ - if (!is_immutable (car (SCHEME_V->args))) + if (!is_immutable (x)) { - set_cdr (car (SCHEME_V->args), cadr (SCHEME_V->args)); - s_return (car (SCHEME_V->args)); + set_cdr (x, cadr (args)); + s_return (car (args)); } else Error_0 ("set-cdr!: unable to alter immutable pair"); case OP_CHAR2INT: /* char->integer */ - s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args)))); + s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x))); case OP_INT2CHAR: /* integer->char */ - s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args)))); + s_return (mk_character (SCHEME_A_ ivalue_unchecked (x))); case OP_CHARUPCASE: { - unsigned char c = ivalue (car (SCHEME_V->args)); + unsigned char c = ivalue_unchecked (x); c = toupper (c); s_return (mk_character (SCHEME_A_ c)); } case OP_CHARDNCASE: { - unsigned char c = ivalue (car (SCHEME_V->args)); + unsigned char c = ivalue_unchecked (x); c = tolower (c); s_return (mk_character (SCHEME_A_ c)); } case OP_STR2SYM: /* string->symbol */ - s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args)))); + s_return (mk_symbol (SCHEME_A_ strvalue (x))); case OP_STR2ATOM: /* string->atom */ { - char *s = strvalue (car (SCHEME_V->args)); + char *s = strvalue (x); long pf = 0; - if (cdr (SCHEME_V->args) != NIL) + if (cdr (args) != NIL) { - /* we know cadr(SCHEME_V->args) is a natural number */ + /* we know cadr(args) is a natural number */ /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked (cadr (SCHEME_V->args)); + pf = ivalue_unchecked (cadr (args)); if (pf == 16 || pf == 10 || pf == 8 || pf == 2) { @@ -4273,7 +4369,7 @@ } if (pf < 0) - Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args)); + Error_1 ("string->atom: bad base:", cadr (args)); else if (*s == '#') /* no use of base! */ s_return (mk_sharp_const (SCHEME_A_ s + 1)); else @@ -4294,7 +4390,7 @@ } case OP_SYM2STR: /* symbol->string */ - x = mk_string (SCHEME_A_ symname (car (SCHEME_V->args))); + x = mk_string (SCHEME_A_ symname (x)); setimmutable (x); s_return (x); @@ -4302,13 +4398,11 @@ { long pf = 0; - x = car (SCHEME_V->args); - - if (cdr (SCHEME_V->args) != NIL) + if (cdr (args) != NIL) { - /* we know cadr(SCHEME_V->args) is a natural number */ + /* we know cadr(args) is a natural number */ /* see if it is 2, 8, 10, or 16, or error */ - pf = ivalue_unchecked (cadr (SCHEME_V->args)); + pf = ivalue_unchecked (cadr (args)); if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { @@ -4319,7 +4413,7 @@ } if (pf < 0) - Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args)); + Error_1 ("atom->string: bad base:", cadr (args)); else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x)) { char *p; @@ -4334,55 +4428,42 @@ case OP_MKSTRING: /* make-string */ { - int fill = ' '; - int len; + int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' '; + int len = ivalue_unchecked (x); - len = ivalue (car (SCHEME_V->args)); - - if (cdr (SCHEME_V->args) != NIL) - fill = charvalue (cadr (SCHEME_V->args)); - - s_return (mk_empty_string (SCHEME_A_ len, (char) fill)); + s_return (mk_empty_string (SCHEME_A_ len, fill)); } case OP_STRLEN: /* string-length */ - s_return (mk_integer (SCHEME_A_ strlength (car (SCHEME_V->args)))); + s_return (mk_integer (SCHEME_A_ strlength (x))); case OP_STRREF: /* string-ref */ { - char *str; - int index; - - str = strvalue (car (SCHEME_V->args)); - - index = ivalue (cadr (SCHEME_V->args)); + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); - if (index >= strlength (car (SCHEME_V->args))) - Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args)); + if (index >= strlength (x)) + Error_1 ("string-ref: out of bounds:", cadr (args)); - s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index])); + s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index])); } case OP_STRSET: /* string-set! */ { - char *str; - int index; + char *str = strvalue (x); + int index = ivalue_unchecked (cadr (args)); int c; - if (is_immutable (car (SCHEME_V->args))) - Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args)); + if (is_immutable (x)) + Error_1 ("string-set!: unable to alter immutable string:", x); - str = strvalue (car (SCHEME_V->args)); + if (index >= strlength (x)) + Error_1 ("string-set!: out of bounds:", cadr (args)); - index = ivalue (cadr (SCHEME_V->args)); + c = charvalue (caddr (args)); - if (index >= strlength (car (SCHEME_V->args))) - Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args)); - - c = charvalue (caddr (SCHEME_V->args)); - - str[index] = (char) c; - s_return (car (SCHEME_V->args)); + str[index] = c; + s_return (car (args)); } case OP_STRAPPEND: /* string-append */ @@ -4393,46 +4474,40 @@ char *pos; /* compute needed length for new string */ - for (x = SCHEME_V->args; x != NIL; x = cdr (x)) + for (x = args; x != NIL; x = cdr (x)) len += strlength (car (x)); newstr = mk_empty_string (SCHEME_A_ len, ' '); /* store the contents of the argument strings into the new string */ - for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x)) + for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x)) memcpy (pos, strvalue (car (x)), strlength (car (x))); s_return (newstr); } - case OP_SUBSTR: /* substring */ + case OP_STRING_COPY: /* substring/string-copy */ { - char *str; - int index0; + char *str = strvalue (x); + int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args)); int index1; int len; - str = strvalue (car (SCHEME_V->args)); - - index0 = ivalue (cadr (SCHEME_V->args)); - - if (index0 > strlength (car (SCHEME_V->args))) - Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args)); + if (index0 > strlength (x)) + Error_1 ("string->copy: start out of bounds:", cadr (args)); - if (cddr (SCHEME_V->args) != NIL) + if (cddr (args) != NIL) { - index1 = ivalue (caddr (SCHEME_V->args)); + index1 = ivalue_unchecked (caddr (args)); - if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0) - Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args)); + if (index1 > strlength (x) || index1 < index0) + Error_1 ("string->copy: end out of bounds:", caddr (args)); } else - index1 = strlength (car (SCHEME_V->args)); + index1 = strlength (x); len = index1 - index0; - x = mk_empty_string (SCHEME_A_ len, ' '); - memcpy (strvalue (x), str + index0, len); - strvalue (x)[len] = 0; + x = mk_counted_string (SCHEME_A_ str + index0, len); s_return (x); } @@ -4441,10 +4516,10 @@ { int i; pointer vec; - int len = list_length (SCHEME_A_ SCHEME_V->args); + int len = list_length (SCHEME_A_ args); if (len < 0) - Error_1 ("vector: not a proper list:", SCHEME_V->args); + Error_1 ("vector: not a proper list:", args); vec = mk_vector (SCHEME_A_ len); @@ -4453,8 +4528,8 @@ s_return (S_SINK); #endif - for (x = SCHEME_V->args, i = 0; is_pair (x); x = cdr (x), i++) - set_vector_elem (vec, i, car (x)); + for (x = args, i = 0; is_pair (x); x = cdr (x), i++) + vector_set (vec, i, car (x)); s_return (vec); } @@ -4462,13 +4537,11 @@ case OP_MKVECTOR: /* make-vector */ { pointer fill = NIL; - int len; pointer vec; + int len = ivalue_unchecked (x); - len = ivalue (car (SCHEME_V->args)); - - if (cdr (SCHEME_V->args) != NIL) - fill = cadr (SCHEME_V->args); + if (cdr (args) != NIL) + fill = cadr (args); vec = mk_vector (SCHEME_A_ len); @@ -4478,250 +4551,148 @@ #endif if (fill != NIL) - fill_vector (vec, fill); + fill_vector (vec, 0, fill); s_return (vec); } case OP_VECLEN: /* vector-length */ - s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args)))); + 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; + int index = ivalue_unchecked (cadr (args)); - index = ivalue (cadr (SCHEME_V->args)); + if (index >= veclength (car (args)) && USE_ERROR_CHECKING) + Error_1 ("vector-ref: out of bounds:", cadr (args)); - if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) - Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); - - s_return (vector_elem (car (SCHEME_V->args), index)); + s_return (vector_get (x, index)); } case OP_VECSET: /* vector-set! */ { - int index; - - if (is_immutable (car (SCHEME_V->args))) - Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); + int index = ivalue_unchecked (cadr (args)); - index = ivalue (cadr (SCHEME_V->args)); + if (is_immutable (x)) + Error_1 ("vector-set!: unable to alter immutable vector:", x); - if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING) - Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); + if (index >= veclength (car (args)) && USE_ERROR_CHECKING) + Error_1 ("vector-set!: out of bounds:", cadr (args)); - set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); - s_return (car (SCHEME_V->args)); + vector_set (x, index, caddr (args)); + s_return (x); } } - return S_T; -} - -INTERFACE int -is_list (SCHEME_P_ pointer a) -{ - return list_length (SCHEME_A_ a) >= 0; + if (USE_ERROR_CHECKING) abort (); } -/* Result is: - proper list: length - circular list: -1 - not even a pair: -2 - dotted list: -2 minus length before dot -*/ -INTERFACE int -list_length (SCHEME_P_ pointer a) +/* relational ops */ +ecb_hot static int +opexe_2 (SCHEME_P_ enum scheme_opcodes op) { - int i = 0; - pointer slow, fast; + pointer x = SCHEME_V->args; - slow = fast = a; - - while (1) + for (;;) { - if (fast == NIL) - return i; - - if (!is_pair (fast)) - return -2 - i; - - fast = cdr (fast); - ++i; + num v = nvalue (car (x)); + x = cdr (x); - if (fast == NIL) - return i; - - if (!is_pair (fast)) - return -2 - i; - - ++i; - fast = cdr (fast); + if (x == NIL) + break; - /* Safe because we would have already returned if `fast' - encountered a non-pair. */ - slow = cdr (slow); + int r = num_cmp (v, nvalue (car (x))); - if (fast == slow) + switch (op) { - /* the fast pointer has looped back around and caught up - with the slow pointer, hence the structure is circular, - not of finite length, and therefore not a list */ - return -1; + case OP_NUMEQ: r = r == 0; break; + case OP_LESS: r = r < 0; break; + case OP_GRE: r = r > 0; break; + case OP_LEQ: r = r <= 0; break; + case OP_GEQ: r = r >= 0; break; } + + if (!r) + s_return (S_F); } + + s_return (S_T); } -static pointer +/* predicates */ +ecb_hot static int opexe_3 (SCHEME_P_ enum scheme_opcodes op) { - pointer x; - num v; - int (*comp_func) (num, num); + pointer args = SCHEME_V->args; + pointer a = car (args); + pointer d = cdr (args); + int r; switch (op) { - case OP_NOT: /* not */ - s_retbool (is_false (car (SCHEME_V->args))); - - case OP_BOOLP: /* boolean? */ - s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T); - - case OP_EOFOBJP: /* boolean? */ - s_retbool (car (SCHEME_V->args) == S_EOF); - - case OP_NULLP: /* null? */ - s_retbool (car (SCHEME_V->args) == NIL); - - case OP_NUMEQ: /* = */ - case OP_LESS: /* < */ - case OP_GRE: /* > */ - case OP_LEQ: /* <= */ - case OP_GEQ: /* >= */ - switch (op) - { - case OP_NUMEQ: - comp_func = num_eq; - break; - - case OP_LESS: - comp_func = num_lt; - break; - - case OP_GRE: - comp_func = num_gt; - break; - - case OP_LEQ: - comp_func = num_le; - break; - - case OP_GEQ: - comp_func = num_ge; - break; - } - - x = SCHEME_V->args; - v = nvalue (car (x)); - x = cdr (x); - - for (; x != NIL; x = cdr (x)) - { - if (!comp_func (v, nvalue (car (x)))) - s_retbool (0); - - v = nvalue (car (x)); - } - - s_retbool (1); - - case OP_SYMBOLP: /* symbol? */ - s_retbool (is_symbol (car (SCHEME_V->args))); - - case OP_NUMBERP: /* number? */ - s_retbool (is_number (car (SCHEME_V->args))); - - case OP_STRINGP: /* string? */ - s_retbool (is_string (car (SCHEME_V->args))); + case OP_NOT: /* not */ r = is_false (a) ; break; + case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break; + case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; + case OP_NULLP: /* null? */ r = a == NIL ; break; + case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; + case OP_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; - case OP_INTEGERP: /* integer? */ - s_retbool (is_integer (car (SCHEME_V->args))); - - case OP_REALP: /* real? */ - s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */ - - case OP_CHARP: /* char? */ - s_retbool (is_character (car (SCHEME_V->args))); #if USE_CHAR_CLASSIFIERS - - case OP_CHARAP: /* char-alphabetic? */ - s_retbool (Cisalpha (ivalue (car (SCHEME_V->args)))); - - case OP_CHARNP: /* char-numeric? */ - s_retbool (Cisdigit (ivalue (car (SCHEME_V->args)))); - - case OP_CHARWP: /* char-whitespace? */ - s_retbool (Cisspace (ivalue (car (SCHEME_V->args)))); - - case OP_CHARUP: /* char-upper-case? */ - s_retbool (Cisupper (ivalue (car (SCHEME_V->args)))); - - case OP_CHARLP: /* char-lower-case? */ - s_retbool (Cislower (ivalue (car (SCHEME_V->args)))); + case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; + case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; + case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; + case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break; + case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break; #endif -#if USE_PORTS - case OP_PORTP: /* port? */ - s_retbool (is_port (car (SCHEME_V->args))); - - case OP_INPORTP: /* input-port? */ - s_retbool (is_inport (car (SCHEME_V->args))); - - case OP_OUTPORTP: /* output-port? */ - s_retbool (is_outport (car (SCHEME_V->args))); +#if USE_PORTS + case OP_PORTP: /* port? */ r = is_port (a) ; break; + case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break; + case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break; #endif case OP_PROCP: /* procedure? */ - /*-- - * continuation should be procedure by the example - * (call-with-current-continuation procedure?) ==> #t - * in R^3 report sec. 6.9 - */ - s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args)) - || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args))); - - case OP_PAIRP: /* pair? */ - s_retbool (is_pair (car (SCHEME_V->args))); - - case OP_LISTP: /* list? */ - s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0); - - case OP_ENVP: /* environment? */ - s_retbool (is_environment (car (SCHEME_V->args))); - - case OP_VECTORP: /* vector? */ - s_retbool (is_vector (car (SCHEME_V->args))); - - case OP_EQ: /* eq? */ - s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args)); + /*-- + * continuation should be procedure by the example + * (call-with-current-continuation procedure?) ==> #t + * in R^3 report sec. 6.9 + */ + r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a); + break; - case OP_EQV: /* eqv? */ - s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args))); + case OP_PAIRP: /* pair? */ r = is_pair (a) ; break; + case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break; + case OP_ENVP: /* environment? */ r = is_environment (a) ; break; + case OP_VECTORP: /* vector? */ r = is_vector (a) ; break; + case OP_EQ: /* eq? */ r = a == cadr (args) ; break; + case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break; } - return S_T; + s_retbool (r); } -static pointer +/* promises, list ops, ports */ +ecb_hot static int opexe_4 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; + pointer a = car (args); pointer x, y; switch (op) { case OP_FORCE: /* force */ - SCHEME_V->code = car (SCHEME_V->args); + SCHEME_V->code = a; if (is_promise (SCHEME_V->code)) { @@ -4734,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 */ @@ -4752,7 +4726,7 @@ } } - SCHEME_V->args = car (SCHEME_V->args); + SCHEME_V->args = a; if (op == OP_WRITE) SCHEME_V->print_flag = 1; @@ -4761,64 +4735,65 @@ s_goto (OP_P0LIST); + //TODO: move to scheme case OP_NEWLINE: /* newline */ - if (is_pair (SCHEME_V->args)) + if (is_pair (args)) { - if (car (SCHEME_V->args) != SCHEME_V->outport) + if (a != SCHEME_V->outport) { x = cons (SCHEME_V->outport, NIL); s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); - SCHEME_V->outport = car (SCHEME_V->args); + SCHEME_V->outport = a; } } - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); s_return (S_T); #endif case OP_ERR0: /* error */ SCHEME_V->retcode = -1; - if (!is_string (car (SCHEME_V->args))) + if (!is_string (a)) { - SCHEME_V->args = cons (mk_string (SCHEME_A_ " -- "), SCHEME_V->args); - setimmutable (car (SCHEME_V->args)); + args = cons (mk_string (SCHEME_A_ " -- "), args); + setimmutable (car (args)); } putstr (SCHEME_A_ "Error: "); - putstr (SCHEME_A_ strvalue (car (SCHEME_V->args))); - SCHEME_V->args = cdr (SCHEME_V->args); + putstr (SCHEME_A_ strvalue (car (args))); + SCHEME_V->args = cdr (args); s_goto (OP_ERR1); case OP_ERR1: /* error */ - putstr (SCHEME_A_ " "); + putcharacter (SCHEME_A_ ' '); - if (SCHEME_V->args != NIL) + if (args != NIL) { - s_save (SCHEME_A_ OP_ERR1, cdr (SCHEME_V->args), NIL); - SCHEME_V->args = car (SCHEME_V->args); + s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); + SCHEME_V->args = a; SCHEME_V->print_flag = 1; s_goto (OP_P0LIST); } else { - putstr (SCHEME_A_ "\n"); + putcharacter (SCHEME_A_ '\n'); if (SCHEME_V->interactive_repl) s_goto (OP_T0LVL); else - return NIL; + return -1; } case OP_REVERSE: /* reverse */ - s_return (reverse (SCHEME_A_ car (SCHEME_V->args))); + s_return (reverse (SCHEME_A_ a)); case OP_LIST_STAR: /* list* */ s_return (list_star (SCHEME_A_ SCHEME_V->args)); case OP_APPEND: /* append */ x = NIL; - y = SCHEME_V->args; + y = args; if (y == x) s_return (x); @@ -4839,27 +4814,27 @@ #if USE_PLIST case OP_PUT: /* put */ - if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) + if (!hasprop (a) || !hasprop (cadr (args))) Error_0 ("illegal use of put"); - for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) + for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x)) { if (caar (x) == y) break; } if (x != NIL) - cdar (x) = caddr (SCHEME_V->args); + cdar (x) = caddr (args); else - symprop (car (SCHEME_V->args)) = cons (cons (y, caddr (SCHEME_V->args)), symprop (car (SCHEME_V->args))); + symprop (a) = cons (cons (y, caddr (args)), symprop (a)); s_return (S_T); case OP_GET: /* get */ - if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) + if (!hasprop (a) || !hasprop (cadr (args))) Error_0 ("illegal use of get"); - for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) + for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x)) if (caar (x) == y) break; @@ -4871,10 +4846,10 @@ #endif /* USE_PLIST */ case OP_QUIT: /* quit */ - if (is_pair (SCHEME_V->args)) - SCHEME_V->retcode = ivalue (car (SCHEME_V->args)); + if (is_pair (args)) + SCHEME_V->retcode = ivalue (a); - return NIL; + return -1; case OP_GC: /* gc */ gc (SCHEME_A_ NIL, NIL); @@ -4884,17 +4859,16 @@ { int was = SCHEME_V->gc_verbose; - SCHEME_V->gc_verbose = (car (SCHEME_V->args) != S_F); + SCHEME_V->gc_verbose = (a != S_F); s_retbool (was); } case OP_NEWSEGMENT: /* new-segment */ - if (!is_pair (SCHEME_V->args) || !is_number (car (SCHEME_V->args))) +#if 0 + if (!is_pair (args) || !is_number (a)) Error_0 ("new-segment: argument must be a number"); - - alloc_cellseg (SCHEME_A_ (int)ivalue (car (SCHEME_V->args))); - - s_return (S_T); +#endif + s_retbool (alloc_cellseg (SCHEME_A)); case OP_OBLIST: /* oblist */ s_return (oblist_all_symbols (SCHEME_A)); @@ -4929,12 +4903,9 @@ break; } - p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop); + p = port_from_filename (SCHEME_A_ strvalue (a), prop); - if (p == NIL) - s_return (S_F); - - s_return (p); + s_return (p == NIL ? S_F : p); } # if USE_STRING_PORTS @@ -4956,43 +4927,30 @@ break; } - p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), - strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop); - - if (p == NIL) - s_return (S_F); + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), prop); - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_OPEN_OUTSTRING: /* open-output-string */ { pointer p; - if (car (SCHEME_V->args) == NIL) - { - p = port_from_scratch (SCHEME_A); - - if (p == NIL) - s_return (S_F); - } + if (a == NIL) + p = port_from_scratch (SCHEME_A); else - { - p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), - strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output); + p = port_from_string (SCHEME_A_ strvalue (a), + strvalue (a) + strlength (a), port_output); - if (p == NIL) - s_return (S_F); - } - - s_return (p); + s_return (p == NIL ? S_F : p); } case OP_GET_OUTSTRING: /* get-output-string */ { - port *p; + port *p = port (a); - if ((p = car (SCHEME_V->args)->object.port)->kind & port_string) + if (p->kind & port_string) { off_t size; char *str; @@ -5018,11 +4976,11 @@ # endif case OP_CLOSE_INPORT: /* close-input-port */ - port_close (SCHEME_A_ car (SCHEME_V->args), port_input); + port_close (SCHEME_A_ a, port_input); s_return (S_T); case OP_CLOSE_OUTPORT: /* close-output-port */ - port_close (SCHEME_A_ car (SCHEME_V->args), port_output); + port_close (SCHEME_A_ a, port_output); s_return (S_T); #endif @@ -5034,12 +4992,14 @@ } - return S_T; + if (USE_ERROR_CHECKING) abort (); } -static pointer +/* reading */ +ecb_cold static int opexe_5 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; pointer x; if (SCHEME_V->nesting != 0) @@ -5056,17 +5016,17 @@ /* ========== reading part ========== */ #if USE_PORTS case OP_READ: - if (!is_pair (SCHEME_V->args)) + if (!is_pair (args)) s_goto (OP_READ_INTERNAL); - if (!is_inport (car (SCHEME_V->args))) - Error_1 ("read: not an input port:", car (SCHEME_V->args)); + if (!is_inport (car (args))) + Error_1 ("read: not an input port:", car (args)); - if (car (SCHEME_V->args) == SCHEME_V->inport) + if (car (args) == SCHEME_V->inport) s_goto (OP_READ_INTERNAL); x = SCHEME_V->inport; - SCHEME_V->inport = car (SCHEME_V->args); + SCHEME_V->inport = car (args); x = cons (x, NIL); s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); s_goto (OP_READ_INTERNAL); @@ -5076,14 +5036,14 @@ { int c; - if (is_pair (SCHEME_V->args)) + if (is_pair (args)) { - if (car (SCHEME_V->args) != SCHEME_V->inport) + if (car (args) != SCHEME_V->inport) { x = SCHEME_V->inport; x = cons (x, NIL); s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); - SCHEME_V->inport = car (SCHEME_V->args); + SCHEME_V->inport = car (args); } } @@ -5103,20 +5063,20 @@ pointer p = SCHEME_V->inport; int res; - if (is_pair (SCHEME_V->args)) - p = car (SCHEME_V->args); + if (is_pair (args)) + p = car (args); - res = p->object.port->kind & port_string; + res = port (p)->kind & port_string; s_retbool (res); } case OP_SET_INPORT: /* set-input-port */ - SCHEME_V->inport = car (SCHEME_V->args); + SCHEME_V->inport = car (args); s_return (SCHEME_V->value); case OP_SET_OUTPORT: /* set-output-port */ - SCHEME_V->outport = car (SCHEME_V->args); + SCHEME_V->outport = car (args); s_return (SCHEME_V->value); #endif @@ -5175,10 +5135,19 @@ s_goto (OP_RDSEXPR); case TOK_ATOM: - s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); + s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))); + + case TOK_DOTATOM: + SCHEME_V->strbuff[0] = '.'; + s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); + + case TOK_STRATOM: + x = readstrexp (SCHEME_A_ '|'); + //TODO: haven't checked whether the garbage collector could interfere + s_return (mk_atom (SCHEME_A_ strvalue (x))); case TOK_DQUOTE: - x = readstrexp (SCHEME_A); + x = readstrexp (SCHEME_A_ '"'); if (x == S_F) Error_0 ("Error reading string"); @@ -5200,7 +5169,7 @@ } case TOK_SHARP_CONST: - if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) + if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) Error_0 ("undefined sharp expression"); else s_return (x); @@ -5212,7 +5181,7 @@ break; case OP_RDLIST: - SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); + SCHEME_V->args = cons (SCHEME_V->value, args); SCHEME_V->tok = token (SCHEME_A); switch (SCHEME_V->tok) @@ -5250,7 +5219,7 @@ Error_0 ("syntax error: illegal dot expression"); SCHEME_V->nesting_stack[SCHEME_V->file_i]--; - s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args)); + s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args)); case OP_RDQUOTE: s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); @@ -5282,63 +5251,56 @@ /* ========== printing part ========== */ case OP_P0LIST: - if (is_vector (SCHEME_V->args)) + if (is_vector (args)) { putstr (SCHEME_A_ "#("); - SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0)); + SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0)); s_goto (OP_PVECFROM); } - else if (is_environment (SCHEME_V->args)) + else if (is_environment (args)) { putstr (SCHEME_A_ "#"); s_return (S_T); } - else if (!is_pair (SCHEME_V->args)) + else if (!is_pair (args)) { - printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); + printatom (SCHEME_A_ args, SCHEME_V->print_flag); s_return (S_T); } - else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ "'"); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } - else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ "`"); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } - else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ ","); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } - else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args))) - { - putstr (SCHEME_A_ ",@"); - SCHEME_V->args = cadr (SCHEME_V->args); - s_goto (OP_P0LIST); - } else { - putstr (SCHEME_A_ "("); - s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL); - SCHEME_V->args = car (SCHEME_V->args); + pointer a = car (args); + pointer b = cdr (args); + int ok_abbr = ok_abbrev (b); + SCHEME_V->args = car (b); + + if (a == SCHEME_V->QUOTE && ok_abbr) + putcharacter (SCHEME_A_ '\''); + else if (a == SCHEME_V->QQUOTE && ok_abbr) + putcharacter (SCHEME_A_ '`'); + else if (a == SCHEME_V->UNQUOTE && ok_abbr) + putcharacter (SCHEME_A_ ','); + else if (a == SCHEME_V->UNQUOTESP && ok_abbr) + putstr (SCHEME_A_ ",@"); + else + { + putcharacter (SCHEME_A_ '('); + s_save (SCHEME_A_ OP_P1LIST, b, NIL); + SCHEME_V->args = a; + } + s_goto (OP_P0LIST); } case OP_P1LIST: - if (is_pair (SCHEME_V->args)) + if (is_pair (args)) { - s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL); - putstr (SCHEME_A_ " "); - SCHEME_V->args = car (SCHEME_V->args); + s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); + putcharacter (SCHEME_A_ ' '); + SCHEME_V->args = car (args); s_goto (OP_P0LIST); } - else if (is_vector (SCHEME_V->args)) + else if (is_vector (args)) { s_save (SCHEME_A_ OP_P1LIST, NIL, NIL); putstr (SCHEME_A_ " . "); @@ -5346,67 +5308,70 @@ } else { - if (SCHEME_V->args != NIL) + if (args != NIL) { putstr (SCHEME_A_ " . "); - printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); + printatom (SCHEME_A_ args, SCHEME_V->print_flag); } - putstr (SCHEME_A_ ")"); + putcharacter (SCHEME_A_ ')'); s_return (S_T); } case OP_PVECFROM: { - int i = ivalue_unchecked (cdr (SCHEME_V->args)); - pointer vec = car (SCHEME_V->args); + int i = ivalue_unchecked (cdr (args)); + pointer vec = car (args); int len = veclength (vec); if (i == len) { - putstr (SCHEME_A_ ")"); + putcharacter (SCHEME_A_ ')'); s_return (S_T); } else { - pointer elem = vector_elem (vec, i); + pointer elem = vector_get (vec, i); - ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1; - s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL); + ivalue_unchecked (cdr (args)) = i + 1; + s_save (SCHEME_A_ OP_PVECFROM, args, NIL); SCHEME_V->args = elem; if (i > 0) - putstr (SCHEME_A_ " "); + putcharacter (SCHEME_A_ ' '); s_goto (OP_P0LIST); } } } - return S_T; + if (USE_ERROR_CHECKING) abort (); } -static pointer +/* list ops */ +ecb_hot static int opexe_6 (SCHEME_P_ enum scheme_opcodes op) { + pointer args = SCHEME_V->args; + pointer a = car (args); pointer x, y; switch (op) { case OP_LIST_LENGTH: /* length *//* a.k */ { - long v = list_length (SCHEME_A_ car (SCHEME_V->args)); + long v = list_length (SCHEME_A_ a); if (v < 0) - Error_1 ("length: not a list:", car (SCHEME_V->args)); + Error_1 ("length: not a list:", a); s_return (mk_integer (SCHEME_A_ v)); } case OP_ASSQ: /* assq *//* a.k */ - x = car (SCHEME_V->args); + x = a; - for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y)) + for (y = cadr (args); is_pair (y); y = cdr (y)) { if (!is_pair (car (y))) Error_0 ("unable to handle non pair element"); @@ -5422,7 +5387,7 @@ case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ - SCHEME_V->args = car (SCHEME_V->args); + SCHEME_V->args = a; if (SCHEME_V->args == NIL) s_return (S_F); @@ -5437,29 +5402,38 @@ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t + * (schmorp) well, obviously not, fix? TODO */ - s_retbool (is_closure (car (SCHEME_V->args))); + s_retbool (is_closure (a)); case OP_MACROP: /* macro? */ - s_retbool (is_macro (car (SCHEME_V->args))); + s_retbool (is_macro (a)); } - return S_T; /* NOTREACHED */ + if (USE_ERROR_CHECKING) abort (); } -typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); +/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ +typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); -typedef int (*test_predicate) (pointer); -static int -is_any (pointer p) +typedef int (*test_predicate)(pointer); + +ecb_hot static int +tst_any (pointer p) { return 1; } -static int -is_nonneg (pointer p) +ecb_hot static int +tst_inonneg (pointer p) { - return ivalue (p) >= 0 && is_integer (p); + return is_integer (p) && ivalue_unchecked (p) >= 0; +} + +ecb_hot static int +tst_is_list (SCHEME_P_ pointer p) +{ + return p == NIL || is_pair (p); } /* Correspond carefully with following defines! */ @@ -5467,104 +5441,123 @@ { test_predicate fct; const char *kind; -} tests[] = -{ - { 0, 0}, /* unused */ - { is_any, 0}, - { is_string, "string" }, - { is_symbol, "symbol" }, - { is_port, "port" }, - { is_inport, "input port" }, - { is_outport, "output port" }, - { is_environment, "environment" }, - { is_pair, "pair" }, - { 0, "pair or '()" }, - { is_character, "character" }, - { is_vector, "vector" }, - { is_number, "number" }, - { is_integer, "integer" }, - { is_nonneg, "non-negative integer" } +} tests[] = { + { tst_any , 0 }, + { is_string , "string" }, + { is_symbol , "symbol" }, + { is_port , "port" }, + { is_inport , "input port" }, + { is_outport , "output port" }, + { is_environment, "environment" }, + { is_pair , "pair" }, + { 0 , "pair or '()" }, + { is_character , "character" }, + { is_vector , "vector" }, + { is_number , "number" }, + { is_integer , "integer" }, + { tst_inonneg , "non-negative integer" } }; -#define TST_NONE 0 -#define TST_ANY "\001" -#define TST_STRING "\002" -#define TST_SYMBOL "\003" -#define TST_PORT "\004" -#define TST_INPORT "\005" -#define TST_OUTPORT "\006" +#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */ +#define TST_ANY "\001" +#define TST_STRING "\002" +#define TST_SYMBOL "\003" +#define TST_PORT "\004" +#define TST_INPORT "\005" +#define TST_OUTPORT "\006" #define TST_ENVIRONMENT "\007" -#define TST_PAIR "\010" -#define TST_LIST "\011" -#define TST_CHAR "\012" -#define TST_VECTOR "\013" -#define TST_NUMBER "\014" -#define TST_INTEGER "\015" -#define TST_NATURAL "\016" +#define TST_PAIR "\010" +#define TST_LIST "\011" +#define TST_CHAR "\012" +#define TST_VECTOR "\013" +#define TST_NUMBER "\014" +#define TST_INTEGER "\015" +#define TST_NATURAL "\016" -typedef struct +#define INF_ARG 0xff +#define UNNAMED_OP "" + +static const char opnames[] = +#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" +#include "opdefines.h" +#undef OP_DEF +; + +ecb_cold static const char * +opname (int idx) { - dispatch_func func; - char *name; - int min_arity; - int max_arity; - char *arg_tests_encoding; -} op_code_info; + const char *name = opnames; -#define INF_ARG 0xffff + /* should do this at compile time, but would require external program, right? */ + while (idx--) + name += strlen (name) + 1; -static op_code_info dispatch_table[] = { -#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, -#include "opdefines.h" - {0} -}; + return *name ? name : "ILLEGAL"; +} -static const char * +ecb_cold static const char * procname (pointer x) { - int n = procnum (x); - const char *name = dispatch_table[n].name; + return opname (procnum (x)); +} - if (name == 0) - name = "ILLEGAL!"; +typedef struct +{ + uint8_t func; + /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */ + uint8_t builtin; +#if USE_ERROR_CHECKING + uint8_t min_arity; + uint8_t max_arity; + char arg_tests_encoding[3]; +#endif +} op_code_info; - return name; -} +static const op_code_info dispatch_table[] = { +#if USE_ERROR_CHECKING +#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest }, +#else +#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 }, +#endif +#include "opdefines.h" +#undef OP_DEF + {0} +}; /* kernel of this interpreter */ -static void +ecb_hot static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) { SCHEME_V->op = op; for (;;) { - op_code_info *pcd = dispatch_table + SCHEME_V->op; + const op_code_info *pcd = dispatch_table + SCHEME_V->op; #if USE_ERROR_CHECKING - if (pcd->name) /* if built-in function, check arguments */ + if (pcd->builtin) /* if built-in function, check arguments */ { - int ok = 1; char msg[STRBUFFSIZE]; int n = list_length (SCHEME_A_ SCHEME_V->args); /* Check number of arguments */ if (ecb_expect_false (n < pcd->min_arity)) { - ok = 0; snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); + opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); + xError_1 (SCHEME_A_ msg, 0); + continue; } - else if (ecb_excpect_false (n > pcd->max_arity)) + else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG)) { - ok = 0; snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", - pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); + opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); + xError_1 (SCHEME_A_ msg, 0); + continue; } - - if (ecb_expect_false (ok)) + else { - if (pcd->arg_tests_encoding) + if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */ { int i = 0; int j; @@ -5575,20 +5568,21 @@ { pointer arg = car (arglist); - j = (int) t[0]; + j = t[0]; + /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */ if (j == TST_LIST[0]) { - if (arg != NIL && !is_pair (arg)) + if (!tst_is_list (SCHEME_A_ arg)) break; } else { - if (!tests[j].fct (arg)) + if (!tests[j - 1].fct (arg)) break; } - if (t[1] != 0) /* last test is replicated as necessary */ + if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */ t++; arglist = cdr (arglist); @@ -5598,30 +5592,33 @@ if (i < n) { - ok = 0; - snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind); + snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind); + xError_1 (SCHEME_A_ msg, 0); + continue; } } } - - if (!ok) - { - if (xError_1 (SCHEME_A_ msg, 0) == NIL) - return; - - pcd = dispatch_table + SCHEME_V->op; - } } #endif ok_to_freely_gc (SCHEME_A); - if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)) + static const dispatch_func dispatch_funcs[] = { + opexe_0, + opexe_1, + opexe_2, + opexe_3, + opexe_4, + opexe_5, + opexe_6, + }; + + if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) return; if (SCHEME_V->no_memory && USE_ERROR_CHECKING) { - xwrstr ("No memory!\n"); + putstr (SCHEME_A_ "No memory!\n"); return; } } @@ -5629,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); @@ -5650,17 +5647,16 @@ pointer y = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (y, (T_PROC | T_ATOM)); ivalue_unchecked (y) = op; - set_num_integer (y); return y; } /* 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') @@ -5725,7 +5721,7 @@ } #if USE_MULTIPLICITY -scheme * +ecb_cold scheme * scheme_init_new () { scheme *sc = malloc (sizeof (scheme)); @@ -5740,12 +5736,18 @@ } #endif -int +ecb_cold int scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); pointer x; + /* this memset is not strictly correct, as we assume (intcache) + * that memset 0 will also set pointers to 0, but memset does + * of course not guarantee that. screw such systems. + */ + memset (SCHEME_V, 0, sizeof (*SCHEME_V)); + num_set_fixnum (num_zero, 1); num_set_ivalue (num_zero, 0); num_set_fixnum (num_one, 1); @@ -5766,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; @@ -5776,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 */ @@ -5823,9 +5826,10 @@ assign_syntax (SCHEME_A_ syntax_names[i]); } + // TODO: should iterate via strlen, to avoid n² complexity for (i = 0; i < n; i++) - if (dispatch_table[i].name != 0) - assign_proc (SCHEME_A_ i, dispatch_table[i].name); + if (dispatch_table[i].builtin) + assign_proc (SCHEME_A_ i, opname (i)); /* initialization of global pointers to special symbols */ SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); @@ -5843,38 +5847,38 @@ } #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; } -void +ecb_cold void scheme_deinit (SCHEME_P) { int i; @@ -5926,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); @@ -5941,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 @@ -5963,25 +5963,25 @@ 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; SCHEME_V->load_stack[0].kind = port_input | port_string; - SCHEME_V->load_stack[0].rep.string.start = (char *) cmd; /* This func respects const */ - SCHEME_V->load_stack[0].rep.string.past_the_end = (char *) cmd + strlen (cmd); - SCHEME_V->load_stack[0].rep.string.curr = (char *) cmd; -#if USE_PORTS + SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ + SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); + SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; SCHEME_V->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; @@ -5991,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; @@ -6008,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; @@ -6023,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), @@ -6043,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)); @@ -6054,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; @@ -6071,7 +6074,7 @@ return SCHEME_V->value; } -pointer +ecb_cold pointer scheme_eval (SCHEME_P_ pointer obj) { int old_repl = SCHEME_V->interactive_repl; @@ -6093,7 +6096,7 @@ #if STANDALONE -int +ecb_cold int main (int argc, char **argv) { # if USE_MULTIPLICITY @@ -6105,22 +6108,23 @@ char *file_name = InitFile; int retcode; int isfile = 1; + system ("ps v $PPID");//D if (argc == 2 && strcmp (argv[1], "-?") == 0) { - xwrstr ("Usage: tinyscheme -?\n"); - xwrstr ("or: tinyscheme [ ...]\n"); - xwrstr ("followed by\n"); - xwrstr (" -1 [ ...]\n"); - xwrstr (" -c [ ...]\n"); - xwrstr ("assuming that the executable is named tinyscheme.\n"); - xwrstr ("Use - as filename for stdin.\n"); + putstr (SCHEME_A_ "Usage: tinyscheme -?\n"); + putstr (SCHEME_A_ "or: tinyscheme [ ...]\n"); + putstr (SCHEME_A_ "followed by\n"); + putstr (SCHEME_A_ " -1 [ ...]\n"); + putstr (SCHEME_A_ " -c [ ...]\n"); + putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n"); + putstr (SCHEME_A_ "Use - as filename for stdin.\n"); return 1; } if (!scheme_init (SCHEME_A)) { - xwrstr ("Could not initialize!\n"); + putstr (SCHEME_A_ "Could not initialize!\n"); return 2; } @@ -6143,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) @@ -6171,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 { @@ -6184,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++;