ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/scheme.c
(Generate patch)

Comparing microscheme/scheme.c (file contents):
Revision 1.29 by root, Sat Nov 28 10:31:06 2015 UTC vs.
Revision 1.43 by root, Mon Nov 30 06:40:57 2015 UTC

… …
16 * (MINISCM) This is a revised and modified version by Akira KIDA. 16 * (MINISCM) This is a revised and modified version by Akira KIDA.
17 * (MINISCM) current version is 0.85k4 (15 May 1994) 17 * (MINISCM) current version is 0.85k4 (15 May 1994)
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1
22
21#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
22#include "malloc.c" 24#include "malloc.c"
23 25
24#define SCHEME_SOURCE 26#define SCHEME_SOURCE
25#include "scheme-private.h" 27#include "scheme-private.h"
… …
34 36
35#include <sys/types.h> 37#include <sys/types.h>
36#include <sys/stat.h> 38#include <sys/stat.h>
37#include <fcntl.h> 39#include <fcntl.h>
38 40
41#if !USE_ERROR_CHECKING
42# define NDEBUG
43#endif
44
45#include <assert.h>
46#include <stdlib.h>
39#include <string.h> 47#include <string.h>
40#include <stdlib.h>
41 48
42#include <limits.h> 49#include <limits.h>
43#include <inttypes.h> 50#include <inttypes.h>
44#include <float.h> 51#include <float.h>
45//#include <ctype.h> 52//#include <ctype.h>
53
54#if '1' != '0' + 1 \
55 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
56 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
57 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
58 || 'f' != 'a' + 5
59# error "execution character set digits not consecutive"
60#endif
46 61
47enum { 62enum {
48 TOK_EOF, 63 TOK_EOF,
49 TOK_LPAREN, 64 TOK_LPAREN,
50 TOK_RPAREN, 65 TOK_RPAREN,
51 TOK_DOT, 66 TOK_DOT,
52 TOK_ATOM, 67 TOK_ATOM,
68 TOK_DOTATOM, /* atom name starting with '.' */
69 TOK_STRATOM, /* atom name enclosed in | */
53 TOK_QUOTE, 70 TOK_QUOTE,
54 TOK_DQUOTE, 71 TOK_DQUOTE,
55 TOK_BQUOTE, 72 TOK_BQUOTE,
56 TOK_COMMA, 73 TOK_COMMA,
57 TOK_ATMARK, 74 TOK_ATMARK,
… …
59 TOK_SHARP_CONST, 76 TOK_SHARP_CONST,
60 TOK_VEC 77 TOK_VEC
61}; 78};
62 79
63#define BACKQUOTE '`' 80#define BACKQUOTE '`'
64#define DELIMITERS "()\";\f\t\v\n\r " 81#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE
65 83
66#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?
67#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
68#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
69#define S_SINK (&SCHEME_V->xsink) 87#define S_SINK (&SCHEME_V->xsink)
… …
391} 409}
392 410
393INTERFACE char * 411INTERFACE char *
394symname (pointer p) 412symname (pointer p)
395{ 413{
396 return strvalue (car (p)); 414 return strvalue (p);
397} 415}
398 416
399#if USE_PLIST 417#if USE_PLIST
418#define symprop(p) cdr(p)
400SCHEME_EXPORT int 419SCHEME_EXPORT int
401hasprop (pointer p) 420hasprop (pointer p)
402{ 421{
403 return typeflag (p) & T_SYMBOL; 422 return typeflag (p) & T_SYMBOL;
404} 423}
405
406# define symprop(p) cdr(p)
407#endif 424#endif
408 425
409INTERFACE int 426INTERFACE int
410is_syntax (pointer p) 427is_syntax (pointer p)
411{ 428{
… …
425} 442}
426 443
427INTERFACE char * 444INTERFACE char *
428syntaxname (pointer p) 445syntaxname (pointer p)
429{ 446{
430 return strvalue (car (p)); 447 return strvalue (p);
431} 448}
432 449
433#define procnum(p) ivalue_unchecked (p) 450#define procnum(p) ivalue_unchecked (p)
434static const char *procname (pointer x); 451static const char *procname (pointer x);
435 452
… …
651#endif 668#endif
652 669
653static int file_push (SCHEME_P_ const char *fname); 670static int file_push (SCHEME_P_ const char *fname);
654static void file_pop (SCHEME_P); 671static void file_pop (SCHEME_P);
655static int file_interactive (SCHEME_P); 672static int file_interactive (SCHEME_P);
656ecb_inline int is_one_of (char *s, int c); 673ecb_inline int is_one_of (const char *s, int c);
657static int alloc_cellseg (SCHEME_P_ int n); 674static int alloc_cellseg (SCHEME_P_ int n);
658ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 675ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
659static void finalize_cell (SCHEME_P_ pointer a); 676static void finalize_cell (SCHEME_P_ pointer a);
660static int count_consecutive_cells (pointer x, int needed); 677static int count_consecutive_cells (pointer x, int needed);
661static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 678static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
… …
678static void mark (pointer a); 695static void mark (pointer a);
679static void gc (SCHEME_P_ pointer a, pointer b); 696static void gc (SCHEME_P_ pointer a, pointer b);
680static int basic_inchar (port *pt); 697static int basic_inchar (port *pt);
681static int inchar (SCHEME_P); 698static int inchar (SCHEME_P);
682static void backchar (SCHEME_P_ int c); 699static void backchar (SCHEME_P_ int c);
683static char *readstr_upto (SCHEME_P_ char *delim); 700static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
684static pointer readstrexp (SCHEME_P); 701static pointer readstrexp (SCHEME_P_ char delim);
685ecb_inline int skipspace (SCHEME_P); 702ecb_inline int skipspace (SCHEME_P);
686static int token (SCHEME_P); 703static int token (SCHEME_P);
687static void printslashstring (SCHEME_P_ char *s, int len); 704static void printslashstring (SCHEME_P_ char *s, int len);
688static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 705static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
689static void printatom (SCHEME_P_ pointer l, int f); 706static void printatom (SCHEME_P_ pointer l, int f);
… …
1077 set_cdr (x, b); 1094 set_cdr (x, b);
1078 1095
1079 return x; 1096 return x;
1080} 1097}
1081 1098
1099static pointer
1100generate_symbol (SCHEME_P_ const char *name)
1101{
1102 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x);
1104 set_typeflag (x, T_SYMBOL | T_ATOM);
1105 return x;
1106}
1107
1082/* ========== oblist implementation ========== */ 1108/* ========== oblist implementation ========== */
1083 1109
1084#ifndef USE_OBJECT_LIST 1110#ifndef USE_OBJECT_LIST
1085 1111
1112static int
1086static int hash_fn (const char *key, int table_size); 1113hash_fn (const char *key, int table_size)
1114{
1115 const unsigned char *p = key;
1116 uint32_t hash = 2166136261;
1117
1118 while (*p)
1119 hash = (hash ^ *p++) * 16777619;
1120
1121 return hash % table_size;
1122}
1087 1123
1088static pointer 1124static pointer
1089oblist_initial_value (SCHEME_P) 1125oblist_initial_value (SCHEME_P)
1090{ 1126{
1091 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1127 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
… …
1093 1129
1094/* returns the new symbol */ 1130/* returns the new symbol */
1095static pointer 1131static pointer
1096oblist_add_by_name (SCHEME_P_ const char *name) 1132oblist_add_by_name (SCHEME_P_ const char *name)
1097{ 1133{
1098 int location; 1134 pointer x = generate_symbol (SCHEME_A_ name);
1099
1100 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1101 set_typeflag (x, T_SYMBOL);
1102 setimmutable (car (x));
1103
1104 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1135 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1105 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1136 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1106 return x; 1137 return x;
1107} 1138}
1108 1139
1109ecb_inline pointer 1140ecb_inline pointer
… …
1169 1200
1170/* returns the new symbol */ 1201/* returns the new symbol */
1171static pointer 1202static pointer
1172oblist_add_by_name (SCHEME_P_ const char *name) 1203oblist_add_by_name (SCHEME_P_ const char *name)
1173{ 1204{
1174 pointer x; 1205 pointer x = mk_string (SCHEME_A_ name);
1175
1176 x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1177 set_typeflag (x, T_SYMBOL); 1206 set_typeflag (x, T_SYMBOL);
1178 setimmutable (car (x)); 1207 setimmutable (x);
1179 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1208 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1180 return x; 1209 return x;
1181} 1210}
1182 1211
1183static pointer 1212static pointer
… …
1273 SCHEME_V->no_memory = 1; 1302 SCHEME_V->no_memory = 1;
1274 return SCHEME_V->strbuff; 1303 return SCHEME_V->strbuff;
1275 } 1304 }
1276 1305
1277 if (str) 1306 if (str)
1278 { 1307 memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1279 int l = strlen (str);
1280
1281 if (l > len_str)
1282 l = len_str;
1283
1284 memcpy (q, str, l);
1285 q[l] = 0;
1286 }
1287 else 1308 else
1288 {
1289 memset (q, fill, len_str); 1309 memset (q, fill, len_str);
1310
1290 q[len_str] = 0; 1311 q[len_str] = 0;
1291 }
1292 1312
1293 return q; 1313 return q;
1294} 1314}
1295 1315
1296INTERFACE pointer 1316INTERFACE pointer
… …
1310 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1330 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1311 1331
1312 set_typeflag (x, T_STRING | T_ATOM); 1332 set_typeflag (x, T_STRING | T_ATOM);
1313 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1333 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1314 strlength (x) = len; 1334 strlength (x) = len;
1335
1315 return x; 1336 return x;
1316} 1337}
1317 1338
1318INTERFACE pointer 1339INTERFACE pointer
1319mk_string (SCHEME_P_ const char *str) 1340mk_string (SCHEME_P_ const char *str)
… …
1332{ 1353{
1333 int i; 1354 int i;
1334 1355
1335 for (i = start; i < veclength (vec); i++) 1356 for (i = start; i < veclength (vec); i++)
1336 vecvalue (vec)[i] = obj; 1357 vecvalue (vec)[i] = obj;
1358}
1359
1360INTERFACE void
1361vector_resize (pointer vec, uint32_t newsize, pointer fill)
1362{
1363 uint32_t oldsize = veclength (vec);
1364 vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
1365 veclength (vec) = newsize;
1366 fill_vector (vec, oldsize, fill);
1337} 1367}
1338 1368
1339INTERFACE pointer 1369INTERFACE pointer
1340vector_get (pointer vec, uint32_t ielem) 1370vector_get (pointer vec, uint32_t ielem)
1341{ 1371{
… …
1363 1393
1364INTERFACE pointer 1394INTERFACE pointer
1365gensym (SCHEME_P) 1395gensym (SCHEME_P)
1366{ 1396{
1367 pointer x; 1397 pointer x;
1368
1369 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1370 {
1371 char name[40] = "gensym-"; 1398 char name[40] = "gensym-";
1372 xnum (name + 7, SCHEME_V->gensym_cnt); 1399 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1373 1400
1374 /* first check oblist */ 1401 return generate_symbol (SCHEME_A_ name);
1375 x = oblist_find_by_name (SCHEME_A_ name); 1402}
1376 1403
1377 if (x == NIL) 1404static int
1378 { 1405is_gensym (SCHEME_P_ pointer x)
1379 x = oblist_add_by_name (SCHEME_A_ name); 1406{
1380 return x; 1407 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1381 }
1382 }
1383
1384 return NIL;
1385} 1408}
1386 1409
1387/* make symbol or number atom from string */ 1410/* make symbol or number atom from string */
1388static pointer 1411static pointer
1389mk_atom (SCHEME_P_ char *q) 1412mk_atom (SCHEME_P_ char *q)
… …
1673 1696
1674static void 1697static void
1675finalize_cell (SCHEME_P_ pointer a) 1698finalize_cell (SCHEME_P_ pointer a)
1676{ 1699{
1677 /* TODO, fast bitmap check? */ 1700 /* TODO, fast bitmap check? */
1678 if (is_string (a)) 1701 if (is_string (a) || is_symbol (a))
1679 free (strvalue (a)); 1702 free (strvalue (a));
1680 else if (is_vector (a)) 1703 else if (is_vector (a))
1681 free (vecvalue (a)); 1704 free (vecvalue (a));
1682#if USE_PORTS 1705#if USE_PORTS
1683 else if (is_port (a)) 1706 else if (is_port (a))
… …
2105#endif 2128#endif
2106} 2129}
2107 2130
2108/* read characters up to delimiter, but cater to character constants */ 2131/* read characters up to delimiter, but cater to character constants */
2109static char * 2132static char *
2110readstr_upto (SCHEME_P_ char *delim) 2133readstr_upto (SCHEME_P_ int skip, const char *delim)
2111{ 2134{
2112 char *p = SCHEME_V->strbuff; 2135 char *p = SCHEME_V->strbuff + skip;
2113 2136
2114 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2137 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2115 2138
2116 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2139 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2117 *p = 0; 2140 *p = 0;
… …
2124 return SCHEME_V->strbuff; 2147 return SCHEME_V->strbuff;
2125} 2148}
2126 2149
2127/* read string expression "xxx...xxx" */ 2150/* read string expression "xxx...xxx" */
2128static pointer 2151static pointer
2129readstrexp (SCHEME_P) 2152readstrexp (SCHEME_P_ char delim)
2130{ 2153{
2131 char *p = SCHEME_V->strbuff; 2154 char *p = SCHEME_V->strbuff;
2132 int c; 2155 int c;
2133 int c1 = 0; 2156 int c1 = 0;
2134 enum
2135 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; 2157 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2136 2158
2137 for (;;) 2159 for (;;)
2138 { 2160 {
2139 c = inchar (SCHEME_A); 2161 c = inchar (SCHEME_A);
2140 2162
… …
2142 return S_F; 2164 return S_F;
2143 2165
2144 switch (state) 2166 switch (state)
2145 { 2167 {
2146 case st_ok: 2168 case st_ok:
2147 switch (c) 2169 if (ecb_expect_false (c == delim))
2148 {
2149 case '\\':
2150 state = st_bsl;
2151 break;
2152
2153 case '"':
2154 *p = 0;
2155 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); 2170 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2156 2171
2157 default: 2172 if (ecb_expect_false (c == '\\'))
2173 state = st_bsl;
2174 else
2158 *p++ = c; 2175 *p++ = c;
2159 break;
2160 }
2161 2176
2162 break; 2177 break;
2163 2178
2164 case st_bsl: 2179 case st_bsl:
2165 switch (c) 2180 switch (c)
… …
2195 case 'r': 2210 case 'r':
2196 *p++ = '\r'; 2211 *p++ = '\r';
2197 state = st_ok; 2212 state = st_ok;
2198 break; 2213 break;
2199 2214
2200 case '"':
2201 *p++ = '"';
2202 state = st_ok;
2203 break;
2204
2205 default: 2215 default:
2206 *p++ = c; 2216 *p++ = c;
2207 state = st_ok; 2217 state = st_ok;
2208 break; 2218 break;
2209 } 2219 }
2210 2220
2211 break; 2221 break;
2212 2222
2213 case st_x1: 2223 case st_x1:
2214 case st_x2: 2224 case st_x2:
2215 c = toupper (c); 2225 c = tolower (c);
2216 2226
2217 if (c >= '0' && c <= 'F') 2227 if (c >= '0' && c <= '9')
2218 {
2219 if (c <= '9')
2220 c1 = (c1 << 4) + c - '0'; 2228 c1 = (c1 << 4) + c - '0';
2221 else 2229 else if (c >= 'a' && c <= 'f')
2222 c1 = (c1 << 4) + c - 'A' + 10; 2230 c1 = (c1 << 4) + c - 'a' + 10;
2223
2224 if (state == st_x1)
2225 state = st_x2;
2226 else
2227 {
2228 *p++ = c1;
2229 state = st_ok;
2230 }
2231 }
2232 else 2231 else
2233 return S_F; 2232 return S_F;
2233
2234 if (state == st_x1)
2235 state = st_x2;
2236 else
2237 {
2238 *p++ = c1;
2239 state = st_ok;
2240 }
2234 2241
2235 break; 2242 break;
2236 2243
2237 case st_oct1: 2244 case st_oct1:
2238 case st_oct2: 2245 case st_oct2:
… …
2242 backchar (SCHEME_A_ c); 2249 backchar (SCHEME_A_ c);
2243 state = st_ok; 2250 state = st_ok;
2244 } 2251 }
2245 else 2252 else
2246 { 2253 {
2247 if (state == st_oct2 && c1 >= 32) 2254 if (state == st_oct2 && c1 >= ' ')
2248 return S_F; 2255 return S_F;
2249 2256
2250 c1 = (c1 << 3) + (c - '0'); 2257 c1 = (c1 << 3) + (c - '0');
2251 2258
2252 if (state == st_oct1) 2259 if (state == st_oct1)
… …
2257 state = st_ok; 2264 state = st_ok;
2258 } 2265 }
2259 } 2266 }
2260 2267
2261 break; 2268 break;
2262
2263 } 2269 }
2264 } 2270 }
2265} 2271}
2266 2272
2267/* check c is in chars */ 2273/* check c is in chars */
2268ecb_inline int 2274ecb_inline int
2269is_one_of (char *s, int c) 2275is_one_of (const char *s, int c)
2270{ 2276{
2271 if (c == EOF)
2272 return 1;
2273
2274 return !!strchr (s, c); 2277 return c == EOF || !!strchr (s, c);
2275} 2278}
2276 2279
2277/* skip white characters */ 2280/* skip white characters */
2278ecb_inline int 2281ecb_inline int
2279skipspace (SCHEME_P) 2282skipspace (SCHEME_P)
… …
2281 int c, curr_line = 0; 2284 int c, curr_line = 0;
2282 2285
2283 do 2286 do
2284 { 2287 {
2285 c = inchar (SCHEME_A); 2288 c = inchar (SCHEME_A);
2289
2286#if SHOW_ERROR_LINE 2290#if SHOW_ERROR_LINE
2287 if (c == '\n') 2291 if (ecb_expect_false (c == '\n'))
2288 curr_line++; 2292 curr_line++;
2289#endif 2293#endif
2294
2295 if (ecb_expect_false (c == EOF))
2296 return c;
2290 } 2297 }
2291 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2298 while (is_one_of (WHITESPACE, c));
2292 2299
2293 /* record it */ 2300 /* record it */
2294#if SHOW_ERROR_LINE 2301#if SHOW_ERROR_LINE
2295 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2302 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2296 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2303 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2297#endif 2304#endif
2298 2305
2299 if (c != EOF)
2300 {
2301 backchar (SCHEME_A_ c); 2306 backchar (SCHEME_A_ c);
2302 return 1; 2307 return 1;
2303 }
2304 else
2305 return EOF;
2306} 2308}
2307 2309
2308/* get token */ 2310/* get token */
2309static int 2311static int
2310token (SCHEME_P) 2312token (SCHEME_P)
… …
2326 return TOK_RPAREN; 2328 return TOK_RPAREN;
2327 2329
2328 case '.': 2330 case '.':
2329 c = inchar (SCHEME_A); 2331 c = inchar (SCHEME_A);
2330 2332
2331 if (is_one_of (" \n\t", c)) 2333 if (is_one_of (WHITESPACE, c))
2332 return TOK_DOT; 2334 return TOK_DOT;
2333 else 2335 else
2334 { 2336 {
2335 //TODO: ungetc twice in a row is not supported in C
2336 backchar (SCHEME_A_ c); 2337 backchar (SCHEME_A_ c);
2337 backchar (SCHEME_A_ '.');
2338 return TOK_ATOM; 2338 return TOK_DOTATOM;
2339 } 2339 }
2340
2341 case '|':
2342 return TOK_STRATOM;
2340 2343
2341 case '\'': 2344 case '\'':
2342 return TOK_QUOTE; 2345 return TOK_QUOTE;
2343 2346
2344 case ';': 2347 case ';':
… …
2476 } 2479 }
2477 2480
2478 putcharacter (SCHEME_A_ '"'); 2481 putcharacter (SCHEME_A_ '"');
2479} 2482}
2480 2483
2481
2482/* print atoms */ 2484/* print atoms */
2483static void 2485static void
2484printatom (SCHEME_P_ pointer l, int f) 2486printatom (SCHEME_P_ pointer l, int f)
2485{ 2487{
2486 char *p; 2488 char *p;
2487 int len; 2489 int len;
2488 2490
2489 atom2str (SCHEME_A_ l, f, &p, &len); 2491 atom2str (SCHEME_A_ l, f, &p, &len);
2490 putchars (SCHEME_A_ p, len); 2492 putchars (SCHEME_A_ p, len);
2491} 2493}
2492
2493 2494
2494/* Uses internal buffer unless string pointer is already available */ 2495/* Uses internal buffer unless string pointer is already available */
2495static void 2496static void
2496atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2497atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2497{ 2498{
… …
2658#endif 2659#endif
2659 } 2660 }
2660 else if (is_continuation (l)) 2661 else if (is_continuation (l))
2661 p = "#<CONTINUATION>"; 2662 p = "#<CONTINUATION>";
2662 else 2663 else
2664 {
2665#if USE_PRINTF
2666 p = SCHEME_V->strbuff;
2667 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2668#else
2663 p = "#<ERROR>"; 2669 p = "#<ERROR>";
2670#endif
2671 }
2664 2672
2665 *pp = p; 2673 *pp = p;
2666 *plen = strlen (p); 2674 *plen = strlen (p);
2667} 2675}
2668 2676
… …
2812/* () is #t in R5RS */ 2820/* () is #t in R5RS */
2813#define is_true(p) ((p) != S_F) 2821#define is_true(p) ((p) != S_F)
2814#define is_false(p) ((p) == S_F) 2822#define is_false(p) ((p) == S_F)
2815 2823
2816/* ========== Environment implementation ========== */ 2824/* ========== Environment implementation ========== */
2817
2818#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2819
2820static int
2821hash_fn (const char *key, int table_size)
2822{
2823 const unsigned char *p = key;
2824 uint32_t hash = 2166136261;
2825
2826 while (*p)
2827 hash = (hash ^ *p++) * 16777619;
2828
2829 return hash % table_size;
2830}
2831#endif
2832 2825
2833#ifndef USE_ALIST_ENV 2826#ifndef USE_ALIST_ENV
2834 2827
2835/* 2828/*
2836 * In this implementation, each frame of the environment may be 2829 * In this implementation, each frame of the environment may be
… …
2853 2846
2854 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2847 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2855 setenvironment (SCHEME_V->envir); 2848 setenvironment (SCHEME_V->envir);
2856} 2849}
2857 2850
2851static uint32_t
2852sym_hash (pointer sym, uint32_t size)
2853{
2854 uintptr_t ptr = (uintptr_t)sym;
2855
2856#if 0
2857 /* table size is prime, so why mix */
2858 ptr += ptr >> 32;
2859 ptr += ptr >> 16;
2860 ptr += ptr >> 8;
2861#endif
2862
2863 return ptr % size;
2864}
2865
2858ecb_inline void 2866ecb_inline void
2859new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2867new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2860{ 2868{
2861 pointer slot = immutable_cons (variable, value); 2869 pointer slot = immutable_cons (variable, value);
2862 2870
2863 if (is_vector (car (env))) 2871 if (is_vector (car (env)))
2864 { 2872 {
2865 int location = hash_fn (symname (variable), veclength (car (env))); 2873 int location = sym_hash (variable, veclength (car (env)));
2866
2867 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); 2874 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2868 } 2875 }
2869 else 2876 else
2870 set_car (env, immutable_cons (slot, car (env))); 2877 set_car (env, immutable_cons (slot, car (env)));
2871} 2878}
2872 2879
2873static pointer 2880static pointer
2874find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2881find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2875{ 2882{
2876 pointer x, y; 2883 pointer x, y;
2877 int location;
2878 2884
2879 for (x = env; x != NIL; x = cdr (x)) 2885 for (x = env; x != NIL; x = cdr (x))
2880 { 2886 {
2881 if (is_vector (car (x))) 2887 if (is_vector (car (x)))
2882 { 2888 {
2883 location = hash_fn (symname (hdl), veclength (car (x))); 2889 int location = sym_hash (hdl, veclength (car (x)));
2884 y = vector_get (car (x), location); 2890 y = vector_get (car (x), location);
2885 } 2891 }
2886 else 2892 else
2887 y = car (x); 2893 y = car (x);
2888 2894
… …
2925 for (y = car (x); y != NIL; y = cdr (y)) 2931 for (y = car (x); y != NIL; y = cdr (y))
2926 if (caar (y) == hdl) 2932 if (caar (y) == hdl)
2927 break; 2933 break;
2928 2934
2929 if (y != NIL) 2935 if (y != NIL)
2936 return car (y);
2930 break; 2937 break;
2931 2938
2932 if (!all) 2939 if (!all)
2933 return NIL; 2940 break;
2934 } 2941 }
2935
2936 if (x != NIL)
2937 return car (y);
2938 2942
2939 return NIL; 2943 return NIL;
2940} 2944}
2941 2945
2942#endif /* USE_ALIST_ENV else */ 2946#endif /* USE_ALIST_ENV else */
2943 2947
2944ecb_inline void 2948ecb_inline void
2945new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2949new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2946{ 2950{
2951 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2947 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2952 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2948} 2953}
2949 2954
2950ecb_inline void 2955ecb_inline void
2951set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2956set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
… …
3243 3248
3244#endif 3249#endif
3245 3250
3246#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3251#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3247 3252
3253#if EXPERIMENT
3254static int
3255debug (SCHEME_P_ int indent, pointer x)
3256{
3257 int c;
3258
3259 if (is_syntax (x))
3260 {
3261 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3262 return 8 + 8;
3263 }
3264
3265 if (x == NIL)
3266 {
3267 printf ("%*sNIL\n", indent, "");
3268 return 3;
3269 }
3270
3271 switch (type (x))
3272 {
3273 case T_INTEGER:
3274 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3275 return 32+8;
3276
3277 case T_SYMBOL:
3278 printf ("%*sS<%s>\n", indent, "", symname (x));
3279 return 24+8;
3280
3281 case T_CLOSURE:
3282 printf ("%*sS<%s>\n", indent, "", "closure");
3283 debug (SCHEME_A_ indent + 3, cdr(x));
3284 return 32 + debug (SCHEME_A_ indent + 3, car (x));
3285
3286 case T_PAIR:
3287 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3288 c = debug (SCHEME_A_ indent + 3, car (x));
3289 c += debug (SCHEME_A_ indent + 3, cdr (x));
3290 return c + 1;
3291
3292 case T_PORT:
3293 printf ("%*sS<%s>\n", indent, "", "port");
3294 return 24+8;
3295
3296 case T_VECTOR:
3297 printf ("%*sS<%s>\n", indent, "", "vector");
3298 return 24+8;
3299
3300 case T_ENVIRONMENT:
3301 printf ("%*sS<%s>\n", indent, "", "environment");
3302 return 0 + debug (SCHEME_A_ indent + 3, car (x));
3303
3304 default:
3305 printf ("unhandled type %d\n", type (x));
3306 break;
3307 }
3308}
3309#endif
3310
3248static int 3311static int
3249opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3312opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3250{ 3313{
3251 pointer args = SCHEME_V->args; 3314 pointer args = SCHEME_V->args;
3252 pointer x, y; 3315 pointer x, y;
3253 3316
3254 switch (op) 3317 switch (op)
3255 { 3318 {
3319#if EXPERIMENT //D
3320 case OP_DEBUG:
3321 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3322 printf ("\n");
3323 s_return (S_T);
3324#endif
3256 case OP_LOAD: /* load */ 3325 case OP_LOAD: /* load */
3257 if (file_interactive (SCHEME_A)) 3326 if (file_interactive (SCHEME_A))
3258 { 3327 {
3259 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3328 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3260 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3329 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
… …
3383 } 3452 }
3384 else 3453 else
3385 s_return (SCHEME_V->code); 3454 s_return (SCHEME_V->code);
3386 3455
3387 case OP_E0ARGS: /* eval arguments */ 3456 case OP_E0ARGS: /* eval arguments */
3388 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3457 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3389 { 3458 {
3390 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3459 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3391 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3460 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3392 SCHEME_V->code = SCHEME_V->value; 3461 SCHEME_V->code = SCHEME_V->value;
3393 s_goto (OP_APPLY); 3462 s_goto (OP_APPLY);
… …
4391 } 4460 }
4392 4461
4393 case OP_VECLEN: /* vector-length */ 4462 case OP_VECLEN: /* vector-length */
4394 s_return (mk_integer (SCHEME_A_ veclength (x))); 4463 s_return (mk_integer (SCHEME_A_ veclength (x)));
4395 4464
4465 case OP_VECRESIZE:
4466 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4467 s_return (x);
4468
4396 case OP_VECREF: /* vector-ref */ 4469 case OP_VECREF: /* vector-ref */
4397 { 4470 {
4398 int index = ivalue_unchecked (cadr (args)); 4471 int index = ivalue_unchecked (cadr (args));
4399 4472
4400 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4473 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
… …
4460 pointer d = cdr (args); 4533 pointer d = cdr (args);
4461 int r; 4534 int r;
4462 4535
4463 switch (op) 4536 switch (op)
4464 { 4537 {
4465 case OP_NOT: /* not */ r = is_false (a) ; break; 4538 case OP_NOT: /* not */ r = is_false (a) ; break;
4466 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; 4539 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4467 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; 4540 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4468 case OP_NULLP: /* null? */ r = a == NIL ; break; 4541 case OP_NULLP: /* null? */ r = a == NIL ; break;
4469 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; 4542 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4543 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4470 case OP_NUMBERP: /* number? */ r = is_number (a) ; break; 4544 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4471 case OP_STRINGP: /* string? */ r = is_string (a) ; break; 4545 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4472 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4546 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4473 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ 4547 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4474 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4548 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4475 4549
4476#if USE_CHAR_CLASSIFIERS 4550#if USE_CHAR_CLASSIFIERS
4477 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 4551 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4478 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; 4552 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4479 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; 4553 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
… …
4955 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 5029 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
4956 SCHEME_V->tok = token (SCHEME_A); 5030 SCHEME_V->tok = token (SCHEME_A);
4957 s_goto (OP_RDSEXPR); 5031 s_goto (OP_RDSEXPR);
4958 5032
4959 case TOK_ATOM: 5033 case TOK_ATOM:
4960 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); 5034 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
5035
5036 case TOK_DOTATOM:
5037 SCHEME_V->strbuff[0] = '.';
5038 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5039
5040 case TOK_STRATOM:
5041 x = readstrexp (SCHEME_A_ '|');
5042 //TODO: haven't checked whether the garbage collector could interfere
5043 s_return (mk_atom (SCHEME_A_ strvalue (x)));
4961 5044
4962 case TOK_DQUOTE: 5045 case TOK_DQUOTE:
4963 x = readstrexp (SCHEME_A); 5046 x = readstrexp (SCHEME_A_ '"');
4964 5047
4965 if (x == S_F) 5048 if (x == S_F)
4966 Error_0 ("Error reading string"); 5049 Error_0 ("Error reading string");
4967 5050
4968 setimmutable (x); 5051 setimmutable (x);
… …
4980 s_goto (OP_EVAL); 5063 s_goto (OP_EVAL);
4981 } 5064 }
4982 } 5065 }
4983 5066
4984 case TOK_SHARP_CONST: 5067 case TOK_SHARP_CONST:
4985 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) 5068 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
4986 Error_0 ("undefined sharp expression"); 5069 Error_0 ("undefined sharp expression");
4987 else 5070 else
4988 s_return (x); 5071 s_return (x);
4989 5072
4990 default: 5073 default:
… …
5212 5295
5213 case OP_CLOSUREP: /* closure? */ 5296 case OP_CLOSUREP: /* closure? */
5214 /* 5297 /*
5215 * Note, macro object is also a closure. 5298 * Note, macro object is also a closure.
5216 * Therefore, (closure? <#MACRO>) ==> #t 5299 * Therefore, (closure? <#MACRO>) ==> #t
5300 * (schmorp) well, obviously not, fix? TODO
5217 */ 5301 */
5218 s_retbool (is_closure (a)); 5302 s_retbool (is_closure (a));
5219 5303
5220 case OP_MACROP: /* macro? */ 5304 case OP_MACROP: /* macro? */
5221 s_retbool (is_macro (a)); 5305 s_retbool (is_macro (a));
… …
5462 5546
5463/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5547/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5464static int 5548static int
5465syntaxnum (pointer p) 5549syntaxnum (pointer p)
5466{ 5550{
5467 const char *s = strvalue (car (p)); 5551 const char *s = strvalue (p);
5468 5552
5469 switch (strlength (car (p))) 5553 switch (strlength (p))
5470 { 5554 {
5471 case 2: 5555 case 2:
5472 if (s[0] == 'i') 5556 if (s[0] == 'i')
5473 return OP_IF0; /* if */ 5557 return OP_IF0; /* if */
5474 else 5558 else
… …
5910# endif 5994# endif
5911 int fin; 5995 int fin;
5912 char *file_name = InitFile; 5996 char *file_name = InitFile;
5913 int retcode; 5997 int retcode;
5914 int isfile = 1; 5998 int isfile = 1;
5999 system ("ps v $PPID");//D
5915 6000
5916 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6001 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5917 { 6002 {
5918 xwrstr ("Usage: tinyscheme -?\n"); 6003 xwrstr ("Usage: tinyscheme -?\n");
5919 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6004 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines