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.10 by root, Thu Nov 26 00:03:19 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.
… …
60#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 65#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
61#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 66#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
62#define S_SINK (&SCHEME_V->xsink) 67#define S_SINK (&SCHEME_V->xsink)
63#define S_EOF (&SCHEME_V->xEOF_OBJ) 68#define S_EOF (&SCHEME_V->xEOF_OBJ)
64 69
70/* should use libecb */
71#if __GNUC__ >= 4
72# define ecb_expect(expr,value) __builtin_expect ((expr),(value))
73# define ecb_expect_false(expr) ecb_expect (!!(expr), 0)
74# define ecb_expect_true(expr) ecb_expect (!!(expr), 1)
75#endif
76
65#if !USE_MULTIPLICITY 77#if !USE_MULTIPLICITY
66static scheme sc; 78static scheme sc;
67#endif 79#endif
68 80
69static void 81static void
… …
128 c += 'a' - 'A'; 140 c += 'a' - 'A';
129 141
130 return c; 142 return c;
131} 143}
132 144
145static int
146xisdigit (char c)
147{
148 return c >= '0' && c <= '9';
149}
150
151#define toupper(c) xtoupper (c)
152#define tolower(c) xtolower (c)
153#define isdigit(c) xisdigit (c)
154
133#if USE_STRLWR 155#if USE_STRLWR
134static const char * 156static const char *
135strlwr (char *s) 157strlwr (char *s)
136{ 158{
137 const char *p = s; 159 const char *p = s;
… …
146} 168}
147#endif 169#endif
148 170
149#define stricmp(a,b) strcmp (a, b) 171#define stricmp(a,b) strcmp (a, b)
150#define strlwr(s) (s) 172#define strlwr(s) (s)
151#define toupper(c) xtoupper(c)
152#define tolower(c) xtolower(c)
153 173
154#ifndef prompt 174#ifndef prompt
155# define prompt "ts> " 175# define prompt "ts> "
156#endif 176#endif
157 177
… …
236is_vector (pointer p) 256is_vector (pointer p)
237{ 257{
238 return type (p) == T_VECTOR; 258 return type (p) == T_VECTOR;
239} 259}
240 260
261#define vecvalue(p) ((p)->object.vector.vvalue)
262#define veclength(p) ((p)->object.vector.length)
241INTERFACE void fill_vector (pointer vec, pointer obj); 263INTERFACE void fill_vector (pointer vec, pointer obj);
264INTERFACE uint32_t vector_length (pointer vec);
242INTERFACE pointer vector_elem (pointer vec, int ielem); 265INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
243INTERFACE void set_vector_elem (pointer vec, int ielem, pointer a); 266INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
267
268INTERFACE uint32_t
269vector_length (pointer vec)
270{
271 return vec->object.vector.length;
272}
244 273
245INTERFACE INLINE int 274INTERFACE INLINE int
246is_number (pointer p) 275is_number (pointer p)
247{ 276{
248 return type (p) == T_NUMBER; 277 return type (p) == T_NUMBER;
… …
307{ 336{
308 return num_get_rvalue (p->object.number); 337 return num_get_rvalue (p->object.number);
309} 338}
310 339
311#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 340#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
312#if USE_FLOAT 341#if USE_REAL
313# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 342# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
314# define set_num_integer(p) (p)->object.number.is_fixnum=1; 343# define set_num_integer(p) (p)->object.number.is_fixnum=1;
315# define set_num_real(p) (p)->object.number.is_fixnum=0; 344# define set_num_real(p) (p)->object.number.is_fixnum=0;
316#else 345#else
317# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 346# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
… …
479 return type (p) == T_ENVIRONMENT; 508 return type (p) == T_ENVIRONMENT;
480} 509}
481 510
482#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 511#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
483 512
484#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
485#define is_atom(p) (typeflag (p) & T_ATOM) 513#define is_atom(p) (typeflag (p) & T_ATOM)
486#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 514#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
487#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 515#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
488 516
489#define is_mark(p) (typeflag (p) & T_MARK) 517#define is_mark(p) (typeflag (p) & T_MARK)
490#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 518#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
491#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 519#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 520
504INTERFACE INLINE int 521INTERFACE INLINE int
505is_immutable (pointer p) 522is_immutable (pointer p)
506{ 523{
507 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 524 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
611static int file_push (SCHEME_P_ const char *fname); 628static int file_push (SCHEME_P_ const char *fname);
612static void file_pop (SCHEME_P); 629static void file_pop (SCHEME_P);
613static int file_interactive (SCHEME_P); 630static int file_interactive (SCHEME_P);
614static INLINE int is_one_of (char *s, int c); 631static INLINE int is_one_of (char *s, int c);
615static int alloc_cellseg (SCHEME_P_ int n); 632static 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); 633static 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); 634static void finalize_cell (SCHEME_P_ pointer a);
622static int count_consecutive_cells (pointer x, int needed); 635static int count_consecutive_cells (pointer x, int needed);
623static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 636static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
624static pointer mk_number (SCHEME_P_ const num n); 637static pointer mk_number (SCHEME_P_ const num n);
625static char *store_string (SCHEME_P_ int len, const char *str, char fill); 638static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
626static pointer mk_vector (SCHEME_P_ int len); 639static pointer mk_vector (SCHEME_P_ uint32_t len);
627static pointer mk_atom (SCHEME_P_ char *q); 640static pointer mk_atom (SCHEME_P_ char *q);
628static pointer mk_sharp_const (SCHEME_P_ char *name); 641static pointer mk_sharp_const (SCHEME_P_ char *name);
629 642
630#if USE_PORTS 643#if USE_PORTS
631static pointer mk_port (SCHEME_P_ port *p); 644static pointer mk_port (SCHEME_P_ port *p);
… …
871#endif 884#endif
872 885
873static int 886static int
874is_zero_rvalue (RVALUE x) 887is_zero_rvalue (RVALUE x)
875{ 888{
876#if USE_FLOAT 889#if USE_REAL
877 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 890 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
878#else 891#else
879 return x == 0; 892 return x == 0;
880#endif 893#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} 894}
897 895
898/* allocate new cell segment */ 896/* allocate new cell segment */
899static int 897static int
900alloc_cellseg (SCHEME_P_ int n) 898alloc_cellseg (SCHEME_P_ int n)
… …
974 972
975/* get new cell. parameter a, b is marked by gc. */ 973/* get new cell. parameter a, b is marked by gc. */
976static INLINE pointer 974static INLINE pointer
977get_cell_x (SCHEME_P_ pointer a, pointer b) 975get_cell_x (SCHEME_P_ pointer a, pointer b)
978{ 976{
979 if (SCHEME_V->free_cell == NIL) 977 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
980 { 978 {
981 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 979 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
982 return S_SINK; 980 return S_SINK;
983 981
984 if (SCHEME_V->free_cell == NIL) 982 if (SCHEME_V->free_cell == NIL)
… …
1008 --SCHEME_V->fcells; 1006 --SCHEME_V->fcells;
1009 return x; 1007 return x;
1010 } 1008 }
1011} 1009}
1012 1010
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 - 1011/* To retain recent allocs before interpreter knows about them -
1124 Tehom */ 1012 Tehom */
1125 1013
1126static void 1014static void
1127push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 1015push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
… …
1150 1038
1151 return cell; 1039 return cell;
1152} 1040}
1153 1041
1154static pointer 1042static pointer
1155get_vector_object (SCHEME_P_ int len, pointer init) 1043get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1156{ 1044{
1157 pointer cells = get_consecutive_cells (SCHEME_A_ len / 2 + len % 2 + 1); 1045 pointer v = get_cell_x (SCHEME_A_ 0, 0);
1046 pointer *e = malloc (len * sizeof (pointer));
1158 1047
1159#if USE_ERROR_CHECKING 1048 if (!e && USE_ERROR_CHECKING)
1160 if (SCHEME_V->no_memory)
1161 return S_SINK; 1049 return S_SINK;
1162#endif
1163 1050
1164 /* Record it as a vector so that gc understands it. */ 1051 /* Record it as a vector so that gc understands it. */
1165 set_typeflag (cells, T_VECTOR | T_ATOM); 1052 set_typeflag (v, T_VECTOR | T_ATOM);
1166 ivalue_unchecked (cells) = len; 1053
1167 set_num_integer (cells); 1054 v->object.vector.vvalue = e;
1055 v->object.vector.length = len;
1168 fill_vector (cells, init); 1056 fill_vector (v, init);
1169 push_recent_alloc (SCHEME_A_ cells, NIL); 1057 push_recent_alloc (SCHEME_A_ v, NIL);
1170 1058
1171 return cells; 1059 return v;
1172} 1060}
1173 1061
1174static INLINE void 1062static INLINE void
1175ok_to_freely_gc (SCHEME_P) 1063ok_to_freely_gc (SCHEME_P)
1176{ 1064{
… …
1212 if (immutable) 1100 if (immutable)
1213 setimmutable (x); 1101 setimmutable (x);
1214 1102
1215 set_car (x, a); 1103 set_car (x, a);
1216 set_cdr (x, b); 1104 set_cdr (x, b);
1105
1217 return x; 1106 return x;
1218} 1107}
1219 1108
1220/* ========== oblist implementation ========== */ 1109/* ========== oblist implementation ========== */
1221 1110
… …
1237 1126
1238 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1127 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1239 set_typeflag (x, T_SYMBOL); 1128 set_typeflag (x, T_SYMBOL);
1240 setimmutable (car (x)); 1129 setimmutable (car (x));
1241 1130
1242 location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist)); 1131 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))); 1132 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1244 return x; 1133 return x;
1245} 1134}
1246 1135
1247static INLINE pointer 1136static INLINE pointer
… …
1249{ 1138{
1250 int location; 1139 int location;
1251 pointer x; 1140 pointer x;
1252 char *s; 1141 char *s;
1253 1142
1254 location = hash_fn (name, ivalue_unchecked (SCHEME_V->oblist)); 1143 location = hash_fn (name, veclength (SCHEME_V->oblist));
1255 1144
1256 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1145 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1257 { 1146 {
1258 s = symname (car (x)); 1147 s = symname (car (x));
1259 1148
… …
1270{ 1159{
1271 int i; 1160 int i;
1272 pointer x; 1161 pointer x;
1273 pointer ob_list = NIL; 1162 pointer ob_list = NIL;
1274 1163
1275 for (i = 0; i < ivalue_unchecked (SCHEME_V->oblist); i++) 1164 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1276 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1165 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1277 ob_list = cons (x, ob_list); 1166 ob_list = cons (x, ob_list);
1278 1167
1279 return ob_list; 1168 return ob_list;
1280} 1169}
… …
1393 return mk_real (SCHEME_A_ num_get_rvalue (n)); 1282 return mk_real (SCHEME_A_ num_get_rvalue (n));
1394} 1283}
1395 1284
1396/* allocate name to string area */ 1285/* allocate name to string area */
1397static char * 1286static char *
1398store_string (SCHEME_P_ int len_str, const char *str, char fill) 1287store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
1399{ 1288{
1400 char *q = malloc (len_str + 1); 1289 char *q = malloc (len_str + 1);
1401 1290
1402 if (q == 0 && USE_ERROR_CHECKING) 1291 if (q == 0 && USE_ERROR_CHECKING)
1403 { 1292 {
… …
1422 } 1311 }
1423 1312
1424 return q; 1313 return q;
1425} 1314}
1426 1315
1427/* get new string */
1428INTERFACE pointer 1316INTERFACE pointer
1429mk_string (SCHEME_P_ const char *str) 1317mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1430{ 1318{
1431 return mk_counted_string (SCHEME_A_ str, strlen (str)); 1319 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1320
1321 set_typeflag (x, T_STRING | T_ATOM);
1322 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1323 strlength (x) = len;
1324 return x;
1432} 1325}
1433 1326
1434INTERFACE pointer 1327INTERFACE pointer
1435mk_counted_string (SCHEME_P_ const char *str, int len) 1328mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1436{ 1329{
1437 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1330 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1438 1331
1439 set_typeflag (x, T_STRING | T_ATOM); 1332 set_typeflag (x, T_STRING | T_ATOM);
1440 strvalue (x) = store_string (SCHEME_A_ len, str, 0); 1333 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1441 strlength (x) = len; 1334 strlength (x) = len;
1442 return x; 1335 return x;
1443} 1336}
1444 1337
1445INTERFACE pointer 1338INTERFACE pointer
1446mk_empty_string (SCHEME_P_ int len, char fill) 1339mk_string (SCHEME_P_ const char *str)
1447{ 1340{
1448 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1341 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} 1342}
1455 1343
1456INTERFACE pointer 1344INTERFACE pointer
1457mk_vector (SCHEME_P_ int len) 1345mk_vector (SCHEME_P_ uint32_t len)
1458{ 1346{
1459 return get_vector_object (SCHEME_A_ len, NIL); 1347 return get_vector_object (SCHEME_A_ len, NIL);
1460} 1348}
1461 1349
1462INTERFACE void 1350INTERFACE void
1463fill_vector (pointer vec, pointer obj) 1351fill_vector (pointer vec, pointer obj)
1464{ 1352{
1465 int i; 1353 int i;
1466 int num = ivalue (vec) / 2 + ivalue (vec) % 2;
1467 1354
1468 for (i = 0; i < num; i++) 1355 for (i = 0; i < vec->object.vector.length; i++)
1469 { 1356 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} 1357}
1476 1358
1477INTERFACE pointer 1359INTERFACE pointer
1478vector_elem (pointer vec, int ielem) 1360vector_elem (pointer vec, uint32_t ielem)
1479{ 1361{
1480 int n = ielem / 2; 1362 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} 1363}
1487 1364
1488INTERFACE void 1365INTERFACE void
1489set_vector_elem (pointer vec, int ielem, pointer a) 1366set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1490{ 1367{
1491 int n = ielem / 2; 1368 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} 1369}
1498 1370
1499/* get new symbol */ 1371/* get new symbol */
1500INTERFACE pointer 1372INTERFACE pointer
1501mk_symbol (SCHEME_P_ const char *name) 1373mk_symbol (SCHEME_P_ const char *name)
… …
1511 1383
1512INTERFACE pointer 1384INTERFACE pointer
1513gensym (SCHEME_P) 1385gensym (SCHEME_P)
1514{ 1386{
1515 pointer x; 1387 pointer x;
1516 char name[40];
1517 1388
1518 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1389 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1519 { 1390 {
1520 strcpy (name, "gensym-"); 1391 char name[40] = "gensym-";
1521 xnum (name + 7, SCHEME_V->gensym_cnt); 1392 xnum (name + 7, SCHEME_V->gensym_cnt);
1522 1393
1523 /* first check oblist */ 1394 /* first check oblist */
1524 x = oblist_find_by_name (SCHEME_A_ name); 1395 x = oblist_find_by_name (SCHEME_A_ name);
1525 1396
1526 if (x != NIL) 1397 if (x == NIL)
1527 continue;
1528 else
1529 { 1398 {
1530 x = oblist_add_by_name (SCHEME_A_ name); 1399 x = oblist_add_by_name (SCHEME_A_ name);
1531 return x; 1400 return x;
1532 } 1401 }
1533 } 1402 }
… …
1542 char c, *p; 1411 char c, *p;
1543 int has_dec_point = 0; 1412 int has_dec_point = 0;
1544 int has_fp_exp = 0; 1413 int has_fp_exp = 0;
1545 1414
1546#if USE_COLON_HOOK 1415#if USE_COLON_HOOK
1547
1548 if ((p = strstr (q, "::")) != 0) 1416 if ((p = strstr (q, "::")) != 0)
1549 { 1417 {
1550 *p = 0; 1418 *p = 0;
1551 return cons (SCHEME_V->COLON_HOOK, 1419 return cons (SCHEME_V->COLON_HOOK,
1552 cons (cons (SCHEME_V->QUOTE, 1420 cons (cons (SCHEME_V->QUOTE,
1553 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); 1421 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1554 } 1422 }
1555
1556#endif 1423#endif
1557 1424
1558 p = q; 1425 p = q;
1559 c = *p++; 1426 c = *p++;
1560 1427
… …
1609 1476
1610 return mk_symbol (SCHEME_A_ strlwr (q)); 1477 return mk_symbol (SCHEME_A_ strlwr (q));
1611 } 1478 }
1612 } 1479 }
1613 1480
1614#if USE_FLOAT 1481#if USE_REAL
1615 if (has_dec_point) 1482 if (has_dec_point)
1616 return mk_real (SCHEME_A_ atof (q)); 1483 return mk_real (SCHEME_A_ atof (q));
1617#endif 1484#endif
1618 1485
1619 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1486 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
… …
1621 1488
1622/* make constant */ 1489/* make constant */
1623static pointer 1490static pointer
1624mk_sharp_const (SCHEME_P_ char *name) 1491mk_sharp_const (SCHEME_P_ char *name)
1625{ 1492{
1626 long x;
1627 char tmp[STRBUFFSIZE];
1628
1629 if (!strcmp (name, "t")) 1493 if (!strcmp (name, "t"))
1630 return S_T; 1494 return S_T;
1631 else if (!strcmp (name, "f")) 1495 else if (!strcmp (name, "f"))
1632 return S_F; 1496 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) */ 1497 else if (*name == '\\') /* #\w (character) */
1654 { 1498 {
1655 int c = 0; 1499 int c;
1656 1500
1657 if (stricmp (name + 1, "space") == 0) 1501 if (stricmp (name + 1, "space") == 0)
1658 c = ' '; 1502 c = ' ';
1659 else if (stricmp (name + 1, "newline") == 0) 1503 else if (stricmp (name + 1, "newline") == 0)
1660 c = '\n'; 1504 c = '\n';
… …
1662 c = '\r'; 1506 c = '\r';
1663 else if (stricmp (name + 1, "tab") == 0) 1507 else if (stricmp (name + 1, "tab") == 0)
1664 c = '\t'; 1508 c = '\t';
1665 else if (name[1] == 'x' && name[2] != 0) 1509 else if (name[1] == 'x' && name[2] != 0)
1666 { 1510 {
1667 int c1 = strtol (name + 2, 0, 16); 1511 long c1 = strtol (name + 2, 0, 16);
1668 1512
1669 if (c1 <= UCHAR_MAX) 1513 if (0 <= c1 && c1 <= UCHAR_MAX)
1670 c = c1; 1514 c = c1;
1671 else 1515 else
1672 return NIL; 1516 return NIL;
1673 1517 }
1674#if USE_ASCII_NAMES 1518#if USE_ASCII_NAMES
1675 }
1676 else if (is_ascii_name (name + 1, &c)) 1519 else if (is_ascii_name (name + 1, &c))
1677 {
1678 /* nothing */ 1520 /* nothing */;
1679#endif 1521#endif
1680 }
1681 else if (name[2] == 0) 1522 else if (name[2] == 0)
1682 c = name[1]; 1523 c = name[1];
1683 else 1524 else
1684 return NIL; 1525 return NIL;
1685 1526
1686 return mk_character (SCHEME_A_ c); 1527 return mk_character (SCHEME_A_ c);
1687 } 1528 }
1688 else 1529 else
1530 {
1531 /* identify base by string index */
1532 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1533 char *base = strchr (baseidx, *name);
1534
1535 if (base)
1536 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1537
1689 return NIL; 1538 return NIL;
1539 }
1690} 1540}
1691 1541
1692/* ========== garbage collector ========== */ 1542/* ========== garbage collector ========== */
1693 1543
1694/*-- 1544/*--
1695 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1545 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1696 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1546 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1697 * for marking. 1547 * for marking.
1548 *
1549 * The exception is vectors - vectors are currently marked recursively,
1550 * which is inherited form tinyscheme and could be fixed by having another
1551 * word of context in the vector
1698 */ 1552 */
1699static void 1553static void
1700mark (pointer a) 1554mark (pointer a)
1701{ 1555{
1702 pointer t, q, p; 1556 pointer t, q, p;
… …
1704 t = 0; 1558 t = 0;
1705 p = a; 1559 p = a;
1706E2: 1560E2:
1707 setmark (p); 1561 setmark (p);
1708 1562
1709 if (is_vector (p)) 1563 if (ecb_expect_false (is_vector (p)))
1710 { 1564 {
1711 int i; 1565 int i;
1712 int num = ivalue_unchecked (p) / 2 + ivalue_unchecked (p) % 2;
1713 1566
1714 for (i = 0; i < num; i++) 1567 for (i = 0; i < p->object.vector.length; i++)
1715 { 1568 mark (vecvalue (p)[i]);
1716 /* Vector cells will be treated like ordinary cells */
1717 mark (p + 1 + i);
1718 }
1719 } 1569 }
1720 1570
1721 if (is_atom (p)) 1571 if (is_atom (p))
1722 goto E6; 1572 goto E6;
1723 1573
… …
1841} 1691}
1842 1692
1843static void 1693static void
1844finalize_cell (SCHEME_P_ pointer a) 1694finalize_cell (SCHEME_P_ pointer a)
1845{ 1695{
1696 /* TODO, fast bitmap check? */
1846 if (is_string (a)) 1697 if (is_string (a))
1847 free (strvalue (a)); 1698 free (strvalue (a));
1699 else if (is_vector (a))
1700 free (vecvalue (a));
1848#if USE_PORTS 1701#if USE_PORTS
1849 else if (is_port (a)) 1702 else if (is_port (a))
1850 { 1703 {
1851 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1704 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1852 port_close (SCHEME_A_ a, port_input | port_output); 1705 port_close (SCHEME_A_ a, port_input | port_output);
… …
2679 2532
2680 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2533 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2681 { 2534 {
2682 if (num_is_integer (l)) 2535 if (num_is_integer (l))
2683 xnum (p, ivalue_unchecked (l)); 2536 xnum (p, ivalue_unchecked (l));
2684#if USE_FLOAT 2537#if USE_REAL
2685 else 2538 else
2686 { 2539 {
2687 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2540 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2688 /* r5rs says there must be a '.' (unless 'e'?) */ 2541 /* r5rs says there must be a '.' (unless 'e'?) */
2689 f = strcspn (p, ".e"); 2542 f = strcspn (p, ".e");
… …
2985#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) 2838#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2986 2839
2987static int 2840static int
2988hash_fn (const char *key, int table_size) 2841hash_fn (const char *key, int table_size)
2989{ 2842{
2990 unsigned int hashed = 0; 2843 const unsigned char *p = key;
2991 const char *c; 2844 uint32_t hash = 2166136261;
2992 int bits_per_int = sizeof (unsigned int) * 8;
2993 2845
2994 for (c = key; *c; c++) 2846 while (*p)
2995 { 2847 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 2848
3001 return hashed % table_size; 2849 return hash % table_size;
3002} 2850}
3003#endif 2851#endif
3004 2852
3005#ifndef USE_ALIST_ENV 2853#ifndef USE_ALIST_ENV
3006 2854
… …
3032{ 2880{
3033 pointer slot = immutable_cons (variable, value); 2881 pointer slot = immutable_cons (variable, value);
3034 2882
3035 if (is_vector (car (env))) 2883 if (is_vector (car (env)))
3036 { 2884 {
3037 int location = hash_fn (symname (variable), ivalue_unchecked (car (env))); 2885 int location = hash_fn (symname (variable), veclength (car (env)));
3038 2886
3039 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2887 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
3040 } 2888 }
3041 else 2889 else
3042 set_car (env, immutable_cons (slot, car (env))); 2890 set_car (env, immutable_cons (slot, car (env)));
… …
3050 2898
3051 for (x = env; x != NIL; x = cdr (x)) 2899 for (x = env; x != NIL; x = cdr (x))
3052 { 2900 {
3053 if (is_vector (car (x))) 2901 if (is_vector (car (x)))
3054 { 2902 {
3055 location = hash_fn (symname (hdl), ivalue_unchecked (car (x))); 2903 location = hash_fn (symname (hdl), veclength (car (x)));
3056 y = vector_elem (car (x), location); 2904 y = vector_elem (car (x), location);
3057 } 2905 }
3058 else 2906 else
3059 y = car (x); 2907 y = car (x);
3060 2908
… …
3170#if USE_ERROR_HOOK 3018#if USE_ERROR_HOOK
3171 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 3019 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3172 3020
3173 if (x != NIL) 3021 if (x != NIL)
3174 { 3022 {
3175 if (a) 3023 pointer code = a
3176 SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); 3024 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3177 else 3025 : NIL;
3178 SCHEME_V->code = NIL;
3179 3026
3180 SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); 3027 code = cons (mk_string (SCHEME_A_ s), code);
3181 setimmutable (car (SCHEME_V->code)); 3028 setimmutable (car (code));
3182 SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); 3029 SCHEME_V->code = cons (slot_value_in_env (x), code);
3183 SCHEME_V->op = OP_EVAL; 3030 SCHEME_V->op = OP_EVAL;
3184 3031
3185 return S_T; 3032 return S_T;
3186 } 3033 }
3187#endif 3034#endif
… …
3478 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); 3325 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3479 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); 3326 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3480 s_goto (OP_READ_INTERNAL); 3327 s_goto (OP_READ_INTERNAL);
3481 3328
3482 case OP_T1LVL: /* top level */ 3329 case OP_T1LVL: /* top level */
3483 SCHEME_V->code = SCHEME_V->value; 3330 SCHEME_V->code = SCHEME_V->value;
3484 SCHEME_V->inport = SCHEME_V->save_inport; 3331 SCHEME_V->inport = SCHEME_V->save_inport;
3485 s_goto (OP_EVAL); 3332 s_goto (OP_EVAL);
3486 3333
3487 case OP_READ_INTERNAL: /* internal read */ 3334 case OP_READ_INTERNAL: /* internal read */
3488 SCHEME_V->tok = token (SCHEME_A); 3335 SCHEME_V->tok = token (SCHEME_A);
… …
3538 else 3385 else
3539 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3386 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3540 } 3387 }
3541 else if (is_pair (SCHEME_V->code)) 3388 else if (is_pair (SCHEME_V->code))
3542 { 3389 {
3390 x = car (SCHEME_V->code);
3391
3543 if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ 3392 if (is_syntax (x)) /* SYNTAX */
3544 { 3393 {
3545 SCHEME_V->code = cdr (SCHEME_V->code); 3394 SCHEME_V->code = cdr (SCHEME_V->code);
3546 s_goto (syntaxnum (x)); 3395 s_goto (syntaxnum (x));
3547 } 3396 }
3548 else /* first, eval top element and eval arguments */ 3397 else /* first, eval top element and eval arguments */
3549 { 3398 {
3550 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); 3399 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)); */ 3400 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3552 SCHEME_V->code = car (SCHEME_V->code); 3401 SCHEME_V->code = x;
3553 s_goto (OP_EVAL); 3402 s_goto (OP_EVAL);
3554 } 3403 }
3555 } 3404 }
3556 else 3405 else
3557 s_return (SCHEME_V->code); 3406 s_return (SCHEME_V->code);
… …
4115 SCHEME_V->code = car (SCHEME_V->args); 3964 SCHEME_V->code = car (SCHEME_V->args);
4116 s_goto (OP_EVAL); 3965 s_goto (OP_EVAL);
4117 3966
4118 case OP_CONTINUATION: /* call-with-current-continuation */ 3967 case OP_CONTINUATION: /* call-with-current-continuation */
4119 SCHEME_V->code = car (SCHEME_V->args); 3968 SCHEME_V->code = car (SCHEME_V->args);
4120 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL); 3969 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
4121 s_goto (OP_APPLY); 3970 s_goto (OP_APPLY);
4122 } 3971 }
4123 3972
4124 return S_T; 3973 return S_T;
4125} 3974}
… …
4633 4482
4634 s_return (vec); 4483 s_return (vec);
4635 } 4484 }
4636 4485
4637 case OP_VECLEN: /* vector-length */ 4486 case OP_VECLEN: /* vector-length */
4638 s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4487 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4639 4488
4640 case OP_VECREF: /* vector-ref */ 4489 case OP_VECREF: /* vector-ref */
4641 { 4490 {
4642 int index; 4491 int index;
4643 4492
4644 index = ivalue (cadr (SCHEME_V->args)); 4493 index = ivalue (cadr (SCHEME_V->args));
4645 4494
4646 if (index >= ivalue (car (SCHEME_V->args))) 4495 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4647 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4496 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4648 4497
4649 s_return (vector_elem (car (SCHEME_V->args), index)); 4498 s_return (vector_elem (car (SCHEME_V->args), index));
4650 } 4499 }
4651 4500
… …
4656 if (is_immutable (car (SCHEME_V->args))) 4505 if (is_immutable (car (SCHEME_V->args)))
4657 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4506 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4658 4507
4659 index = ivalue (cadr (SCHEME_V->args)); 4508 index = ivalue (cadr (SCHEME_V->args));
4660 4509
4661 if (index >= ivalue (car (SCHEME_V->args))) 4510 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4662 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4511 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4663 4512
4664 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4513 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4665 s_return (car (SCHEME_V->args)); 4514 s_return (car (SCHEME_V->args));
4666 } 4515 }
… …
5509 5358
5510 case OP_PVECFROM: 5359 case OP_PVECFROM:
5511 { 5360 {
5512 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5361 int i = ivalue_unchecked (cdr (SCHEME_V->args));
5513 pointer vec = car (SCHEME_V->args); 5362 pointer vec = car (SCHEME_V->args);
5514 int len = ivalue_unchecked (vec); 5363 int len = veclength (vec);
5515 5364
5516 if (i == len) 5365 if (i == len)
5517 { 5366 {
5518 putstr (SCHEME_A_ ")"); 5367 putstr (SCHEME_A_ ")");
5519 s_return (S_T); 5368 s_return (S_T);
… …
5690 5539
5691 for (;;) 5540 for (;;)
5692 { 5541 {
5693 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5542 op_code_info *pcd = dispatch_table + SCHEME_V->op;
5694 5543
5544#if USE_ERROR_CHECKING
5695 if (pcd->name) /* if built-in function, check arguments */ 5545 if (pcd->name) /* if built-in function, check arguments */
5696 { 5546 {
5697#if USE_ERROR_CHECKING 5547 int ok = 1;
5698 char msg[STRBUFFSIZE]; 5548 char msg[STRBUFFSIZE];
5699 int ok = 1;
5700 int n = list_length (SCHEME_A_ SCHEME_V->args); 5549 int n = list_length (SCHEME_A_ SCHEME_V->args);
5701 5550
5702 /* Check number of arguments */ 5551 /* Check number of arguments */
5703 if (n < pcd->min_arity) 5552 if (ecb_expect_false (n < pcd->min_arity))
5704 { 5553 {
5705 ok = 0; 5554 ok = 0;
5706 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5555 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5707 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5556 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5708 } 5557 }
5709 5558 else if (ecb_excpect_false (n > pcd->max_arity))
5710 if (ok && n > pcd->max_arity)
5711 { 5559 {
5712 ok = 0; 5560 ok = 0;
5713 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5561 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5714 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5562 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5715 } 5563 }
5716#endif
5717 5564
5718 if (ok) 5565 if (ecb_expect_false (ok))
5719 { 5566 {
5720 if (pcd->arg_tests_encoding && USE_ERROR_CHECKING) 5567 if (pcd->arg_tests_encoding)
5721 { 5568 {
5722 int i = 0; 5569 int i = 0;
5723 int j; 5570 int j;
5724 const char *t = pcd->arg_tests_encoding; 5571 const char *t = pcd->arg_tests_encoding;
5725 pointer arglist = SCHEME_V->args; 5572 pointer arglist = SCHEME_V->args;
… …
5763 return; 5610 return;
5764 5611
5765 pcd = dispatch_table + SCHEME_V->op; 5612 pcd = dispatch_table + SCHEME_V->op;
5766 } 5613 }
5767 } 5614 }
5615#endif
5768 5616
5769 ok_to_freely_gc (SCHEME_A); 5617 ok_to_freely_gc (SCHEME_A);
5770 5618
5771 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5619 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5772 return; 5620 return;
5773 5621
5774#if USE_ERROR_CHECKING 5622 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5775 if (SCHEME_V->no_memory)
5776 { 5623 {
5777 xwrstr ("No memory!\n"); 5624 xwrstr ("No memory!\n");
5778 return; 5625 return;
5779 } 5626 }
5780#endif
5781 } 5627 }
5782} 5628}
5783 5629
5784/* ========== Initialization of internal keywords ========== */ 5630/* ========== Initialization of internal keywords ========== */
5785 5631
… …
5836 5682
5837 case 'd': 5683 case 'd':
5838 return OP_COND0; /* cond */ 5684 return OP_COND0; /* cond */
5839 5685
5840 case '*': 5686 case '*':
5841 return OP_LET0AST; /* let* */ 5687 return OP_LET0AST;/* let* */
5842 5688
5843 default: 5689 default:
5844 return OP_SET0; /* set! */ 5690 return OP_SET0; /* set! */
5845 } 5691 }
5846 5692
… …
5868 5714
5869 case 'f': 5715 case 'f':
5870 return OP_DEF0; /* define */ 5716 return OP_DEF0; /* define */
5871 5717
5872 default: 5718 default:
5873 return OP_LET0REC; /* letrec */ 5719 return OP_LET0REC;/* letrec */
5874 } 5720 }
5875 5721
5876 default: 5722 default:
5877 return OP_C0STREAM; /* cons-stream */ 5723 return OP_C0STREAM; /* cons-stream */
5878 } 5724 }
… …
5945 set_cdr (S_T, S_T); 5791 set_cdr (S_T, S_T);
5946 /* init F */ 5792 /* init F */
5947 set_typeflag (S_F, T_ATOM | T_MARK); 5793 set_typeflag (S_F, T_ATOM | T_MARK);
5948 set_car (S_F, S_F); 5794 set_car (S_F, S_F);
5949 set_cdr (S_F, S_F); 5795 set_cdr (S_F, S_F);
5796 /* init EOF_OBJ */
5797 set_typeflag (S_EOF, T_ATOM | T_MARK);
5798 set_car (S_EOF, S_EOF);
5799 set_cdr (S_EOF, S_EOF);
5950 /* init sink */ 5800 /* init sink */
5951 set_typeflag (S_SINK, T_PAIR | T_MARK); 5801 set_typeflag (S_SINK, T_PAIR | T_MARK);
5952 set_car (S_SINK, NIL); 5802 set_car (S_SINK, NIL);
5803
5953 /* init c_nest */ 5804 /* init c_nest */
5954 SCHEME_V->c_nest = NIL; 5805 SCHEME_V->c_nest = NIL;
5955 5806
5956 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5807 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5957 /* init global_env */ 5808 /* init global_env */
… …
5975 for (i = 0; i < n; i++) 5826 for (i = 0; i < n; i++)
5976 if (dispatch_table[i].name != 0) 5827 if (dispatch_table[i].name != 0)
5977 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5828 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5978 5829
5979 /* initialization of global pointers to special symbols */ 5830 /* initialization of global pointers to special symbols */
5980 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5831 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5981 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5832 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5982 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5833 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5983 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); 5834 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5984 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); 5835 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5985 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); 5836 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5986 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); 5837 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*");
5987 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); 5838 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*");
5988 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); 5839 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*");
5989 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); 5840 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");
5990 5841
5991 return !SCHEME_V->no_memory; 5842 return !SCHEME_V->no_memory;
5992} 5843}
5993 5844
… …
6240 6091
6241/* ========== Main ========== */ 6092/* ========== Main ========== */
6242 6093
6243#if STANDALONE 6094#if STANDALONE
6244 6095
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 6096int
6262main (int argc, char **argv) 6097main (int argc, char **argv)
6263{ 6098{
6264# endif
6265# if USE_MULTIPLICITY 6099# if USE_MULTIPLICITY
6266 scheme ssc; 6100 scheme ssc;
6267 scheme *const SCHEME_V = &ssc; 6101 scheme *const SCHEME_V = &ssc;
6268# else 6102# else
6269# endif 6103# endif

Diff Legend

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