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.14 by root, Thu Nov 26 08:56:32 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); 213enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
207static num num_mul (num a, num b); 214
208static num num_div (num a, num b); 215static num num_op (enum num_op op, num a, num b);
209static num num_intdiv (num a, num b); 216static num num_intdiv (num a, num b);
210static num num_sub (num a, num b);
211static num num_rem (num a, num b); 217static num num_rem (num a, num b);
212static num num_mod (num a, num b); 218static num num_mod (num a, num b);
213static int num_eq (num a, num b);
214static int num_gt (num a, num b);
215static int num_ge (num a, num b);
216static int num_lt (num a, num b);
217static int num_le (num a, num b);
218 219
219#if USE_MATH 220#if USE_MATH
220static double round_per_R5RS (double x); 221static double round_per_R5RS (double x);
221#endif 222#endif
222static int is_zero_rvalue (RVALUE x); 223static int is_zero_rvalue (RVALUE x);
… …
369{ 370{
370 return type (p) == T_PAIR; 371 return type (p) == T_PAIR;
371} 372}
372 373
373#define car(p) ((p)->object.cons.car + 0) 374#define car(p) ((p)->object.cons.car + 0)
374#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ 375#define cdr(p) ((p)->object.cons.cdr + 0)
375 376
376#define caar(p) car (car (p)) 377static pointer caar (pointer p) { return car (car (p)); }
377#define cadr(p) car (cdr (p)) 378static pointer cadr (pointer p) { return car (cdr (p)); }
378#define cdar(p) cdr (car (p)) 379static pointer cdar (pointer p) { return cdr (car (p)); }
379#define cddr(p) cdr (cdr (p)) 380static pointer cddr (pointer p) { return cdr (cdr (p)); }
380 381
381#define cadar(p) car (cdr (car (p))) 382static pointer cadar (pointer p) { return car (cdr (car (p))); }
382#define caddr(p) car (cdr (cdr (p))) 383static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
383#define cdaar(p) cdr (car (car (p))) 384static pointer cdaar (pointer p) { return cdr (car (car (p))); }
384 385
385INTERFACE void 386INTERFACE void
386set_car (pointer p, pointer q) 387set_car (pointer p, pointer q)
387{ 388{
388 p->object.cons.car = q; 389 p->object.cons.car = q;
… …
664static pointer ss_get_cont (SCHEME_P); 665static pointer ss_get_cont (SCHEME_P);
665static void ss_set_cont (SCHEME_P_ pointer cont); 666static void ss_set_cont (SCHEME_P_ pointer cont);
666static void dump_stack_mark (SCHEME_P); 667static void dump_stack_mark (SCHEME_P);
667static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); 668static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);
668static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); 669static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);
670static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
669static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 671static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);
670static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 672static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);
671static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 673static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);
672static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 674static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);
673static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 675static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
674static void assign_syntax (SCHEME_P_ const char *name); 676static void assign_syntax (SCHEME_P_ const char *name);
675static int syntaxnum (pointer p); 677static int syntaxnum (pointer p);
676static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 678static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
677 679
678static num 680static num
679num_add (num a, num b) 681num_op (enum num_op op, num a, num b)
680{ 682{
681 num ret; 683 num ret;
682 684
683 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 685 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
684 686
685 if (num_is_fixnum (ret)) 687 if (num_is_fixnum (ret))
686 num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b)); 688 {
689 IVALUE av = num_get_ivalue (a);
690 IVALUE bv = num_get_ivalue (b);
691
692 switch (op)
693 {
694 case NUM_ADD: av += bv; break;
695 case NUM_SUB: av -= bv; break;
696 case NUM_MUL: av *= bv; break;
697 case NUM_INTDIV: av /= bv; break;
698 }
699
700 num_set_ivalue (ret, av);
701 }
687 else 702 else
688 num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b)); 703 {
704 RVALUE av = num_get_rvalue (a);
705 RVALUE bv = num_get_rvalue (b);
689 706
690 return ret; 707 switch (op)
691} 708 {
709 case NUM_ADD: av += bv; break;
710 case NUM_SUB: av -= bv; break;
711 case NUM_MUL: av *= bv; break;
712 case NUM_INTDIV: av /= bv; break;
713 }
692 714
693static num 715 num_set_rvalue (ret, av);
694num_mul (num a, num b) 716 }
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 717
705 return ret; 718 return ret;
706} 719}
707 720
708static num 721static num
… …
719 732
720 return ret; 733 return ret;
721} 734}
722 735
723static num 736static 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
750 return ret;
751}
752
753static num
754num_rem (num a, num b) 737num_rem (num a, num b)
755{ 738{
756 num ret; 739 num ret;
757 long e1, e2, res; 740 long e1, e2, res;
758 741
… …
794 777
795 num_set_ivalue (ret, res); 778 num_set_ivalue (ret, res);
796 return ret; 779 return ret;
797} 780}
798 781
782/* this completely disrespects NaNs */
799static int 783static int
800num_eq (num a, num b) 784num_cmp (num a, num b)
801{ 785{
786 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
802 int ret; 787 int ret;
803 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
804 788
805 if (is_fixnum) 789 if (is_fixnum)
806 ret = num_get_ivalue (a) == num_get_ivalue (b); 790 {
791 IVALUE av = num_get_ivalue (a);
792 IVALUE bv = num_get_ivalue (b);
793
794 ret = av == bv ? 0 : av < bv ? -1 : +1;
795 }
807 else 796 else
808 ret = num_get_rvalue (a) == num_get_rvalue (b); 797 {
798 RVALUE av = num_get_rvalue (a);
799 RVALUE bv = num_get_rvalue (b);
800
801 ret = av == bv ? 0 : av < bv ? -1 : +1;
802 }
809 803
810 return ret; 804 return ret;
811}
812
813
814static int
815num_gt (num a, num b)
816{
817 int ret;
818 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
819
820 if (is_fixnum)
821 ret = num_get_ivalue (a) > num_get_ivalue (b);
822 else
823 ret = num_get_rvalue (a) > num_get_rvalue (b);
824
825 return ret;
826}
827
828static int
829num_ge (num a, num b)
830{
831 return !num_lt (a, b);
832}
833
834static int
835num_lt (num a, num b)
836{
837 int ret;
838 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
839
840 if (is_fixnum)
841 ret = num_get_ivalue (a) < num_get_ivalue (b);
842 else
843 ret = num_get_rvalue (a) < num_get_rvalue (b);
844
845 return ret;
846}
847
848static int
849num_le (num a, num b)
850{
851 return !num_gt (a, b);
852} 805}
853 806
854#if USE_MATH 807#if USE_MATH
855 808
856/* Round to nearest. Round to even if midway */ 809/* Round to nearest. Round to even if midway */
… …
965 918
966/* get new cell. parameter a, b is marked by gc. */ 919/* get new cell. parameter a, b is marked by gc. */
967static INLINE pointer 920static INLINE pointer
968get_cell_x (SCHEME_P_ pointer a, pointer b) 921get_cell_x (SCHEME_P_ pointer a, pointer b)
969{ 922{
970 if (SCHEME_V->free_cell == NIL) 923 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
971 { 924 {
972 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 925 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
973 return S_SINK; 926 return S_SINK;
974 927
975 if (SCHEME_V->free_cell == NIL) 928 if (SCHEME_V->free_cell == NIL)
… …
1481 1434
1482/* make constant */ 1435/* make constant */
1483static pointer 1436static pointer
1484mk_sharp_const (SCHEME_P_ char *name) 1437mk_sharp_const (SCHEME_P_ char *name)
1485{ 1438{
1486 long x;
1487 char tmp[STRBUFFSIZE];
1488
1489 if (!strcmp (name, "t")) 1439 if (!strcmp (name, "t"))
1490 return S_T; 1440 return S_T;
1491 else if (!strcmp (name, "f")) 1441 else if (!strcmp (name, "f"))
1492 return S_F; 1442 return S_F;
1493 else if (*name == '\\') /* #\w (character) */ 1443 else if (*name == '\\') /* #\w (character) */
1494 { 1444 {
1495 int c = 0; 1445 int c;
1496 1446
1497 if (stricmp (name + 1, "space") == 0) 1447 if (stricmp (name + 1, "space") == 0)
1498 c = ' '; 1448 c = ' ';
1499 else if (stricmp (name + 1, "newline") == 0) 1449 else if (stricmp (name + 1, "newline") == 0)
1500 c = '\n'; 1450 c = '\n';
… …
1502 c = '\r'; 1452 c = '\r';
1503 else if (stricmp (name + 1, "tab") == 0) 1453 else if (stricmp (name + 1, "tab") == 0)
1504 c = '\t'; 1454 c = '\t';
1505 else if (name[1] == 'x' && name[2] != 0) 1455 else if (name[1] == 'x' && name[2] != 0)
1506 { 1456 {
1507 int c1 = strtol (name + 2, 0, 16); 1457 long c1 = strtol (name + 2, 0, 16);
1508 1458
1509 if (c1 <= UCHAR_MAX) 1459 if (0 <= c1 && c1 <= UCHAR_MAX)
1510 c = c1; 1460 c = c1;
1511 else 1461 else
1512 return NIL; 1462 return NIL;
1513 1463 }
1514#if USE_ASCII_NAMES 1464#if USE_ASCII_NAMES
1515 }
1516 else if (is_ascii_name (name + 1, &c)) 1465 else if (is_ascii_name (name + 1, &c))
1517 {
1518 /* nothing */ 1466 /* nothing */;
1519#endif 1467#endif
1520 }
1521 else if (name[2] == 0) 1468 else if (name[2] == 0)
1522 c = name[1]; 1469 c = name[1];
1523 else 1470 else
1524 return NIL; 1471 return NIL;
1525 1472
… …
1542 1489
1543/*-- 1490/*--
1544 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1491 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1545 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1492 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1546 * for marking. 1493 * for marking.
1494 *
1495 * The exception is vectors - vectors are currently marked recursively,
1496 * which is inherited form tinyscheme and could be fixed by having another
1497 * word of context in the vector
1547 */ 1498 */
1548static void 1499static void
1549mark (pointer a) 1500mark (pointer a)
1550{ 1501{
1551 pointer t, q, p; 1502 pointer t, q, p;
… …
1553 t = 0; 1504 t = 0;
1554 p = a; 1505 p = a;
1555E2: 1506E2:
1556 setmark (p); 1507 setmark (p);
1557 1508
1558 if (is_vector (p)) 1509 if (ecb_expect_false (is_vector (p)))
1559 { 1510 {
1560 int i; 1511 int i;
1561 1512
1562 for (i = 0; i < p->object.vector.length; i++) 1513 for (i = 0; i < p->object.vector.length; i++)
1563 mark (vecvalue (p)[i]); 1514 mark (vecvalue (p)[i]);
… …
1686} 1637}
1687 1638
1688static void 1639static void
1689finalize_cell (SCHEME_P_ pointer a) 1640finalize_cell (SCHEME_P_ pointer a)
1690{ 1641{
1642 /* TODO, fast bitmap check? */
1691 if (is_string (a)) 1643 if (is_string (a))
1692 free (strvalue (a)); 1644 free (strvalue (a));
1693 else if (is_vector (a)) 1645 else if (is_vector (a))
1694 free (vecvalue (a)); 1646 free (vecvalue (a));
1695#if USE_PORTS 1647#if USE_PORTS
… …
2790 } 2742 }
2791 else if (is_number (a)) 2743 else if (is_number (a))
2792 { 2744 {
2793 if (is_number (b)) 2745 if (is_number (b))
2794 if (num_is_integer (a) == num_is_integer (b)) 2746 if (num_is_integer (a) == num_is_integer (b))
2795 return num_eq (nvalue (a), nvalue (b)); 2747 return num_cmp (nvalue (a), nvalue (b)) == 0;
2796 2748
2797 return 0; 2749 return 0;
2798 } 2750 }
2799 else if (is_character (a)) 2751 else if (is_character (a))
2800 { 2752 {
… …
3962 SCHEME_V->code = car (SCHEME_V->args); 3914 SCHEME_V->code = car (SCHEME_V->args);
3963 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); 3915 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3964 s_goto (OP_APPLY); 3916 s_goto (OP_APPLY);
3965 } 3917 }
3966 3918
3967 return S_T; 3919 abort ();
3968} 3920}
3969 3921
3970static pointer 3922static pointer
3971opexe_2 (SCHEME_P_ enum scheme_opcodes op) 3923opexe_2 (SCHEME_P_ enum scheme_opcodes op)
3972{ 3924{
… …
4101 4053
4102 case OP_ADD: /* + */ 4054 case OP_ADD: /* + */
4103 v = num_zero; 4055 v = num_zero;
4104 4056
4105 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4057 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4106 v = num_add (v, nvalue (car (x))); 4058 v = num_op ('+', v, nvalue (car (x)));
4107 4059
4108 s_return (mk_number (SCHEME_A_ v)); 4060 s_return (mk_number (SCHEME_A_ v));
4109 4061
4110 case OP_MUL: /* * */ 4062 case OP_MUL: /* * */
4111 v = num_one; 4063 v = num_one;
4112 4064
4113 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4065 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4114 v = num_mul (v, nvalue (car (x))); 4066 v = num_op ('+', v, nvalue (car (x)));
4115 4067
4116 s_return (mk_number (SCHEME_A_ v)); 4068 s_return (mk_number (SCHEME_A_ v));
4117 4069
4118 case OP_SUB: /* - */ 4070 case OP_SUB: /* - */
4119 if (cdr (SCHEME_V->args) == NIL) 4071 if (cdr (SCHEME_V->args) == NIL)
… …
4126 x = cdr (SCHEME_V->args); 4078 x = cdr (SCHEME_V->args);
4127 v = nvalue (car (SCHEME_V->args)); 4079 v = nvalue (car (SCHEME_V->args));
4128 } 4080 }
4129 4081
4130 for (; x != NIL; x = cdr (x)) 4082 for (; x != NIL; x = cdr (x))
4131 v = num_sub (v, nvalue (car (x))); 4083 v = num_op ('+', v, nvalue (car (x)));
4132 4084
4133 s_return (mk_number (SCHEME_A_ v)); 4085 s_return (mk_number (SCHEME_A_ v));
4134 4086
4135 case OP_DIV: /* / */ 4087 case OP_DIV: /* / */
4136 if (cdr (SCHEME_V->args) == NIL) 4088 if (cdr (SCHEME_V->args) == NIL)
… …
4167 } 4119 }
4168 4120
4169 for (; x != NIL; x = cdr (x)) 4121 for (; x != NIL; x = cdr (x))
4170 { 4122 {
4171 if (ivalue (car (x)) != 0) 4123 if (ivalue (car (x)) != 0)
4172 v = num_intdiv (v, nvalue (car (x))); 4124 v = num_op ('/', v, nvalue (car (x)));
4173 else 4125 else
4174 Error_0 ("quotient: division by zero"); 4126 Error_0 ("quotient: division by zero");
4175 } 4127 }
4176 4128
4177 s_return (mk_number (SCHEME_A_ v)); 4129 s_return (mk_number (SCHEME_A_ v));
… …
4565 } 4517 }
4566 } 4518 }
4567} 4519}
4568 4520
4569static pointer 4521static pointer
4522opexe_r (SCHEME_P_ enum scheme_opcodes op)
4523{
4524 pointer x = SCHEME_V->args;
4525
4526 for (;;)
4527 {
4528 num v = nvalue (car (x));
4529 x = cdr (x);
4530
4531 if (x == NIL)
4532 break;
4533
4534 int r = num_cmp (v, nvalue (car (x)));
4535
4536 switch (op)
4537 {
4538 case OP_NUMEQ: r = r == 0; break;
4539 case OP_LESS: r = r < 0; break;
4540 case OP_GRE: r = r > 0; break;
4541 case OP_LEQ: r = r <= 0; break;
4542 case OP_GEQ: r = r >= 0; break;
4543 }
4544
4545 if (!r)
4546 s_return (S_F);
4547 }
4548
4549 s_return (S_T);
4550}
4551
4552static pointer
4570opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4553opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4571{ 4554{
4572 pointer x; 4555 pointer x = SCHEME_V->args;
4573 num v; 4556 pointer a = car (x);
4574 int (*comp_func) (num, num); 4557 pointer d = cdr (x);
4558 int r;
4575 4559
4576 switch (op) 4560 switch (op)
4577 { 4561 {
4578 case OP_NOT: /* not */ 4562 case OP_NOT: /* not */
4579 s_retbool (is_false (car (SCHEME_V->args))); 4563 r = is_false (a); break;
4580 4564
4581 case OP_BOOLP: /* boolean? */ 4565 case OP_BOOLP: /* boolean? */
4582 s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T); 4566 r = a == S_F || a == S_T; break;
4583 4567
4584 case OP_EOFOBJP: /* boolean? */ 4568 case OP_EOFOBJP: /* eof-object? */
4585 s_retbool (car (SCHEME_V->args) == S_EOF); 4569 r = a == S_EOF; break;
4586 4570
4587 case OP_NULLP: /* null? */ 4571 case OP_NULLP: /* null? */
4588 s_retbool (car (SCHEME_V->args) == NIL); 4572 r = a == NIL; break;
4589
4590 case OP_NUMEQ: /* = */
4591 case OP_LESS: /* < */
4592 case OP_GRE: /* > */
4593 case OP_LEQ: /* <= */
4594 case OP_GEQ: /* >= */
4595 switch (op)
4596 {
4597 case OP_NUMEQ:
4598 comp_func = num_eq;
4599 break;
4600
4601 case OP_LESS:
4602 comp_func = num_lt;
4603 break;
4604
4605 case OP_GRE:
4606 comp_func = num_gt;
4607 break;
4608
4609 case OP_LEQ:
4610 comp_func = num_le;
4611 break;
4612
4613 case OP_GEQ:
4614 comp_func = num_ge;
4615 break;
4616 }
4617
4618 x = SCHEME_V->args;
4619 v = nvalue (car (x));
4620 x = cdr (x);
4621
4622 for (; x != NIL; x = cdr (x))
4623 {
4624 if (!comp_func (v, nvalue (car (x))))
4625 s_retbool (0);
4626
4627 v = nvalue (car (x));
4628 }
4629
4630 s_retbool (1);
4631 4573
4632 case OP_SYMBOLP: /* symbol? */ 4574 case OP_SYMBOLP: /* symbol? */
4633 s_retbool (is_symbol (car (SCHEME_V->args))); 4575 r = is_symbol (a); break;
4634 4576
4635 case OP_NUMBERP: /* number? */ 4577 case OP_NUMBERP: /* number? */
4636 s_retbool (is_number (car (SCHEME_V->args))); 4578 r = is_number (a); break;
4637 4579
4638 case OP_STRINGP: /* string? */ 4580 case OP_STRINGP: /* string? */
4639 s_retbool (is_string (car (SCHEME_V->args))); 4581 r = is_string (a); break;
4640 4582
4641 case OP_INTEGERP: /* integer? */ 4583 case OP_INTEGERP: /* integer? */
4642 s_retbool (is_integer (car (SCHEME_V->args))); 4584 r = is_integer (a); break;
4643 4585
4644 case OP_REALP: /* real? */ 4586 case OP_REALP: /* real? */
4645 s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */ 4587 r = is_number (a); break; /* all numbers are real */
4646 4588
4647 case OP_CHARP: /* char? */ 4589 case OP_CHARP: /* char? */
4648 s_retbool (is_character (car (SCHEME_V->args))); 4590 r = is_character (a); break;
4591
4649#if USE_CHAR_CLASSIFIERS 4592#if USE_CHAR_CLASSIFIERS
4650
4651 case OP_CHARAP: /* char-alphabetic? */ 4593 case OP_CHARAP: /* char-alphabetic? */
4652 s_retbool (Cisalpha (ivalue (car (SCHEME_V->args)))); 4594 r = Cisalpha (ivalue (a)); break;
4653 4595
4654 case OP_CHARNP: /* char-numeric? */ 4596 case OP_CHARNP: /* char-numeric? */
4655 s_retbool (Cisdigit (ivalue (car (SCHEME_V->args)))); 4597 r = Cisdigit (ivalue (a)); break;
4656 4598
4657 case OP_CHARWP: /* char-whitespace? */ 4599 case OP_CHARWP: /* char-whitespace? */
4658 s_retbool (Cisspace (ivalue (car (SCHEME_V->args)))); 4600 r = Cisspace (ivalue (a)); break;
4659 4601
4660 case OP_CHARUP: /* char-upper-case? */ 4602 case OP_CHARUP: /* char-upper-case? */
4661 s_retbool (Cisupper (ivalue (car (SCHEME_V->args)))); 4603 r = Cisupper (ivalue (a)); break;
4662 4604
4663 case OP_CHARLP: /* char-lower-case? */ 4605 case OP_CHARLP: /* char-lower-case? */
4664 s_retbool (Cislower (ivalue (car (SCHEME_V->args)))); 4606 r = Cislower (ivalue (a)); break;
4665#endif 4607#endif
4608
4666#if USE_PORTS 4609#if USE_PORTS
4667
4668 case OP_PORTP: /* port? */ 4610 case OP_PORTP: /* port? */
4669 s_retbool (is_port (car (SCHEME_V->args))); 4611 r = is_port (a); break;
4670 4612
4671 case OP_INPORTP: /* input-port? */ 4613 case OP_INPORTP: /* input-port? */
4672 s_retbool (is_inport (car (SCHEME_V->args))); 4614 r = is_inport (a); break;
4673 4615
4674 case OP_OUTPORTP: /* output-port? */ 4616 case OP_OUTPORTP: /* output-port? */
4675 s_retbool (is_outport (car (SCHEME_V->args))); 4617 r = is_outport (a); break;
4676#endif 4618#endif
4677 4619
4678 case OP_PROCP: /* procedure? */ 4620 case OP_PROCP: /* procedure? */
4679 4621
4680 /*-- 4622 /*--
4681 * continuation should be procedure by the example 4623 * continuation should be procedure by the example
4682 * (call-with-current-continuation procedure?) ==> #t 4624 * (call-with-current-continuation procedure?) ==> #t
4683 * in R^3 report sec. 6.9 4625 * in R^3 report sec. 6.9
4684 */ 4626 */
4685 s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args)) 4627 r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a);
4686 || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args))); 4628 break;
4687 4629
4688 case OP_PAIRP: /* pair? */ 4630 case OP_PAIRP: /* pair? */
4689 s_retbool (is_pair (car (SCHEME_V->args))); 4631 r = is_pair (a); break;
4690 4632
4691 case OP_LISTP: /* list? */ 4633 case OP_LISTP: /* list? */
4692 s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0); 4634 r = list_length (SCHEME_A_ a) >= 0; break;
4693 4635
4694 case OP_ENVP: /* environment? */ 4636 case OP_ENVP: /* environment? */
4695 s_retbool (is_environment (car (SCHEME_V->args))); 4637 r = is_environment (a); break;
4696 4638
4697 case OP_VECTORP: /* vector? */ 4639 case OP_VECTORP: /* vector? */
4698 s_retbool (is_vector (car (SCHEME_V->args))); 4640 r = is_vector (a); break;
4699 4641
4700 case OP_EQ: /* eq? */ 4642 case OP_EQ: /* eq? */
4701 s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args)); 4643 r = a == cadr (x); break;
4702 4644
4703 case OP_EQV: /* eqv? */ 4645 case OP_EQV: /* eqv? */
4704 s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args))); 4646 r = eqv (a, cadr (x)); break;
4705 } 4647 }
4706 4648
4707 return S_T; 4649 s_retbool (r);
4708} 4650}
4709 4651
4710static pointer 4652static pointer
4711opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4653opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4712{ 4654{
… …
5026 case OP_CURR_ENV: /* current-environment */ 4968 case OP_CURR_ENV: /* current-environment */
5027 s_return (SCHEME_V->envir); 4969 s_return (SCHEME_V->envir);
5028 4970
5029 } 4971 }
5030 4972
5031 return S_T; 4973 abort ();
5032} 4974}
5033 4975
5034static pointer 4976static pointer
5035opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4977opexe_5 (SCHEME_P_ enum scheme_opcodes op)
5036{ 4978{
… …
5375 s_goto (OP_P0LIST); 5317 s_goto (OP_P0LIST);
5376 } 5318 }
5377 } 5319 }
5378 } 5320 }
5379 5321
5380 return S_T; 5322 abort ();
5381} 5323}
5382 5324
5383static pointer 5325static pointer
5384opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5326opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5385{ 5327{
… …
5436 5378
5437 case OP_MACROP: /* macro? */ 5379 case OP_MACROP: /* macro? */
5438 s_retbool (is_macro (car (SCHEME_V->args))); 5380 s_retbool (is_macro (car (SCHEME_V->args)));
5439 } 5381 }
5440 5382
5441 return S_T; /* NOTREACHED */ 5383 abort ();
5442} 5384}
5443 5385
5444typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5386typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);
5445 5387
5446typedef int (*test_predicate) (pointer); 5388typedef int (*test_predicate) (pointer);
… …
5541 int ok = 1; 5483 int ok = 1;
5542 char msg[STRBUFFSIZE]; 5484 char msg[STRBUFFSIZE];
5543 int n = list_length (SCHEME_A_ SCHEME_V->args); 5485 int n = list_length (SCHEME_A_ SCHEME_V->args);
5544 5486
5545 /* Check number of arguments */ 5487 /* Check number of arguments */
5546 if (n < pcd->min_arity) 5488 if (ecb_expect_false (n < pcd->min_arity))
5547 { 5489 {
5548 ok = 0; 5490 ok = 0;
5549 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5491 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5550 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5492 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5551 } 5493 }
5552 5494 else if (ecb_excpect_false (n > pcd->max_arity))
5553 if (ok && n > pcd->max_arity)
5554 { 5495 {
5555 ok = 0; 5496 ok = 0;
5556 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5497 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5557 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5498 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5558 } 5499 }
5559 5500
5560 if (ok) 5501 if (ecb_expect_false (ok))
5561 { 5502 {
5562 if (pcd->arg_tests_encoding) 5503 if (pcd->arg_tests_encoding)
5563 { 5504 {
5564 int i = 0; 5505 int i = 0;
5565 int j; 5506 int j;
… …
5609 } 5550 }
5610#endif 5551#endif
5611 5552
5612 ok_to_freely_gc (SCHEME_A); 5553 ok_to_freely_gc (SCHEME_A);
5613 5554
5614 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5555 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5615 return; 5556 return;
5616 5557
5617 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5558 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5618 { 5559 {
5619 xwrstr ("No memory!\n"); 5560 xwrstr ("No memory!\n");
… …
5677 5618
5678 case 'd': 5619 case 'd':
5679 return OP_COND0; /* cond */ 5620 return OP_COND0; /* cond */
5680 5621
5681 case '*': 5622 case '*':
5682 return OP_LET0AST; /* let* */ 5623 return OP_LET0AST;/* let* */
5683 5624
5684 default: 5625 default:
5685 return OP_SET0; /* set! */ 5626 return OP_SET0; /* set! */
5686 } 5627 }
5687 5628
… …
5709 5650
5710 case 'f': 5651 case 'f':
5711 return OP_DEF0; /* define */ 5652 return OP_DEF0; /* define */
5712 5653
5713 default: 5654 default:
5714 return OP_LET0REC; /* letrec */ 5655 return OP_LET0REC;/* letrec */
5715 } 5656 }
5716 5657
5717 default: 5658 default:
5718 return OP_C0STREAM; /* cons-stream */ 5659 return OP_C0STREAM; /* cons-stream */
5719 } 5660 }

Diff Legend

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