ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/scheme.c
(Generate patch)

Comparing microscheme/scheme.c (file contents):
Revision 1.3 by root, Wed Nov 25 10:30:34 2015 UTC vs.
Revision 1.12 by root, Thu Nov 26 07:30: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.
… …
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);
242INTERFACE uint32_t vector_length (pointer vec); 264INTERFACE uint32_t vector_length (pointer vec);
243INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 265INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);
244INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 266INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);
245 267
… …
314{ 336{
315 return num_get_rvalue (p->object.number); 337 return num_get_rvalue (p->object.number);
316} 338}
317 339
318#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 340#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)
319#if USE_FLOAT 341#if USE_REAL
320# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 342# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)
321# define set_num_integer(p) (p)->object.number.is_fixnum=1; 343# define set_num_integer(p) (p)->object.number.is_fixnum=1;
322# define set_num_real(p) (p)->object.number.is_fixnum=0; 344# define set_num_real(p) (p)->object.number.is_fixnum=0;
323#else 345#else
324# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 346# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
… …
354{ 376{
355 return type (p) == T_PAIR; 377 return type (p) == T_PAIR;
356} 378}
357 379
358#define car(p) ((p)->object.cons.car + 0) 380#define car(p) ((p)->object.cons.car + 0)
359#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ 381#define cdr(p) ((p)->object.cons.cdr + 0)
360 382
361#define caar(p) car (car (p)) 383static pointer caar (pointer p) { return car (car (p)); }
362#define cadr(p) car (cdr (p)) 384static pointer cadr (pointer p) { return car (cdr (p)); }
363#define cdar(p) cdr (car (p)) 385static pointer cdar (pointer p) { return cdr (car (p)); }
364#define cddr(p) cdr (cdr (p)) 386static pointer cddr (pointer p) { return cdr (cdr (p)); }
365 387
366#define cadar(p) car (cdr (car (p))) 388static pointer cadar (pointer p) { return car (cdr (car (p))); }
367#define caddr(p) car (cdr (cdr (p))) 389static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
368#define cdaar(p) cdr (car (car (p))) 390static pointer cdaar (pointer p) { return cdr (car (car (p))); }
369 391
370INTERFACE void 392INTERFACE void
371set_car (pointer p, pointer q) 393set_car (pointer p, pointer q)
372{ 394{
373 p->object.cons.car = q; 395 p->object.cons.car = q;
… …
486 return type (p) == T_ENVIRONMENT; 508 return type (p) == T_ENVIRONMENT;
487} 509}
488 510
489#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 511#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
490 512
491#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
492#define is_atom(p) (typeflag (p) & T_ATOM) 513#define is_atom(p) (typeflag (p) & T_ATOM)
493#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 514#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
494#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 515#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
495 516
496#define is_mark(p) (typeflag (p) & T_MARK) 517#define is_mark(p) (typeflag (p) & T_MARK)
497#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 518#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
498#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 519#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 520
511INTERFACE INLINE int 521INTERFACE INLINE int
512is_immutable (pointer p) 522is_immutable (pointer p)
513{ 523{
514 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 524 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
618static int file_push (SCHEME_P_ const char *fname); 628static int file_push (SCHEME_P_ const char *fname);
619static void file_pop (SCHEME_P); 629static void file_pop (SCHEME_P);
620static int file_interactive (SCHEME_P); 630static int file_interactive (SCHEME_P);
621static INLINE int is_one_of (char *s, int c); 631static INLINE int is_one_of (char *s, int c);
622static int alloc_cellseg (SCHEME_P_ int n); 632static 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); 633static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
625static void finalize_cell (SCHEME_P_ pointer a); 634static void finalize_cell (SCHEME_P_ pointer a);
626static int count_consecutive_cells (pointer x, int needed); 635static int count_consecutive_cells (pointer x, int needed);
627static 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);
628static pointer mk_number (SCHEME_P_ const num n); 637static pointer mk_number (SCHEME_P_ const num n);
… …
875#endif 884#endif
876 885
877static int 886static int
878is_zero_rvalue (RVALUE x) 887is_zero_rvalue (RVALUE x)
879{ 888{
880#if USE_FLOAT 889#if USE_REAL
881 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. */
882#else 891#else
883 return x == 0; 892 return x == 0;
884#endif 893#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} 894}
901 895
902/* allocate new cell segment */ 896/* allocate new cell segment */
903static int 897static int
904alloc_cellseg (SCHEME_P_ int n) 898alloc_cellseg (SCHEME_P_ int n)
… …
978 972
979/* get new cell. parameter a, b is marked by gc. */ 973/* get new cell. parameter a, b is marked by gc. */
980static INLINE pointer 974static INLINE pointer
981get_cell_x (SCHEME_P_ pointer a, pointer b) 975get_cell_x (SCHEME_P_ pointer a, pointer b)
982{ 976{
983 if (SCHEME_V->free_cell == NIL) 977 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
984 { 978 {
985 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 979 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
986 return S_SINK; 980 return S_SINK;
987 981
988 if (SCHEME_V->free_cell == NIL) 982 if (SCHEME_V->free_cell == NIL)
… …
1132 1126
1133 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL); 1127 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1134 set_typeflag (x, T_SYMBOL); 1128 set_typeflag (x, T_SYMBOL);
1135 setimmutable (car (x)); 1129 setimmutable (car (x));
1136 1130
1137 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1131 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))); 1132 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1139 return x; 1133 return x;
1140} 1134}
1141 1135
1142static INLINE pointer 1136static INLINE pointer
… …
1144{ 1138{
1145 int location; 1139 int location;
1146 pointer x; 1140 pointer x;
1147 char *s; 1141 char *s;
1148 1142
1149 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1143 location = hash_fn (name, veclength (SCHEME_V->oblist));
1150 1144
1151 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))
1152 { 1146 {
1153 s = symname (car (x)); 1147 s = symname (car (x));
1154 1148
… …
1165{ 1159{
1166 int i; 1160 int i;
1167 pointer x; 1161 pointer x;
1168 pointer ob_list = NIL; 1162 pointer ob_list = NIL;
1169 1163
1170 for (i = 0; i < vector_length (SCHEME_V->oblist); i++) 1164 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1171 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))
1172 ob_list = cons (x, ob_list); 1166 ob_list = cons (x, ob_list);
1173 1167
1174 return ob_list; 1168 return ob_list;
1175} 1169}
… …
1317 } 1311 }
1318 1312
1319 return q; 1313 return q;
1320} 1314}
1321 1315
1322/* get new string */
1323INTERFACE pointer 1316INTERFACE pointer
1324mk_string (SCHEME_P_ const char *str) 1317mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1325{ 1318{
1326 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;
1327} 1325}
1328 1326
1329INTERFACE pointer 1327INTERFACE pointer
1330mk_counted_string (SCHEME_P_ const char *str, uint32_t len) 1328mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1331{ 1329{
… …
1336 strlength (x) = len; 1334 strlength (x) = len;
1337 return x; 1335 return x;
1338} 1336}
1339 1337
1340INTERFACE pointer 1338INTERFACE pointer
1341mk_empty_string (SCHEME_P_ uint32_t len, char fill) 1339mk_string (SCHEME_P_ const char *str)
1342{ 1340{
1343 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1341 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} 1342}
1350 1343
1351INTERFACE pointer 1344INTERFACE pointer
1352mk_vector (SCHEME_P_ uint32_t len) 1345mk_vector (SCHEME_P_ uint32_t len)
1353{ 1346{
… …
1358fill_vector (pointer vec, pointer obj) 1351fill_vector (pointer vec, pointer obj)
1359{ 1352{
1360 int i; 1353 int i;
1361 1354
1362 for (i = 0; i < vec->object.vector.length; i++) 1355 for (i = 0; i < vec->object.vector.length; i++)
1363 vec->object.vector.vvalue[i] = obj; 1356 vecvalue (vec)[i] = obj;
1364} 1357}
1365 1358
1366INTERFACE pointer 1359INTERFACE pointer
1367vector_elem (pointer vec, uint32_t ielem) 1360vector_elem (pointer vec, uint32_t ielem)
1368{ 1361{
1369 return vec->object.vector.vvalue[ielem]; 1362 return vecvalue(vec)[ielem];
1370} 1363}
1371 1364
1372INTERFACE void 1365INTERFACE void
1373set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1366set_vector_elem (pointer vec, uint32_t ielem, pointer a)
1374{ 1367{
1375 vec->object.vector.vvalue[ielem] = a; 1368 vecvalue(vec)[ielem] = a;
1376} 1369}
1377 1370
1378/* get new symbol */ 1371/* get new symbol */
1379INTERFACE pointer 1372INTERFACE pointer
1380mk_symbol (SCHEME_P_ const char *name) 1373mk_symbol (SCHEME_P_ const char *name)
… …
1390 1383
1391INTERFACE pointer 1384INTERFACE pointer
1392gensym (SCHEME_P) 1385gensym (SCHEME_P)
1393{ 1386{
1394 pointer x; 1387 pointer x;
1395 char name[40];
1396 1388
1397 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1389 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1398 { 1390 {
1399 strcpy (name, "gensym-"); 1391 char name[40] = "gensym-";
1400 xnum (name + 7, SCHEME_V->gensym_cnt); 1392 xnum (name + 7, SCHEME_V->gensym_cnt);
1401 1393
1402 /* first check oblist */ 1394 /* first check oblist */
1403 x = oblist_find_by_name (SCHEME_A_ name); 1395 x = oblist_find_by_name (SCHEME_A_ name);
1404 1396
1405 if (x != NIL) 1397 if (x == NIL)
1406 continue;
1407 else
1408 { 1398 {
1409 x = oblist_add_by_name (SCHEME_A_ name); 1399 x = oblist_add_by_name (SCHEME_A_ name);
1410 return x; 1400 return x;
1411 } 1401 }
1412 } 1402 }
… …
1421 char c, *p; 1411 char c, *p;
1422 int has_dec_point = 0; 1412 int has_dec_point = 0;
1423 int has_fp_exp = 0; 1413 int has_fp_exp = 0;
1424 1414
1425#if USE_COLON_HOOK 1415#if USE_COLON_HOOK
1426
1427 if ((p = strstr (q, "::")) != 0) 1416 if ((p = strstr (q, "::")) != 0)
1428 { 1417 {
1429 *p = 0; 1418 *p = 0;
1430 return cons (SCHEME_V->COLON_HOOK, 1419 return cons (SCHEME_V->COLON_HOOK,
1431 cons (cons (SCHEME_V->QUOTE, 1420 cons (cons (SCHEME_V->QUOTE,
1432 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)));
1433 } 1422 }
1434
1435#endif 1423#endif
1436 1424
1437 p = q; 1425 p = q;
1438 c = *p++; 1426 c = *p++;
1439 1427
… …
1488 1476
1489 return mk_symbol (SCHEME_A_ strlwr (q)); 1477 return mk_symbol (SCHEME_A_ strlwr (q));
1490 } 1478 }
1491 } 1479 }
1492 1480
1493#if USE_FLOAT 1481#if USE_REAL
1494 if (has_dec_point) 1482 if (has_dec_point)
1495 return mk_real (SCHEME_A_ atof (q)); 1483 return mk_real (SCHEME_A_ atof (q));
1496#endif 1484#endif
1497 1485
1498 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1486 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
… …
1500 1488
1501/* make constant */ 1489/* make constant */
1502static pointer 1490static pointer
1503mk_sharp_const (SCHEME_P_ char *name) 1491mk_sharp_const (SCHEME_P_ char *name)
1504{ 1492{
1505 long x;
1506 char tmp[STRBUFFSIZE];
1507
1508 if (!strcmp (name, "t")) 1493 if (!strcmp (name, "t"))
1509 return S_T; 1494 return S_T;
1510 else if (!strcmp (name, "f")) 1495 else if (!strcmp (name, "f"))
1511 return S_F; 1496 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) */ 1497 else if (*name == '\\') /* #\w (character) */
1533 { 1498 {
1534 int c = 0; 1499 int c;
1535 1500
1536 if (stricmp (name + 1, "space") == 0) 1501 if (stricmp (name + 1, "space") == 0)
1537 c = ' '; 1502 c = ' ';
1538 else if (stricmp (name + 1, "newline") == 0) 1503 else if (stricmp (name + 1, "newline") == 0)
1539 c = '\n'; 1504 c = '\n';
… …
1541 c = '\r'; 1506 c = '\r';
1542 else if (stricmp (name + 1, "tab") == 0) 1507 else if (stricmp (name + 1, "tab") == 0)
1543 c = '\t'; 1508 c = '\t';
1544 else if (name[1] == 'x' && name[2] != 0) 1509 else if (name[1] == 'x' && name[2] != 0)
1545 { 1510 {
1546 int c1 = strtol (name + 2, 0, 16); 1511 long c1 = strtol (name + 2, 0, 16);
1547 1512
1548 if (c1 <= UCHAR_MAX) 1513 if (0 <= c1 && c1 <= UCHAR_MAX)
1549 c = c1; 1514 c = c1;
1550 else 1515 else
1551 return NIL; 1516 return NIL;
1552 1517 }
1553#if USE_ASCII_NAMES 1518#if USE_ASCII_NAMES
1554 }
1555 else if (is_ascii_name (name + 1, &c)) 1519 else if (is_ascii_name (name + 1, &c))
1556 {
1557 /* nothing */ 1520 /* nothing */;
1558#endif 1521#endif
1559 }
1560 else if (name[2] == 0) 1522 else if (name[2] == 0)
1561 c = name[1]; 1523 c = name[1];
1562 else 1524 else
1563 return NIL; 1525 return NIL;
1564 1526
1565 return mk_character (SCHEME_A_ c); 1527 return mk_character (SCHEME_A_ c);
1566 } 1528 }
1567 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
1568 return NIL; 1538 return NIL;
1539 }
1569} 1540}
1570 1541
1571/* ========== garbage collector ========== */ 1542/* ========== garbage collector ========== */
1572 1543
1573/*-- 1544/*--
1574 * 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,
1575 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1546 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1576 * 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
1577 */ 1552 */
1578static void 1553static void
1579mark (pointer a) 1554mark (pointer a)
1580{ 1555{
1581 pointer t, q, p; 1556 pointer t, q, p;
… …
1583 t = 0; 1558 t = 0;
1584 p = a; 1559 p = a;
1585E2: 1560E2:
1586 setmark (p); 1561 setmark (p);
1587 1562
1588 if (is_vector (p)) 1563 if (ecb_expect_false (is_vector (p)))
1589 { 1564 {
1590 int i; 1565 int i;
1591 1566
1592 for (i = 0; i < p->object.vector.length; i++) 1567 for (i = 0; i < p->object.vector.length; i++)
1593 mark (p->object.vector.vvalue[i]); 1568 mark (vecvalue (p)[i]);
1594 } 1569 }
1595 1570
1596 if (is_atom (p)) 1571 if (is_atom (p))
1597 goto E6; 1572 goto E6;
1598 1573
… …
1716} 1691}
1717 1692
1718static void 1693static void
1719finalize_cell (SCHEME_P_ pointer a) 1694finalize_cell (SCHEME_P_ pointer a)
1720{ 1695{
1696 /* TODO, fast bitmap check? */
1721 if (is_string (a)) 1697 if (is_string (a))
1722 free (strvalue (a)); 1698 free (strvalue (a));
1723 else if (is_vector (a)) 1699 else if (is_vector (a))
1724 free (a->object.vector.vvalue); 1700 free (vecvalue (a));
1725#if USE_PORTS 1701#if USE_PORTS
1726 else if (is_port (a)) 1702 else if (is_port (a))
1727 { 1703 {
1728 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)
1729 port_close (SCHEME_A_ a, port_input | port_output); 1705 port_close (SCHEME_A_ a, port_input | port_output);
… …
2556 2532
2557 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 */
2558 { 2534 {
2559 if (num_is_integer (l)) 2535 if (num_is_integer (l))
2560 xnum (p, ivalue_unchecked (l)); 2536 xnum (p, ivalue_unchecked (l));
2561#if USE_FLOAT 2537#if USE_REAL
2562 else 2538 else
2563 { 2539 {
2564 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2540 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2565 /* r5rs says there must be a '.' (unless 'e'?) */ 2541 /* r5rs says there must be a '.' (unless 'e'?) */
2566 f = strcspn (p, ".e"); 2542 f = strcspn (p, ".e");
… …
2904{ 2880{
2905 pointer slot = immutable_cons (variable, value); 2881 pointer slot = immutable_cons (variable, value);
2906 2882
2907 if (is_vector (car (env))) 2883 if (is_vector (car (env)))
2908 { 2884 {
2909 int location = hash_fn (symname (variable), vector_length (car (env))); 2885 int location = hash_fn (symname (variable), veclength (car (env)));
2910 2886
2911 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)));
2912 } 2888 }
2913 else 2889 else
2914 set_car (env, immutable_cons (slot, car (env))); 2890 set_car (env, immutable_cons (slot, car (env)));
… …
2922 2898
2923 for (x = env; x != NIL; x = cdr (x)) 2899 for (x = env; x != NIL; x = cdr (x))
2924 { 2900 {
2925 if (is_vector (car (x))) 2901 if (is_vector (car (x)))
2926 { 2902 {
2927 location = hash_fn (symname (hdl), vector_length (car (x))); 2903 location = hash_fn (symname (hdl), veclength (car (x)));
2928 y = vector_elem (car (x), location); 2904 y = vector_elem (car (x), location);
2929 } 2905 }
2930 else 2906 else
2931 y = car (x); 2907 y = car (x);
2932 2908
… …
3042#if USE_ERROR_HOOK 3018#if USE_ERROR_HOOK
3043 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);
3044 3020
3045 if (x != NIL) 3021 if (x != NIL)
3046 { 3022 {
3047 if (a) 3023 pointer code = a
3048 SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); 3024 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3049 else 3025 : NIL;
3050 SCHEME_V->code = NIL;
3051 3026
3052 SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); 3027 code = cons (mk_string (SCHEME_A_ s), code);
3053 setimmutable (car (SCHEME_V->code)); 3028 setimmutable (car (code));
3054 SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); 3029 SCHEME_V->code = cons (slot_value_in_env (x), code);
3055 SCHEME_V->op = OP_EVAL; 3030 SCHEME_V->op = OP_EVAL;
3056 3031
3057 return S_T; 3032 return S_T;
3058 } 3033 }
3059#endif 3034#endif
… …
3350 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); 3325 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3351 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); 3326 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3352 s_goto (OP_READ_INTERNAL); 3327 s_goto (OP_READ_INTERNAL);
3353 3328
3354 case OP_T1LVL: /* top level */ 3329 case OP_T1LVL: /* top level */
3355 SCHEME_V->code = SCHEME_V->value; 3330 SCHEME_V->code = SCHEME_V->value;
3356 SCHEME_V->inport = SCHEME_V->save_inport; 3331 SCHEME_V->inport = SCHEME_V->save_inport;
3357 s_goto (OP_EVAL); 3332 s_goto (OP_EVAL);
3358 3333
3359 case OP_READ_INTERNAL: /* internal read */ 3334 case OP_READ_INTERNAL: /* internal read */
3360 SCHEME_V->tok = token (SCHEME_A); 3335 SCHEME_V->tok = token (SCHEME_A);
… …
3410 else 3385 else
3411 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3386 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3412 } 3387 }
3413 else if (is_pair (SCHEME_V->code)) 3388 else if (is_pair (SCHEME_V->code))
3414 { 3389 {
3390 x = car (SCHEME_V->code);
3391
3415 if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ 3392 if (is_syntax (x)) /* SYNTAX */
3416 { 3393 {
3417 SCHEME_V->code = cdr (SCHEME_V->code); 3394 SCHEME_V->code = cdr (SCHEME_V->code);
3418 s_goto (syntaxnum (x)); 3395 s_goto (syntaxnum (x));
3419 } 3396 }
3420 else /* first, eval top element and eval arguments */ 3397 else /* first, eval top element and eval arguments */
3421 { 3398 {
3422 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); 3399 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)); */ 3400 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3424 SCHEME_V->code = car (SCHEME_V->code); 3401 SCHEME_V->code = x;
3425 s_goto (OP_EVAL); 3402 s_goto (OP_EVAL);
3426 } 3403 }
3427 } 3404 }
3428 else 3405 else
3429 s_return (SCHEME_V->code); 3406 s_return (SCHEME_V->code);
… …
3987 SCHEME_V->code = car (SCHEME_V->args); 3964 SCHEME_V->code = car (SCHEME_V->args);
3988 s_goto (OP_EVAL); 3965 s_goto (OP_EVAL);
3989 3966
3990 case OP_CONTINUATION: /* call-with-current-continuation */ 3967 case OP_CONTINUATION: /* call-with-current-continuation */
3991 SCHEME_V->code = car (SCHEME_V->args); 3968 SCHEME_V->code = car (SCHEME_V->args);
3992 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);
3993 s_goto (OP_APPLY); 3970 s_goto (OP_APPLY);
3994 } 3971 }
3995 3972
3996 return S_T; 3973 return S_T;
3997} 3974}
… …
4505 4482
4506 s_return (vec); 4483 s_return (vec);
4507 } 4484 }
4508 4485
4509 case OP_VECLEN: /* vector-length */ 4486 case OP_VECLEN: /* vector-length */
4510 s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args)))); 4487 s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));
4511 4488
4512 case OP_VECREF: /* vector-ref */ 4489 case OP_VECREF: /* vector-ref */
4513 { 4490 {
4514 int index; 4491 int index;
4515 4492
4516 index = ivalue (cadr (SCHEME_V->args)); 4493 index = ivalue (cadr (SCHEME_V->args));
4517 4494
4518 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4495 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4519 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4496 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));
4520 4497
4521 s_return (vector_elem (car (SCHEME_V->args), index)); 4498 s_return (vector_elem (car (SCHEME_V->args), index));
4522 } 4499 }
4523 4500
… …
4528 if (is_immutable (car (SCHEME_V->args))) 4505 if (is_immutable (car (SCHEME_V->args)))
4529 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));
4530 4507
4531 index = ivalue (cadr (SCHEME_V->args)); 4508 index = ivalue (cadr (SCHEME_V->args));
4532 4509
4533 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4510 if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)
4534 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4511 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));
4535 4512
4536 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));
4537 s_return (car (SCHEME_V->args)); 4514 s_return (car (SCHEME_V->args));
4538 } 4515 }
… …
5381 5358
5382 case OP_PVECFROM: 5359 case OP_PVECFROM:
5383 { 5360 {
5384 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5361 int i = ivalue_unchecked (cdr (SCHEME_V->args));
5385 pointer vec = car (SCHEME_V->args); 5362 pointer vec = car (SCHEME_V->args);
5386 int len = vector_length (vec); 5363 int len = veclength (vec);
5387 5364
5388 if (i == len) 5365 if (i == len)
5389 { 5366 {
5390 putstr (SCHEME_A_ ")"); 5367 putstr (SCHEME_A_ ")");
5391 s_return (S_T); 5368 s_return (S_T);
… …
5562 5539
5563 for (;;) 5540 for (;;)
5564 { 5541 {
5565 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5542 op_code_info *pcd = dispatch_table + SCHEME_V->op;
5566 5543
5544#if USE_ERROR_CHECKING
5567 if (pcd->name) /* if built-in function, check arguments */ 5545 if (pcd->name) /* if built-in function, check arguments */
5568 { 5546 {
5569#if USE_ERROR_CHECKING 5547 int ok = 1;
5570 char msg[STRBUFFSIZE]; 5548 char msg[STRBUFFSIZE];
5571 int ok = 1;
5572 int n = list_length (SCHEME_A_ SCHEME_V->args); 5549 int n = list_length (SCHEME_A_ SCHEME_V->args);
5573 5550
5574 /* Check number of arguments */ 5551 /* Check number of arguments */
5575 if (n < pcd->min_arity) 5552 if (ecb_expect_false (n < pcd->min_arity))
5576 { 5553 {
5577 ok = 0; 5554 ok = 0;
5578 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5555 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5579 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);
5580 } 5557 }
5581 5558 else if (ecb_excpect_false (n > pcd->max_arity))
5582 if (ok && n > pcd->max_arity)
5583 { 5559 {
5584 ok = 0; 5560 ok = 0;
5585 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5561 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5586 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);
5587 } 5563 }
5588#endif
5589 5564
5590 if (ok) 5565 if (ecb_expect_false (ok))
5591 { 5566 {
5592 if (pcd->arg_tests_encoding && USE_ERROR_CHECKING) 5567 if (pcd->arg_tests_encoding)
5593 { 5568 {
5594 int i = 0; 5569 int i = 0;
5595 int j; 5570 int j;
5596 const char *t = pcd->arg_tests_encoding; 5571 const char *t = pcd->arg_tests_encoding;
5597 pointer arglist = SCHEME_V->args; 5572 pointer arglist = SCHEME_V->args;
… …
5635 return; 5610 return;
5636 5611
5637 pcd = dispatch_table + SCHEME_V->op; 5612 pcd = dispatch_table + SCHEME_V->op;
5638 } 5613 }
5639 } 5614 }
5615#endif
5640 5616
5641 ok_to_freely_gc (SCHEME_A); 5617 ok_to_freely_gc (SCHEME_A);
5642 5618
5643 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5619 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5644 return; 5620 return;
5645 5621
5646#if USE_ERROR_CHECKING 5622 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5647 if (SCHEME_V->no_memory)
5648 { 5623 {
5649 xwrstr ("No memory!\n"); 5624 xwrstr ("No memory!\n");
5650 return; 5625 return;
5651 } 5626 }
5652#endif
5653 } 5627 }
5654} 5628}
5655 5629
5656/* ========== Initialization of internal keywords ========== */ 5630/* ========== Initialization of internal keywords ========== */
5657 5631
… …
5708 5682
5709 case 'd': 5683 case 'd':
5710 return OP_COND0; /* cond */ 5684 return OP_COND0; /* cond */
5711 5685
5712 case '*': 5686 case '*':
5713 return OP_LET0AST; /* let* */ 5687 return OP_LET0AST;/* let* */
5714 5688
5715 default: 5689 default:
5716 return OP_SET0; /* set! */ 5690 return OP_SET0; /* set! */
5717 } 5691 }
5718 5692
… …
5740 5714
5741 case 'f': 5715 case 'f':
5742 return OP_DEF0; /* define */ 5716 return OP_DEF0; /* define */
5743 5717
5744 default: 5718 default:
5745 return OP_LET0REC; /* letrec */ 5719 return OP_LET0REC;/* letrec */
5746 } 5720 }
5747 5721
5748 default: 5722 default:
5749 return OP_C0STREAM; /* cons-stream */ 5723 return OP_C0STREAM; /* cons-stream */
5750 } 5724 }
… …
5817 set_cdr (S_T, S_T); 5791 set_cdr (S_T, S_T);
5818 /* init F */ 5792 /* init F */
5819 set_typeflag (S_F, T_ATOM | T_MARK); 5793 set_typeflag (S_F, T_ATOM | T_MARK);
5820 set_car (S_F, S_F); 5794 set_car (S_F, S_F);
5821 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);
5822 /* init sink */ 5800 /* init sink */
5823 set_typeflag (S_SINK, T_PAIR | T_MARK); 5801 set_typeflag (S_SINK, T_PAIR | T_MARK);
5824 set_car (S_SINK, NIL); 5802 set_car (S_SINK, NIL);
5803
5825 /* init c_nest */ 5804 /* init c_nest */
5826 SCHEME_V->c_nest = NIL; 5805 SCHEME_V->c_nest = NIL;
5827 5806
5828 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5807 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5829 /* init global_env */ 5808 /* init global_env */
… …
5847 for (i = 0; i < n; i++) 5826 for (i = 0; i < n; i++)
5848 if (dispatch_table[i].name != 0) 5827 if (dispatch_table[i].name != 0)
5849 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5828 assign_proc (SCHEME_A_ i, dispatch_table[i].name);
5850 5829
5851 /* initialization of global pointers to special symbols */ 5830 /* initialization of global pointers to special symbols */
5852 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5831 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5853 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5832 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5854 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5833 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
5855 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); 5834 SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote");
5856 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); 5835 SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing");
5857 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); 5836 SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>");
5858 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); 5837 SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*");
5859 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); 5838 SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*");
5860 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); 5839 SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*");
5861 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); 5840 SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");
5862 5841
5863 return !SCHEME_V->no_memory; 5842 return !SCHEME_V->no_memory;
5864} 5843}
5865 5844
… …
6112 6091
6113/* ========== Main ========== */ 6092/* ========== Main ========== */
6114 6093
6115#if STANDALONE 6094#if STANDALONE
6116 6095
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 6096int
6134main (int argc, char **argv) 6097main (int argc, char **argv)
6135{ 6098{
6136# endif
6137# if USE_MULTIPLICITY 6099# if USE_MULTIPLICITY
6138 scheme ssc; 6100 scheme ssc;
6139 scheme *const SCHEME_V = &ssc; 6101 scheme *const SCHEME_V = &ssc;
6140# else 6102# else
6141# endif 6103# endif

Diff Legend

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