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.7 by root, Wed Nov 25 22:12:59 2015 UTC vs.
Revision 1.11 by root, Thu Nov 26 00:05:20 2015 UTC

… …
65#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 65#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
66#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 66#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
67#define S_SINK (&SCHEME_V->xsink) 67#define S_SINK (&SCHEME_V->xsink)
68#define S_EOF (&SCHEME_V->xEOF_OBJ) 68#define S_EOF (&SCHEME_V->xEOF_OBJ)
69 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
70#if !USE_MULTIPLICITY 77#if !USE_MULTIPLICITY
71static scheme sc; 78static scheme sc;
72#endif 79#endif
73 80
74static void 81static void
… …
369{ 376{
370 return type (p) == T_PAIR; 377 return type (p) == T_PAIR;
371} 378}
372 379
373#define car(p) ((p)->object.cons.car + 0) 380#define car(p) ((p)->object.cons.car + 0)
374#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ 381#define cdr(p) ((p)->object.cons.cdr + 0)
375 382
376#define caar(p) car (car (p)) 383#define caar(p) car (car (p))
377#define cadr(p) car (cdr (p)) 384#define cadr(p) car (cdr (p))
378#define cdar(p) cdr (car (p)) 385#define cdar(p) cdr (car (p))
379#define cddr(p) cdr (cdr (p)) 386#define cddr(p) cdr (cdr (p))
… …
621static int file_push (SCHEME_P_ const char *fname); 628static int file_push (SCHEME_P_ const char *fname);
622static void file_pop (SCHEME_P); 629static void file_pop (SCHEME_P);
623static int file_interactive (SCHEME_P); 630static int file_interactive (SCHEME_P);
624static INLINE int is_one_of (char *s, int c); 631static INLINE int is_one_of (char *s, int c);
625static int alloc_cellseg (SCHEME_P_ int n); 632static int alloc_cellseg (SCHEME_P_ int n);
626static long binary_decode (const char *s);
627static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 633static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
628static void finalize_cell (SCHEME_P_ pointer a); 634static void finalize_cell (SCHEME_P_ pointer a);
629static int count_consecutive_cells (pointer x, int needed); 635static int count_consecutive_cells (pointer x, int needed);
630static 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);
631static pointer mk_number (SCHEME_P_ const num n); 637static pointer mk_number (SCHEME_P_ const num n);
… …
885#else 891#else
886 return x == 0; 892 return x == 0;
887#endif 893#endif
888} 894}
889 895
890static long
891binary_decode (const char *s)
892{
893 long x = 0;
894
895 while (*s != 0 && (*s == '1' || *s == '0'))
896 {
897 x <<= 1;
898 x += *s - '0';
899 s++;
900 }
901
902 return x;
903}
904
905/* allocate new cell segment */ 896/* allocate new cell segment */
906static int 897static int
907alloc_cellseg (SCHEME_P_ int n) 898alloc_cellseg (SCHEME_P_ int n)
908{ 899{
909 pointer newp; 900 pointer newp;
… …
981 972
982/* get new cell. parameter a, b is marked by gc. */ 973/* get new cell. parameter a, b is marked by gc. */
983static INLINE pointer 974static INLINE pointer
984get_cell_x (SCHEME_P_ pointer a, pointer b) 975get_cell_x (SCHEME_P_ pointer a, pointer b)
985{ 976{
986 if (SCHEME_V->free_cell == NIL) 977 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
987 { 978 {
988 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 979 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
989 return S_SINK; 980 return S_SINK;
990 981
991 if (SCHEME_V->free_cell == NIL) 982 if (SCHEME_V->free_cell == NIL)
… …
1320 } 1311 }
1321 1312
1322 return q; 1313 return q;
1323} 1314}
1324 1315
1325/* get new string */
1326INTERFACE pointer 1316INTERFACE pointer
1327mk_string (SCHEME_P_ const char *str) 1317mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1328{ 1318{
1329 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;
1330} 1325}
1331 1326
1332INTERFACE pointer 1327INTERFACE pointer
1333mk_counted_string (SCHEME_P_ const char *str, uint32_t len) 1328mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1334{ 1329{
… …
1339 strlength (x) = len; 1334 strlength (x) = len;
1340 return x; 1335 return x;
1341} 1336}
1342 1337
1343INTERFACE pointer 1338INTERFACE pointer
1344mk_empty_string (SCHEME_P_ uint32_t len, char fill) 1339mk_string (SCHEME_P_ const char *str)
1345{ 1340{
1346 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1341 return mk_counted_string (SCHEME_A_ str, strlen (str));
1347
1348 set_typeflag (x, T_STRING | T_ATOM);
1349 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1350 strlength (x) = len;
1351 return x;
1352} 1342}
1353 1343
1354INTERFACE pointer 1344INTERFACE pointer
1355mk_vector (SCHEME_P_ uint32_t len) 1345mk_vector (SCHEME_P_ uint32_t len)
1356{ 1346{
… …
1393 1383
1394INTERFACE pointer 1384INTERFACE pointer
1395gensym (SCHEME_P) 1385gensym (SCHEME_P)
1396{ 1386{
1397 pointer x; 1387 pointer x;
1398 char name[40];
1399 1388
1400 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1389 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1401 { 1390 {
1402 strcpy (name, "gensym-"); 1391 char name[40] = "gensym-";
1403 xnum (name + 7, SCHEME_V->gensym_cnt); 1392 xnum (name + 7, SCHEME_V->gensym_cnt);
1404 1393
1405 /* first check oblist */ 1394 /* first check oblist */
1406 x = oblist_find_by_name (SCHEME_A_ name); 1395 x = oblist_find_by_name (SCHEME_A_ name);
1407 1396
1408 if (x != NIL) 1397 if (x == NIL)
1409 continue;
1410 else
1411 { 1398 {
1412 x = oblist_add_by_name (SCHEME_A_ name); 1399 x = oblist_add_by_name (SCHEME_A_ name);
1413 return x; 1400 return x;
1414 } 1401 }
1415 } 1402 }
… …
1424 char c, *p; 1411 char c, *p;
1425 int has_dec_point = 0; 1412 int has_dec_point = 0;
1426 int has_fp_exp = 0; 1413 int has_fp_exp = 0;
1427 1414
1428#if USE_COLON_HOOK 1415#if USE_COLON_HOOK
1429
1430 if ((p = strstr (q, "::")) != 0) 1416 if ((p = strstr (q, "::")) != 0)
1431 { 1417 {
1432 *p = 0; 1418 *p = 0;
1433 return cons (SCHEME_V->COLON_HOOK, 1419 return cons (SCHEME_V->COLON_HOOK,
1434 cons (cons (SCHEME_V->QUOTE, 1420 cons (cons (SCHEME_V->QUOTE,
1435 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)));
1436 } 1422 }
1437
1438#endif 1423#endif
1439 1424
1440 p = q; 1425 p = q;
1441 c = *p++; 1426 c = *p++;
1442 1427
… …
1503 1488
1504/* make constant */ 1489/* make constant */
1505static pointer 1490static pointer
1506mk_sharp_const (SCHEME_P_ char *name) 1491mk_sharp_const (SCHEME_P_ char *name)
1507{ 1492{
1508 long x;
1509 char tmp[STRBUFFSIZE];
1510
1511 if (!strcmp (name, "t")) 1493 if (!strcmp (name, "t"))
1512 return S_T; 1494 return S_T;
1513 else if (!strcmp (name, "f")) 1495 else if (!strcmp (name, "f"))
1514 return S_F; 1496 return S_F;
1515 else if (*name == 'o') /* #o (octal) */
1516 {
1517 x = strtol (name + 1, 0, 8);
1518 return mk_integer (SCHEME_A_ x);
1519 }
1520 else if (*name == 'd') /* #d (decimal) */
1521 {
1522 x = strtol (name + 1, 0, 10);
1523 return mk_integer (SCHEME_A_ x);
1524 }
1525 else if (*name == 'x') /* #x (hex) */
1526 {
1527 x = strtol (name + 1, 0, 16);
1528 return mk_integer (SCHEME_A_ x);
1529 }
1530 else if (*name == 'b') /* #b (binary) */
1531 {
1532 x = binary_decode (name + 1);
1533 return mk_integer (SCHEME_A_ x);
1534 }
1535 else if (*name == '\\') /* #\w (character) */ 1497 else if (*name == '\\') /* #\w (character) */
1536 { 1498 {
1537 int c = 0; 1499 int c;
1538 1500
1539 if (stricmp (name + 1, "space") == 0) 1501 if (stricmp (name + 1, "space") == 0)
1540 c = ' '; 1502 c = ' ';
1541 else if (stricmp (name + 1, "newline") == 0) 1503 else if (stricmp (name + 1, "newline") == 0)
1542 c = '\n'; 1504 c = '\n';
… …
1544 c = '\r'; 1506 c = '\r';
1545 else if (stricmp (name + 1, "tab") == 0) 1507 else if (stricmp (name + 1, "tab") == 0)
1546 c = '\t'; 1508 c = '\t';
1547 else if (name[1] == 'x' && name[2] != 0) 1509 else if (name[1] == 'x' && name[2] != 0)
1548 { 1510 {
1549 int c1 = strtol (name + 2, 0, 16); 1511 long c1 = strtol (name + 2, 0, 16);
1550 1512
1551 if (c1 <= UCHAR_MAX) 1513 if (0 <= c1 && c1 <= UCHAR_MAX)
1552 c = c1; 1514 c = c1;
1553 else 1515 else
1554 return NIL; 1516 return NIL;
1555 1517 }
1556#if USE_ASCII_NAMES 1518#if USE_ASCII_NAMES
1557 }
1558 else if (is_ascii_name (name + 1, &c)) 1519 else if (is_ascii_name (name + 1, &c))
1559 {
1560 /* nothing */ 1520 /* nothing */;
1561#endif 1521#endif
1562 }
1563 else if (name[2] == 0) 1522 else if (name[2] == 0)
1564 c = name[1]; 1523 c = name[1];
1565 else 1524 else
1566 return NIL; 1525 return NIL;
1567 1526
1568 return mk_character (SCHEME_A_ c); 1527 return mk_character (SCHEME_A_ c);
1569 } 1528 }
1570 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
1571 return NIL; 1538 return NIL;
1539 }
1572} 1540}
1573 1541
1574/* ========== garbage collector ========== */ 1542/* ========== garbage collector ========== */
1575 1543
1576/*-- 1544/*--
1577 * 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,
1578 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1546 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1579 * 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
1580 */ 1552 */
1581static void 1553static void
1582mark (pointer a) 1554mark (pointer a)
1583{ 1555{
1584 pointer t, q, p; 1556 pointer t, q, p;
… …
1586 t = 0; 1558 t = 0;
1587 p = a; 1559 p = a;
1588E2: 1560E2:
1589 setmark (p); 1561 setmark (p);
1590 1562
1591 if (is_vector (p)) 1563 if (ecb_expect_false (is_vector (p)))
1592 { 1564 {
1593 int i; 1565 int i;
1594 1566
1595 for (i = 0; i < p->object.vector.length; i++) 1567 for (i = 0; i < p->object.vector.length; i++)
1596 mark (vecvalue (p)[i]); 1568 mark (vecvalue (p)[i]);
… …
1719} 1691}
1720 1692
1721static void 1693static void
1722finalize_cell (SCHEME_P_ pointer a) 1694finalize_cell (SCHEME_P_ pointer a)
1723{ 1695{
1696 /* TODO, fast bitmap check? */
1724 if (is_string (a)) 1697 if (is_string (a))
1725 free (strvalue (a)); 1698 free (strvalue (a));
1726 else if (is_vector (a)) 1699 else if (is_vector (a))
1727 free (vecvalue (a)); 1700 free (vecvalue (a));
1728#if USE_PORTS 1701#if USE_PORTS
… …
5574 int ok = 1; 5547 int ok = 1;
5575 char msg[STRBUFFSIZE]; 5548 char msg[STRBUFFSIZE];
5576 int n = list_length (SCHEME_A_ SCHEME_V->args); 5549 int n = list_length (SCHEME_A_ SCHEME_V->args);
5577 5550
5578 /* Check number of arguments */ 5551 /* Check number of arguments */
5579 if (n < pcd->min_arity) 5552 if (ecb_expect_false (n < pcd->min_arity))
5580 { 5553 {
5581 ok = 0; 5554 ok = 0;
5582 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5555 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5583 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);
5584 } 5557 }
5585 5558 else if (ecb_excpect_false (n > pcd->max_arity))
5586 if (ok && n > pcd->max_arity)
5587 { 5559 {
5588 ok = 0; 5560 ok = 0;
5589 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5561 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5590 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);
5591 } 5563 }
5592 5564
5593 if (ok) 5565 if (ecb_expect_false (ok))
5594 { 5566 {
5595 if (pcd->arg_tests_encoding) 5567 if (pcd->arg_tests_encoding)
5596 { 5568 {
5597 int i = 0; 5569 int i = 0;
5598 int j; 5570 int j;
… …
5642 } 5614 }
5643#endif 5615#endif
5644 5616
5645 ok_to_freely_gc (SCHEME_A); 5617 ok_to_freely_gc (SCHEME_A);
5646 5618
5647 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5619 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5648 return; 5620 return;
5649 5621
5650 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5622 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5651 { 5623 {
5652 xwrstr ("No memory!\n"); 5624 xwrstr ("No memory!\n");
… …
5710 5682
5711 case 'd': 5683 case 'd':
5712 return OP_COND0; /* cond */ 5684 return OP_COND0; /* cond */
5713 5685
5714 case '*': 5686 case '*':
5715 return OP_LET0AST; /* let* */ 5687 return OP_LET0AST;/* let* */
5716 5688
5717 default: 5689 default:
5718 return OP_SET0; /* set! */ 5690 return OP_SET0; /* set! */
5719 } 5691 }
5720 5692
… …
5742 5714
5743 case 'f': 5715 case 'f':
5744 return OP_DEF0; /* define */ 5716 return OP_DEF0; /* define */
5745 5717
5746 default: 5718 default:
5747 return OP_LET0REC; /* letrec */ 5719 return OP_LET0REC;/* letrec */
5748 } 5720 }
5749 5721
5750 default: 5722 default:
5751 return OP_C0STREAM; /* cons-stream */ 5723 return OP_C0STREAM; /* cons-stream */
5752 } 5724 }

Diff Legend

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