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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.32 by root, Sat Nov 28 10:56:45 2015 UTC vs.
Revision 1.40 by root, Mon Nov 30 05:19:01 2015 UTC

… …
34 34
35#include <sys/types.h> 35#include <sys/types.h>
36#include <sys/stat.h> 36#include <sys/stat.h>
37#include <fcntl.h> 37#include <fcntl.h>
38 38
39#if !USE_ERROR_CHECKING
40# define NDEBUG
41#endif
42
43#include <assert.h>
44#include <stdlib.h>
39#include <string.h> 45#include <string.h>
40#include <stdlib.h>
41 46
42#include <limits.h> 47#include <limits.h>
43#include <inttypes.h> 48#include <inttypes.h>
44#include <float.h> 49#include <float.h>
45//#include <ctype.h> 50//#include <ctype.h>
51
52#if '1' != '0' + 1 \
53 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
54 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
55 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
56 || 'f' != 'a' + 5
57# error "execution character set digits not consecutive"
58#endif
46 59
47enum { 60enum {
48 TOK_EOF, 61 TOK_EOF,
49 TOK_LPAREN, 62 TOK_LPAREN,
50 TOK_RPAREN, 63 TOK_RPAREN,
51 TOK_DOT, 64 TOK_DOT,
52 TOK_ATOM, 65 TOK_ATOM,
66 TOK_DOTATOM, /* atom name starting with '.' */
67 TOK_STRATOM, /* atom name enclosed in | */
53 TOK_QUOTE, 68 TOK_QUOTE,
54 TOK_DQUOTE, 69 TOK_DQUOTE,
55 TOK_BQUOTE, 70 TOK_BQUOTE,
56 TOK_COMMA, 71 TOK_COMMA,
57 TOK_ATMARK, 72 TOK_ATMARK,
… …
59 TOK_SHARP_CONST, 74 TOK_SHARP_CONST,
60 TOK_VEC 75 TOK_VEC
61}; 76};
62 77
63#define BACKQUOTE '`' 78#define BACKQUOTE '`'
64#define DELIMITERS "()\";\f\t\v\n\r " 79#define WHITESPACE " \t\r\n\v\f"
80#define DELIMITERS "()\";" WHITESPACE
65 81
66#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 82#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?
67#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 83#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
68#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 84#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
69#define S_SINK (&SCHEME_V->xsink) 85#define S_SINK (&SCHEME_V->xsink)
… …
391} 407}
392 408
393INTERFACE char * 409INTERFACE char *
394symname (pointer p) 410symname (pointer p)
395{ 411{
396 return strvalue (car (p)); 412 return strvalue (p);
397} 413}
398 414
399#if USE_PLIST 415#if USE_PLIST
400SCHEME_EXPORT int 416SCHEME_EXPORT int
401hasprop (pointer p) 417hasprop (pointer p)
… …
425} 441}
426 442
427INTERFACE char * 443INTERFACE char *
428syntaxname (pointer p) 444syntaxname (pointer p)
429{ 445{
430 return strvalue (car (p)); 446 return strvalue (p);
431} 447}
432 448
433#define procnum(p) ivalue_unchecked (p) 449#define procnum(p) ivalue_unchecked (p)
434static const char *procname (pointer x); 450static const char *procname (pointer x);
435 451
… …
651#endif 667#endif
652 668
653static int file_push (SCHEME_P_ const char *fname); 669static int file_push (SCHEME_P_ const char *fname);
654static void file_pop (SCHEME_P); 670static void file_pop (SCHEME_P);
655static int file_interactive (SCHEME_P); 671static int file_interactive (SCHEME_P);
656ecb_inline int is_one_of (char *s, int c); 672ecb_inline int is_one_of (const char *s, int c);
657static int alloc_cellseg (SCHEME_P_ int n); 673static int alloc_cellseg (SCHEME_P_ int n);
658ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 674ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
659static void finalize_cell (SCHEME_P_ pointer a); 675static void finalize_cell (SCHEME_P_ pointer a);
660static int count_consecutive_cells (pointer x, int needed); 676static int count_consecutive_cells (pointer x, int needed);
661static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 677static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
… …
678static void mark (pointer a); 694static void mark (pointer a);
679static void gc (SCHEME_P_ pointer a, pointer b); 695static void gc (SCHEME_P_ pointer a, pointer b);
680static int basic_inchar (port *pt); 696static int basic_inchar (port *pt);
681static int inchar (SCHEME_P); 697static int inchar (SCHEME_P);
682static void backchar (SCHEME_P_ int c); 698static void backchar (SCHEME_P_ int c);
683static char *readstr_upto (SCHEME_P_ char *delim); 699static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
684static pointer readstrexp (SCHEME_P); 700static pointer readstrexp (SCHEME_P_ char delim);
685ecb_inline int skipspace (SCHEME_P); 701ecb_inline int skipspace (SCHEME_P);
686static int token (SCHEME_P); 702static int token (SCHEME_P);
687static void printslashstring (SCHEME_P_ char *s, int len); 703static void printslashstring (SCHEME_P_ char *s, int len);
688static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 704static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
689static void printatom (SCHEME_P_ pointer l, int f); 705static void printatom (SCHEME_P_ pointer l, int f);
… …
1079 return x; 1095 return x;
1080} 1096}
1081 1097
1082/* ========== oblist implementation ========== */ 1098/* ========== oblist implementation ========== */
1083 1099
1100static pointer
1101generate_symbol (SCHEME_P_ const char *name)
1102{
1103 pointer x = mk_string (SCHEME_A_ name);
1104 setimmutable (x);
1105 set_typeflag (x, T_SYMBOL | T_ATOM);
1106 return x;
1107}
1108
1084#ifndef USE_OBJECT_LIST 1109#ifndef USE_OBJECT_LIST
1085 1110
1111static int
1086static int hash_fn (const char *key, int table_size); 1112hash_fn (const char *key, int table_size)
1113{
1114 const unsigned char *p = key;
1115 uint32_t hash = 2166136261;
1116
1117 while (*p)
1118 hash = (hash ^ *p++) * 16777619;
1119
1120 return hash % table_size;
1121}
1087 1122
1088static pointer 1123static pointer
1089oblist_initial_value (SCHEME_P) 1124oblist_initial_value (SCHEME_P)
1090{ 1125{
1091 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1126 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
… …
1093 1128
1094/* returns the new symbol */ 1129/* returns the new symbol */
1095static pointer 1130static pointer
1096oblist_add_by_name (SCHEME_P_ const char *name) 1131oblist_add_by_name (SCHEME_P_ const char *name)
1097{ 1132{
1098 int location; 1133 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)); 1134 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))); 1135 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1106 return x; 1136 return x;
1107} 1137}
1108 1138
1109ecb_inline pointer 1139ecb_inline pointer
… …
1271 SCHEME_V->no_memory = 1; 1301 SCHEME_V->no_memory = 1;
1272 return SCHEME_V->strbuff; 1302 return SCHEME_V->strbuff;
1273 } 1303 }
1274 1304
1275 if (str) 1305 if (str)
1276 { 1306 memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1277 int l = strlen (str);
1278
1279 if (l > len_str)
1280 l = len_str;
1281
1282 memcpy (q, str, l);
1283 q[l] = 0;
1284 }
1285 else 1307 else
1286 {
1287 memset (q, fill, len_str); 1308 memset (q, fill, len_str);
1309
1288 q[len_str] = 0; 1310 q[len_str] = 0;
1289 }
1290 1311
1291 return q; 1312 return q;
1292} 1313}
1293 1314
1294INTERFACE pointer 1315INTERFACE pointer
… …
1308 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1329 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1309 1330
1310 set_typeflag (x, T_STRING | T_ATOM); 1331 set_typeflag (x, T_STRING | T_ATOM);
1311 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1332 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1312 strlength (x) = len; 1333 strlength (x) = len;
1334
1313 return x; 1335 return x;
1314} 1336}
1315 1337
1316INTERFACE pointer 1338INTERFACE pointer
1317mk_string (SCHEME_P_ const char *str) 1339mk_string (SCHEME_P_ const char *str)
… …
1330{ 1352{
1331 int i; 1353 int i;
1332 1354
1333 for (i = start; i < veclength (vec); i++) 1355 for (i = start; i < veclength (vec); i++)
1334 vecvalue (vec)[i] = obj; 1356 vecvalue (vec)[i] = obj;
1357}
1358
1359INTERFACE void
1360vector_resize (pointer vec, uint32_t newsize, pointer fill)
1361{
1362 uint32_t oldsize = veclength (vec);
1363 vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
1364 veclength (vec) = newsize;
1365 fill_vector (vec, oldsize, fill);
1335} 1366}
1336 1367
1337INTERFACE pointer 1368INTERFACE pointer
1338vector_get (pointer vec, uint32_t ielem) 1369vector_get (pointer vec, uint32_t ielem)
1339{ 1370{
… …
1361 1392
1362INTERFACE pointer 1393INTERFACE pointer
1363gensym (SCHEME_P) 1394gensym (SCHEME_P)
1364{ 1395{
1365 pointer x; 1396 pointer x;
1366
1367 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1368 {
1369 char name[40] = "gensym-"; 1397 char name[40] = "gensym-";
1370 xnum (name + 7, SCHEME_V->gensym_cnt); 1398 xnum (name + 7, SCHEME_V->gensym_cnt);
1371 1399
1372 /* first check oblist */ 1400 return generate_symbol (SCHEME_A_ name);
1373 x = oblist_find_by_name (SCHEME_A_ name);
1374
1375 if (x == NIL)
1376 {
1377 x = oblist_add_by_name (SCHEME_A_ name);
1378 return x;
1379 }
1380 }
1381
1382 return NIL;
1383} 1401}
1384 1402
1385/* make symbol or number atom from string */ 1403/* make symbol or number atom from string */
1386static pointer 1404static pointer
1387mk_atom (SCHEME_P_ char *q) 1405mk_atom (SCHEME_P_ char *q)
… …
1671 1689
1672static void 1690static void
1673finalize_cell (SCHEME_P_ pointer a) 1691finalize_cell (SCHEME_P_ pointer a)
1674{ 1692{
1675 /* TODO, fast bitmap check? */ 1693 /* TODO, fast bitmap check? */
1676 if (is_string (a)) 1694 if (is_string (a) || is_symbol (a))
1677 free (strvalue (a)); 1695 free (strvalue (a));
1678 else if (is_vector (a)) 1696 else if (is_vector (a))
1679 free (vecvalue (a)); 1697 free (vecvalue (a));
1680#if USE_PORTS 1698#if USE_PORTS
1681 else if (is_port (a)) 1699 else if (is_port (a))
… …
2103#endif 2121#endif
2104} 2122}
2105 2123
2106/* read characters up to delimiter, but cater to character constants */ 2124/* read characters up to delimiter, but cater to character constants */
2107static char * 2125static char *
2108readstr_upto (SCHEME_P_ char *delim) 2126readstr_upto (SCHEME_P_ int skip, const char *delim)
2109{ 2127{
2110 char *p = SCHEME_V->strbuff; 2128 char *p = SCHEME_V->strbuff + skip;
2111 2129
2112 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2130 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2113 2131
2114 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2132 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2115 *p = 0; 2133 *p = 0;
… …
2122 return SCHEME_V->strbuff; 2140 return SCHEME_V->strbuff;
2123} 2141}
2124 2142
2125/* read string expression "xxx...xxx" */ 2143/* read string expression "xxx...xxx" */
2126static pointer 2144static pointer
2127readstrexp (SCHEME_P) 2145readstrexp (SCHEME_P_ char delim)
2128{ 2146{
2129 char *p = SCHEME_V->strbuff; 2147 char *p = SCHEME_V->strbuff;
2130 int c; 2148 int c;
2131 int c1 = 0; 2149 int c1 = 0;
2132 enum
2133 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; 2150 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2134 2151
2135 for (;;) 2152 for (;;)
2136 { 2153 {
2137 c = inchar (SCHEME_A); 2154 c = inchar (SCHEME_A);
2138 2155
… …
2140 return S_F; 2157 return S_F;
2141 2158
2142 switch (state) 2159 switch (state)
2143 { 2160 {
2144 case st_ok: 2161 case st_ok:
2145 switch (c) 2162 if (ecb_expect_false (c == delim))
2146 {
2147 case '\\':
2148 state = st_bsl;
2149 break;
2150
2151 case '"':
2152 *p = 0;
2153 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); 2163 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2154 2164
2155 default: 2165 if (ecb_expect_false (c == '\\'))
2166 state = st_bsl;
2167 else
2156 *p++ = c; 2168 *p++ = c;
2157 break;
2158 }
2159 2169
2160 break; 2170 break;
2161 2171
2162 case st_bsl: 2172 case st_bsl:
2163 switch (c) 2173 switch (c)
… …
2193 case 'r': 2203 case 'r':
2194 *p++ = '\r'; 2204 *p++ = '\r';
2195 state = st_ok; 2205 state = st_ok;
2196 break; 2206 break;
2197 2207
2198 case '"':
2199 *p++ = '"';
2200 state = st_ok;
2201 break;
2202
2203 default: 2208 default:
2204 *p++ = c; 2209 *p++ = c;
2205 state = st_ok; 2210 state = st_ok;
2206 break; 2211 break;
2207 } 2212 }
2208 2213
2209 break; 2214 break;
2210 2215
2211 case st_x1: 2216 case st_x1:
2212 case st_x2: 2217 case st_x2:
2213 c = toupper (c); 2218 c = tolower (c);
2214 2219
2215 if (c >= '0' && c <= 'F') 2220 if (c >= '0' && c <= '9')
2216 {
2217 if (c <= '9')
2218 c1 = (c1 << 4) + c - '0'; 2221 c1 = (c1 << 4) + c - '0';
2219 else 2222 else if (c >= 'a' && c <= 'f')
2220 c1 = (c1 << 4) + c - 'A' + 10; 2223 c1 = (c1 << 4) + c - 'a' + 10;
2221
2222 if (state == st_x1)
2223 state = st_x2;
2224 else
2225 {
2226 *p++ = c1;
2227 state = st_ok;
2228 }
2229 }
2230 else 2224 else
2231 return S_F; 2225 return S_F;
2226
2227 if (state == st_x1)
2228 state = st_x2;
2229 else
2230 {
2231 *p++ = c1;
2232 state = st_ok;
2233 }
2232 2234
2233 break; 2235 break;
2234 2236
2235 case st_oct1: 2237 case st_oct1:
2236 case st_oct2: 2238 case st_oct2:
… …
2240 backchar (SCHEME_A_ c); 2242 backchar (SCHEME_A_ c);
2241 state = st_ok; 2243 state = st_ok;
2242 } 2244 }
2243 else 2245 else
2244 { 2246 {
2245 if (state == st_oct2 && c1 >= 32) 2247 if (state == st_oct2 && c1 >= ' ')
2246 return S_F; 2248 return S_F;
2247 2249
2248 c1 = (c1 << 3) + (c - '0'); 2250 c1 = (c1 << 3) + (c - '0');
2249 2251
2250 if (state == st_oct1) 2252 if (state == st_oct1)
… …
2255 state = st_ok; 2257 state = st_ok;
2256 } 2258 }
2257 } 2259 }
2258 2260
2259 break; 2261 break;
2260
2261 } 2262 }
2262 } 2263 }
2263} 2264}
2264 2265
2265/* check c is in chars */ 2266/* check c is in chars */
2266ecb_inline int 2267ecb_inline int
2267is_one_of (char *s, int c) 2268is_one_of (const char *s, int c)
2268{ 2269{
2269 if (c == EOF)
2270 return 1;
2271
2272 return !!strchr (s, c); 2270 return c == EOF || !!strchr (s, c);
2273} 2271}
2274 2272
2275/* skip white characters */ 2273/* skip white characters */
2276ecb_inline int 2274ecb_inline int
2277skipspace (SCHEME_P) 2275skipspace (SCHEME_P)
… …
2284#if SHOW_ERROR_LINE 2282#if SHOW_ERROR_LINE
2285 if (c == '\n') 2283 if (c == '\n')
2286 curr_line++; 2284 curr_line++;
2287#endif 2285#endif
2288 } 2286 }
2289 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2287 while (is_one_of (WHITESPACE, c));
2290 2288
2291 /* record it */ 2289 /* record it */
2292#if SHOW_ERROR_LINE 2290#if SHOW_ERROR_LINE
2293 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2291 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2294 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2292 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
… …
2324 return TOK_RPAREN; 2322 return TOK_RPAREN;
2325 2323
2326 case '.': 2324 case '.':
2327 c = inchar (SCHEME_A); 2325 c = inchar (SCHEME_A);
2328 2326
2329 if (is_one_of (" \n\t", c)) 2327 if (is_one_of (WHITESPACE, c))
2330 return TOK_DOT; 2328 return TOK_DOT;
2331 else 2329 else
2332 { 2330 {
2333 //TODO: ungetc twice in a row is not supported in C
2334 backchar (SCHEME_A_ c); 2331 backchar (SCHEME_A_ c);
2335 backchar (SCHEME_A_ '.');
2336 return TOK_ATOM; 2332 return TOK_DOTATOM;
2337 } 2333 }
2334
2335 case '|':
2336 return TOK_STRATOM;
2338 2337
2339 case '\'': 2338 case '\'':
2340 return TOK_QUOTE; 2339 return TOK_QUOTE;
2341 2340
2342 case ';': 2341 case ';':
… …
2474 } 2473 }
2475 2474
2476 putcharacter (SCHEME_A_ '"'); 2475 putcharacter (SCHEME_A_ '"');
2477} 2476}
2478 2477
2479
2480/* print atoms */ 2478/* print atoms */
2481static void 2479static void
2482printatom (SCHEME_P_ pointer l, int f) 2480printatom (SCHEME_P_ pointer l, int f)
2483{ 2481{
2484 char *p; 2482 char *p;
2485 int len; 2483 int len;
2486 2484
2487 atom2str (SCHEME_A_ l, f, &p, &len); 2485 atom2str (SCHEME_A_ l, f, &p, &len);
2488 putchars (SCHEME_A_ p, len); 2486 putchars (SCHEME_A_ p, len);
2489} 2487}
2490
2491 2488
2492/* Uses internal buffer unless string pointer is already available */ 2489/* Uses internal buffer unless string pointer is already available */
2493static void 2490static void
2494atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2491atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2495{ 2492{
… …
2656#endif 2653#endif
2657 } 2654 }
2658 else if (is_continuation (l)) 2655 else if (is_continuation (l))
2659 p = "#<CONTINUATION>"; 2656 p = "#<CONTINUATION>";
2660 else 2657 else
2658 {
2659#if USE_PRINTF
2660 p = SCHEME_V->strbuff;
2661 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2662#else
2661 p = "#<ERROR>"; 2663 p = "#<ERROR>";
2664#endif
2665 }
2662 2666
2663 *pp = p; 2667 *pp = p;
2664 *plen = strlen (p); 2668 *plen = strlen (p);
2665} 2669}
2666 2670
… …
2810/* () is #t in R5RS */ 2814/* () is #t in R5RS */
2811#define is_true(p) ((p) != S_F) 2815#define is_true(p) ((p) != S_F)
2812#define is_false(p) ((p) == S_F) 2816#define is_false(p) ((p) == S_F)
2813 2817
2814/* ========== Environment implementation ========== */ 2818/* ========== Environment implementation ========== */
2815
2816#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2817
2818static int
2819hash_fn (const char *key, int table_size)
2820{
2821 const unsigned char *p = key;
2822 uint32_t hash = 2166136261;
2823
2824 while (*p)
2825 hash = (hash ^ *p++) * 16777619;
2826
2827 return hash % table_size;
2828}
2829#endif
2830 2819
2831#ifndef USE_ALIST_ENV 2820#ifndef USE_ALIST_ENV
2832 2821
2833/* 2822/*
2834 * In this implementation, each frame of the environment may be 2823 * In this implementation, each frame of the environment may be
… …
2857sym_hash (pointer sym, uint32_t size) 2846sym_hash (pointer sym, uint32_t size)
2858{ 2847{
2859 uintptr_t ptr = (uintptr_t)sym; 2848 uintptr_t ptr = (uintptr_t)sym;
2860 2849
2861#if 0 2850#if 0
2862 /* tqable size is prime, so why mix */ 2851 /* table size is prime, so why mix */
2863 ptr += ptr >> 32; 2852 ptr += ptr >> 32;
2864 ptr += ptr >> 16; 2853 ptr += ptr >> 16;
2865 ptr += ptr >> 8; 2854 ptr += ptr >> 8;
2866#endif 2855#endif
2867 2856
… …
2951#endif /* USE_ALIST_ENV else */ 2940#endif /* USE_ALIST_ENV else */
2952 2941
2953ecb_inline void 2942ecb_inline void
2954new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2943new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2955{ 2944{
2945 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2956 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2946 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2957} 2947}
2958 2948
2959ecb_inline void 2949ecb_inline void
2960set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2950set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
… …
3252 3242
3253#endif 3243#endif
3254 3244
3255#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3245#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3256 3246
3247#if 1
3248static int
3249debug (SCHEME_P_ int indent, pointer x)
3250{
3251 int c;
3252
3253 if (is_syntax (x))
3254 {
3255 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3256 return 8 + 8;
3257 }
3258
3259 if (x == NIL)
3260 {
3261 printf ("%*sNIL\n", indent, "");
3262 return 3;
3263 }
3264
3265 switch (type (x))
3266 {
3267 case T_INTEGER:
3268 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3269 return 32+8;
3270
3271 case T_SYMBOL:
3272 printf ("%*sS<%s>\n", indent, "", symname (x));
3273 return 24+8;
3274
3275 case T_CLOSURE:
3276 printf ("%*sS<%s>\n", indent, "", "closure");
3277 debug (SCHEME_A_ indent + 3, cdr(x));
3278 return 32 + debug (SCHEME_A_ indent + 3, car (x));
3279
3280 case T_PAIR:
3281 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3282 c = debug (SCHEME_A_ indent + 3, car (x));
3283 c += debug (SCHEME_A_ indent + 3, cdr (x));
3284 return c + 1;
3285
3286 case T_PORT:
3287 printf ("%*sS<%s>\n", indent, "", "port");
3288 return 24+8;
3289
3290 case T_VECTOR:
3291 printf ("%*sS<%s>\n", indent, "", "vector");
3292 return 24+8;
3293
3294 case T_ENVIRONMENT:
3295 printf ("%*sS<%s>\n", indent, "", "environment");
3296 return 0 + debug (SCHEME_A_ indent + 3, car (x));
3297
3298 default:
3299 printf ("unhandled type %d\n", type (x));
3300 break;
3301 }
3302}
3303#endif
3304
3257static int 3305static int
3258opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3306opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3259{ 3307{
3260 pointer args = SCHEME_V->args; 3308 pointer args = SCHEME_V->args;
3261 pointer x, y; 3309 pointer x, y;
3262 3310
3263 switch (op) 3311 switch (op)
3264 { 3312 {
3313#if 1 //D
3314 case OP_DEBUG:
3315 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3316 printf ("\n");
3317 s_return (S_T);
3318#endif
3265 case OP_LOAD: /* load */ 3319 case OP_LOAD: /* load */
3266 if (file_interactive (SCHEME_A)) 3320 if (file_interactive (SCHEME_A))
3267 { 3321 {
3268 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3322 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3269 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3323 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
… …
3392 } 3446 }
3393 else 3447 else
3394 s_return (SCHEME_V->code); 3448 s_return (SCHEME_V->code);
3395 3449
3396 case OP_E0ARGS: /* eval arguments */ 3450 case OP_E0ARGS: /* eval arguments */
3397 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3451 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3398 { 3452 {
3399 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3453 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3400 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3454 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3401 SCHEME_V->code = SCHEME_V->value; 3455 SCHEME_V->code = SCHEME_V->value;
3402 s_goto (OP_APPLY); 3456 s_goto (OP_APPLY);
… …
4400 } 4454 }
4401 4455
4402 case OP_VECLEN: /* vector-length */ 4456 case OP_VECLEN: /* vector-length */
4403 s_return (mk_integer (SCHEME_A_ veclength (x))); 4457 s_return (mk_integer (SCHEME_A_ veclength (x)));
4404 4458
4459 case OP_VECRESIZE:
4460 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4461 s_return (x);
4462
4405 case OP_VECREF: /* vector-ref */ 4463 case OP_VECREF: /* vector-ref */
4406 { 4464 {
4407 int index = ivalue_unchecked (cadr (args)); 4465 int index = ivalue_unchecked (cadr (args));
4408 4466
4409 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4467 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
… …
4964 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 5022 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
4965 SCHEME_V->tok = token (SCHEME_A); 5023 SCHEME_V->tok = token (SCHEME_A);
4966 s_goto (OP_RDSEXPR); 5024 s_goto (OP_RDSEXPR);
4967 5025
4968 case TOK_ATOM: 5026 case TOK_ATOM:
4969 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); 5027 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
5028
5029 case TOK_DOTATOM:
5030 SCHEME_V->strbuff[0] = '.';
5031 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5032
5033 case TOK_STRATOM:
5034 x = readstrexp (SCHEME_A_ '|');
5035 //TODO: haven't checked whether the garbage collector could interfere
5036 s_return (mk_atom (SCHEME_A_ strvalue (x)));
4970 5037
4971 case TOK_DQUOTE: 5038 case TOK_DQUOTE:
4972 x = readstrexp (SCHEME_A); 5039 x = readstrexp (SCHEME_A_ '"');
4973 5040
4974 if (x == S_F) 5041 if (x == S_F)
4975 Error_0 ("Error reading string"); 5042 Error_0 ("Error reading string");
4976 5043
4977 setimmutable (x); 5044 setimmutable (x);
… …
4989 s_goto (OP_EVAL); 5056 s_goto (OP_EVAL);
4990 } 5057 }
4991 } 5058 }
4992 5059
4993 case TOK_SHARP_CONST: 5060 case TOK_SHARP_CONST:
4994 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) 5061 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
4995 Error_0 ("undefined sharp expression"); 5062 Error_0 ("undefined sharp expression");
4996 else 5063 else
4997 s_return (x); 5064 s_return (x);
4998 5065
4999 default: 5066 default:
… …
5221 5288
5222 case OP_CLOSUREP: /* closure? */ 5289 case OP_CLOSUREP: /* closure? */
5223 /* 5290 /*
5224 * Note, macro object is also a closure. 5291 * Note, macro object is also a closure.
5225 * Therefore, (closure? <#MACRO>) ==> #t 5292 * Therefore, (closure? <#MACRO>) ==> #t
5293 * (schmorp) well, obviously not, fix? TODO
5226 */ 5294 */
5227 s_retbool (is_closure (a)); 5295 s_retbool (is_closure (a));
5228 5296
5229 case OP_MACROP: /* macro? */ 5297 case OP_MACROP: /* macro? */
5230 s_retbool (is_macro (a)); 5298 s_retbool (is_macro (a));
… …
5471 5539
5472/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5540/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5473static int 5541static int
5474syntaxnum (pointer p) 5542syntaxnum (pointer p)
5475{ 5543{
5476 const char *s = strvalue (car (p)); 5544 const char *s = strvalue (p);
5477 5545
5478 switch (strlength (car (p))) 5546 switch (strlength (p))
5479 { 5547 {
5480 case 2: 5548 case 2:
5481 if (s[0] == 'i') 5549 if (s[0] == 'i')
5482 return OP_IF0; /* if */ 5550 return OP_IF0; /* if */
5483 else 5551 else
… …
5919# endif 5987# endif
5920 int fin; 5988 int fin;
5921 char *file_name = InitFile; 5989 char *file_name = InitFile;
5922 int retcode; 5990 int retcode;
5923 int isfile = 1; 5991 int isfile = 1;
5992 system ("ps v $PPID");//D
5924 5993
5925 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5994 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5926 { 5995 {
5927 xwrstr ("Usage: tinyscheme -?\n"); 5996 xwrstr ("Usage: tinyscheme -?\n");
5928 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 5997 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");

Diff Legend

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