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.13 by root, Thu Nov 26 07:59:42 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
… …
201#define T_SYNTAX 0x0010 208#define T_SYNTAX 0x0010
202#define T_IMMUTABLE 0x0020 209#define T_IMMUTABLE 0x0020
203#define T_ATOM 0x0040 /* only for gc */ 210#define T_ATOM 0x0040 /* only for gc */
204#define T_MARK 0x0080 /* only for gc */ 211#define T_MARK 0x0080 /* only for gc */
205 212
206static num num_add (num a, num b);
207static num num_mul (num a, num b); 213static num num_op (char op, num a, num b);
208static num num_div (num a, num b);
209static num num_intdiv (num a, num b); 214static num num_intdiv (num a, num b);
210static num num_sub (num a, num b);
211static num num_rem (num a, num b); 215static num num_rem (num a, num b);
212static num num_mod (num a, num b); 216static num num_mod (num a, num b);
213static int num_eq (num a, num b); 217static int num_eq (num a, num b);
214static int num_gt (num a, num b); 218static int num_gt (num a, num b);
215static int num_ge (num a, num b); 219static int num_ge (num a, num b);
… …
369{ 373{
370 return type (p) == T_PAIR; 374 return type (p) == T_PAIR;
371} 375}
372 376
373#define car(p) ((p)->object.cons.car + 0) 377#define car(p) ((p)->object.cons.car + 0)
374#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ 378#define cdr(p) ((p)->object.cons.cdr + 0)
375 379
376#define caar(p) car (car (p)) 380static pointer caar (pointer p) { return car (car (p)); }
377#define cadr(p) car (cdr (p)) 381static pointer cadr (pointer p) { return car (cdr (p)); }
378#define cdar(p) cdr (car (p)) 382static pointer cdar (pointer p) { return cdr (car (p)); }
379#define cddr(p) cdr (cdr (p)) 383static pointer cddr (pointer p) { return cdr (cdr (p)); }
380 384
381#define cadar(p) car (cdr (car (p))) 385static pointer cadar (pointer p) { return car (cdr (car (p))); }
382#define caddr(p) car (cdr (cdr (p))) 386static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
383#define cdaar(p) cdr (car (car (p))) 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
384 388
385INTERFACE void 389INTERFACE void
386set_car (pointer p, pointer q) 390set_car (pointer p, pointer q)
387{ 391{
388 p->object.cons.car = q; 392 p->object.cons.car = q;
… …
674static void assign_syntax (SCHEME_P_ const char *name); 678static void assign_syntax (SCHEME_P_ const char *name);
675static int syntaxnum (pointer p); 679static int syntaxnum (pointer p);
676static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 680static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
677 681
678static num 682static num
679num_add (num a, num b) 683num_op (char op, num a, num b)
680{ 684{
681 num ret; 685 num ret;
682 686
683 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 687 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
684 688
685 if (num_is_fixnum (ret)) 689 if (num_is_fixnum (ret))
686 num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b)); 690 {
691 IVALUE av = num_get_ivalue (a);
692 IVALUE bv = num_get_ivalue (b);
693
694 switch (op)
695 {
696 case '+': av += bv; break;
697 case '-': av -= bv; break;
698 case '*': av *= bv; break;
699 case '/': av /= bv; break;
700 }
701
702 num_set_ivalue (ret, av);
703 }
687 else 704 else
688 num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b)); 705 {
706 RVALUE av = num_get_rvalue (a);
707 RVALUE bv = num_get_rvalue (b);
689 708
690 return ret; 709 switch (op)
691} 710 {
711 case '+': av += bv; break;
712 case '-': av -= bv; break;
713 case '*': av *= bv; break;
714 case '/': av /= bv; break;
715 }
692 716
693static num 717 num_set_rvalue (ret, av);
694num_mul (num a, num b) 718 }
695{
696 num ret;
697
698 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
699
700 if (num_is_fixnum (ret))
701 num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
702 else
703 num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
704 719
705 return ret; 720 return ret;
706} 721}
707 722
708static num 723static num
… …
714 729
715 if (num_is_fixnum (ret)) 730 if (num_is_fixnum (ret))
716 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); 731 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
717 else 732 else
718 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); 733 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
719
720 return ret;
721}
722
723static num
724num_intdiv (num a, num b)
725{
726 num ret;
727
728 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
729
730 if (num_is_fixnum (ret))
731 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
732 else
733 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
734
735 return ret;
736}
737
738static num
739num_sub (num a, num b)
740{
741 num ret;
742
743 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
744
745 if (num_is_fixnum (ret))
746 num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
747 else
748 num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
749 734
750 return ret; 735 return ret;
751} 736}
752 737
753static num 738static num
… …
965 950
966/* get new cell. parameter a, b is marked by gc. */ 951/* get new cell. parameter a, b is marked by gc. */
967static INLINE pointer 952static INLINE pointer
968get_cell_x (SCHEME_P_ pointer a, pointer b) 953get_cell_x (SCHEME_P_ pointer a, pointer b)
969{ 954{
970 if (SCHEME_V->free_cell == NIL) 955 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
971 { 956 {
972 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 957 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
973 return S_SINK; 958 return S_SINK;
974 959
975 if (SCHEME_V->free_cell == NIL) 960 if (SCHEME_V->free_cell == NIL)
… …
1481 1466
1482/* make constant */ 1467/* make constant */
1483static pointer 1468static pointer
1484mk_sharp_const (SCHEME_P_ char *name) 1469mk_sharp_const (SCHEME_P_ char *name)
1485{ 1470{
1486 long x;
1487 char tmp[STRBUFFSIZE];
1488
1489 if (!strcmp (name, "t")) 1471 if (!strcmp (name, "t"))
1490 return S_T; 1472 return S_T;
1491 else if (!strcmp (name, "f")) 1473 else if (!strcmp (name, "f"))
1492 return S_F; 1474 return S_F;
1493 else if (*name == '\\') /* #\w (character) */ 1475 else if (*name == '\\') /* #\w (character) */
1494 { 1476 {
1495 int c = 0; 1477 int c;
1496 1478
1497 if (stricmp (name + 1, "space") == 0) 1479 if (stricmp (name + 1, "space") == 0)
1498 c = ' '; 1480 c = ' ';
1499 else if (stricmp (name + 1, "newline") == 0) 1481 else if (stricmp (name + 1, "newline") == 0)
1500 c = '\n'; 1482 c = '\n';
… …
1502 c = '\r'; 1484 c = '\r';
1503 else if (stricmp (name + 1, "tab") == 0) 1485 else if (stricmp (name + 1, "tab") == 0)
1504 c = '\t'; 1486 c = '\t';
1505 else if (name[1] == 'x' && name[2] != 0) 1487 else if (name[1] == 'x' && name[2] != 0)
1506 { 1488 {
1507 int c1 = strtol (name + 2, 0, 16); 1489 long c1 = strtol (name + 2, 0, 16);
1508 1490
1509 if (c1 <= UCHAR_MAX) 1491 if (0 <= c1 && c1 <= UCHAR_MAX)
1510 c = c1; 1492 c = c1;
1511 else 1493 else
1512 return NIL; 1494 return NIL;
1513 1495 }
1514#if USE_ASCII_NAMES 1496#if USE_ASCII_NAMES
1515 }
1516 else if (is_ascii_name (name + 1, &c)) 1497 else if (is_ascii_name (name + 1, &c))
1517 {
1518 /* nothing */ 1498 /* nothing */;
1519#endif 1499#endif
1520 }
1521 else if (name[2] == 0) 1500 else if (name[2] == 0)
1522 c = name[1]; 1501 c = name[1];
1523 else 1502 else
1524 return NIL; 1503 return NIL;
1525 1504
… …
1542 1521
1543/*-- 1522/*--
1544 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1523 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1545 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1524 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1546 * for marking. 1525 * for marking.
1526 *
1527 * The exception is vectors - vectors are currently marked recursively,
1528 * which is inherited form tinyscheme and could be fixed by having another
1529 * word of context in the vector
1547 */ 1530 */
1548static void 1531static void
1549mark (pointer a) 1532mark (pointer a)
1550{ 1533{
1551 pointer t, q, p; 1534 pointer t, q, p;
… …
1553 t = 0; 1536 t = 0;
1554 p = a; 1537 p = a;
1555E2: 1538E2:
1556 setmark (p); 1539 setmark (p);
1557 1540
1558 if (is_vector (p)) 1541 if (ecb_expect_false (is_vector (p)))
1559 { 1542 {
1560 int i; 1543 int i;
1561 1544
1562 for (i = 0; i < p->object.vector.length; i++) 1545 for (i = 0; i < p->object.vector.length; i++)
1563 mark (vecvalue (p)[i]); 1546 mark (vecvalue (p)[i]);
… …
1686} 1669}
1687 1670
1688static void 1671static void
1689finalize_cell (SCHEME_P_ pointer a) 1672finalize_cell (SCHEME_P_ pointer a)
1690{ 1673{
1674 /* TODO, fast bitmap check? */
1691 if (is_string (a)) 1675 if (is_string (a))
1692 free (strvalue (a)); 1676 free (strvalue (a));
1693 else if (is_vector (a)) 1677 else if (is_vector (a))
1694 free (vecvalue (a)); 1678 free (vecvalue (a));
1695#if USE_PORTS 1679#if USE_PORTS
… …
4101 4085
4102 case OP_ADD: /* + */ 4086 case OP_ADD: /* + */
4103 v = num_zero; 4087 v = num_zero;
4104 4088
4105 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4089 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4106 v = num_add (v, nvalue (car (x))); 4090 v = num_op ('+', v, nvalue (car (x)));
4107 4091
4108 s_return (mk_number (SCHEME_A_ v)); 4092 s_return (mk_number (SCHEME_A_ v));
4109 4093
4110 case OP_MUL: /* * */ 4094 case OP_MUL: /* * */
4111 v = num_one; 4095 v = num_one;
4112 4096
4113 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4097 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4114 v = num_mul (v, nvalue (car (x))); 4098 v = num_op ('+', v, nvalue (car (x)));
4115 4099
4116 s_return (mk_number (SCHEME_A_ v)); 4100 s_return (mk_number (SCHEME_A_ v));
4117 4101
4118 case OP_SUB: /* - */ 4102 case OP_SUB: /* - */
4119 if (cdr (SCHEME_V->args) == NIL) 4103 if (cdr (SCHEME_V->args) == NIL)
… …
4126 x = cdr (SCHEME_V->args); 4110 x = cdr (SCHEME_V->args);
4127 v = nvalue (car (SCHEME_V->args)); 4111 v = nvalue (car (SCHEME_V->args));
4128 } 4112 }
4129 4113
4130 for (; x != NIL; x = cdr (x)) 4114 for (; x != NIL; x = cdr (x))
4131 v = num_sub (v, nvalue (car (x))); 4115 v = num_op ('+', v, nvalue (car (x)));
4132 4116
4133 s_return (mk_number (SCHEME_A_ v)); 4117 s_return (mk_number (SCHEME_A_ v));
4134 4118
4135 case OP_DIV: /* / */ 4119 case OP_DIV: /* / */
4136 if (cdr (SCHEME_V->args) == NIL) 4120 if (cdr (SCHEME_V->args) == NIL)
… …
4167 } 4151 }
4168 4152
4169 for (; x != NIL; x = cdr (x)) 4153 for (; x != NIL; x = cdr (x))
4170 { 4154 {
4171 if (ivalue (car (x)) != 0) 4155 if (ivalue (car (x)) != 0)
4172 v = num_intdiv (v, nvalue (car (x))); 4156 v = num_op ('/', v, nvalue (car (x)));
4173 else 4157 else
4174 Error_0 ("quotient: division by zero"); 4158 Error_0 ("quotient: division by zero");
4175 } 4159 }
4176 4160
4177 s_return (mk_number (SCHEME_A_ v)); 4161 s_return (mk_number (SCHEME_A_ v));
… …
5541 int ok = 1; 5525 int ok = 1;
5542 char msg[STRBUFFSIZE]; 5526 char msg[STRBUFFSIZE];
5543 int n = list_length (SCHEME_A_ SCHEME_V->args); 5527 int n = list_length (SCHEME_A_ SCHEME_V->args);
5544 5528
5545 /* Check number of arguments */ 5529 /* Check number of arguments */
5546 if (n < pcd->min_arity) 5530 if (ecb_expect_false (n < pcd->min_arity))
5547 { 5531 {
5548 ok = 0; 5532 ok = 0;
5549 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5533 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5550 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5534 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5551 } 5535 }
5552 5536 else if (ecb_excpect_false (n > pcd->max_arity))
5553 if (ok && n > pcd->max_arity)
5554 { 5537 {
5555 ok = 0; 5538 ok = 0;
5556 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5539 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5557 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5540 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5558 } 5541 }
5559 5542
5560 if (ok) 5543 if (ecb_expect_false (ok))
5561 { 5544 {
5562 if (pcd->arg_tests_encoding) 5545 if (pcd->arg_tests_encoding)
5563 { 5546 {
5564 int i = 0; 5547 int i = 0;
5565 int j; 5548 int j;
… …
5609 } 5592 }
5610#endif 5593#endif
5611 5594
5612 ok_to_freely_gc (SCHEME_A); 5595 ok_to_freely_gc (SCHEME_A);
5613 5596
5614 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5597 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5615 return; 5598 return;
5616 5599
5617 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5600 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5618 { 5601 {
5619 xwrstr ("No memory!\n"); 5602 xwrstr ("No memory!\n");
… …
5677 5660
5678 case 'd': 5661 case 'd':
5679 return OP_COND0; /* cond */ 5662 return OP_COND0; /* cond */
5680 5663
5681 case '*': 5664 case '*':
5682 return OP_LET0AST; /* let* */ 5665 return OP_LET0AST;/* let* */
5683 5666
5684 default: 5667 default:
5685 return OP_SET0; /* set! */ 5668 return OP_SET0; /* set! */
5686 } 5669 }
5687 5670
… …
5709 5692
5710 case 'f': 5693 case 'f':
5711 return OP_DEF0; /* define */ 5694 return OP_DEF0; /* define */
5712 5695
5713 default: 5696 default:
5714 return OP_LET0REC; /* letrec */ 5697 return OP_LET0REC;/* letrec */
5715 } 5698 }
5716 5699
5717 default: 5700 default:
5718 return OP_C0STREAM; /* cons-stream */ 5701 return OP_C0STREAM; /* cons-stream */
5719 } 5702 }

Diff Legend

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