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.8 by root, Wed Nov 25 22:36:25 2015 UTC vs.
Revision 1.10 by root, Thu Nov 26 00:03:19 2015 UTC

… …
64#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 64#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?
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
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
69 76
70#if !USE_MULTIPLICITY 77#if !USE_MULTIPLICITY
71static scheme sc; 78static scheme sc;
72#endif 79#endif
73 80
… …
965 972
966/* get new cell. parameter a, b is marked by gc. */ 973/* get new cell. parameter a, b is marked by gc. */
967static INLINE pointer 974static INLINE pointer
968get_cell_x (SCHEME_P_ pointer a, pointer b) 975get_cell_x (SCHEME_P_ pointer a, pointer b)
969{ 976{
970 if (SCHEME_V->free_cell == NIL) 977 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
971 { 978 {
972 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 979 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
973 return S_SINK; 980 return S_SINK;
974 981
975 if (SCHEME_V->free_cell == NIL) 982 if (SCHEME_V->free_cell == NIL)
… …
1481 1488
1482/* make constant */ 1489/* make constant */
1483static pointer 1490static pointer
1484mk_sharp_const (SCHEME_P_ char *name) 1491mk_sharp_const (SCHEME_P_ char *name)
1485{ 1492{
1486 long x;
1487 char tmp[STRBUFFSIZE];
1488
1489 if (!strcmp (name, "t")) 1493 if (!strcmp (name, "t"))
1490 return S_T; 1494 return S_T;
1491 else if (!strcmp (name, "f")) 1495 else if (!strcmp (name, "f"))
1492 return S_F; 1496 return S_F;
1493 else if (*name == '\\') /* #\w (character) */ 1497 else if (*name == '\\') /* #\w (character) */
1494 { 1498 {
1495 int c = 0; 1499 int c;
1496 1500
1497 if (stricmp (name + 1, "space") == 0) 1501 if (stricmp (name + 1, "space") == 0)
1498 c = ' '; 1502 c = ' ';
1499 else if (stricmp (name + 1, "newline") == 0) 1503 else if (stricmp (name + 1, "newline") == 0)
1500 c = '\n'; 1504 c = '\n';
… …
1502 c = '\r'; 1506 c = '\r';
1503 else if (stricmp (name + 1, "tab") == 0) 1507 else if (stricmp (name + 1, "tab") == 0)
1504 c = '\t'; 1508 c = '\t';
1505 else if (name[1] == 'x' && name[2] != 0) 1509 else if (name[1] == 'x' && name[2] != 0)
1506 { 1510 {
1507 int c1 = strtol (name + 2, 0, 16); 1511 long c1 = strtol (name + 2, 0, 16);
1508 1512
1509 if (c1 <= UCHAR_MAX) 1513 if (0 <= c1 && c1 <= UCHAR_MAX)
1510 c = c1; 1514 c = c1;
1511 else 1515 else
1512 return NIL; 1516 return NIL;
1513 1517 }
1514#if USE_ASCII_NAMES 1518#if USE_ASCII_NAMES
1515 }
1516 else if (is_ascii_name (name + 1, &c)) 1519 else if (is_ascii_name (name + 1, &c))
1517 {
1518 /* nothing */ 1520 /* nothing */;
1519#endif 1521#endif
1520 }
1521 else if (name[2] == 0) 1522 else if (name[2] == 0)
1522 c = name[1]; 1523 c = name[1];
1523 else 1524 else
1524 return NIL; 1525 return NIL;
1525 1526
… …
1542 1543
1543/*-- 1544/*--
1544 * 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,
1545 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1546 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1546 * 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
1547 */ 1552 */
1548static void 1553static void
1549mark (pointer a) 1554mark (pointer a)
1550{ 1555{
1551 pointer t, q, p; 1556 pointer t, q, p;
… …
1553 t = 0; 1558 t = 0;
1554 p = a; 1559 p = a;
1555E2: 1560E2:
1556 setmark (p); 1561 setmark (p);
1557 1562
1558 if (is_vector (p)) 1563 if (ecb_expect_false (is_vector (p)))
1559 { 1564 {
1560 int i; 1565 int i;
1561 1566
1562 for (i = 0; i < p->object.vector.length; i++) 1567 for (i = 0; i < p->object.vector.length; i++)
1563 mark (vecvalue (p)[i]); 1568 mark (vecvalue (p)[i]);
… …
1686} 1691}
1687 1692
1688static void 1693static void
1689finalize_cell (SCHEME_P_ pointer a) 1694finalize_cell (SCHEME_P_ pointer a)
1690{ 1695{
1696 /* TODO, fast bitmap check? */
1691 if (is_string (a)) 1697 if (is_string (a))
1692 free (strvalue (a)); 1698 free (strvalue (a));
1693 else if (is_vector (a)) 1699 else if (is_vector (a))
1694 free (vecvalue (a)); 1700 free (vecvalue (a));
1695#if USE_PORTS 1701#if USE_PORTS
… …
5541 int ok = 1; 5547 int ok = 1;
5542 char msg[STRBUFFSIZE]; 5548 char msg[STRBUFFSIZE];
5543 int n = list_length (SCHEME_A_ SCHEME_V->args); 5549 int n = list_length (SCHEME_A_ SCHEME_V->args);
5544 5550
5545 /* Check number of arguments */ 5551 /* Check number of arguments */
5546 if (n < pcd->min_arity) 5552 if (ecb_expect_false (n < pcd->min_arity))
5547 { 5553 {
5548 ok = 0; 5554 ok = 0;
5549 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5555 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5550 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);
5551 } 5557 }
5552 5558 else if (ecb_excpect_false (n > pcd->max_arity))
5553 if (ok && n > pcd->max_arity)
5554 { 5559 {
5555 ok = 0; 5560 ok = 0;
5556 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5561 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5557 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);
5558 } 5563 }
5559 5564
5560 if (ok) 5565 if (ecb_expect_false (ok))
5561 { 5566 {
5562 if (pcd->arg_tests_encoding) 5567 if (pcd->arg_tests_encoding)
5563 { 5568 {
5564 int i = 0; 5569 int i = 0;
5565 int j; 5570 int j;
… …
5609 } 5614 }
5610#endif 5615#endif
5611 5616
5612 ok_to_freely_gc (SCHEME_A); 5617 ok_to_freely_gc (SCHEME_A);
5613 5618
5614 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5619 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5615 return; 5620 return;
5616 5621
5617 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5622 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5618 { 5623 {
5619 xwrstr ("No memory!\n"); 5624 xwrstr ("No memory!\n");
… …
5677 5682
5678 case 'd': 5683 case 'd':
5679 return OP_COND0; /* cond */ 5684 return OP_COND0; /* cond */
5680 5685
5681 case '*': 5686 case '*':
5682 return OP_LET0AST; /* let* */ 5687 return OP_LET0AST;/* let* */
5683 5688
5684 default: 5689 default:
5685 return OP_SET0; /* set! */ 5690 return OP_SET0; /* set! */
5686 } 5691 }
5687 5692
… …
5709 5714
5710 case 'f': 5715 case 'f':
5711 return OP_DEF0; /* define */ 5716 return OP_DEF0; /* define */
5712 5717
5713 default: 5718 default:
5714 return OP_LET0REC; /* letrec */ 5719 return OP_LET0REC;/* letrec */
5715 } 5720 }
5716 5721
5717 default: 5722 default:
5718 return OP_C0STREAM; /* cons-stream */ 5723 return OP_C0STREAM; /* cons-stream */
5719 } 5724 }

Diff Legend

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