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.26 by root, Sat Nov 28 05:12:53 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)
… …
270 return type (p) == T_VECTOR; 286 return type (p) == T_VECTOR;
271} 287}
272 288
273#define vecvalue(p) ((p)->object.vector.vvalue) 289#define vecvalue(p) ((p)->object.vector.vvalue)
274#define veclength(p) ((p)->object.vector.length) 290#define veclength(p) ((p)->object.vector.length)
275INTERFACE void fill_vector (pointer vec, pointer obj); 291INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
276INTERFACE uint32_t vector_length (pointer vec);
277INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 292INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
278INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 293INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
279
280INTERFACE uint32_t
281vector_length (pointer vec)
282{
283 return vec->object.vector.length;
284}
285 294
286INTERFACE int 295INTERFACE int
287is_integer (pointer p) 296is_integer (pointer p)
288{ 297{
289 return type (p) == T_INTEGER; 298 return type (p) == T_INTEGER;
… …
398} 407}
399 408
400INTERFACE char * 409INTERFACE char *
401symname (pointer p) 410symname (pointer p)
402{ 411{
403 return strvalue (car (p)); 412 return strvalue (p);
404} 413}
405 414
406#if USE_PLIST 415#if USE_PLIST
407SCHEME_EXPORT int 416SCHEME_EXPORT int
408hasprop (pointer p) 417hasprop (pointer p)
… …
432} 441}
433 442
434INTERFACE char * 443INTERFACE char *
435syntaxname (pointer p) 444syntaxname (pointer p)
436{ 445{
437 return strvalue (car (p)); 446 return strvalue (p);
438} 447}
439 448
440#define procnum(p) ivalue_unchecked (p) 449#define procnum(p) ivalue_unchecked (p)
441static const char *procname (pointer x); 450static const char *procname (pointer x);
442 451
… …
658#endif 667#endif
659 668
660static int file_push (SCHEME_P_ const char *fname); 669static int file_push (SCHEME_P_ const char *fname);
661static void file_pop (SCHEME_P); 670static void file_pop (SCHEME_P);
662static int file_interactive (SCHEME_P); 671static int file_interactive (SCHEME_P);
663ecb_inline int is_one_of (char *s, int c); 672ecb_inline int is_one_of (const char *s, int c);
664static int alloc_cellseg (SCHEME_P_ int n); 673static int alloc_cellseg (SCHEME_P_ int n);
665ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 674ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
666static void finalize_cell (SCHEME_P_ pointer a); 675static void finalize_cell (SCHEME_P_ pointer a);
667static int count_consecutive_cells (pointer x, int needed); 676static int count_consecutive_cells (pointer x, int needed);
668static 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);
… …
685static void mark (pointer a); 694static void mark (pointer a);
686static void gc (SCHEME_P_ pointer a, pointer b); 695static void gc (SCHEME_P_ pointer a, pointer b);
687static int basic_inchar (port *pt); 696static int basic_inchar (port *pt);
688static int inchar (SCHEME_P); 697static int inchar (SCHEME_P);
689static void backchar (SCHEME_P_ int c); 698static void backchar (SCHEME_P_ int c);
690static char *readstr_upto (SCHEME_P_ char *delim); 699static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
691static pointer readstrexp (SCHEME_P); 700static pointer readstrexp (SCHEME_P_ char delim);
692ecb_inline int skipspace (SCHEME_P); 701ecb_inline int skipspace (SCHEME_P);
693static int token (SCHEME_P); 702static int token (SCHEME_P);
694static void printslashstring (SCHEME_P_ char *s, int len); 703static void printslashstring (SCHEME_P_ char *s, int len);
695static 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);
696static void printatom (SCHEME_P_ pointer l, int f); 705static void printatom (SCHEME_P_ pointer l, int f);
… …
928 return k; 937 return k;
929 938
930 i = ++SCHEME_V->last_cell_seg; 939 i = ++SCHEME_V->last_cell_seg;
931 SCHEME_V->alloc_seg[i] = cp; 940 SCHEME_V->alloc_seg[i] = cp;
932 941
933 /* insert new segment in address order */
934 newp = (pointer)cp; 942 newp = (pointer)cp;
935 SCHEME_V->cell_seg[i] = newp; 943 SCHEME_V->cell_seg[i] = newp;
936 SCHEME_V->cell_segsize[i] = segsize; 944 SCHEME_V->cell_segsize[i] = segsize;
937
938 //TODO: insert, not swap
939 while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
940 {
941 p = SCHEME_V->cell_seg[i];
942 SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
943 SCHEME_V->cell_seg[i - 1] = p;
944
945 k = SCHEME_V->cell_segsize[i];
946 SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
947 SCHEME_V->cell_segsize[i - 1] = k;
948
949 --i;
950 }
951
952 SCHEME_V->fcells += segsize; 945 SCHEME_V->fcells += segsize;
953 last = newp + segsize - 1; 946 last = newp + segsize - 1;
954 947
955 for (p = newp; p <= last; p++) 948 for (p = newp; p <= last; p++)
956 { 949 {
957 set_typeflag (p, T_PAIR); 950 set_typeflag (p, T_PAIR);
958 set_car (p, NIL); 951 set_car (p, NIL);
959 set_cdr (p, p + 1); 952 set_cdr (p, p + 1);
960 } 953 }
961 954
962 /* insert new cells in address order on free list */
963 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
964 {
965 set_cdr (last, SCHEME_V->free_cell); 955 set_cdr (last, SCHEME_V->free_cell);
966 SCHEME_V->free_cell = newp; 956 SCHEME_V->free_cell = newp;
967 }
968 else
969 {
970 p = SCHEME_V->free_cell;
971
972 while (cdr (p) != NIL && newp > cdr (p))
973 p = cdr (p);
974
975 set_cdr (last, cdr (p));
976 set_cdr (p, newp);
977 }
978 } 957 }
979 958
980 return n; 959 return n;
981} 960}
982 961
… …
1061 /* Record it as a vector so that gc understands it. */ 1040 /* Record it as a vector so that gc understands it. */
1062 set_typeflag (v, T_VECTOR | T_ATOM); 1041 set_typeflag (v, T_VECTOR | T_ATOM);
1063 1042
1064 v->object.vector.vvalue = e; 1043 v->object.vector.vvalue = e;
1065 v->object.vector.length = len; 1044 v->object.vector.length = len;
1066 fill_vector (v, init); 1045 fill_vector (v, 0, init);
1067 push_recent_alloc (SCHEME_A_ v, NIL); 1046 push_recent_alloc (SCHEME_A_ v, NIL);
1068 1047
1069 return v; 1048 return v;
1070} 1049}
1071 1050
… …
1116 return x; 1095 return x;
1117} 1096}
1118 1097
1119/* ========== oblist implementation ========== */ 1098/* ========== oblist implementation ========== */
1120 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
1121#ifndef USE_OBJECT_LIST 1109#ifndef USE_OBJECT_LIST
1122 1110
1111static int
1123static 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}
1124 1122
1125static pointer 1123static pointer
1126oblist_initial_value (SCHEME_P) 1124oblist_initial_value (SCHEME_P)
1127{ 1125{
1128 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1126 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
… …
1130 1128
1131/* returns the new symbol */ 1129/* returns the new symbol */
1132static pointer 1130static pointer
1133oblist_add_by_name (SCHEME_P_ const char *name) 1131oblist_add_by_name (SCHEME_P_ const char *name)
1134{ 1132{
1135 int location; 1133 pointer x = generate_symbol (SCHEME_A_ name);
1136
1137 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1138 set_typeflag (x, T_SYMBOL);
1139 setimmutable (car (x));
1140
1141 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1134 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1142 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1135 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1143 return x; 1136 return x;
1144} 1137}
1145 1138
1146ecb_inline pointer 1139ecb_inline pointer
1147oblist_find_by_name (SCHEME_P_ const char *name) 1140oblist_find_by_name (SCHEME_P_ const char *name)
… …
1150 pointer x; 1143 pointer x;
1151 char *s; 1144 char *s;
1152 1145
1153 location = hash_fn (name, veclength (SCHEME_V->oblist)); 1146 location = hash_fn (name, veclength (SCHEME_V->oblist));
1154 1147
1155 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1148 for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1156 { 1149 {
1157 s = symname (car (x)); 1150 s = symname (car (x));
1158 1151
1159 /* case-insensitive, per R5RS section 2 */ 1152 /* case-insensitive, per R5RS section 2 */
1160 if (stricmp (name, s) == 0) 1153 if (stricmp (name, s) == 0)
… …
1170 int i; 1163 int i;
1171 pointer x; 1164 pointer x;
1172 pointer ob_list = NIL; 1165 pointer ob_list = NIL;
1173 1166
1174 for (i = 0; i < veclength (SCHEME_V->oblist); i++) 1167 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1175 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1168 for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1176 ob_list = cons (x, ob_list); 1169 ob_list = cons (x, ob_list);
1177 1170
1178 return ob_list; 1171 return ob_list;
1179} 1172}
1180 1173
… …
1206 1199
1207/* returns the new symbol */ 1200/* returns the new symbol */
1208static pointer 1201static pointer
1209oblist_add_by_name (SCHEME_P_ const char *name) 1202oblist_add_by_name (SCHEME_P_ const char *name)
1210{ 1203{
1211 pointer x; 1204 pointer x = mk_string (SCHEME_A_ name);
1212
1213 x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1214 set_typeflag (x, T_SYMBOL); 1205 set_typeflag (x, T_SYMBOL);
1215 setimmutable (car (x)); 1206 setimmutable (x);
1216 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1207 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1217 return x; 1208 return x;
1218} 1209}
1219 1210
1220static pointer 1211static pointer
… …
1310 SCHEME_V->no_memory = 1; 1301 SCHEME_V->no_memory = 1;
1311 return SCHEME_V->strbuff; 1302 return SCHEME_V->strbuff;
1312 } 1303 }
1313 1304
1314 if (str) 1305 if (str)
1315 { 1306 memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1316 int l = strlen (str);
1317
1318 if (l > len_str)
1319 l = len_str;
1320
1321 memcpy (q, str, l);
1322 q[l] = 0;
1323 }
1324 else 1307 else
1325 {
1326 memset (q, fill, len_str); 1308 memset (q, fill, len_str);
1309
1327 q[len_str] = 0; 1310 q[len_str] = 0;
1328 }
1329 1311
1330 return q; 1312 return q;
1331} 1313}
1332 1314
1333INTERFACE pointer 1315INTERFACE pointer
… …
1347 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1329 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1348 1330
1349 set_typeflag (x, T_STRING | T_ATOM); 1331 set_typeflag (x, T_STRING | T_ATOM);
1350 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1332 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1351 strlength (x) = len; 1333 strlength (x) = len;
1334
1352 return x; 1335 return x;
1353} 1336}
1354 1337
1355INTERFACE pointer 1338INTERFACE pointer
1356mk_string (SCHEME_P_ const char *str) 1339mk_string (SCHEME_P_ const char *str)
… …
1363{ 1346{
1364 return get_vector_object (SCHEME_A_ len, NIL); 1347 return get_vector_object (SCHEME_A_ len, NIL);
1365} 1348}
1366 1349
1367INTERFACE void 1350INTERFACE void
1368fill_vector (pointer vec, pointer obj) 1351fill_vector (pointer vec, uint32_t start, pointer obj)
1369{ 1352{
1370 int i; 1353 int i;
1371 1354
1372 for (i = 0; i < vec->object.vector.length; i++) 1355 for (i = start; i < veclength (vec); i++)
1373 vecvalue (vec)[i] = obj; 1356 vecvalue (vec)[i] = obj;
1374} 1357}
1375 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);
1366}
1367
1376INTERFACE pointer 1368INTERFACE pointer
1377vector_elem (pointer vec, uint32_t ielem) 1369vector_get (pointer vec, uint32_t ielem)
1378{ 1370{
1379 return vecvalue(vec)[ielem]; 1371 return vecvalue(vec)[ielem];
1380} 1372}
1381 1373
1382INTERFACE void 1374INTERFACE void
1383set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1375vector_set (pointer vec, uint32_t ielem, pointer a)
1384{ 1376{
1385 vecvalue(vec)[ielem] = a; 1377 vecvalue(vec)[ielem] = a;
1386} 1378}
1387 1379
1388/* get new symbol */ 1380/* get new symbol */
… …
1400 1392
1401INTERFACE pointer 1393INTERFACE pointer
1402gensym (SCHEME_P) 1394gensym (SCHEME_P)
1403{ 1395{
1404 pointer x; 1396 pointer x;
1405
1406 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1407 {
1408 char name[40] = "gensym-"; 1397 char name[40] = "gensym-";
1409 xnum (name + 7, SCHEME_V->gensym_cnt); 1398 xnum (name + 7, SCHEME_V->gensym_cnt);
1410 1399
1411 /* first check oblist */ 1400 return generate_symbol (SCHEME_A_ name);
1412 x = oblist_find_by_name (SCHEME_A_ name);
1413
1414 if (x == NIL)
1415 {
1416 x = oblist_add_by_name (SCHEME_A_ name);
1417 return x;
1418 }
1419 }
1420
1421 return NIL;
1422} 1401}
1423 1402
1424/* make symbol or number atom from string */ 1403/* make symbol or number atom from string */
1425static pointer 1404static pointer
1426mk_atom (SCHEME_P_ char *q) 1405mk_atom (SCHEME_P_ char *q)
… …
1578 1557
1579 if (ecb_expect_false (is_vector (p))) 1558 if (ecb_expect_false (is_vector (p)))
1580 { 1559 {
1581 int i; 1560 int i;
1582 1561
1583 for (i = 0; i < p->object.vector.length; i++) 1562 for (i = 0; i < veclength (p); i++)
1584 mark (vecvalue (p)[i]); 1563 mark (vecvalue (p)[i]);
1585 } 1564 }
1586 1565
1587 if (is_atom (p)) 1566 if (is_atom (p))
1588 goto E6; 1567 goto E6;
… …
1710 1689
1711static void 1690static void
1712finalize_cell (SCHEME_P_ pointer a) 1691finalize_cell (SCHEME_P_ pointer a)
1713{ 1692{
1714 /* TODO, fast bitmap check? */ 1693 /* TODO, fast bitmap check? */
1715 if (is_string (a)) 1694 if (is_string (a) || is_symbol (a))
1716 free (strvalue (a)); 1695 free (strvalue (a));
1717 else if (is_vector (a)) 1696 else if (is_vector (a))
1718 free (vecvalue (a)); 1697 free (vecvalue (a));
1719#if USE_PORTS 1698#if USE_PORTS
1720 else if (is_port (a)) 1699 else if (is_port (a))
… …
2142#endif 2121#endif
2143} 2122}
2144 2123
2145/* read characters up to delimiter, but cater to character constants */ 2124/* read characters up to delimiter, but cater to character constants */
2146static char * 2125static char *
2147readstr_upto (SCHEME_P_ char *delim) 2126readstr_upto (SCHEME_P_ int skip, const char *delim)
2148{ 2127{
2149 char *p = SCHEME_V->strbuff; 2128 char *p = SCHEME_V->strbuff + skip;
2150 2129
2151 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))));
2152 2131
2153 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2132 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2154 *p = 0; 2133 *p = 0;
… …
2161 return SCHEME_V->strbuff; 2140 return SCHEME_V->strbuff;
2162} 2141}
2163 2142
2164/* read string expression "xxx...xxx" */ 2143/* read string expression "xxx...xxx" */
2165static pointer 2144static pointer
2166readstrexp (SCHEME_P) 2145readstrexp (SCHEME_P_ char delim)
2167{ 2146{
2168 char *p = SCHEME_V->strbuff; 2147 char *p = SCHEME_V->strbuff;
2169 int c; 2148 int c;
2170 int c1 = 0; 2149 int c1 = 0;
2171 enum
2172 { 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;
2173 2151
2174 for (;;) 2152 for (;;)
2175 { 2153 {
2176 c = inchar (SCHEME_A); 2154 c = inchar (SCHEME_A);
2177 2155
… …
2179 return S_F; 2157 return S_F;
2180 2158
2181 switch (state) 2159 switch (state)
2182 { 2160 {
2183 case st_ok: 2161 case st_ok:
2184 switch (c) 2162 if (ecb_expect_false (c == delim))
2185 {
2186 case '\\':
2187 state = st_bsl;
2188 break;
2189
2190 case '"':
2191 *p = 0;
2192 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);
2193 2164
2194 default: 2165 if (ecb_expect_false (c == '\\'))
2166 state = st_bsl;
2167 else
2195 *p++ = c; 2168 *p++ = c;
2196 break;
2197 }
2198 2169
2199 break; 2170 break;
2200 2171
2201 case st_bsl: 2172 case st_bsl:
2202 switch (c) 2173 switch (c)
… …
2232 case 'r': 2203 case 'r':
2233 *p++ = '\r'; 2204 *p++ = '\r';
2234 state = st_ok; 2205 state = st_ok;
2235 break; 2206 break;
2236 2207
2237 case '"':
2238 *p++ = '"';
2239 state = st_ok;
2240 break;
2241
2242 default: 2208 default:
2243 *p++ = c; 2209 *p++ = c;
2244 state = st_ok; 2210 state = st_ok;
2245 break; 2211 break;
2246 } 2212 }
2247 2213
2248 break; 2214 break;
2249 2215
2250 case st_x1: 2216 case st_x1:
2251 case st_x2: 2217 case st_x2:
2252 c = toupper (c); 2218 c = tolower (c);
2253 2219
2254 if (c >= '0' && c <= 'F') 2220 if (c >= '0' && c <= '9')
2255 {
2256 if (c <= '9')
2257 c1 = (c1 << 4) + c - '0'; 2221 c1 = (c1 << 4) + c - '0';
2258 else 2222 else if (c >= 'a' && c <= 'f')
2259 c1 = (c1 << 4) + c - 'A' + 10; 2223 c1 = (c1 << 4) + c - 'a' + 10;
2260
2261 if (state == st_x1)
2262 state = st_x2;
2263 else
2264 {
2265 *p++ = c1;
2266 state = st_ok;
2267 }
2268 }
2269 else 2224 else
2270 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 }
2271 2234
2272 break; 2235 break;
2273 2236
2274 case st_oct1: 2237 case st_oct1:
2275 case st_oct2: 2238 case st_oct2:
… …
2279 backchar (SCHEME_A_ c); 2242 backchar (SCHEME_A_ c);
2280 state = st_ok; 2243 state = st_ok;
2281 } 2244 }
2282 else 2245 else
2283 { 2246 {
2284 if (state == st_oct2 && c1 >= 32) 2247 if (state == st_oct2 && c1 >= ' ')
2285 return S_F; 2248 return S_F;
2286 2249
2287 c1 = (c1 << 3) + (c - '0'); 2250 c1 = (c1 << 3) + (c - '0');
2288 2251
2289 if (state == st_oct1) 2252 if (state == st_oct1)
… …
2294 state = st_ok; 2257 state = st_ok;
2295 } 2258 }
2296 } 2259 }
2297 2260
2298 break; 2261 break;
2299
2300 } 2262 }
2301 } 2263 }
2302} 2264}
2303 2265
2304/* check c is in chars */ 2266/* check c is in chars */
2305ecb_inline int 2267ecb_inline int
2306is_one_of (char *s, int c) 2268is_one_of (const char *s, int c)
2307{ 2269{
2308 if (c == EOF)
2309 return 1;
2310
2311 return !!strchr (s, c); 2270 return c == EOF || !!strchr (s, c);
2312} 2271}
2313 2272
2314/* skip white characters */ 2273/* skip white characters */
2315ecb_inline int 2274ecb_inline int
2316skipspace (SCHEME_P) 2275skipspace (SCHEME_P)
… …
2323#if SHOW_ERROR_LINE 2282#if SHOW_ERROR_LINE
2324 if (c == '\n') 2283 if (c == '\n')
2325 curr_line++; 2284 curr_line++;
2326#endif 2285#endif
2327 } 2286 }
2328 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2287 while (is_one_of (WHITESPACE, c));
2329 2288
2330 /* record it */ 2289 /* record it */
2331#if SHOW_ERROR_LINE 2290#if SHOW_ERROR_LINE
2332 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)
2333 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;
… …
2363 return TOK_RPAREN; 2322 return TOK_RPAREN;
2364 2323
2365 case '.': 2324 case '.':
2366 c = inchar (SCHEME_A); 2325 c = inchar (SCHEME_A);
2367 2326
2368 if (is_one_of (" \n\t", c)) 2327 if (is_one_of (WHITESPACE, c))
2369 return TOK_DOT; 2328 return TOK_DOT;
2370 else 2329 else
2371 { 2330 {
2372 //TODO: ungetc twice in a row is not supported in C
2373 backchar (SCHEME_A_ c); 2331 backchar (SCHEME_A_ c);
2374 backchar (SCHEME_A_ '.');
2375 return TOK_ATOM; 2332 return TOK_DOTATOM;
2376 } 2333 }
2334
2335 case '|':
2336 return TOK_STRATOM;
2377 2337
2378 case '\'': 2338 case '\'':
2379 return TOK_QUOTE; 2339 return TOK_QUOTE;
2380 2340
2381 case ';': 2341 case ';':
… …
2513 } 2473 }
2514 2474
2515 putcharacter (SCHEME_A_ '"'); 2475 putcharacter (SCHEME_A_ '"');
2516} 2476}
2517 2477
2518
2519/* print atoms */ 2478/* print atoms */
2520static void 2479static void
2521printatom (SCHEME_P_ pointer l, int f) 2480printatom (SCHEME_P_ pointer l, int f)
2522{ 2481{
2523 char *p; 2482 char *p;
2524 int len; 2483 int len;
2525 2484
2526 atom2str (SCHEME_A_ l, f, &p, &len); 2485 atom2str (SCHEME_A_ l, f, &p, &len);
2527 putchars (SCHEME_A_ p, len); 2486 putchars (SCHEME_A_ p, len);
2528} 2487}
2529
2530 2488
2531/* Uses internal buffer unless string pointer is already available */ 2489/* Uses internal buffer unless string pointer is already available */
2532static void 2490static void
2533atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2491atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2534{ 2492{
… …
2695#endif 2653#endif
2696 } 2654 }
2697 else if (is_continuation (l)) 2655 else if (is_continuation (l))
2698 p = "#<CONTINUATION>"; 2656 p = "#<CONTINUATION>";
2699 else 2657 else
2658 {
2659#if USE_PRINTF
2660 p = SCHEME_V->strbuff;
2661 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2662#else
2700 p = "#<ERROR>"; 2663 p = "#<ERROR>";
2664#endif
2665 }
2701 2666
2702 *pp = p; 2667 *pp = p;
2703 *plen = strlen (p); 2668 *plen = strlen (p);
2704} 2669}
2705 2670
… …
2849/* () is #t in R5RS */ 2814/* () is #t in R5RS */
2850#define is_true(p) ((p) != S_F) 2815#define is_true(p) ((p) != S_F)
2851#define is_false(p) ((p) == S_F) 2816#define is_false(p) ((p) == S_F)
2852 2817
2853/* ========== Environment implementation ========== */ 2818/* ========== Environment implementation ========== */
2854
2855#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2856
2857static int
2858hash_fn (const char *key, int table_size)
2859{
2860 const unsigned char *p = key;
2861 uint32_t hash = 2166136261;
2862
2863 while (*p)
2864 hash = (hash ^ *p++) * 16777619;
2865
2866 return hash % table_size;
2867}
2868#endif
2869 2819
2870#ifndef USE_ALIST_ENV 2820#ifndef USE_ALIST_ENV
2871 2821
2872/* 2822/*
2873 * In this implementation, each frame of the environment may be 2823 * In this implementation, each frame of the environment may be
… …
2890 2840
2891 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2841 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2892 setenvironment (SCHEME_V->envir); 2842 setenvironment (SCHEME_V->envir);
2893} 2843}
2894 2844
2845static uint32_t
2846sym_hash (pointer sym, uint32_t size)
2847{
2848 uintptr_t ptr = (uintptr_t)sym;
2849
2850#if 0
2851 /* table size is prime, so why mix */
2852 ptr += ptr >> 32;
2853 ptr += ptr >> 16;
2854 ptr += ptr >> 8;
2855#endif
2856
2857 return ptr % size;
2858}
2859
2895ecb_inline void 2860ecb_inline void
2896new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2861new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2897{ 2862{
2898 pointer slot = immutable_cons (variable, value); 2863 pointer slot = immutable_cons (variable, value);
2899 2864
2900 if (is_vector (car (env))) 2865 if (is_vector (car (env)))
2901 { 2866 {
2902 int location = hash_fn (symname (variable), veclength (car (env))); 2867 int location = sym_hash (variable, veclength (car (env)));
2903
2904 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2868 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2905 } 2869 }
2906 else 2870 else
2907 set_car (env, immutable_cons (slot, car (env))); 2871 set_car (env, immutable_cons (slot, car (env)));
2908} 2872}
2909 2873
2910static pointer 2874static pointer
2911find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2875find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2912{ 2876{
2913 pointer x, y; 2877 pointer x, y;
2914 int location;
2915 2878
2916 for (x = env; x != NIL; x = cdr (x)) 2879 for (x = env; x != NIL; x = cdr (x))
2917 { 2880 {
2918 if (is_vector (car (x))) 2881 if (is_vector (car (x)))
2919 { 2882 {
2920 location = hash_fn (symname (hdl), veclength (car (x))); 2883 int location = sym_hash (hdl, veclength (car (x)));
2921 y = vector_elem (car (x), location); 2884 y = vector_get (car (x), location);
2922 } 2885 }
2923 else 2886 else
2924 y = car (x); 2887 y = car (x);
2925 2888
2926 for (; y != NIL; y = cdr (y)) 2889 for (; y != NIL; y = cdr (y))
2927 if (caar (y) == hdl) 2890 if (caar (y) == hdl)
2928 break; 2891 break;
2929 2892
2930 if (y != NIL) 2893 if (y != NIL)
2894 return car (y);
2895
2896 if (!all)
2931 break; 2897 break;
2932
2933 if (!all)
2934 return NIL;
2935 } 2898 }
2936
2937 if (x != NIL)
2938 return car (y);
2939 2899
2940 return NIL; 2900 return NIL;
2941} 2901}
2942 2902
2943#else /* USE_ALIST_ENV */ 2903#else /* USE_ALIST_ENV */
… …
2965 for (y = car (x); y != NIL; y = cdr (y)) 2925 for (y = car (x); y != NIL; y = cdr (y))
2966 if (caar (y) == hdl) 2926 if (caar (y) == hdl)
2967 break; 2927 break;
2968 2928
2969 if (y != NIL) 2929 if (y != NIL)
2930 return car (y);
2970 break; 2931 break;
2971 2932
2972 if (!all) 2933 if (!all)
2973 return NIL; 2934 break;
2974 } 2935 }
2975
2976 if (x != NIL)
2977 return car (y);
2978 2936
2979 return NIL; 2937 return NIL;
2980} 2938}
2981 2939
2982#endif /* USE_ALIST_ENV else */ 2940#endif /* USE_ALIST_ENV else */
2983 2941
2984ecb_inline void 2942ecb_inline void
2985new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2943new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2986{ 2944{
2945 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2987 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);
2988} 2947}
2989 2948
2990ecb_inline void 2949ecb_inline void
2991set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2950set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
… …
3283 3242
3284#endif 3243#endif
3285 3244
3286#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3245#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3287 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
3288static int 3305static int
3289opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3306opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3290{ 3307{
3291 pointer args = SCHEME_V->args; 3308 pointer args = SCHEME_V->args;
3292 pointer x, y; 3309 pointer x, y;
3293 3310
3294 switch (op) 3311 switch (op)
3295 { 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
3296 case OP_LOAD: /* load */ 3319 case OP_LOAD: /* load */
3297 if (file_interactive (SCHEME_A)) 3320 if (file_interactive (SCHEME_A))
3298 { 3321 {
3299 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3322 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3300 //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)));
… …
3423 } 3446 }
3424 else 3447 else
3425 s_return (SCHEME_V->code); 3448 s_return (SCHEME_V->code);
3426 3449
3427 case OP_E0ARGS: /* eval arguments */ 3450 case OP_E0ARGS: /* eval arguments */
3428 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3451 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3429 { 3452 {
3430 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3453 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3431 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3454 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3432 SCHEME_V->code = SCHEME_V->value; 3455 SCHEME_V->code = SCHEME_V->value;
3433 s_goto (OP_APPLY); 3456 s_goto (OP_APPLY);
… …
4401 if (SCHEME_V->no_memory) 4424 if (SCHEME_V->no_memory)
4402 s_return (S_SINK); 4425 s_return (S_SINK);
4403#endif 4426#endif
4404 4427
4405 for (x = args, i = 0; is_pair (x); x = cdr (x), i++) 4428 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4406 set_vector_elem (vec, i, car (x)); 4429 vector_set (vec, i, car (x));
4407 4430
4408 s_return (vec); 4431 s_return (vec);
4409 } 4432 }
4410 4433
4411 case OP_MKVECTOR: /* make-vector */ 4434 case OP_MKVECTOR: /* make-vector */
… …
4423 if (SCHEME_V->no_memory) 4446 if (SCHEME_V->no_memory)
4424 s_return (S_SINK); 4447 s_return (S_SINK);
4425#endif 4448#endif
4426 4449
4427 if (fill != NIL) 4450 if (fill != NIL)
4428 fill_vector (vec, fill); 4451 fill_vector (vec, 0, fill);
4429 4452
4430 s_return (vec); 4453 s_return (vec);
4431 } 4454 }
4432 4455
4433 case OP_VECLEN: /* vector-length */ 4456 case OP_VECLEN: /* vector-length */
4434 s_return (mk_integer (SCHEME_A_ veclength (x))); 4457 s_return (mk_integer (SCHEME_A_ veclength (x)));
4458
4459 case OP_VECRESIZE:
4460 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4461 s_return (x);
4435 4462
4436 case OP_VECREF: /* vector-ref */ 4463 case OP_VECREF: /* vector-ref */
4437 { 4464 {
4438 int index = ivalue_unchecked (cadr (args)); 4465 int index = ivalue_unchecked (cadr (args));
4439 4466
4440 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4467 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4441 Error_1 ("vector-ref: out of bounds:", cadr (args)); 4468 Error_1 ("vector-ref: out of bounds:", cadr (args));
4442 4469
4443 s_return (vector_elem (x, index)); 4470 s_return (vector_get (x, index));
4444 } 4471 }
4445 4472
4446 case OP_VECSET: /* vector-set! */ 4473 case OP_VECSET: /* vector-set! */
4447 { 4474 {
4448 int index = ivalue_unchecked (cadr (args)); 4475 int index = ivalue_unchecked (cadr (args));
… …
4451 Error_1 ("vector-set!: unable to alter immutable vector:", x); 4478 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4452 4479
4453 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4480 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4454 Error_1 ("vector-set!: out of bounds:", cadr (args)); 4481 Error_1 ("vector-set!: out of bounds:", cadr (args));
4455 4482
4456 set_vector_elem (x, index, caddr (args)); 4483 vector_set (x, index, caddr (args));
4457 s_return (x); 4484 s_return (x);
4458 } 4485 }
4459 } 4486 }
4460 4487
4461 if (USE_ERROR_CHECKING) abort (); 4488 if (USE_ERROR_CHECKING) abort ();
… …
4709 4736
4710 case OP_QUIT: /* quit */ 4737 case OP_QUIT: /* quit */
4711 if (is_pair (args)) 4738 if (is_pair (args))
4712 SCHEME_V->retcode = ivalue (a); 4739 SCHEME_V->retcode = ivalue (a);
4713 4740
4714 exit(0);//D
4715 return -1; 4741 return -1;
4716 4742
4717 case OP_GC: /* gc */ 4743 case OP_GC: /* gc */
4718 gc (SCHEME_A_ NIL, NIL); 4744 gc (SCHEME_A_ NIL, NIL);
4719 s_return (S_T); 4745 s_return (S_T);
… …
4996 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 5022 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
4997 SCHEME_V->tok = token (SCHEME_A); 5023 SCHEME_V->tok = token (SCHEME_A);
4998 s_goto (OP_RDSEXPR); 5024 s_goto (OP_RDSEXPR);
4999 5025
5000 case TOK_ATOM: 5026 case TOK_ATOM:
5001 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)));
5002 5037
5003 case TOK_DQUOTE: 5038 case TOK_DQUOTE:
5004 x = readstrexp (SCHEME_A); 5039 x = readstrexp (SCHEME_A_ '"');
5005 5040
5006 if (x == S_F) 5041 if (x == S_F)
5007 Error_0 ("Error reading string"); 5042 Error_0 ("Error reading string");
5008 5043
5009 setimmutable (x); 5044 setimmutable (x);
… …
5021 s_goto (OP_EVAL); 5056 s_goto (OP_EVAL);
5022 } 5057 }
5023 } 5058 }
5024 5059
5025 case TOK_SHARP_CONST: 5060 case TOK_SHARP_CONST:
5026 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)
5027 Error_0 ("undefined sharp expression"); 5062 Error_0 ("undefined sharp expression");
5028 else 5063 else
5029 s_return (x); 5064 s_return (x);
5030 5065
5031 default: 5066 default:
… …
5183 putstr (SCHEME_A_ ")"); 5218 putstr (SCHEME_A_ ")");
5184 s_return (S_T); 5219 s_return (S_T);
5185 } 5220 }
5186 else 5221 else
5187 { 5222 {
5188 pointer elem = vector_elem (vec, i); 5223 pointer elem = vector_get (vec, i);
5189 5224
5190 ivalue_unchecked (cdr (args)) = i + 1; 5225 ivalue_unchecked (cdr (args)) = i + 1;
5191 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5226 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5192 SCHEME_V->args = elem; 5227 SCHEME_V->args = elem;
5193 5228
… …
5253 5288
5254 case OP_CLOSUREP: /* closure? */ 5289 case OP_CLOSUREP: /* closure? */
5255 /* 5290 /*
5256 * Note, macro object is also a closure. 5291 * Note, macro object is also a closure.
5257 * Therefore, (closure? <#MACRO>) ==> #t 5292 * Therefore, (closure? <#MACRO>) ==> #t
5293 * (schmorp) well, obviously not, fix? TODO
5258 */ 5294 */
5259 s_retbool (is_closure (a)); 5295 s_retbool (is_closure (a));
5260 5296
5261 case OP_MACROP: /* macro? */ 5297 case OP_MACROP: /* macro? */
5262 s_retbool (is_macro (a)); 5298 s_retbool (is_macro (a));
… …
5431 { 5467 {
5432 if (!tests[j - 1].fct (arg)) 5468 if (!tests[j - 1].fct (arg))
5433 break; 5469 break;
5434 } 5470 }
5435 5471
5436 if (t[1]) /* last test is replicated as necessary */ 5472 if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5437 t++; 5473 t++;
5438 5474
5439 arglist = cdr (arglist); 5475 arglist = cdr (arglist);
5440 i++; 5476 i++;
5441 } 5477 }
… …
5503 5539
5504/* 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! */
5505static int 5541static int
5506syntaxnum (pointer p) 5542syntaxnum (pointer p)
5507{ 5543{
5508 const char *s = strvalue (car (p)); 5544 const char *s = strvalue (p);
5509 5545
5510 switch (strlength (car (p))) 5546 switch (strlength (p))
5511 { 5547 {
5512 case 2: 5548 case 2:
5513 if (s[0] == 'i') 5549 if (s[0] == 'i')
5514 return OP_IF0; /* if */ 5550 return OP_IF0; /* if */
5515 else 5551 else
… …
5951# endif 5987# endif
5952 int fin; 5988 int fin;
5953 char *file_name = InitFile; 5989 char *file_name = InitFile;
5954 int retcode; 5990 int retcode;
5955 int isfile = 1; 5991 int isfile = 1;
5992 system ("ps v $PPID");//D
5956 5993
5957 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5994 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5958 { 5995 {
5959 xwrstr ("Usage: tinyscheme -?\n"); 5996 xwrstr ("Usage: tinyscheme -?\n");
5960 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 5997 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");

Diff Legend

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