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.35 by root, Sun Nov 29 00:02:21 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,
… …
270 return type (p) == T_VECTOR; 285 return type (p) == T_VECTOR;
271} 286}
272 287
273#define vecvalue(p) ((p)->object.vector.vvalue) 288#define vecvalue(p) ((p)->object.vector.vvalue)
274#define veclength(p) ((p)->object.vector.length) 289#define veclength(p) ((p)->object.vector.length)
275INTERFACE void fill_vector (pointer vec, pointer obj); 290INTERFACE 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); 291INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
278INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 292INTERFACE 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 293
286INTERFACE int 294INTERFACE int
287is_integer (pointer p) 295is_integer (pointer p)
288{ 296{
289 return type (p) == T_INTEGER; 297 return type (p) == T_INTEGER;
… …
658#endif 666#endif
659 667
660static int file_push (SCHEME_P_ const char *fname); 668static int file_push (SCHEME_P_ const char *fname);
661static void file_pop (SCHEME_P); 669static void file_pop (SCHEME_P);
662static int file_interactive (SCHEME_P); 670static int file_interactive (SCHEME_P);
663ecb_inline int is_one_of (char *s, int c); 671ecb_inline int is_one_of (const char *s, int c);
664static int alloc_cellseg (SCHEME_P_ int n); 672static int alloc_cellseg (SCHEME_P_ int n);
665ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 673ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
666static void finalize_cell (SCHEME_P_ pointer a); 674static void finalize_cell (SCHEME_P_ pointer a);
667static int count_consecutive_cells (pointer x, int needed); 675static int count_consecutive_cells (pointer x, int needed);
668static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 676static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
… …
685static void mark (pointer a); 693static void mark (pointer a);
686static void gc (SCHEME_P_ pointer a, pointer b); 694static void gc (SCHEME_P_ pointer a, pointer b);
687static int basic_inchar (port *pt); 695static int basic_inchar (port *pt);
688static int inchar (SCHEME_P); 696static int inchar (SCHEME_P);
689static void backchar (SCHEME_P_ int c); 697static void backchar (SCHEME_P_ int c);
690static char *readstr_upto (SCHEME_P_ char *delim); 698static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
691static pointer readstrexp (SCHEME_P); 699static pointer readstrexp (SCHEME_P_ char delim);
692ecb_inline int skipspace (SCHEME_P); 700ecb_inline int skipspace (SCHEME_P);
693static int token (SCHEME_P); 701static int token (SCHEME_P);
694static void printslashstring (SCHEME_P_ char *s, int len); 702static void printslashstring (SCHEME_P_ char *s, int len);
695static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 703static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
696static void printatom (SCHEME_P_ pointer l, int f); 704static void printatom (SCHEME_P_ pointer l, int f);
… …
928 return k; 936 return k;
929 937
930 i = ++SCHEME_V->last_cell_seg; 938 i = ++SCHEME_V->last_cell_seg;
931 SCHEME_V->alloc_seg[i] = cp; 939 SCHEME_V->alloc_seg[i] = cp;
932 940
933 /* insert new segment in address order */
934 newp = (pointer)cp; 941 newp = (pointer)cp;
935 SCHEME_V->cell_seg[i] = newp; 942 SCHEME_V->cell_seg[i] = newp;
936 SCHEME_V->cell_segsize[i] = segsize; 943 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; 944 SCHEME_V->fcells += segsize;
953 last = newp + segsize - 1; 945 last = newp + segsize - 1;
954 946
955 for (p = newp; p <= last; p++) 947 for (p = newp; p <= last; p++)
956 { 948 {
957 set_typeflag (p, T_PAIR); 949 set_typeflag (p, T_PAIR);
958 set_car (p, NIL); 950 set_car (p, NIL);
959 set_cdr (p, p + 1); 951 set_cdr (p, p + 1);
960 } 952 }
961 953
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); 954 set_cdr (last, SCHEME_V->free_cell);
966 SCHEME_V->free_cell = newp; 955 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 } 956 }
979 957
980 return n; 958 return n;
981} 959}
982 960
… …
1061 /* Record it as a vector so that gc understands it. */ 1039 /* Record it as a vector so that gc understands it. */
1062 set_typeflag (v, T_VECTOR | T_ATOM); 1040 set_typeflag (v, T_VECTOR | T_ATOM);
1063 1041
1064 v->object.vector.vvalue = e; 1042 v->object.vector.vvalue = e;
1065 v->object.vector.length = len; 1043 v->object.vector.length = len;
1066 fill_vector (v, init); 1044 fill_vector (v, 0, init);
1067 push_recent_alloc (SCHEME_A_ v, NIL); 1045 push_recent_alloc (SCHEME_A_ v, NIL);
1068 1046
1069 return v; 1047 return v;
1070} 1048}
1071 1049
… …
1116 return x; 1094 return x;
1117} 1095}
1118 1096
1119/* ========== oblist implementation ========== */ 1097/* ========== oblist implementation ========== */
1120 1098
1099static pointer
1100generate_symbol (SCHEME_P_ const char *name)
1101{
1102 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x);
1104 x = immutable_cons (x, NIL);
1105 set_typeflag (x, T_SYMBOL);
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
1376INTERFACE pointer 1359INTERFACE pointer
1377vector_elem (pointer vec, uint32_t ielem) 1360vector_get (pointer vec, uint32_t ielem)
1378{ 1361{
1379 return vecvalue(vec)[ielem]; 1362 return vecvalue(vec)[ielem];
1380} 1363}
1381 1364
1382INTERFACE void 1365INTERFACE void
1383set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1366vector_set (pointer vec, uint32_t ielem, pointer a)
1384{ 1367{
1385 vecvalue(vec)[ielem] = a; 1368 vecvalue(vec)[ielem] = a;
1386} 1369}
1387 1370
1388/* get new symbol */ 1371/* get new symbol */
… …
1400 1383
1401INTERFACE pointer 1384INTERFACE pointer
1402gensym (SCHEME_P) 1385gensym (SCHEME_P)
1403{ 1386{
1404 pointer x; 1387 pointer x;
1405
1406 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1407 {
1408 char name[40] = "gensym-"; 1388 char name[40] = "gensym-";
1409 xnum (name + 7, SCHEME_V->gensym_cnt); 1389 xnum (name + 7, SCHEME_V->gensym_cnt);
1410 1390
1411 /* first check oblist */ 1391 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} 1392}
1423 1393
1424/* make symbol or number atom from string */ 1394/* make symbol or number atom from string */
1425static pointer 1395static pointer
1426mk_atom (SCHEME_P_ char *q) 1396mk_atom (SCHEME_P_ char *q)
… …
1578 1548
1579 if (ecb_expect_false (is_vector (p))) 1549 if (ecb_expect_false (is_vector (p)))
1580 { 1550 {
1581 int i; 1551 int i;
1582 1552
1583 for (i = 0; i < p->object.vector.length; i++) 1553 for (i = 0; i < veclength (p); i++)
1584 mark (vecvalue (p)[i]); 1554 mark (vecvalue (p)[i]);
1585 } 1555 }
1586 1556
1587 if (is_atom (p)) 1557 if (is_atom (p))
1588 goto E6; 1558 goto E6;
… …
2142#endif 2112#endif
2143} 2113}
2144 2114
2145/* read characters up to delimiter, but cater to character constants */ 2115/* read characters up to delimiter, but cater to character constants */
2146static char * 2116static char *
2147readstr_upto (SCHEME_P_ char *delim) 2117readstr_upto (SCHEME_P_ int skip, const char *delim)
2148{ 2118{
2149 char *p = SCHEME_V->strbuff; 2119 char *p = SCHEME_V->strbuff + skip;
2150 2120
2151 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2121 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2152 2122
2153 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2123 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2154 *p = 0; 2124 *p = 0;
… …
2161 return SCHEME_V->strbuff; 2131 return SCHEME_V->strbuff;
2162} 2132}
2163 2133
2164/* read string expression "xxx...xxx" */ 2134/* read string expression "xxx...xxx" */
2165static pointer 2135static pointer
2166readstrexp (SCHEME_P) 2136readstrexp (SCHEME_P_ char delim)
2167{ 2137{
2168 char *p = SCHEME_V->strbuff; 2138 char *p = SCHEME_V->strbuff;
2169 int c; 2139 int c;
2170 int c1 = 0; 2140 int c1 = 0;
2171 enum
2172 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; 2141 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2173 2142
2174 for (;;) 2143 for (;;)
2175 { 2144 {
2176 c = inchar (SCHEME_A); 2145 c = inchar (SCHEME_A);
2177 2146
… …
2179 return S_F; 2148 return S_F;
2180 2149
2181 switch (state) 2150 switch (state)
2182 { 2151 {
2183 case st_ok: 2152 case st_ok:
2184 switch (c) 2153 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); 2154 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2193 2155
2194 default: 2156 if (ecb_expect_false (c == '\\'))
2157 state = st_bsl;
2158 else
2195 *p++ = c; 2159 *p++ = c;
2196 break;
2197 }
2198 2160
2199 break; 2161 break;
2200 2162
2201 case st_bsl: 2163 case st_bsl:
2202 switch (c) 2164 switch (c)
… …
2232 case 'r': 2194 case 'r':
2233 *p++ = '\r'; 2195 *p++ = '\r';
2234 state = st_ok; 2196 state = st_ok;
2235 break; 2197 break;
2236 2198
2237 case '"':
2238 *p++ = '"';
2239 state = st_ok;
2240 break;
2241
2242 default: 2199 default:
2243 *p++ = c; 2200 *p++ = c;
2244 state = st_ok; 2201 state = st_ok;
2245 break; 2202 break;
2246 } 2203 }
2247 2204
2248 break; 2205 break;
2249 2206
2250 case st_x1: 2207 case st_x1:
2251 case st_x2: 2208 case st_x2:
2252 c = toupper (c); 2209 c = tolower (c);
2253 2210
2254 if (c >= '0' && c <= 'F') 2211 if (c >= '0' && c <= '9')
2255 {
2256 if (c <= '9')
2257 c1 = (c1 << 4) + c - '0'; 2212 c1 = (c1 << 4) + c - '0';
2258 else 2213 else if (c >= 'a' && c <= 'f')
2259 c1 = (c1 << 4) + c - 'A' + 10; 2214 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 2215 else
2270 return S_F; 2216 return S_F;
2217
2218 if (state == st_x1)
2219 state = st_x2;
2220 else
2221 {
2222 *p++ = c1;
2223 state = st_ok;
2224 }
2271 2225
2272 break; 2226 break;
2273 2227
2274 case st_oct1: 2228 case st_oct1:
2275 case st_oct2: 2229 case st_oct2:
… …
2279 backchar (SCHEME_A_ c); 2233 backchar (SCHEME_A_ c);
2280 state = st_ok; 2234 state = st_ok;
2281 } 2235 }
2282 else 2236 else
2283 { 2237 {
2284 if (state == st_oct2 && c1 >= 32) 2238 if (state == st_oct2 && c1 >= ' ')
2285 return S_F; 2239 return S_F;
2286 2240
2287 c1 = (c1 << 3) + (c - '0'); 2241 c1 = (c1 << 3) + (c - '0');
2288 2242
2289 if (state == st_oct1) 2243 if (state == st_oct1)
… …
2294 state = st_ok; 2248 state = st_ok;
2295 } 2249 }
2296 } 2250 }
2297 2251
2298 break; 2252 break;
2299
2300 } 2253 }
2301 } 2254 }
2302} 2255}
2303 2256
2304/* check c is in chars */ 2257/* check c is in chars */
2305ecb_inline int 2258ecb_inline int
2306is_one_of (char *s, int c) 2259is_one_of (const char *s, int c)
2307{ 2260{
2308 if (c == EOF) 2261 if (c == EOF)
2309 return 1; 2262 return 1;
2310 2263
2311 return !!strchr (s, c); 2264 return !!strchr (s, c);
… …
2367 2320
2368 if (is_one_of (" \n\t", c)) 2321 if (is_one_of (" \n\t", c))
2369 return TOK_DOT; 2322 return TOK_DOT;
2370 else 2323 else
2371 { 2324 {
2372 //TODO: ungetc twice in a row is not supported in C
2373 backchar (SCHEME_A_ c); 2325 backchar (SCHEME_A_ c);
2374 backchar (SCHEME_A_ '.');
2375 return TOK_ATOM; 2326 return TOK_DOTATOM;
2376 } 2327 }
2328
2329 case '|':
2330 return TOK_STRATOM;
2377 2331
2378 case '\'': 2332 case '\'':
2379 return TOK_QUOTE; 2333 return TOK_QUOTE;
2380 2334
2381 case ';': 2335 case ';':
… …
2850#define is_true(p) ((p) != S_F) 2804#define is_true(p) ((p) != S_F)
2851#define is_false(p) ((p) == S_F) 2805#define is_false(p) ((p) == S_F)
2852 2806
2853/* ========== Environment implementation ========== */ 2807/* ========== Environment implementation ========== */
2854 2808
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
2870#ifndef USE_ALIST_ENV 2809#ifndef USE_ALIST_ENV
2871 2810
2872/* 2811/*
2873 * In this implementation, each frame of the environment may be 2812 * In this implementation, each frame of the environment may be
2874 * a hash table: a vector of alists hashed by variable name. 2813 * a hash table: a vector of alists hashed by variable name.
… …
2890 2829
2891 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2830 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2892 setenvironment (SCHEME_V->envir); 2831 setenvironment (SCHEME_V->envir);
2893} 2832}
2894 2833
2834static uint32_t
2835sym_hash (pointer sym, uint32_t size)
2836{
2837 uintptr_t ptr = (uintptr_t)sym;
2838
2839#if 0
2840 /* table size is prime, so why mix */
2841 ptr += ptr >> 32;
2842 ptr += ptr >> 16;
2843 ptr += ptr >> 8;
2844#endif
2845
2846 return ptr % size;
2847}
2848
2895ecb_inline void 2849ecb_inline void
2896new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2850new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2897{ 2851{
2898 pointer slot = immutable_cons (variable, value); 2852 pointer slot = immutable_cons (variable, value);
2899 2853
2900 if (is_vector (car (env))) 2854 if (is_vector (car (env)))
2901 { 2855 {
2902 int location = hash_fn (symname (variable), veclength (car (env))); 2856 int location = sym_hash (variable, veclength (car (env)));
2903
2904 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2857 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2905 } 2858 }
2906 else 2859 else
2907 set_car (env, immutable_cons (slot, car (env))); 2860 set_car (env, immutable_cons (slot, car (env)));
2908} 2861}
2909 2862
2910static pointer 2863static pointer
2911find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2864find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2912{ 2865{
2913 pointer x, y; 2866 pointer x, y;
2914 int location;
2915 2867
2916 for (x = env; x != NIL; x = cdr (x)) 2868 for (x = env; x != NIL; x = cdr (x))
2917 { 2869 {
2918 if (is_vector (car (x))) 2870 if (is_vector (car (x)))
2919 { 2871 {
2920 location = hash_fn (symname (hdl), veclength (car (x))); 2872 int location = sym_hash (hdl, veclength (car (x)));
2921 y = vector_elem (car (x), location); 2873 y = vector_get (car (x), location);
2922 } 2874 }
2923 else 2875 else
2924 y = car (x); 2876 y = car (x);
2925 2877
2926 for (; y != NIL; y = cdr (y)) 2878 for (; y != NIL; y = cdr (y))
2927 if (caar (y) == hdl) 2879 if (caar (y) == hdl)
2928 break; 2880 break;
2929 2881
2930 if (y != NIL) 2882 if (y != NIL)
2883 return car (y);
2884
2885 if (!all)
2931 break; 2886 break;
2932
2933 if (!all)
2934 return NIL;
2935 } 2887 }
2936
2937 if (x != NIL)
2938 return car (y);
2939 2888
2940 return NIL; 2889 return NIL;
2941} 2890}
2942 2891
2943#else /* USE_ALIST_ENV */ 2892#else /* USE_ALIST_ENV */
… …
2965 for (y = car (x); y != NIL; y = cdr (y)) 2914 for (y = car (x); y != NIL; y = cdr (y))
2966 if (caar (y) == hdl) 2915 if (caar (y) == hdl)
2967 break; 2916 break;
2968 2917
2969 if (y != NIL) 2918 if (y != NIL)
2919 return car (y);
2970 break; 2920 break;
2971 2921
2972 if (!all) 2922 if (!all)
2973 return NIL; 2923 break;
2974 } 2924 }
2975
2976 if (x != NIL)
2977 return car (y);
2978 2925
2979 return NIL; 2926 return NIL;
2980} 2927}
2981 2928
2982#endif /* USE_ALIST_ENV else */ 2929#endif /* USE_ALIST_ENV else */
… …
4401 if (SCHEME_V->no_memory) 4348 if (SCHEME_V->no_memory)
4402 s_return (S_SINK); 4349 s_return (S_SINK);
4403#endif 4350#endif
4404 4351
4405 for (x = args, i = 0; is_pair (x); x = cdr (x), i++) 4352 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4406 set_vector_elem (vec, i, car (x)); 4353 vector_set (vec, i, car (x));
4407 4354
4408 s_return (vec); 4355 s_return (vec);
4409 } 4356 }
4410 4357
4411 case OP_MKVECTOR: /* make-vector */ 4358 case OP_MKVECTOR: /* make-vector */
… …
4423 if (SCHEME_V->no_memory) 4370 if (SCHEME_V->no_memory)
4424 s_return (S_SINK); 4371 s_return (S_SINK);
4425#endif 4372#endif
4426 4373
4427 if (fill != NIL) 4374 if (fill != NIL)
4428 fill_vector (vec, fill); 4375 fill_vector (vec, 0, fill);
4429 4376
4430 s_return (vec); 4377 s_return (vec);
4431 } 4378 }
4432 4379
4433 case OP_VECLEN: /* vector-length */ 4380 case OP_VECLEN: /* vector-length */
… …
4438 int index = ivalue_unchecked (cadr (args)); 4385 int index = ivalue_unchecked (cadr (args));
4439 4386
4440 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4387 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4441 Error_1 ("vector-ref: out of bounds:", cadr (args)); 4388 Error_1 ("vector-ref: out of bounds:", cadr (args));
4442 4389
4443 s_return (vector_elem (x, index)); 4390 s_return (vector_get (x, index));
4444 } 4391 }
4445 4392
4446 case OP_VECSET: /* vector-set! */ 4393 case OP_VECSET: /* vector-set! */
4447 { 4394 {
4448 int index = ivalue_unchecked (cadr (args)); 4395 int index = ivalue_unchecked (cadr (args));
… …
4451 Error_1 ("vector-set!: unable to alter immutable vector:", x); 4398 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4452 4399
4453 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4400 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4454 Error_1 ("vector-set!: out of bounds:", cadr (args)); 4401 Error_1 ("vector-set!: out of bounds:", cadr (args));
4455 4402
4456 set_vector_elem (x, index, caddr (args)); 4403 vector_set (x, index, caddr (args));
4457 s_return (x); 4404 s_return (x);
4458 } 4405 }
4459 } 4406 }
4460 4407
4461 if (USE_ERROR_CHECKING) abort (); 4408 if (USE_ERROR_CHECKING) abort ();
… …
4709 4656
4710 case OP_QUIT: /* quit */ 4657 case OP_QUIT: /* quit */
4711 if (is_pair (args)) 4658 if (is_pair (args))
4712 SCHEME_V->retcode = ivalue (a); 4659 SCHEME_V->retcode = ivalue (a);
4713 4660
4714 exit(0);//D
4715 return -1; 4661 return -1;
4716 4662
4717 case OP_GC: /* gc */ 4663 case OP_GC: /* gc */
4718 gc (SCHEME_A_ NIL, NIL); 4664 gc (SCHEME_A_ NIL, NIL);
4719 s_return (S_T); 4665 s_return (S_T);
… …
4996 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 4942 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
4997 SCHEME_V->tok = token (SCHEME_A); 4943 SCHEME_V->tok = token (SCHEME_A);
4998 s_goto (OP_RDSEXPR); 4944 s_goto (OP_RDSEXPR);
4999 4945
5000 case TOK_ATOM: 4946 case TOK_ATOM:
5001 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); 4947 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
4948
4949 case TOK_DOTATOM:
4950 SCHEME_V->strbuff[0] = '.';
4951 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5002 4952
5003 case TOK_DQUOTE: 4953 case TOK_DQUOTE:
5004 x = readstrexp (SCHEME_A); 4954 x = readstrexp (SCHEME_A_ '"');
5005 4955
5006 if (x == S_F) 4956 if (x == S_F)
5007 Error_0 ("Error reading string"); 4957 Error_0 ("Error reading string");
5008 4958
5009 setimmutable (x); 4959 setimmutable (x);
… …
5021 s_goto (OP_EVAL); 4971 s_goto (OP_EVAL);
5022 } 4972 }
5023 } 4973 }
5024 4974
5025 case TOK_SHARP_CONST: 4975 case TOK_SHARP_CONST:
5026 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) 4976 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5027 Error_0 ("undefined sharp expression"); 4977 Error_0 ("undefined sharp expression");
5028 else 4978 else
5029 s_return (x); 4979 s_return (x);
5030 4980
5031 default: 4981 default:
… …
5183 putstr (SCHEME_A_ ")"); 5133 putstr (SCHEME_A_ ")");
5184 s_return (S_T); 5134 s_return (S_T);
5185 } 5135 }
5186 else 5136 else
5187 { 5137 {
5188 pointer elem = vector_elem (vec, i); 5138 pointer elem = vector_get (vec, i);
5189 5139
5190 ivalue_unchecked (cdr (args)) = i + 1; 5140 ivalue_unchecked (cdr (args)) = i + 1;
5191 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5141 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5192 SCHEME_V->args = elem; 5142 SCHEME_V->args = elem;
5193 5143
… …
5431 { 5381 {
5432 if (!tests[j - 1].fct (arg)) 5382 if (!tests[j - 1].fct (arg))
5433 break; 5383 break;
5434 } 5384 }
5435 5385
5436 if (t[1]) /* last test is replicated as necessary */ 5386 if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5437 t++; 5387 t++;
5438 5388
5439 arglist = cdr (arglist); 5389 arglist = cdr (arglist);
5440 i++; 5390 i++;
5441 } 5391 }

Diff Legend

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