--- microscheme/scheme.c 2015/11/28 10:31:06 1.29 +++ microscheme/scheme.c 2015/11/30 05:19:01 1.40 @@ -36,20 +36,35 @@ #include #include -#include +#if !USE_ERROR_CHECKING +# define NDEBUG +#endif + +#include #include +#include #include #include #include //#include +#if '1' != '0' + 1 \ + || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ + || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ + || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ + || 'f' != 'a' + 5 +# error "execution character set digits not consecutive" +#endif + enum { TOK_EOF, TOK_LPAREN, TOK_RPAREN, TOK_DOT, TOK_ATOM, + TOK_DOTATOM, /* atom name starting with '.' */ + TOK_STRATOM, /* atom name enclosed in | */ TOK_QUOTE, TOK_DQUOTE, TOK_BQUOTE, @@ -61,7 +76,8 @@ }; #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? @@ -393,7 +409,7 @@ INTERFACE char * symname (pointer p) { - return strvalue (car (p)); + return strvalue (p); } #if USE_PLIST @@ -427,7 +443,7 @@ INTERFACE char * syntaxname (pointer p) { - return strvalue (car (p)); + return strvalue (p); } #define procnum(p) ivalue_unchecked (p) @@ -653,7 +669,7 @@ static int file_push (SCHEME_P_ const char *fname); static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); -ecb_inline int is_one_of (char *s, int c); +ecb_inline int is_one_of (const char *s, int c); static int alloc_cellseg (SCHEME_P_ int n); ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); static void finalize_cell (SCHEME_P_ pointer a); @@ -680,8 +696,8 @@ static int basic_inchar (port *pt); static int inchar (SCHEME_P); static void backchar (SCHEME_P_ int c); -static char *readstr_upto (SCHEME_P_ char *delim); -static pointer readstrexp (SCHEME_P); +static char *readstr_upto (SCHEME_P_ int skip, const char *delim); +static pointer readstrexp (SCHEME_P_ char delim); ecb_inline int skipspace (SCHEME_P); static int token (SCHEME_P); static void printslashstring (SCHEME_P_ char *s, int len); @@ -1081,9 +1097,28 @@ /* ========== oblist implementation ========== */ +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; +} + #ifndef USE_OBJECT_LIST -static int hash_fn (const char *key, int table_size); +static int +hash_fn (const char *key, int table_size) +{ + const unsigned char *p = key; + uint32_t hash = 2166136261; + + while (*p) + hash = (hash ^ *p++) * 16777619; + + return hash % table_size; +} static pointer oblist_initial_value (SCHEME_P) @@ -1095,13 +1130,8 @@ static pointer oblist_add_by_name (SCHEME_P_ const char *name) { - int location; - - pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); - set_typeflag (x, T_SYMBOL); - setimmutable (car (x)); - - location = hash_fn (name, veclength (SCHEME_V->oblist)); + pointer x = generate_symbol (SCHEME_A_ name); + int location = hash_fn (name, veclength (SCHEME_V->oblist)); vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); return x; } @@ -1171,11 +1201,9 @@ static pointer oblist_add_by_name (SCHEME_P_ const char *name) { - pointer x; - - x = immutable_cons (mk_string (SCHEME_A_ name), NIL); + pointer x = mk_string (SCHEME_A_ name); set_typeflag (x, T_SYMBOL); - setimmutable (car (x)); + setimmutable (x); SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); return x; } @@ -1275,20 +1303,11 @@ } if (str) - { - int l = strlen (str); - - if (l > len_str) - l = len_str; - - memcpy (q, str, l); - q[l] = 0; - } + memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */ else - { - memset (q, fill, len_str); - q[len_str] = 0; - } + memset (q, fill, len_str); + + q[len_str] = 0; return q; } @@ -1312,6 +1331,7 @@ set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, str, 0); strlength (x) = len; + return x; } @@ -1336,6 +1356,15 @@ vecvalue (vec)[i] = obj; } +INTERFACE void +vector_resize (pointer vec, uint32_t newsize, pointer fill) +{ + uint32_t oldsize = veclength (vec); + vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer)); + veclength (vec) = newsize; + fill_vector (vec, oldsize, fill); +} + INTERFACE pointer vector_get (pointer vec, uint32_t ielem) { @@ -1365,23 +1394,10 @@ 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 NIL; + return generate_symbol (SCHEME_A_ name); } /* make symbol or number atom from string */ @@ -1675,7 +1691,7 @@ finalize_cell (SCHEME_P_ pointer a) { /* TODO, fast bitmap check? */ - if (is_string (a)) + if (is_string (a) || is_symbol (a)) free (strvalue (a)); else if (is_vector (a)) free (vecvalue (a)); @@ -2107,9 +2123,9 @@ /* read characters up to delimiter, but cater to character constants */ static char * -readstr_upto (SCHEME_P_ char *delim) +readstr_upto (SCHEME_P_ int skip, const char *delim) { - char *p = SCHEME_V->strbuff; + char *p = SCHEME_V->strbuff + skip; while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); @@ -2126,13 +2142,12 @@ /* read string expression "xxx...xxx" */ static pointer -readstrexp (SCHEME_P) +readstrexp (SCHEME_P_ char delim) { char *p = SCHEME_V->strbuff; int c; int c1 = 0; - enum - { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; + enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; for (;;) { @@ -2144,20 +2159,13 @@ switch (state) { case st_ok: - switch (c) - { - case '\\': - state = st_bsl; - break; - - case '"': - *p = 0; - return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); + if (ecb_expect_false (c == delim)) + return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); - default: - *p++ = c; - break; - } + if (ecb_expect_false (c == '\\')) + state = st_bsl; + else + *p++ = c; break; @@ -2197,11 +2205,6 @@ state = st_ok; break; - case '"': - *p++ = '"'; - state = st_ok; - break; - default: *p++ = c; state = st_ok; @@ -2212,26 +2215,23 @@ case st_x1: case st_x2: - c = toupper (c); - - if (c >= '0' && c <= 'F') - { - if (c <= '9') - c1 = (c1 << 4) + c - '0'; - else - c1 = (c1 << 4) + c - 'A' + 10; + c = tolower (c); - if (state == st_x1) - state = st_x2; - else - { - *p++ = c1; - state = st_ok; - } - } + if (c >= '0' && c <= '9') + c1 = (c1 << 4) + c - '0'; + else if (c >= 'a' && c <= 'f') + c1 = (c1 << 4) + c - 'a' + 10; else return S_F; + if (state == st_x1) + state = st_x2; + else + { + *p++ = c1; + state = st_ok; + } + break; case st_oct1: @@ -2244,7 +2244,7 @@ } else { - if (state == st_oct2 && c1 >= 32) + if (state == st_oct2 && c1 >= ' ') return S_F; c1 = (c1 << 3) + (c - '0'); @@ -2259,19 +2259,15 @@ } break; - } } } /* check c is in chars */ ecb_inline int -is_one_of (char *s, int c) +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 */ @@ -2288,7 +2284,7 @@ curr_line++; #endif } - while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); + while (is_one_of (WHITESPACE, c)); /* record it */ #if SHOW_ERROR_LINE @@ -2328,16 +2324,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; @@ -2478,7 +2475,6 @@ putcharacter (SCHEME_A_ '"'); } - /* print atoms */ static void printatom (SCHEME_P_ pointer l, int f) @@ -2490,7 +2486,6 @@ putchars (SCHEME_A_ p, len); } - /* Uses internal buffer unless string pointer is already available */ static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) @@ -2660,7 +2655,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); @@ -2815,21 +2817,6 @@ /* ========== Environment implementation ========== */ -#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) - -static int -hash_fn (const char *key, int table_size) -{ - const unsigned char *p = key; - uint32_t hash = 2166136261; - - while (*p) - hash = (hash ^ *p++) * 16777619; - - return hash % table_size; -} -#endif - #ifndef USE_ALIST_ENV /* @@ -2855,6 +2842,21 @@ setenvironment (SCHEME_V->envir); } +static uint32_t +sym_hash (pointer sym, uint32_t size) +{ + uintptr_t ptr = (uintptr_t)sym; + +#if 0 + /* table size is prime, so why mix */ + ptr += ptr >> 32; + ptr += ptr >> 16; + ptr += ptr >> 8; +#endif + + return ptr % size; +} + ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { @@ -2862,8 +2864,7 @@ if (is_vector (car (env))) { - int location = hash_fn (symname (variable), veclength (car (env))); - + int location = sym_hash (variable, veclength (car (env))); vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); } else @@ -2874,13 +2875,12 @@ find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) { pointer x, y; - int location; for (x = env; x != NIL; x = cdr (x)) { if (is_vector (car (x))) { - location = hash_fn (symname (hdl), veclength (car (x))); + int location = sym_hash (hdl, veclength (car (x))); y = vector_get (car (x), location); } else @@ -2927,15 +2927,13 @@ break; if (y != NIL) + return car (y); break; if (!all) - return NIL; + break; } - if (x != NIL) - return car (y); - return NIL; } @@ -2944,6 +2942,7 @@ ecb_inline void new_slot_in_env (SCHEME_P_ pointer variable, pointer value) { + assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); } @@ -3245,6 +3244,64 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) +#if 1 +static int +debug (SCHEME_P_ int indent, pointer x) +{ + int c; + + if (is_syntax (x)) + { + printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x)); + return 8 + 8; + } + + if (x == NIL) + { + printf ("%*sNIL\n", indent, ""); + return 3; + } + + switch (type (x)) + { + case T_INTEGER: + printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x); + return 32+8; + + case T_SYMBOL: + printf ("%*sS<%s>\n", indent, "", symname (x)); + return 24+8; + + case T_CLOSURE: + printf ("%*sS<%s>\n", indent, "", "closure"); + debug (SCHEME_A_ indent + 3, cdr(x)); + return 32 + debug (SCHEME_A_ indent + 3, car (x)); + + case T_PAIR: + printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); + c = debug (SCHEME_A_ indent + 3, car (x)); + c += debug (SCHEME_A_ indent + 3, cdr (x)); + return c + 1; + + case T_PORT: + printf ("%*sS<%s>\n", indent, "", "port"); + return 24+8; + + case T_VECTOR: + printf ("%*sS<%s>\n", indent, "", "vector"); + return 24+8; + + case T_ENVIRONMENT: + printf ("%*sS<%s>\n", indent, "", "environment"); + return 0 + debug (SCHEME_A_ indent + 3, car (x)); + + default: + printf ("unhandled type %d\n", type (x)); + break; + } +} +#endif + static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { @@ -3253,6 +3310,12 @@ switch (op) { +#if 1 //D + case OP_DEBUG: + printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); + printf ("\n"); + s_return (S_T); +#endif case OP_LOAD: /* load */ if (file_interactive (SCHEME_A)) { @@ -3385,7 +3448,7 @@ s_return (SCHEME_V->code); case OP_E0ARGS: /* eval arguments */ - if (is_macro (SCHEME_V->value)) /* macro expansion */ + if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ { s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); SCHEME_V->args = cons (SCHEME_V->code, NIL); @@ -4393,6 +4456,10 @@ case OP_VECLEN: /* vector-length */ s_return (mk_integer (SCHEME_A_ veclength (x))); + case OP_VECRESIZE: + vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args)); + s_return (x); + case OP_VECREF: /* vector-ref */ { int index = ivalue_unchecked (cadr (args)); @@ -4957,10 +5024,19 @@ s_goto (OP_RDSEXPR); case TOK_ATOM: - s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); + s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))); + + case TOK_DOTATOM: + SCHEME_V->strbuff[0] = '.'; + s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); + + case TOK_STRATOM: + x = readstrexp (SCHEME_A_ '|'); + //TODO: haven't checked whether the garbage collector could interfere + s_return (mk_atom (SCHEME_A_ strvalue (x))); case TOK_DQUOTE: - x = readstrexp (SCHEME_A); + x = readstrexp (SCHEME_A_ '"'); if (x == S_F) Error_0 ("Error reading string"); @@ -4982,7 +5058,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); @@ -5214,6 +5290,7 @@ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t + * (schmorp) well, obviously not, fix? TODO */ s_retbool (is_closure (a)); @@ -5464,9 +5541,9 @@ static int syntaxnum (pointer p) { - const char *s = strvalue (car (p)); + const char *s = strvalue (p); - switch (strlength (car (p))) + switch (strlength (p)) { case 2: if (s[0] == 'i') @@ -5912,6 +5989,7 @@ char *file_name = InitFile; int retcode; int isfile = 1; + system ("ps v $PPID");//D if (argc == 2 && strcmp (argv[1], "-?") == 0) {