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.2 by root, Wed Nov 25 10:01:39 2015 UTC vs.
Revision 1.8 by root, Wed Nov 25 22:36:25 2015 UTC

1 1/*
2/* T I N Y S C H E M E 1 . 4 1 2 * µscheme
3 *
4 * Copyright (C) 2015 Marc Alexander Lehmann <uscheme@schmorp.de>
5 * do as you want with this, attribution appreciated.
6 *
7 * Based opn tinyscheme-1.41 (original credits follow)
3 * Dimitrios Souflis (dsouflis@acm.org) 8 * Dimitrios Souflis (dsouflis@acm.org)
4 * Based on MiniScheme (original credits follow) 9 * Based on MiniScheme (original credits follow)
5 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) 10 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
6 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 11 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
7 * (MINISCM) This version has been modified by R.C. Secrist. 12 * (MINISCM) This version has been modified by R.C. Secrist.
… …
128 c += 'a' - 'A'; 133 c += 'a' - 'A';
129 134
130 return c; 135 return c;
131} 136}
132 137
138static int
139xisdigit (char c)
140{
141 return c >= '0' && c <= '9';
142}
143
144#define toupper(c) xtoupper (c)
145#define tolower(c) xtolower (c)
146#define isdigit(c) xisdigit (c)
147
133#if USE_STRLWR 148#if USE_STRLWR
134static const char * 149static const char *
135strlwr (char *s) 150strlwr (char *s)
136{ 151{
137 const char *p = s; 152 const char *p = s;
… …
146} 161}
147#endif 162#endif
148 163
149#define stricmp(a,b) strcmp (a, b) 164#define stricmp(a,b) strcmp (a, b)
150#define strlwr(s) (s) 165#define strlwr(s) (s)
151#define toupper(c) xtoupper(c)
152#define tolower(c) xtolower(c)
153 166
154#ifndef prompt 167#ifndef prompt
155# define prompt "ts> " 168# define prompt "ts> "
156#endif 169#endif
157 170
… …
236is_vector (pointer p) 249is_vector (pointer p)
237{ 250{
238 return type (p) == T_VECTOR; 251 return type (p) == T_VECTOR;
239} 252}
240 253
254#define vecvalue(p) ((p)->object.vector.vvalue)
255#define veclength(p) ((p)->object.vector.length)
241INTERFACE void fill_vector (pointer vec, pointer obj); 256INTERFACE void fill_vector (pointer vec, pointer obj);
257INTERFACE uint32_t vector_length (pointer vec);
242INTERFACE pointer vector_elem (pointer vec, int ielem); 258INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
243INTERFACE void set_vector_elem (pointer vec, int ielem, pointer a); 259INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
260
261INTERFACE uint32_t
262vector_length (pointer vec)
263{
264 return vec->object.vector.length;
265}
244 266
245INTERFACE INLINE int 267INTERFACE INLINE int
246is_number (pointer p) 268is_number (pointer p)
247{ 269{
248 return type (p) == T_NUMBER; 270 return type (p) == T_NUMBER;
… …
307{ 329{
308 return num_get_rvalue (p->object.number); 330 return num_get_rvalue (p->object.number);
309} 331}
310 332
311#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 333#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
312#if USE_FLOAT 334#if USE_REAL
313# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 335# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
314# define set_num_integer(p) (p)->object.number.is_fixnum=1; 336# define set_num_integer(p) (p)->object.number.is_fixnum=1;
315# define set_num_real(p) (p)->object.number.is_fixnum=0; 337# define set_num_real(p) (p)->object.number.is_fixnum=0;
316#else 338#else
317# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 339# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
… …
479 return type (p) == T_ENVIRONMENT; 501 return type (p) == T_ENVIRONMENT;
480} 502}
481 503
482#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 504#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
483 505
484#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
485#define is_atom(p) (typeflag (p) & T_ATOM) 506#define is_atom(p) (typeflag (p) & T_ATOM)
486#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 507#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
487#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 508#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
488 509
489#define is_mark(p) (typeflag (p) & T_MARK) 510#define is_mark(p) (typeflag (p) & T_MARK)
490#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 511#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
491#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 512#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
492
493#if 0
494static int
495is_atom(pointer p)
496{
497 if (!is_atom1(p) != !is_atom2(p))
498 printf ("atoms disagree %x\n", typeflag(p));
499
500 return is_atom2(p);
501}
502#endif
503 513
504INTERFACE INLINE int 514INTERFACE INLINE int
505is_immutable (pointer p) 515is_immutable (pointer p)
506{ 516{
507 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 517 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
611static int file_push (SCHEME_P_ const char *fname); 621static int file_push (SCHEME_P_ const char *fname);
612static void file_pop (SCHEME_P); 622static void file_pop (SCHEME_P);
613static int file_interactive (SCHEME_P); 623static int file_interactive (SCHEME_P);
614static INLINE int is_one_of (char *s, int c); 624static INLINE int is_one_of (char *s, int c);
615static int alloc_cellseg (SCHEME_P_ int n); 625static int alloc_cellseg (SCHEME_P_ int n);
616static long binary_decode (const char *s);
617static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 626static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
618static pointer reserve_cells (SCHEME_P_ int n);
619static pointer get_consecutive_cells (SCHEME_P_ int n);
620static pointer find_consecutive_cells (SCHEME_P_ int n);
621static void finalize_cell (SCHEME_P_ pointer a); 627static void finalize_cell (SCHEME_P_ pointer a);
622static int count_consecutive_cells (pointer x, int needed); 628static int count_consecutive_cells (pointer x, int needed);
623static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 629static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
624static pointer mk_number (SCHEME_P_ const num n); 630static pointer mk_number (SCHEME_P_ const num n);
625static char *store_string (SCHEME_P_ int len, const char *str, char fill); 631static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
626static pointer mk_vector (SCHEME_P_ int len); 632static pointer mk_vector (SCHEME_P_ uint32_t len);
627static pointer mk_atom (SCHEME_P_ char *q); 633static pointer mk_atom (SCHEME_P_ char *q);
628static pointer mk_sharp_const (SCHEME_P_ char *name); 634static pointer mk_sharp_const (SCHEME_P_ char *name);
629 635
630#if USE_PORTS 636#if USE_PORTS
631static pointer mk_port (SCHEME_P_ port *p); 637static pointer mk_port (SCHEME_P_ port *p);
… …
871#endif 877#endif
872 878
873static int 879static int
874is_zero_rvalue (RVALUE x) 880is_zero_rvalue (RVALUE x)
875{ 881{
876#if USE_FLOAT 882#if USE_REAL
877 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 883 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
878#else 884#else
879 return x == 0; 885 return x == 0;
880#endif 886#endif
881}
882
883static long
884binary_decode (const char *s)
885{
886 long x = 0;
887
888 while (*s != 0 && (*s == '1' || *s == '0'))
889 {
890 x <<= 1;
891 x += *s - '0';
892 s++;
893 }
894
895 return x;
896} 887}
897 888
898/* allocate new cell segment */ 889/* allocate new cell segment */
899static int 890static int
900alloc_cellseg (SCHEME_P_ int n) 891alloc_cellseg (SCHEME_P_ int n)
… …
1008 --SCHEME_V->fcells; 999 --SCHEME_V->fcells;
1009 return x; 1000 return x;
1010 } 1001 }
1011} 1002}
1012 1003
1013/* make sure that there is a given number of cells free */
1014static pointer
1015reserve_cells (SCHEME_P_ int n)
1016{
1017 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
1018 return NIL;
1019
1020 /* Are there enough cells available? */
1021 if (SCHEME_V->fcells < n)
1022 {
1023 /* If not, try gc'ing some */
1024 gc (SCHEME_A_ NIL, NIL);
1025
1026 if (SCHEME_V->fcells < n)
1027 {
1028 /* If there still aren't, try getting more heap */
1029 if (!alloc_cellseg (SCHEME_A_ 1) && USE_ERROR_CHECKING)
1030 {
1031 SCHEME_V->no_memory = 1;
1032 return NIL;
1033 }
1034 }
1035
1036 if (SCHEME_V->fcells < n && USE_ERROR_CHECKING)
1037 {
1038 /* If all fail, report failure */
1039 SCHEME_V->no_memory = 1;
1040 return NIL;
1041 }
1042 }
1043
1044 return S_T;
1045}
1046
1047static pointer
1048get_consecutive_cells (SCHEME_P_ int n)
1049{
1050 pointer x;
1051
1052 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
1053 return S_SINK;
1054
1055 /* Are there any cells available? */
1056 x = find_consecutive_cells (SCHEME_A_ n);
1057
1058 if (x != NIL)
1059 return x;
1060
1061 /* If not, try gc'ing some */
1062 gc (SCHEME_A_ NIL, NIL);
1063
1064 for (;;)
1065 {
1066 x = find_consecutive_cells (SCHEME_A_ n);
1067
1068 if (x != NIL)
1069 return x;
1070
1071 /* If there still aren't, try getting more heap */
1072 if (!alloc_cellseg (SCHEME_A_ 1))
1073 {
1074#if USE_ERROR_CHECKING
1075 SCHEME_V->no_memory = 1;
1076 return S_SINK;
1077#endif
1078 }
1079 }
1080}
1081
1082static int
1083count_consecutive_cells (pointer x, int needed)
1084{
1085 int n = 1;
1086
1087 while (cdr (x) == x + 1)
1088 {
1089 x = cdr (x);
1090 n++;
1091
1092 if (n >= needed)
1093 break;
1094 }
1095
1096 return n;
1097}
1098
1099static pointer
1100find_consecutive_cells (SCHEME_P_ int n)
1101{
1102 pointer *pp = &SCHEME_V->free_cell;
1103
1104 while (*pp != NIL)
1105 {
1106 int cnt = count_consecutive_cells (*pp, n);
1107
1108 if (cnt >= n)
1109 {
1110 pointer x = *pp;
1111
1112 *pp = cdr (*pp + n - 1);
1113 SCHEME_V->fcells -= n;
1114 return x;
1115 }
1116
1117 pp = &cdr (*pp + cnt - 1);
1118 }
1119
1120 return NIL;
1121}
1122
1123/* To retain recent allocs before interpreter knows about them - 1004/* To retain recent allocs before interpreter knows about them -
1124 Tehom */ 1005 Tehom */
1125 1006
1126static void 1007static void
1127push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 1008push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
… …
1150 1031
1151 return cell; 1032 return cell;
1152} 1033}
1153 1034
1154static pointer 1035static pointer
1155get_vector_object (SCHEME_P_ int len, pointer init) 1036get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1156{ 1037{
1157 pointer cells = get_consecutive_cells (SCHEME_A_ len / 2 + len % 2 + 1); 1038 pointer v = get_cell_x (SCHEME_A_ 0, 0);
1039 pointer *e = malloc (len * sizeof (pointer));
1158 1040
1159#if USE_ERROR_CHECKING 1041 if (!e && USE_ERROR_CHECKING)
1160 if (SCHEME_V->no_memory)
1161 return S_SINK; 1042 return S_SINK;
1162#endif
1163 1043
1164 /* Record it as a vector so that gc understands it. */ 1044 /* Record it as a vector so that gc understands it. */
1165 set_typeflag (cells, T_VECTOR | T_ATOM); 1045 set_typeflag (v, T_VECTOR | T_ATOM);
1166 ivalue_unchecked (cells) = len; 1046
1167 set_num_integer (cells); 1047 v->object.vector.vvalue = e;
1048 v->object.vector.length = len;
1168 fill_vector (cells, init); 1049 fill_vector (v, init);
1169 push_recent_alloc (SCHEME_A_ cells, NIL); 1050 push_recent_alloc (SCHEME_A_ v, NIL);
1170 1051
1171 return cells; 1052 return v;
1172} 1053}
1173 1054
1174static INLINE void 1055static INLINE void
1175ok_to_freely_gc (SCHEME_P) 1056ok_to_freely_gc (SCHEME_P)
1176{ 1057{
… …
1212 if (immutable) 1093 if (immutable)
1213 setimmutable (x); 1094 setimmutable (x);
1214 1095
1215 set_car (x, a); 1096 set_car (x, a);
1216 set_cdr (x, b); 1097 set_cdr (x, b);
1098
1217 return x; 1099 return x;
1218} 1100}
1219 1101
1220/* ========== oblist implementation ========== */ 1102/* ========== oblist implementation ========== */
1221 1103
… …
1237 1119
1238 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1120 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1239 set_typeflag (x, T_SYMBOL); 1121 set_typeflag (x, T_SYMBOL);
1240 setimmutable (car (x)); 1122 setimmutable (car (x));
1241 1123
1242 location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist)); 1124 location = hash_fn (name, veclength (SCHEME_V->oblist));
1243 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1125 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1244 return x; 1126 return x;
1245} 1127}
1246 1128
1247static INLINE pointer 1129static INLINE pointer
… …
1249{ 1131{
1250 int location; 1132 int location;
1251 pointer x; 1133 pointer x;
1252 char *s; 1134 char *s;
1253 1135
1254 location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist)); 1136 location = hash_fn (name, veclength (SCHEME_V->oblist));
1255 1137
1256 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1138 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1257 { 1139 {
1258 s = symname (car (x)); 1140 s = symname (car (x));
1259 1141
… …
1270{ 1152{
1271 int i; 1153 int i;
1272 pointer x; 1154 pointer x;
1273 pointer ob_list = NIL; 1155 pointer ob_list = NIL;
1274 1156
1275 for (i = 0; i < ivalue_unchecked (SCHEME_V->oblist); i++) 1157 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1276 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1158 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1277 ob_list = cons (x, ob_list); 1159 ob_list = cons (x, ob_list);
1278 1160
1279 return ob_list; 1161 return ob_list;
1280} 1162}
… …
1393 return mk_real (SCHEME_A_ num_get_rvalue (n)); 1275 return mk_real (SCHEME_A_ num_get_rvalue (n));
1394} 1276}
1395 1277
1396/* allocate name to string area */ 1278/* allocate name to string area */
1397static char * 1279static char *
1398store_string (SCHEME_P_ int len_str, const char *str, char fill) 1280store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
1399{ 1281{
1400 char *q = malloc (len_str + 1); 1282 char *q = malloc (len_str + 1);
1401 1283
1402 if (q == 0 && USE_ERROR_CHECKING) 1284 if (q == 0 && USE_ERROR_CHECKING)
1403 { 1285 {
… …
1422 } 1304 }
1423 1305
1424 return q; 1306 return q;
1425} 1307}
1426 1308
1427/* get new string */
1428INTERFACE pointer 1309INTERFACE pointer
1429mk_string (SCHEME_P_ const char *str) 1310mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1430{ 1311{
1431 return mk_counted_string (SCHEME_A_ str, strlen (str)); 1312 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1313
1314 set_typeflag (x, T_STRING | T_ATOM);
1315 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1316 strlength (x) = len;
1317 return x;
1432} 1318}
1433 1319
1434INTERFACE pointer 1320INTERFACE pointer
1435mk_counted_string (SCHEME_P_ const char *str, int len) 1321mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1436{ 1322{
1437 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1323 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1438 1324
1439 set_typeflag (x, T_STRING | T_ATOM); 1325 set_typeflag (x, T_STRING | T_ATOM);
1440 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1326 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1441 strlength (x) = len; 1327 strlength (x) = len;
1442 return x; 1328 return x;
1443} 1329}
1444 1330
1445INTERFACE pointer 1331INTERFACE pointer
1446mk_empty_string (SCHEME_P_ int len, char fill) 1332mk_string (SCHEME_P_ const char *str)
1447{ 1333{
1448 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1334 return mk_counted_string (SCHEME_A_ str, strlen (str));
1449
1450 set_typeflag (x, T_STRING | T_ATOM);
1451 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1452 strlength (x) = len;
1453 return x;
1454} 1335}
1455 1336
1456INTERFACE pointer 1337INTERFACE pointer
1457mk_vector (SCHEME_P_ int len) 1338mk_vector (SCHEME_P_ uint32_t len)
1458{ 1339{
1459 return get_vector_object (SCHEME_A_ len, NIL); 1340 return get_vector_object (SCHEME_A_ len, NIL);
1460} 1341}
1461 1342
1462INTERFACE void 1343INTERFACE void
1463fill_vector (pointer vec, pointer obj) 1344fill_vector (pointer vec, pointer obj)
1464{ 1345{
1465 int i; 1346 int i;
1466 int num = ivalue (vec) / 2 + ivalue (vec) % 2;
1467 1347
1468 for (i = 0; i < num; i++) 1348 for (i = 0; i < vec->object.vector.length; i++)
1469 { 1349 vecvalue (vec)[i] = obj;
1470 set_typeflag (vec + 1 + i, T_PAIR);
1471 setimmutable (vec + 1 + i);
1472 set_car (vec + 1 + i, obj);
1473 set_cdr (vec + 1 + i, obj);
1474 }
1475} 1350}
1476 1351
1477INTERFACE pointer 1352INTERFACE pointer
1478vector_elem (pointer vec, int ielem) 1353vector_elem (pointer vec, uint32_t ielem)
1479{ 1354{
1480 int n = ielem / 2; 1355 return vecvalue(vec)[ielem];
1481
1482 if (ielem % 2 == 0)
1483 return car (vec + 1 + n);
1484 else
1485 return cdr (vec + 1 + n);
1486} 1356}
1487 1357
1488INTERFACE void 1358INTERFACE void
1489set_vector_elem (pointer vec, int ielem, pointer a) 1359set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1490{ 1360{
1491 int n = ielem / 2; 1361 vecvalue(vec)[ielem] = a;
1492
1493 if (ielem % 2 == 0)
1494 set_car (vec + 1 + n, a);
1495 else
1496 set_cdr (vec + 1 + n, a);
1497} 1362}
1498 1363
1499/* get new symbol */ 1364/* get new symbol */
1500INTERFACE pointer 1365INTERFACE pointer
1501mk_symbol (SCHEME_P_ const char *name) 1366mk_symbol (SCHEME_P_ const char *name)
… …
1511 1376
1512INTERFACE pointer 1377INTERFACE pointer
1513gensym (SCHEME_P) 1378gensym (SCHEME_P)
1514{ 1379{
1515 pointer x; 1380 pointer x;
1516 char name[40];
1517 1381
1518 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1382 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1519 { 1383 {
1520 strcpy (name, "gensym-"); 1384 char name[40] = "gensym-";
1521 xnum (name + 7, SCHEME_V->gensym_cnt); 1385 xnum (name + 7, SCHEME_V->gensym_cnt);
1522 1386
1523 /* first check oblist */ 1387 /* first check oblist */
1524 x = oblist_find_by_name (SCHEME_A_ name); 1388 x = oblist_find_by_name (SCHEME_A_ name);
1525 1389
1526 if (x != NIL) 1390 if (x == NIL)
1527 continue;
1528 else
1529 { 1391 {
1530 x = oblist_add_by_name (SCHEME_A_ name); 1392 x = oblist_add_by_name (SCHEME_A_ name);
1531 return x; 1393 return x;
1532 } 1394 }
1533 } 1395 }
… …
1542 char c, *p; 1404 char c, *p;
1543 int has_dec_point = 0; 1405 int has_dec_point = 0;
1544 int has_fp_exp = 0; 1406 int has_fp_exp = 0;
1545 1407
1546#if USE_COLON_HOOK 1408#if USE_COLON_HOOK
1547
1548 if ((p = strstr (q, "::")) != 0) 1409 if ((p = strstr (q, "::")) != 0)
1549 { 1410 {
1550 *p = 0; 1411 *p = 0;
1551 return cons (SCHEME_V->COLON_HOOK, 1412 return cons (SCHEME_V->COLON_HOOK,
1552 cons (cons (SCHEME_V->QUOTE, 1413 cons (cons (SCHEME_V->QUOTE,
1553 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); 1414 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1554 } 1415 }
1555
1556#endif 1416#endif
1557 1417
1558 p = q; 1418 p = q;
1559 c = *p++; 1419 c = *p++;
1560 1420
… …
1609 1469
1610 return mk_symbol (SCHEME_A_ strlwr (q)); 1470 return mk_symbol (SCHEME_A_ strlwr (q));
1611 } 1471 }
1612 } 1472 }
1613 1473
1614#if USE_FLOAT 1474#if USE_REAL
1615 if (has_dec_point) 1475 if (has_dec_point)
1616 return mk_real (SCHEME_A_ atof (q)); 1476 return mk_real (SCHEME_A_ atof (q));
1617#endif 1477#endif
1618 1478
1619 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1479 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
… …
1628 1488
1629 if (!strcmp (name, "t")) 1489 if (!strcmp (name, "t"))
1630 return S_T; 1490 return S_T;
1631 else if (!strcmp (name, "f")) 1491 else if (!strcmp (name, "f"))
1632 return S_F; 1492 return S_F;
1633 else if (*name == 'o') /* #o (octal) */
1634 {
1635 x = strtol (name + 1, 0, 8);
1636 return mk_integer (SCHEME_A_ x);
1637 }
1638 else if (*name == 'd') /* #d (decimal) */
1639 {
1640 x = strtol (name + 1, 0, 10);
1641 return mk_integer (SCHEME_A_ x);
1642 }
1643 else if (*name == 'x') /* #x (hex) */
1644 {
1645 x = strtol (name + 1, 0, 16);
1646 return mk_integer (SCHEME_A_ x);
1647 }
1648 else if (*name == 'b') /* #b (binary) */
1649 {
1650 x = binary_decode (name + 1);
1651 return mk_integer (SCHEME_A_ x);
1652 }
1653 else if (*name == '\\') /* #\w (character) */ 1493 else if (*name == '\\') /* #\w (character) */
1654 { 1494 {
1655 int c = 0; 1495 int c = 0;
1656 1496
1657 if (stricmp (name + 1, "space") == 0) 1497 if (stricmp (name + 1, "space") == 0)
… …
1684 return NIL; 1524 return NIL;
1685 1525
1686 return mk_character (SCHEME_A_ c); 1526 return mk_character (SCHEME_A_ c);
1687 } 1527 }
1688 else 1528 else
1529 {
1530 /* identify base by string index */
1531 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1532 char *base = strchr (baseidx, *name);
1533
1534 if (base)
1535 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1536
1689 return NIL; 1537 return NIL;
1538 }
1690} 1539}
1691 1540
1692/* ========== garbage collector ========== */ 1541/* ========== garbage collector ========== */
1693 1542
1694/*-- 1543/*--
… …
1707 setmark (p); 1556 setmark (p);
1708 1557
1709 if (is_vector (p)) 1558 if (is_vector (p))
1710 { 1559 {
1711 int i; 1560 int i;
1712 int num = ivalue_unchecked (p) / 2 + ivalue_unchecked (p) % 2;
1713 1561
1714 for (i = 0; i < num; i++) 1562 for (i = 0; i < p->object.vector.length; i++)
1715 { 1563 mark (vecvalue (p)[i]);
1716 /* Vector cells will be treated like ordinary cells */
1717 mark (p + 1 + i);
1718 }
1719 } 1564 }
1720 1565
1721 if (is_atom (p)) 1566 if (is_atom (p))
1722 goto E6; 1567 goto E6;
1723 1568
… …
1843static void 1688static void
1844finalize_cell (SCHEME_P_ pointer a) 1689finalize_cell (SCHEME_P_ pointer a)
1845{ 1690{
1846 if (is_string (a)) 1691 if (is_string (a))
1847 free (strvalue (a)); 1692 free (strvalue (a));
1693 else if (is_vector (a))
1694 free (vecvalue (a));
1848#if USE_PORTS 1695#if USE_PORTS
1849 else if (is_port (a)) 1696 else if (is_port (a))
1850 { 1697 {
1851 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1698 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1852 port_close (SCHEME_A_ a, port_input | port_output); 1699 port_close (SCHEME_A_ a, port_input | port_output);
… …
2679 2526
2680 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2527 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2681 { 2528 {
2682 if (num_is_integer (l)) 2529 if (num_is_integer (l))
2683 xnum (p, ivalue_unchecked (l)); 2530 xnum (p, ivalue_unchecked (l));
2684#if USE_FLOAT 2531#if USE_REAL
2685 else 2532 else
2686 { 2533 {
2687 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2534 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2688 /* r5rs says there must be a '.' (unless 'e'?) */ 2535 /* r5rs says there must be a '.' (unless 'e'?) */
2689 f = strcspn (p, ".e"); 2536 f = strcspn (p, ".e");
… …
2985#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) 2832#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2986 2833
2987static int 2834static int
2988hash_fn (const char *key, int table_size) 2835hash_fn (const char *key, int table_size)
2989{ 2836{
2990 unsigned int hashed = 0; 2837 const unsigned char *p = key;
2991 const char *c; 2838 uint32_t hash = 2166136261;
2992 int bits_per_int = sizeof (unsigned int) * 8;
2993 2839
2994 for (c = key; *c; c++) 2840 while (*p)
2995 { 2841 hash = (hash ^ *p++) * 16777619;
2996 /* letters have about 5 bits in them */
2997 hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
2998 hashed ^= *c;
2999 }
3000 2842
3001 return hashed % table_size; 2843 return hash % table_size;
3002} 2844}
3003#endif 2845#endif
3004 2846
3005#ifndef USE_ALIST_ENV 2847#ifndef USE_ALIST_ENV
3006 2848
… …
3032{ 2874{
3033 pointer slot = immutable_cons (variable, value); 2875 pointer slot = immutable_cons (variable, value);
3034 2876
3035 if (is_vector (car (env))) 2877 if (is_vector (car (env)))
3036 { 2878 {
3037 int location = hash_fn (symname (variable), ivalue_unchecked (car (env))); 2879 int location = hash_fn (symname (variable), veclength (car (env)));
3038 2880
3039 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2881 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
3040 } 2882 }
3041 else 2883 else
3042 set_car (env, immutable_cons (slot, car (env))); 2884 set_car (env, immutable_cons (slot, car (env)));
… …
3050 2892
3051 for (x = env; x != NIL; x = cdr (x)) 2893 for (x = env; x != NIL; x = cdr (x))
3052 { 2894 {
3053 if (is_vector (car (x))) 2895 if (is_vector (car (x)))
3054 { 2896 {
3055 location = hash_fn (symname (hdl), ivalue_unchecked (car (x))); 2897 location = hash_fn (symname (hdl), veclength (car (x)));
3056 y = vector_elem (car (x), location); 2898 y = vector_elem (car (x), location);
3057 } 2899 }
3058 else 2900 else
3059 y = car (x); 2901 y = car (x);
3060 2902
… …
3170#if USE_ERROR_HOOK 3012#if USE_ERROR_HOOK
3171 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 3013 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3172 3014
3173 if (x != NIL) 3015 if (x != NIL)
3174 { 3016 {
3175 if (a) 3017 pointer code = a
3176 SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); 3018 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3177 else 3019 : NIL;
3178 SCHEME_V->code = NIL;
3179 3020
3180 SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); 3021 code = cons (mk_string (SCHEME_A_ s), code);
3181 setimmutable (car (SCHEME_V->code)); 3022 setimmutable (car (code));
3182 SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); 3023 SCHEME_V->code = cons (slot_value_in_env (x), code);
3183 SCHEME_V->op = OP_EVAL; 3024 SCHEME_V->op = OP_EVAL;
3184 3025
3185 return S_T; 3026 return S_T;
3186 } 3027 }
3187#endif 3028#endif
… …
3478 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); 3319 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3479 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); 3320 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3480 s_goto (OP_READ_INTERNAL); 3321 s_goto (OP_READ_INTERNAL);
3481 3322
3482 case OP_T1LVL: /* top level */ 3323 case OP_T1LVL: /* top level */
3483 SCHEME_V->code = SCHEME_V->value; 3324 SCHEME_V->code = SCHEME_V->value;
3484 SCHEME_V->inport = SCHEME_V->save_inport; 3325 SCHEME_V->inport = SCHEME_V->save_inport;
3485 s_goto (OP_EVAL); 3326 s_goto (OP_EVAL);
3486 3327
3487 case OP_READ_INTERNAL: /* internal read */ 3328 case OP_READ_INTERNAL: /* internal read */
3488 SCHEME_V->tok = token (SCHEME_A); 3329 SCHEME_V->tok = token (SCHEME_A);
… …
3538 else 3379 else
3539 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3380 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3540 } 3381 }
3541 else if (is_pair (SCHEME_V->code)) 3382 else if (is_pair (SCHEME_V->code))
3542 { 3383 {
3384 x = car (SCHEME_V->code);
3385
3543 if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ 3386 if (is_syntax (x)) /* SYNTAX */
3544 { 3387 {
3545 SCHEME_V->code = cdr (SCHEME_V->code); 3388 SCHEME_V->code = cdr (SCHEME_V->code);
3546 s_goto (syntaxnum (x)); 3389 s_goto (syntaxnum (x));
3547 } 3390 }
3548 else /* first, eval top element and eval arguments */ 3391 else /* first, eval top element and eval arguments */
3549 { 3392 {
3550 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); 3393 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
3551 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3394 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3552 SCHEME_V->code = car (SCHEME_V->code); 3395 SCHEME_V->code = x;
3553 s_goto (OP_EVAL); 3396 s_goto (OP_EVAL);
3554 } 3397 }
3555 } 3398 }
3556 else 3399 else
3557 s_return (SCHEME_V->code); 3400 s_return (SCHEME_V->code);
… …
4115 SCHEME_V->code = car (SCHEME_V->args); 3958 SCHEME_V->code = car (SCHEME_V->args);
4116 s_goto (OP_EVAL); 3959 s_goto (OP_EVAL);
4117 3960
4118 case OP_CONTINUATION: /* call-with-current-continuation */ 3961 case OP_CONTINUATION: /* call-with-current-continuation */
4119 SCHEME_V->code = car (SCHEME_V->args); 3962 SCHEME_V->code = car (SCHEME_V->args);
4120 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL); 3963 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
4121 s_goto (OP_APPLY); 3964 s_goto (OP_APPLY);
4122 } 3965 }
4123 3966
4124 return S_T; 3967 return S_T;
4125} 3968}
… …
4633 4476
4634 s_return (vec); 4477 s_return (vec);
4635 } 4478 }
4636 4479
4637 case OP_VECLEN: /* vector-length */ 4480 case OP_VECLEN: /* vector-length */
4638 s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4481 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4639 4482
4640 case OP_VECREF: /* vector-ref */ 4483 case OP_VECREF: /* vector-ref */
4641 { 4484 {
4642 int index; 4485 int index;
4643 4486
4644 index = ivalue (cadr (SCHEME_V->args)); 4487 index = ivalue (cadr (SCHEME_V->args));
4645 4488
4646 if (index >= ivalue (car (SCHEME_V->args))) 4489 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4647 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4490 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4648 4491
4649 s_return (vector_elem (car (SCHEME_V->args), index)); 4492 s_return (vector_elem (car (SCHEME_V->args), index));
4650 } 4493 }
4651 4494
… …
4656 if (is_immutable (car (SCHEME_V->args))) 4499 if (is_immutable (car (SCHEME_V->args)))
4657 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4500 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4658 4501
4659 index = ivalue (cadr (SCHEME_V->args)); 4502 index = ivalue (cadr (SCHEME_V->args));
4660 4503
4661 if (index >= ivalue (car (SCHEME_V->args))) 4504 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4662 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4505 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4663 4506
4664 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4507 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4665 s_return (car (SCHEME_V->args)); 4508 s_return (car (SCHEME_V->args));
4666 } 4509 }
… …
5509 5352
5510 case OP_PVECFROM: 5353 case OP_PVECFROM:
5511 { 5354 {
5512 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5355 int i = ivalue_unchecked (cdr (SCHEME_V->args));
5513 pointer vec = car (SCHEME_V->args); 5356 pointer vec = car (SCHEME_V->args);
5514 int len = ivalue_unchecked (vec); 5357 int len = veclength (vec);
5515 5358
5516 if (i == len) 5359 if (i == len)
5517 { 5360 {
5518 putstr (SCHEME_A_ ")"); 5361 putstr (SCHEME_A_ ")");
5519 s_return (S_T); 5362 s_return (S_T);
… …
5690 5533
5691 for (;;) 5534 for (;;)
5692 { 5535 {
5693 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5536 op_code_info *pcd = dispatch_table + SCHEME_V->op;
5694 5537
5538#if USE_ERROR_CHECKING
5695 if (pcd->name) /* if built-in function, check arguments */ 5539 if (pcd->name) /* if built-in function, check arguments */
5696 { 5540 {
5697#if USE_ERROR_CHECKING 5541 int ok = 1;
5698 char msg[STRBUFFSIZE]; 5542 char msg[STRBUFFSIZE];
5699 int ok = 1;
5700 int n = list_length (SCHEME_A_ SCHEME_V->args); 5543 int n = list_length (SCHEME_A_ SCHEME_V->args);
5701 5544
5702 /* Check number of arguments */ 5545 /* Check number of arguments */
5703 if (n < pcd->min_arity) 5546 if (n < pcd->min_arity)
5704 { 5547 {
… …
5711 { 5554 {
5712 ok = 0; 5555 ok = 0;
5713 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5556 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5714 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5557 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5715 } 5558 }
5716#endif
5717 5559
5718 if (ok) 5560 if (ok)
5719 { 5561 {
5720 if (pcd->arg_tests_encoding && USE_ERROR_CHECKING) 5562 if (pcd->arg_tests_encoding)
5721 { 5563 {
5722 int i = 0; 5564 int i = 0;
5723 int j; 5565 int j;
5724 const char *t = pcd->arg_tests_encoding; 5566 const char *t = pcd->arg_tests_encoding;
5725 pointer arglist = SCHEME_V->args; 5567 pointer arglist = SCHEME_V->args;
… …
5763 return; 5605 return;
5764 5606
5765 pcd = dispatch_table + SCHEME_V->op; 5607 pcd = dispatch_table + SCHEME_V->op;
5766 } 5608 }
5767 } 5609 }
5610#endif
5768 5611
5769 ok_to_freely_gc (SCHEME_A); 5612 ok_to_freely_gc (SCHEME_A);
5770 5613
5771 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5614 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)
5772 return; 5615 return;
5773 5616
5774#if USE_ERROR_CHECKING 5617 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5775 if (SCHEME_V->no_memory)
5776 { 5618 {
5777 xwrstr ("No memory!\n"); 5619 xwrstr ("No memory!\n");
5778 return; 5620 return;
5779 } 5621 }
5780#endif
5781 } 5622 }
5782} 5623}
5783 5624
5784/* ========== Initialization of internal keywords ========== */ 5625/* ========== Initialization of internal keywords ========== */
5785 5626
… …
5945 set_cdr (S_T, S_T); 5786 set_cdr (S_T, S_T);
5946 /* init F */ 5787 /* init F */
5947 set_typeflag (S_F, T_ATOM | T_MARK); 5788 set_typeflag (S_F, T_ATOM | T_MARK);
5948 set_car (S_F, S_F); 5789 set_car (S_F, S_F);
5949 set_cdr (S_F, S_F); 5790 set_cdr (S_F, S_F);
5791 /* init EOF_OBJ */
5792 set_typeflag (S_EOF, T_ATOM | T_MARK);
5793 set_car (S_EOF, S_EOF);
5794 set_cdr (S_EOF, S_EOF);
5950 /* init sink */ 5795 /* init sink */
5951 set_typeflag (S_SINK, T_PAIR | T_MARK); 5796 set_typeflag (S_SINK, T_PAIR | T_MARK);
5952 set_car (S_SINK, NIL); 5797 set_car (S_SINK, NIL);
5798
5953 /* init c_nest */ 5799 /* init c_nest */
5954 SCHEME_V->c_nest = NIL; 5800 SCHEME_V->c_nest = NIL;
5955 5801
5956 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5802 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5957 /* init global_env */ 5803 /* init global_env */
… …
5975 for (i = 0; i < n; i++) 5821 for (i = 0; i < n; i++)
5976 if (dispatch_table[i].name != 0) 5822 if (dispatch_table[i].name != 0)
5977 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5823 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5978 5824
5979 /* initialization of global pointers to special symbols */ 5825 /* initialization of global pointers to special symbols */
5980 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5826 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5981 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5827 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5982 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5828 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5983 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); 5829 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5984 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); 5830 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5985 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); 5831 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5986 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); 5832 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*");
5987 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); 5833 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*");
5988 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); 5834 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*");
5989 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); 5835 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");
5990 5836
5991 return !SCHEME_V->no_memory; 5837 return !SCHEME_V->no_memory;
5992} 5838}
5993 5839
… …
6240 6086
6241/* ========== Main ========== */ 6087/* ========== Main ========== */
6242 6088
6243#if STANDALONE 6089#if STANDALONE
6244 6090
6245# if defined(__APPLE__) && !defined (OSX)
6246int
6247main ()
6248{
6249 extern MacTS_main (int argc, char **argv);
6250 char **argv;
6251 int argc = ccommand (&argv);
6252
6253 MacTS_main (argc, argv);
6254 return 0;
6255}
6256
6257int
6258MacTS_main (int argc, char **argv)
6259{
6260# else
6261int 6091int
6262main (int argc, char **argv) 6092main (int argc, char **argv)
6263{ 6093{
6264# endif
6265# if USE_MULTIPLICITY 6094# if USE_MULTIPLICITY
6266 scheme ssc; 6095 scheme ssc;
6267 scheme *const SCHEME_V = &ssc; 6096 scheme *const SCHEME_V = &ssc;
6268# else 6097# else
6269# endif 6098# endif

Diff Legend

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