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.4 by root, Wed Nov 25 10:49:29 2015 UTC vs.
Revision 1.9 by root, Wed Nov 25 22:39: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.
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);
242INTERFACE uint32_t vector_length (pointer vec); 257INTERFACE uint32_t vector_length (pointer vec);
243INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 258INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
244INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 259INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
245 260
314{ 329{
315 return num_get_rvalue (p->object.number); 330 return num_get_rvalue (p->object.number);
316} 331}
317 332
318#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 333#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
319#if USE_FLOAT 334#if USE_REAL
320# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 335# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
321# define set_num_integer(p) (p)->object.number.is_fixnum=1; 336# define set_num_integer(p) (p)->object.number.is_fixnum=1;
322# define set_num_real(p) (p)->object.number.is_fixnum=0; 337# define set_num_real(p) (p)->object.number.is_fixnum=0;
323#else 338#else
324# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 339# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
486 return type (p) == T_ENVIRONMENT; 501 return type (p) == T_ENVIRONMENT;
487} 502}
488 503
489#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 504#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
490 505
491#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
492#define is_atom(p) (typeflag (p) & T_ATOM) 506#define is_atom(p) (typeflag (p) & T_ATOM)
493#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 507#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
494#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 508#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
495 509
496#define is_mark(p) (typeflag (p) & T_MARK) 510#define is_mark(p) (typeflag (p) & T_MARK)
497#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 511#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
498#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 512#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
499
500#if 0
501static int
502is_atom(pointer p)
503{
504 if (!is_atom1(p) != !is_atom2(p))
505 printf ("atoms disagree %x\n", typeflag(p));
506
507 return is_atom2(p);
508}
509#endif
510 513
511INTERFACE INLINE int 514INTERFACE INLINE int
512is_immutable (pointer p) 515is_immutable (pointer p)
513{ 516{
514 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 517 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
618static int file_push (SCHEME_P_ const char *fname); 621static int file_push (SCHEME_P_ const char *fname);
619static void file_pop (SCHEME_P); 622static void file_pop (SCHEME_P);
620static int file_interactive (SCHEME_P); 623static int file_interactive (SCHEME_P);
621static INLINE int is_one_of (char *s, int c); 624static INLINE int is_one_of (char *s, int c);
622static int alloc_cellseg (SCHEME_P_ int n); 625static int alloc_cellseg (SCHEME_P_ int n);
623static long binary_decode (const char *s);
624static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 626static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
625static void finalize_cell (SCHEME_P_ pointer a); 627static void finalize_cell (SCHEME_P_ pointer a);
626static int count_consecutive_cells (pointer x, int needed); 628static int count_consecutive_cells (pointer x, int needed);
627static 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);
628static pointer mk_number (SCHEME_P_ const num n); 630static pointer mk_number (SCHEME_P_ const num n);
875#endif 877#endif
876 878
877static int 879static int
878is_zero_rvalue (RVALUE x) 880is_zero_rvalue (RVALUE x)
879{ 881{
880#if USE_FLOAT 882#if USE_REAL
881 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. */
882#else 884#else
883 return x == 0; 885 return x == 0;
884#endif 886#endif
885}
886
887static long
888binary_decode (const char *s)
889{
890 long x = 0;
891
892 while (*s != 0 && (*s == '1' || *s == '0'))
893 {
894 x <<= 1;
895 x += *s - '0';
896 s++;
897 }
898
899 return x;
900} 887}
901 888
902/* allocate new cell segment */ 889/* allocate new cell segment */
903static int 890static int
904alloc_cellseg (SCHEME_P_ int n) 891alloc_cellseg (SCHEME_P_ int n)
1132 1119
1133 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1120 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1134 set_typeflag (x, T_SYMBOL); 1121 set_typeflag (x, T_SYMBOL);
1135 setimmutable (car (x)); 1122 setimmutable (car (x));
1136 1123
1137 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1124 location = hash_fn (name, veclength (SCHEME_V->oblist));
1138 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)));
1139 return x; 1126 return x;
1140} 1127}
1141 1128
1142static INLINE pointer 1129static INLINE pointer
1144{ 1131{
1145 int location; 1132 int location;
1146 pointer x; 1133 pointer x;
1147 char *s; 1134 char *s;
1148 1135
1149 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1136 location = hash_fn (name, veclength (SCHEME_V->oblist));
1150 1137
1151 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))
1152 { 1139 {
1153 s = symname (car (x)); 1140 s = symname (car (x));
1154 1141
1165{ 1152{
1166 int i; 1153 int i;
1167 pointer x; 1154 pointer x;
1168 pointer ob_list = NIL; 1155 pointer ob_list = NIL;
1169 1156
1170 for (i = 0; i < vector_length (SCHEME_V->oblist); i++) 1157 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1171 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))
1172 ob_list = cons (x, ob_list); 1159 ob_list = cons (x, ob_list);
1173 1160
1174 return ob_list; 1161 return ob_list;
1175} 1162}
1317 } 1304 }
1318 1305
1319 return q; 1306 return q;
1320} 1307}
1321 1308
1322/* get new string */
1323INTERFACE pointer 1309INTERFACE pointer
1324mk_string (SCHEME_P_ const char *str) 1310mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1325{ 1311{
1326 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;
1327} 1318}
1328 1319
1329INTERFACE pointer 1320INTERFACE pointer
1330mk_counted_string (SCHEME_P_ const char *str, uint32_t len) 1321mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1331{ 1322{
1336 strlength (x) = len; 1327 strlength (x) = len;
1337 return x; 1328 return x;
1338} 1329}
1339 1330
1340INTERFACE pointer 1331INTERFACE pointer
1341mk_empty_string (SCHEME_P_ uint32_t len, char fill) 1332mk_string (SCHEME_P_ const char *str)
1342{ 1333{
1343 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1334 return mk_counted_string (SCHEME_A_ str, strlen (str));
1344
1345 set_typeflag (x, T_STRING | T_ATOM);
1346 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1347 strlength (x) = len;
1348 return x;
1349} 1335}
1350 1336
1351INTERFACE pointer 1337INTERFACE pointer
1352mk_vector (SCHEME_P_ uint32_t len) 1338mk_vector (SCHEME_P_ uint32_t len)
1353{ 1339{
1358fill_vector (pointer vec, pointer obj) 1344fill_vector (pointer vec, pointer obj)
1359{ 1345{
1360 int i; 1346 int i;
1361 1347
1362 for (i = 0; i < vec->object.vector.length; i++) 1348 for (i = 0; i < vec->object.vector.length; i++)
1363 vec->object.vector.vvalue[i] = obj; 1349 vecvalue (vec)[i] = obj;
1364} 1350}
1365 1351
1366INTERFACE pointer 1352INTERFACE pointer
1367vector_elem (pointer vec, uint32_t ielem) 1353vector_elem (pointer vec, uint32_t ielem)
1368{ 1354{
1369 return vec->object.vector.vvalue[ielem]; 1355 return vecvalue(vec)[ielem];
1370} 1356}
1371 1357
1372INTERFACE void 1358INTERFACE void
1373set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1359set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1374{ 1360{
1375 vec->object.vector.vvalue[ielem] = a; 1361 vecvalue(vec)[ielem] = a;
1376} 1362}
1377 1363
1378/* get new symbol */ 1364/* get new symbol */
1379INTERFACE pointer 1365INTERFACE pointer
1380mk_symbol (SCHEME_P_ const char *name) 1366mk_symbol (SCHEME_P_ const char *name)
1390 1376
1391INTERFACE pointer 1377INTERFACE pointer
1392gensym (SCHEME_P) 1378gensym (SCHEME_P)
1393{ 1379{
1394 pointer x; 1380 pointer x;
1395 char name[40];
1396 1381
1397 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1382 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1398 { 1383 {
1399 strcpy (name, "gensym-"); 1384 char name[40] = "gensym-";
1400 xnum (name + 7, SCHEME_V->gensym_cnt); 1385 xnum (name + 7, SCHEME_V->gensym_cnt);
1401 1386
1402 /* first check oblist */ 1387 /* first check oblist */
1403 x = oblist_find_by_name (SCHEME_A_ name); 1388 x = oblist_find_by_name (SCHEME_A_ name);
1404 1389
1405 if (x != NIL) 1390 if (x == NIL)
1406 continue;
1407 else
1408 { 1391 {
1409 x = oblist_add_by_name (SCHEME_A_ name); 1392 x = oblist_add_by_name (SCHEME_A_ name);
1410 return x; 1393 return x;
1411 } 1394 }
1412 } 1395 }
1421 char c, *p; 1404 char c, *p;
1422 int has_dec_point = 0; 1405 int has_dec_point = 0;
1423 int has_fp_exp = 0; 1406 int has_fp_exp = 0;
1424 1407
1425#if USE_COLON_HOOK 1408#if USE_COLON_HOOK
1426
1427 if ((p = strstr (q, "::")) != 0) 1409 if ((p = strstr (q, "::")) != 0)
1428 { 1410 {
1429 *p = 0; 1411 *p = 0;
1430 return cons (SCHEME_V->COLON_HOOK, 1412 return cons (SCHEME_V->COLON_HOOK,
1431 cons (cons (SCHEME_V->QUOTE, 1413 cons (cons (SCHEME_V->QUOTE,
1432 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)));
1433 } 1415 }
1434
1435#endif 1416#endif
1436 1417
1437 p = q; 1418 p = q;
1438 c = *p++; 1419 c = *p++;
1439 1420
1488 1469
1489 return mk_symbol (SCHEME_A_ strlwr (q)); 1470 return mk_symbol (SCHEME_A_ strlwr (q));
1490 } 1471 }
1491 } 1472 }
1492 1473
1493#if USE_FLOAT 1474#if USE_REAL
1494 if (has_dec_point) 1475 if (has_dec_point)
1495 return mk_real (SCHEME_A_ atof (q)); 1476 return mk_real (SCHEME_A_ atof (q));
1496#endif 1477#endif
1497 1478
1498 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1479 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1500 1481
1501/* make constant */ 1482/* make constant */
1502static pointer 1483static pointer
1503mk_sharp_const (SCHEME_P_ char *name) 1484mk_sharp_const (SCHEME_P_ char *name)
1504{ 1485{
1505 long x;
1506 char tmp[STRBUFFSIZE];
1507
1508 if (!strcmp (name, "t")) 1486 if (!strcmp (name, "t"))
1509 return S_T; 1487 return S_T;
1510 else if (!strcmp (name, "f")) 1488 else if (!strcmp (name, "f"))
1511 return S_F; 1489 return S_F;
1512 else if (*name == 'o') /* #o (octal) */
1513 {
1514 x = strtol (name + 1, 0, 8);
1515 return mk_integer (SCHEME_A_ x);
1516 }
1517 else if (*name == 'd') /* #d (decimal) */
1518 {
1519 x = strtol (name + 1, 0, 10);
1520 return mk_integer (SCHEME_A_ x);
1521 }
1522 else if (*name == 'x') /* #x (hex) */
1523 {
1524 x = strtol (name + 1, 0, 16);
1525 return mk_integer (SCHEME_A_ x);
1526 }
1527 else if (*name == 'b') /* #b (binary) */
1528 {
1529 x = binary_decode (name + 1);
1530 return mk_integer (SCHEME_A_ x);
1531 }
1532 else if (*name == '\\') /* #\w (character) */ 1490 else if (*name == '\\') /* #\w (character) */
1533 { 1491 {
1534 int c = 0; 1492 int c;
1535 1493
1536 if (stricmp (name + 1, "space") == 0) 1494 if (stricmp (name + 1, "space") == 0)
1537 c = ' '; 1495 c = ' ';
1538 else if (stricmp (name + 1, "newline") == 0) 1496 else if (stricmp (name + 1, "newline") == 0)
1539 c = '\n'; 1497 c = '\n';
1541 c = '\r'; 1499 c = '\r';
1542 else if (stricmp (name + 1, "tab") == 0) 1500 else if (stricmp (name + 1, "tab") == 0)
1543 c = '\t'; 1501 c = '\t';
1544 else if (name[1] == 'x' && name[2] != 0) 1502 else if (name[1] == 'x' && name[2] != 0)
1545 { 1503 {
1546 int c1 = strtol (name + 2, 0, 16); 1504 long c1 = strtol (name + 2, 0, 16);
1547 1505
1548 if (c1 <= UCHAR_MAX) 1506 if (0 <= c1 && c1 <= UCHAR_MAX)
1549 c = c1; 1507 c = c1;
1550 else 1508 else
1551 return NIL; 1509 return NIL;
1552 1510 }
1553#if USE_ASCII_NAMES 1511#if USE_ASCII_NAMES
1554 }
1555 else if (is_ascii_name (name + 1, &c)) 1512 else if (is_ascii_name (name + 1, &c))
1556 {
1557 /* nothing */ 1513 /* nothing */;
1558#endif 1514#endif
1559 }
1560 else if (name[2] == 0) 1515 else if (name[2] == 0)
1561 c = name[1]; 1516 c = name[1];
1562 else 1517 else
1563 return NIL; 1518 return NIL;
1564 1519
1565 return mk_character (SCHEME_A_ c); 1520 return mk_character (SCHEME_A_ c);
1566 } 1521 }
1567 else 1522 else
1523 {
1524 /* identify base by string index */
1525 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1526 char *base = strchr (baseidx, *name);
1527
1528 if (base)
1529 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1530
1568 return NIL; 1531 return NIL;
1532 }
1569} 1533}
1570 1534
1571/* ========== garbage collector ========== */ 1535/* ========== garbage collector ========== */
1572 1536
1573/*-- 1537/*--
1588 if (is_vector (p)) 1552 if (is_vector (p))
1589 { 1553 {
1590 int i; 1554 int i;
1591 1555
1592 for (i = 0; i < p->object.vector.length; i++) 1556 for (i = 0; i < p->object.vector.length; i++)
1593 mark (p->object.vector.vvalue[i]); 1557 mark (vecvalue (p)[i]);
1594 } 1558 }
1595 1559
1596 if (is_atom (p)) 1560 if (is_atom (p))
1597 goto E6; 1561 goto E6;
1598 1562
1719finalize_cell (SCHEME_P_ pointer a) 1683finalize_cell (SCHEME_P_ pointer a)
1720{ 1684{
1721 if (is_string (a)) 1685 if (is_string (a))
1722 free (strvalue (a)); 1686 free (strvalue (a));
1723 else if (is_vector (a)) 1687 else if (is_vector (a))
1724 free (a->object.vector.vvalue); 1688 free (vecvalue (a));
1725#if USE_PORTS 1689#if USE_PORTS
1726 else if (is_port (a)) 1690 else if (is_port (a))
1727 { 1691 {
1728 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1692 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1729 port_close (SCHEME_A_ a, port_input | port_output); 1693 port_close (SCHEME_A_ a, port_input | port_output);
2556 2520
2557 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2521 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2558 { 2522 {
2559 if (num_is_integer (l)) 2523 if (num_is_integer (l))
2560 xnum (p, ivalue_unchecked (l)); 2524 xnum (p, ivalue_unchecked (l));
2561#if USE_FLOAT 2525#if USE_REAL
2562 else 2526 else
2563 { 2527 {
2564 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2528 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2565 /* r5rs says there must be a '.' (unless 'e'?) */ 2529 /* r5rs says there must be a '.' (unless 'e'?) */
2566 f = strcspn (p, ".e"); 2530 f = strcspn (p, ".e");
2904{ 2868{
2905 pointer slot = immutable_cons (variable, value); 2869 pointer slot = immutable_cons (variable, value);
2906 2870
2907 if (is_vector (car (env))) 2871 if (is_vector (car (env)))
2908 { 2872 {
2909 int location = hash_fn (symname (variable), vector_length (car (env))); 2873 int location = hash_fn (symname (variable), veclength (car (env)));
2910 2874
2911 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2875 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
2912 } 2876 }
2913 else 2877 else
2914 set_car (env, immutable_cons (slot, car (env))); 2878 set_car (env, immutable_cons (slot, car (env)));
2922 2886
2923 for (x = env; x != NIL; x = cdr (x)) 2887 for (x = env; x != NIL; x = cdr (x))
2924 { 2888 {
2925 if (is_vector (car (x))) 2889 if (is_vector (car (x)))
2926 { 2890 {
2927 location = hash_fn (symname (hdl), vector_length (car (x))); 2891 location = hash_fn (symname (hdl), veclength (car (x)));
2928 y = vector_elem (car (x), location); 2892 y = vector_elem (car (x), location);
2929 } 2893 }
2930 else 2894 else
2931 y = car (x); 2895 y = car (x);
2932 2896
3042#if USE_ERROR_HOOK 3006#if USE_ERROR_HOOK
3043 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 3007 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3044 3008
3045 if (x != NIL) 3009 if (x != NIL)
3046 { 3010 {
3047 if (a) 3011 pointer code = a
3048 SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); 3012 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3049 else 3013 : NIL;
3050 SCHEME_V->code = NIL;
3051 3014
3052 SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); 3015 code = cons (mk_string (SCHEME_A_ s), code);
3053 setimmutable (car (SCHEME_V->code)); 3016 setimmutable (car (code));
3054 SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); 3017 SCHEME_V->code = cons (slot_value_in_env (x), code);
3055 SCHEME_V->op = OP_EVAL; 3018 SCHEME_V->op = OP_EVAL;
3056 3019
3057 return S_T; 3020 return S_T;
3058 } 3021 }
3059#endif 3022#endif
3350 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); 3313 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3351 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); 3314 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3352 s_goto (OP_READ_INTERNAL); 3315 s_goto (OP_READ_INTERNAL);
3353 3316
3354 case OP_T1LVL: /* top level */ 3317 case OP_T1LVL: /* top level */
3355 SCHEME_V->code = SCHEME_V->value; 3318 SCHEME_V->code = SCHEME_V->value;
3356 SCHEME_V->inport = SCHEME_V->save_inport; 3319 SCHEME_V->inport = SCHEME_V->save_inport;
3357 s_goto (OP_EVAL); 3320 s_goto (OP_EVAL);
3358 3321
3359 case OP_READ_INTERNAL: /* internal read */ 3322 case OP_READ_INTERNAL: /* internal read */
3360 SCHEME_V->tok = token (SCHEME_A); 3323 SCHEME_V->tok = token (SCHEME_A);
3410 else 3373 else
3411 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3374 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3412 } 3375 }
3413 else if (is_pair (SCHEME_V->code)) 3376 else if (is_pair (SCHEME_V->code))
3414 { 3377 {
3378 x = car (SCHEME_V->code);
3379
3415 if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ 3380 if (is_syntax (x)) /* SYNTAX */
3416 { 3381 {
3417 SCHEME_V->code = cdr (SCHEME_V->code); 3382 SCHEME_V->code = cdr (SCHEME_V->code);
3418 s_goto (syntaxnum (x)); 3383 s_goto (syntaxnum (x));
3419 } 3384 }
3420 else /* first, eval top element and eval arguments */ 3385 else /* first, eval top element and eval arguments */
3421 { 3386 {
3422 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); 3387 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
3423 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3388 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3424 SCHEME_V->code = car (SCHEME_V->code); 3389 SCHEME_V->code = x;
3425 s_goto (OP_EVAL); 3390 s_goto (OP_EVAL);
3426 } 3391 }
3427 } 3392 }
3428 else 3393 else
3429 s_return (SCHEME_V->code); 3394 s_return (SCHEME_V->code);
3987 SCHEME_V->code = car (SCHEME_V->args); 3952 SCHEME_V->code = car (SCHEME_V->args);
3988 s_goto (OP_EVAL); 3953 s_goto (OP_EVAL);
3989 3954
3990 case OP_CONTINUATION: /* call-with-current-continuation */ 3955 case OP_CONTINUATION: /* call-with-current-continuation */
3991 SCHEME_V->code = car (SCHEME_V->args); 3956 SCHEME_V->code = car (SCHEME_V->args);
3992 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL); 3957 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3993 s_goto (OP_APPLY); 3958 s_goto (OP_APPLY);
3994 } 3959 }
3995 3960
3996 return S_T; 3961 return S_T;
3997} 3962}
4505 4470
4506 s_return (vec); 4471 s_return (vec);
4507 } 4472 }
4508 4473
4509 case OP_VECLEN: /* vector-length */ 4474 case OP_VECLEN: /* vector-length */
4510 s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args)))); 4475 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4511 4476
4512 case OP_VECREF: /* vector-ref */ 4477 case OP_VECREF: /* vector-ref */
4513 { 4478 {
4514 int index; 4479 int index;
4515 4480
4516 index = ivalue (cadr (SCHEME_V->args)); 4481 index = ivalue (cadr (SCHEME_V->args));
4517 4482
4518 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4483 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4519 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4484 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4520 4485
4521 s_return (vector_elem (car (SCHEME_V->args), index)); 4486 s_return (vector_elem (car (SCHEME_V->args), index));
4522 } 4487 }
4523 4488
4528 if (is_immutable (car (SCHEME_V->args))) 4493 if (is_immutable (car (SCHEME_V->args)))
4529 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4494 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));
4530 4495
4531 index = ivalue (cadr (SCHEME_V->args)); 4496 index = ivalue (cadr (SCHEME_V->args));
4532 4497
4533 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4498 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4534 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4499 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4535 4500
4536 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4501 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
4537 s_return (car (SCHEME_V->args)); 4502 s_return (car (SCHEME_V->args));
4538 } 4503 }
5381 5346
5382 case OP_PVECFROM: 5347 case OP_PVECFROM:
5383 { 5348 {
5384 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5349 int i = ivalue_unchecked (cdr (SCHEME_V->args));
5385 pointer vec = car (SCHEME_V->args); 5350 pointer vec = car (SCHEME_V->args);
5386 int len = vector_length (vec); 5351 int len = veclength (vec);
5387 5352
5388 if (i == len) 5353 if (i == len)
5389 { 5354 {
5390 putstr (SCHEME_A_ ")"); 5355 putstr (SCHEME_A_ ")");
5391 s_return (S_T); 5356 s_return (S_T);
5641 ok_to_freely_gc (SCHEME_A); 5606 ok_to_freely_gc (SCHEME_A);
5642 5607
5643 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5608 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)
5644 return; 5609 return;
5645 5610
5646#if USE_ERROR_CHECKING 5611 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5647 if (SCHEME_V->no_memory)
5648 { 5612 {
5649 xwrstr ("No memory!\n"); 5613 xwrstr ("No memory!\n");
5650 return; 5614 return;
5651 } 5615 }
5652#endif
5653 } 5616 }
5654} 5617}
5655 5618
5656/* ========== Initialization of internal keywords ========== */ 5619/* ========== Initialization of internal keywords ========== */
5657 5620
5817 set_cdr (S_T, S_T); 5780 set_cdr (S_T, S_T);
5818 /* init F */ 5781 /* init F */
5819 set_typeflag (S_F, T_ATOM | T_MARK); 5782 set_typeflag (S_F, T_ATOM | T_MARK);
5820 set_car (S_F, S_F); 5783 set_car (S_F, S_F);
5821 set_cdr (S_F, S_F); 5784 set_cdr (S_F, S_F);
5785 /* init EOF_OBJ */
5786 set_typeflag (S_EOF, T_ATOM | T_MARK);
5787 set_car (S_EOF, S_EOF);
5788 set_cdr (S_EOF, S_EOF);
5822 /* init sink */ 5789 /* init sink */
5823 set_typeflag (S_SINK, T_PAIR | T_MARK); 5790 set_typeflag (S_SINK, T_PAIR | T_MARK);
5824 set_car (S_SINK, NIL); 5791 set_car (S_SINK, NIL);
5792
5825 /* init c_nest */ 5793 /* init c_nest */
5826 SCHEME_V->c_nest = NIL; 5794 SCHEME_V->c_nest = NIL;
5827 5795
5828 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5796 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5829 /* init global_env */ 5797 /* init global_env */
5847 for (i = 0; i < n; i++) 5815 for (i = 0; i < n; i++)
5848 if (dispatch_table[i].name != 0) 5816 if (dispatch_table[i].name != 0)
5849 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5817 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5850 5818
5851 /* initialization of global pointers to special symbols */ 5819 /* initialization of global pointers to special symbols */
5852 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5820 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5853 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5821 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5854 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5822 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5855 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); 5823 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5856 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); 5824 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5857 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); 5825 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5858 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); 5826 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*");
5859 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); 5827 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*");
5860 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); 5828 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*");
5861 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); 5829 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");
5862 5830
5863 return !SCHEME_V->no_memory; 5831 return !SCHEME_V->no_memory;
5864} 5832}
5865 5833
6112 6080
6113/* ========== Main ========== */ 6081/* ========== Main ========== */
6114 6082
6115#if STANDALONE 6083#if STANDALONE
6116 6084
6117# if defined(__APPLE__) && !defined (OSX)
6118int
6119main ()
6120{
6121 extern MacTS_main (int argc, char **argv);
6122 char **argv;
6123 int argc = ccommand (&argv);
6124
6125 MacTS_main (argc, argv);
6126 return 0;
6127}
6128
6129int
6130MacTS_main (int argc, char **argv)
6131{
6132# else
6133int 6085int
6134main (int argc, char **argv) 6086main (int argc, char **argv)
6135{ 6087{
6136# endif
6137# if USE_MULTIPLICITY 6088# if USE_MULTIPLICITY
6138 scheme ssc; 6089 scheme ssc;
6139 scheme *const SCHEME_V = &ssc; 6090 scheme *const SCHEME_V = &ssc;
6140# else 6091# else
6141# endif 6092# endif

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines