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.15 by root, Thu Nov 26 09: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
… …
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;
… …
621static int file_push (SCHEME_P_ const char *fname); 622static int file_push (SCHEME_P_ const char *fname);
622static void file_pop (SCHEME_P); 623static void file_pop (SCHEME_P);
623static int file_interactive (SCHEME_P); 624static int file_interactive (SCHEME_P);
624static INLINE int is_one_of (char *s, int c); 625static INLINE int is_one_of (char *s, int c);
625static int alloc_cellseg (SCHEME_P_ int n); 626static 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); 627static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);
628static void finalize_cell (SCHEME_P_ pointer a); 628static void finalize_cell (SCHEME_P_ pointer a);
629static int count_consecutive_cells (pointer x, int needed); 629static int count_consecutive_cells (pointer x, int needed);
630static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 630static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
631static pointer mk_number (SCHEME_P_ const num n); 631static pointer mk_number (SCHEME_P_ const num n);
… …
665static pointer ss_get_cont (SCHEME_P); 665static pointer ss_get_cont (SCHEME_P);
666static void ss_set_cont (SCHEME_P_ pointer cont); 666static void ss_set_cont (SCHEME_P_ pointer cont);
667static void dump_stack_mark (SCHEME_P); 667static void dump_stack_mark (SCHEME_P);
668static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); 668static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);
669static 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);
670static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 671static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);
671static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 672static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);
672static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 673static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);
673static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 674static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);
674static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 675static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
675static void assign_syntax (SCHEME_P_ const char *name); 676static void assign_syntax (SCHEME_P_ const char *name);
676static int syntaxnum (pointer p); 677static int syntaxnum (pointer p);
677static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 678static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
678 679
679static num 680static num
680num_add (num a, num b) 681num_op (enum num_op op, num a, num b)
681{ 682{
682 num ret; 683 num ret;
683 684
684 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));
685 686
686 if (num_is_fixnum (ret)) 687 if (num_is_fixnum (ret))
687 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 }
688 else 702 else
689 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);
690 706
691 return ret; 707 switch (op)
692} 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 }
693 714
694static num 715 num_set_rvalue (ret, av);
695num_mul (num a, num b) 716 }
696{
697 num ret;
698
699 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
700
701 if (num_is_fixnum (ret))
702 num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
703 else
704 num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
705 717
706 return ret; 718 return ret;
707} 719}
708 720
709static num 721static num
… …
720 732
721 return ret; 733 return ret;
722} 734}
723 735
724static num 736static num
725num_intdiv (num a, num b)
726{
727 num ret;
728
729 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
730
731 if (num_is_fixnum (ret))
732 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
733 else
734 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
735
736 return ret;
737}
738
739static num
740num_sub (num a, num b)
741{
742 num ret;
743
744 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
745
746 if (num_is_fixnum (ret))
747 num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
748 else
749 num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
750
751 return ret;
752}
753
754static num
755num_rem (num a, num b) 737num_rem (num a, num b)
756{ 738{
757 num ret; 739 num ret;
758 long e1, e2, res; 740 long e1, e2, res;
759 741
… …
795 777
796 num_set_ivalue (ret, res); 778 num_set_ivalue (ret, res);
797 return ret; 779 return ret;
798} 780}
799 781
782/* this completely disrespects NaNs */
800static int 783static int
801num_eq (num a, num b) 784num_cmp (num a, num b)
802{ 785{
786 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
803 int ret; 787 int ret;
804 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
805 788
806 if (is_fixnum) 789 if (is_fixnum)
807 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 }
808 else 796 else
809 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 }
810 803
811 return ret; 804 return ret;
812}
813
814
815static int
816num_gt (num a, num b)
817{
818 int ret;
819 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
820
821 if (is_fixnum)
822 ret = num_get_ivalue (a) > num_get_ivalue (b);
823 else
824 ret = num_get_rvalue (a) > num_get_rvalue (b);
825
826 return ret;
827}
828
829static int
830num_ge (num a, num b)
831{
832 return !num_lt (a, b);
833}
834
835static int
836num_lt (num a, num b)
837{
838 int ret;
839 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
840
841 if (is_fixnum)
842 ret = num_get_ivalue (a) < num_get_ivalue (b);
843 else
844 ret = num_get_rvalue (a) < num_get_rvalue (b);
845
846 return ret;
847}
848
849static int
850num_le (num a, num b)
851{
852 return !num_gt (a, b);
853} 805}
854 806
855#if USE_MATH 807#if USE_MATH
856 808
857/* Round to nearest. Round to even if midway */ 809/* Round to nearest. Round to even if midway */
… …
883#if USE_REAL 835#if USE_REAL
884 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 836 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
885#else 837#else
886 return x == 0; 838 return x == 0;
887#endif 839#endif
888}
889
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} 840}
904 841
905/* allocate new cell segment */ 842/* allocate new cell segment */
906static int 843static int
907alloc_cellseg (SCHEME_P_ int n) 844alloc_cellseg (SCHEME_P_ int n)
… …
981 918
982/* get new cell. parameter a, b is marked by gc. */ 919/* get new cell. parameter a, b is marked by gc. */
983static INLINE pointer 920static INLINE pointer
984get_cell_x (SCHEME_P_ pointer a, pointer b) 921get_cell_x (SCHEME_P_ pointer a, pointer b)
985{ 922{
986 if (SCHEME_V->free_cell == NIL) 923 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
987 { 924 {
988 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 925 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
989 return S_SINK; 926 return S_SINK;
990 927
991 if (SCHEME_V->free_cell == NIL) 928 if (SCHEME_V->free_cell == NIL)
… …
1320 } 1257 }
1321 1258
1322 return q; 1259 return q;
1323} 1260}
1324 1261
1325/* get new string */
1326INTERFACE pointer 1262INTERFACE pointer
1327mk_string (SCHEME_P_ const char *str) 1263mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1328{ 1264{
1329 return mk_counted_string (SCHEME_A_ str, strlen (str)); 1265 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1266
1267 set_typeflag (x, T_STRING | T_ATOM);
1268 strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
1269 strlength (x) = len;
1270 return x;
1330} 1271}
1331 1272
1332INTERFACE pointer 1273INTERFACE pointer
1333mk_counted_string (SCHEME_P_ const char *str, uint32_t len) 1274mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1334{ 1275{
… …
1339 strlength (x) = len; 1280 strlength (x) = len;
1340 return x; 1281 return x;
1341} 1282}
1342 1283
1343INTERFACE pointer 1284INTERFACE pointer
1344mk_empty_string (SCHEME_P_ uint32_t len, char fill) 1285mk_string (SCHEME_P_ const char *str)
1345{ 1286{
1346 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1287 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} 1288}
1353 1289
1354INTERFACE pointer 1290INTERFACE pointer
1355mk_vector (SCHEME_P_ uint32_t len) 1291mk_vector (SCHEME_P_ uint32_t len)
1356{ 1292{
… …
1393 1329
1394INTERFACE pointer 1330INTERFACE pointer
1395gensym (SCHEME_P) 1331gensym (SCHEME_P)
1396{ 1332{
1397 pointer x; 1333 pointer x;
1398 char name[40];
1399 1334
1400 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++) 1335 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1401 { 1336 {
1402 strcpy (name, "gensym-"); 1337 char name[40] = "gensym-";
1403 xnum (name + 7, SCHEME_V->gensym_cnt); 1338 xnum (name + 7, SCHEME_V->gensym_cnt);
1404 1339
1405 /* first check oblist */ 1340 /* first check oblist */
1406 x = oblist_find_by_name (SCHEME_A_ name); 1341 x = oblist_find_by_name (SCHEME_A_ name);
1407 1342
1408 if (x != NIL) 1343 if (x == NIL)
1409 continue;
1410 else
1411 { 1344 {
1412 x = oblist_add_by_name (SCHEME_A_ name); 1345 x = oblist_add_by_name (SCHEME_A_ name);
1413 return x; 1346 return x;
1414 } 1347 }
1415 } 1348 }
… …
1424 char c, *p; 1357 char c, *p;
1425 int has_dec_point = 0; 1358 int has_dec_point = 0;
1426 int has_fp_exp = 0; 1359 int has_fp_exp = 0;
1427 1360
1428#if USE_COLON_HOOK 1361#if USE_COLON_HOOK
1429
1430 if ((p = strstr (q, "::")) != 0) 1362 if ((p = strstr (q, "::")) != 0)
1431 { 1363 {
1432 *p = 0; 1364 *p = 0;
1433 return cons (SCHEME_V->COLON_HOOK, 1365 return cons (SCHEME_V->COLON_HOOK,
1434 cons (cons (SCHEME_V->QUOTE, 1366 cons (cons (SCHEME_V->QUOTE,
1435 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); 1367 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1436 } 1368 }
1437
1438#endif 1369#endif
1439 1370
1440 p = q; 1371 p = q;
1441 c = *p++; 1372 c = *p++;
1442 1373
… …
1503 1434
1504/* make constant */ 1435/* make constant */
1505static pointer 1436static pointer
1506mk_sharp_const (SCHEME_P_ char *name) 1437mk_sharp_const (SCHEME_P_ char *name)
1507{ 1438{
1508 long x;
1509 char tmp[STRBUFFSIZE];
1510
1511 if (!strcmp (name, "t")) 1439 if (!strcmp (name, "t"))
1512 return S_T; 1440 return S_T;
1513 else if (!strcmp (name, "f")) 1441 else if (!strcmp (name, "f"))
1514 return S_F; 1442 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) */ 1443 else if (*name == '\\') /* #\w (character) */
1536 { 1444 {
1537 int c = 0; 1445 int c;
1538 1446
1539 if (stricmp (name + 1, "space") == 0) 1447 if (stricmp (name + 1, "space") == 0)
1540 c = ' '; 1448 c = ' ';
1541 else if (stricmp (name + 1, "newline") == 0) 1449 else if (stricmp (name + 1, "newline") == 0)
1542 c = '\n'; 1450 c = '\n';
… …
1544 c = '\r'; 1452 c = '\r';
1545 else if (stricmp (name + 1, "tab") == 0) 1453 else if (stricmp (name + 1, "tab") == 0)
1546 c = '\t'; 1454 c = '\t';
1547 else if (name[1] == 'x' && name[2] != 0) 1455 else if (name[1] == 'x' && name[2] != 0)
1548 { 1456 {
1549 int c1 = strtol (name + 2, 0, 16); 1457 long c1 = strtol (name + 2, 0, 16);
1550 1458
1551 if (c1 <= UCHAR_MAX) 1459 if (0 <= c1 && c1 <= UCHAR_MAX)
1552 c = c1; 1460 c = c1;
1553 else 1461 else
1554 return NIL; 1462 return NIL;
1555 1463 }
1556#if USE_ASCII_NAMES 1464#if USE_ASCII_NAMES
1557 }
1558 else if (is_ascii_name (name + 1, &c)) 1465 else if (is_ascii_name (name + 1, &c))
1559 {
1560 /* nothing */ 1466 /* nothing */;
1561#endif 1467#endif
1562 }
1563 else if (name[2] == 0) 1468 else if (name[2] == 0)
1564 c = name[1]; 1469 c = name[1];
1565 else 1470 else
1566 return NIL; 1471 return NIL;
1567 1472
1568 return mk_character (SCHEME_A_ c); 1473 return mk_character (SCHEME_A_ c);
1569 } 1474 }
1570 else 1475 else
1476 {
1477 /* identify base by string index */
1478 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1479 char *base = strchr (baseidx, *name);
1480
1481 if (base)
1482 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1483
1571 return NIL; 1484 return NIL;
1485 }
1572} 1486}
1573 1487
1574/* ========== garbage collector ========== */ 1488/* ========== garbage collector ========== */
1575 1489
1576/*-- 1490/*--
1577 * 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,
1578 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1492 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1579 * 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
1580 */ 1498 */
1581static void 1499static void
1582mark (pointer a) 1500mark (pointer a)
1583{ 1501{
1584 pointer t, q, p; 1502 pointer t, q, p;
… …
1586 t = 0; 1504 t = 0;
1587 p = a; 1505 p = a;
1588E2: 1506E2:
1589 setmark (p); 1507 setmark (p);
1590 1508
1591 if (is_vector (p)) 1509 if (ecb_expect_false (is_vector (p)))
1592 { 1510 {
1593 int i; 1511 int i;
1594 1512
1595 for (i = 0; i < p->object.vector.length; i++) 1513 for (i = 0; i < p->object.vector.length; i++)
1596 mark (vecvalue (p)[i]); 1514 mark (vecvalue (p)[i]);
… …
1719} 1637}
1720 1638
1721static void 1639static void
1722finalize_cell (SCHEME_P_ pointer a) 1640finalize_cell (SCHEME_P_ pointer a)
1723{ 1641{
1642 /* TODO, fast bitmap check? */
1724 if (is_string (a)) 1643 if (is_string (a))
1725 free (strvalue (a)); 1644 free (strvalue (a));
1726 else if (is_vector (a)) 1645 else if (is_vector (a))
1727 free (vecvalue (a)); 1646 free (vecvalue (a));
1728#if USE_PORTS 1647#if USE_PORTS
… …
2823 } 2742 }
2824 else if (is_number (a)) 2743 else if (is_number (a))
2825 { 2744 {
2826 if (is_number (b)) 2745 if (is_number (b))
2827 if (num_is_integer (a) == num_is_integer (b)) 2746 if (num_is_integer (a) == num_is_integer (b))
2828 return num_eq (nvalue (a), nvalue (b)); 2747 return num_cmp (nvalue (a), nvalue (b)) == 0;
2829 2748
2830 return 0; 2749 return 0;
2831 } 2750 }
2832 else if (is_character (a)) 2751 else if (is_character (a))
2833 { 2752 {
… …
3995 SCHEME_V->code = car (SCHEME_V->args); 3914 SCHEME_V->code = car (SCHEME_V->args);
3996 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);
3997 s_goto (OP_APPLY); 3916 s_goto (OP_APPLY);
3998 } 3917 }
3999 3918
4000 return S_T; 3919 abort ();
4001} 3920}
4002 3921
4003static pointer 3922static pointer
4004opexe_2 (SCHEME_P_ enum scheme_opcodes op) 3923opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4005{ 3924{
… …
4134 4053
4135 case OP_ADD: /* + */ 4054 case OP_ADD: /* + */
4136 v = num_zero; 4055 v = num_zero;
4137 4056
4138 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4057 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4139 v = num_add (v, nvalue (car (x))); 4058 v = num_op ('+', v, nvalue (car (x)));
4140 4059
4141 s_return (mk_number (SCHEME_A_ v)); 4060 s_return (mk_number (SCHEME_A_ v));
4142 4061
4143 case OP_MUL: /* * */ 4062 case OP_MUL: /* * */
4144 v = num_one; 4063 v = num_one;
4145 4064
4146 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4065 for (x = SCHEME_V->args; x != NIL; x = cdr (x))
4147 v = num_mul (v, nvalue (car (x))); 4066 v = num_op ('+', v, nvalue (car (x)));
4148 4067
4149 s_return (mk_number (SCHEME_A_ v)); 4068 s_return (mk_number (SCHEME_A_ v));
4150 4069
4151 case OP_SUB: /* - */ 4070 case OP_SUB: /* - */
4152 if (cdr (SCHEME_V->args) == NIL) 4071 if (cdr (SCHEME_V->args) == NIL)
… …
4159 x = cdr (SCHEME_V->args); 4078 x = cdr (SCHEME_V->args);
4160 v = nvalue (car (SCHEME_V->args)); 4079 v = nvalue (car (SCHEME_V->args));
4161 } 4080 }
4162 4081
4163 for (; x != NIL; x = cdr (x)) 4082 for (; x != NIL; x = cdr (x))
4164 v = num_sub (v, nvalue (car (x))); 4083 v = num_op ('+', v, nvalue (car (x)));
4165 4084
4166 s_return (mk_number (SCHEME_A_ v)); 4085 s_return (mk_number (SCHEME_A_ v));
4167 4086
4168 case OP_DIV: /* / */ 4087 case OP_DIV: /* / */
4169 if (cdr (SCHEME_V->args) == NIL) 4088 if (cdr (SCHEME_V->args) == NIL)
… …
4200 } 4119 }
4201 4120
4202 for (; x != NIL; x = cdr (x)) 4121 for (; x != NIL; x = cdr (x))
4203 { 4122 {
4204 if (ivalue (car (x)) != 0) 4123 if (ivalue (car (x)) != 0)
4205 v = num_intdiv (v, nvalue (car (x))); 4124 v = num_op ('/', v, nvalue (car (x)));
4206 else 4125 else
4207 Error_0 ("quotient: division by zero"); 4126 Error_0 ("quotient: division by zero");
4208 } 4127 }
4209 4128
4210 s_return (mk_number (SCHEME_A_ v)); 4129 s_return (mk_number (SCHEME_A_ v));
… …
4598 } 4517 }
4599 } 4518 }
4600} 4519}
4601 4520
4602static 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
4603opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4553opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4604{ 4554{
4605 pointer x; 4555 pointer x = SCHEME_V->args;
4606 num v; 4556 pointer a = car (x);
4607 int (*comp_func) (num, num); 4557 pointer d = cdr (x);
4558 int r;
4608 4559
4609 switch (op) 4560 switch (op)
4610 { 4561 {
4611 case OP_NOT: /* not */ 4562 case OP_NOT: /* not */ r = is_false (a) ; break;
4612 s_retbool (is_false (car (SCHEME_V->args))); 4563 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break;
4564 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4565 case OP_NULLP: /* null? */ r = a == NIL ; break;
4566 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4567 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4568 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4569 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4570 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4571 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4613 4572
4614 case OP_BOOLP: /* boolean? */
4615 s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T);
4616
4617 case OP_EOFOBJP: /* boolean? */
4618 s_retbool (car (SCHEME_V->args) == S_EOF);
4619
4620 case OP_NULLP: /* null? */
4621 s_retbool (car (SCHEME_V->args) == NIL);
4622
4623 case OP_NUMEQ: /* = */
4624 case OP_LESS: /* < */
4625 case OP_GRE: /* > */
4626 case OP_LEQ: /* <= */
4627 case OP_GEQ: /* >= */
4628 switch (op)
4629 {
4630 case OP_NUMEQ:
4631 comp_func = num_eq;
4632 break;
4633
4634 case OP_LESS:
4635 comp_func = num_lt;
4636 break;
4637
4638 case OP_GRE:
4639 comp_func = num_gt;
4640 break;
4641
4642 case OP_LEQ:
4643 comp_func = num_le;
4644 break;
4645
4646 case OP_GEQ:
4647 comp_func = num_ge;
4648 break;
4649 }
4650
4651 x = SCHEME_V->args;
4652 v = nvalue (car (x));
4653 x = cdr (x);
4654
4655 for (; x != NIL; x = cdr (x))
4656 {
4657 if (!comp_func (v, nvalue (car (x))))
4658 s_retbool (0);
4659
4660 v = nvalue (car (x));
4661 }
4662
4663 s_retbool (1);
4664
4665 case OP_SYMBOLP: /* symbol? */
4666 s_retbool (is_symbol (car (SCHEME_V->args)));
4667
4668 case OP_NUMBERP: /* number? */
4669 s_retbool (is_number (car (SCHEME_V->args)));
4670
4671 case OP_STRINGP: /* string? */
4672 s_retbool (is_string (car (SCHEME_V->args)));
4673
4674 case OP_INTEGERP: /* integer? */
4675 s_retbool (is_integer (car (SCHEME_V->args)));
4676
4677 case OP_REALP: /* real? */
4678 s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */
4679
4680 case OP_CHARP: /* char? */
4681 s_retbool (is_character (car (SCHEME_V->args)));
4682#if USE_CHAR_CLASSIFIERS 4573#if USE_CHAR_CLASSIFIERS
4683
4684 case OP_CHARAP: /* char-alphabetic? */ 4574 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break;
4685 s_retbool (Cisalpha (ivalue (car (SCHEME_V->args)))); 4575 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break;
4686
4687 case OP_CHARNP: /* char-numeric? */
4688 s_retbool (Cisdigit (ivalue (car (SCHEME_V->args))));
4689
4690 case OP_CHARWP: /* char-whitespace? */ 4576 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break;
4691 s_retbool (Cisspace (ivalue (car (SCHEME_V->args))));
4692
4693 case OP_CHARUP: /* char-upper-case? */ 4577 case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break;
4694 s_retbool (Cisupper (ivalue (car (SCHEME_V->args))));
4695
4696 case OP_CHARLP: /* char-lower-case? */ 4578 case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break;
4697 s_retbool (Cislower (ivalue (car (SCHEME_V->args))));
4698#endif 4579#endif
4580
4699#if USE_PORTS 4581#if USE_PORTS
4700 4582 case OP_PORTP: /* port? */ r = is_port (a) ; break;
4701 case OP_PORTP: /* port? */
4702 s_retbool (is_port (car (SCHEME_V->args)));
4703
4704 case OP_INPORTP: /* input-port? */ 4583 case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
4705 s_retbool (is_inport (car (SCHEME_V->args)));
4706
4707 case OP_OUTPORTP: /* output-port? */ 4584 case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break;
4708 s_retbool (is_outport (car (SCHEME_V->args)));
4709#endif 4585#endif
4710 4586
4711 case OP_PROCP: /* procedure? */ 4587 case OP_PROCP: /* procedure? */
4712 4588
4713 /*-- 4589 /*--
4714 * continuation should be procedure by the example 4590 * continuation should be procedure by the example
4715 * (call-with-current-continuation procedure?) ==> #t 4591 * (call-with-current-continuation procedure?) ==> #t
4716 * in R^3 report sec. 6.9 4592 * in R^3 report sec. 6.9
4717 */ 4593 */
4718 s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args)) 4594 r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a);
4719 || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args))); 4595 break;
4720 4596
4721 case OP_PAIRP: /* pair? */ 4597 case OP_PAIRP: /* pair? */ r = is_pair (a) ; break;
4722 s_retbool (is_pair (car (SCHEME_V->args))); 4598 case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break;
4723 4599 case OP_ENVP: /* environment? */ r = is_environment (a) ; break;
4724 case OP_LISTP: /* list? */ 4600 case OP_VECTORP: /* vector? */ r = is_vector (a) ; break;
4725 s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0); 4601 case OP_EQ: /* eq? */ r = a == cadr (x) ; break;
4726 4602 case OP_EQV: /* eqv? */ r = eqv (a, cadr (x)) ; break;
4727 case OP_ENVP: /* environment? */
4728 s_retbool (is_environment (car (SCHEME_V->args)));
4729
4730 case OP_VECTORP: /* vector? */
4731 s_retbool (is_vector (car (SCHEME_V->args)));
4732
4733 case OP_EQ: /* eq? */
4734 s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args));
4735
4736 case OP_EQV: /* eqv? */
4737 s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args)));
4738 } 4603 }
4739 4604
4740 return S_T; 4605 s_retbool (r);
4741} 4606}
4742 4607
4743static pointer 4608static pointer
4744opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4609opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4745{ 4610{
… …
5059 case OP_CURR_ENV: /* current-environment */ 4924 case OP_CURR_ENV: /* current-environment */
5060 s_return (SCHEME_V->envir); 4925 s_return (SCHEME_V->envir);
5061 4926
5062 } 4927 }
5063 4928
5064 return S_T; 4929 abort ();
5065} 4930}
5066 4931
5067static pointer 4932static pointer
5068opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4933opexe_5 (SCHEME_P_ enum scheme_opcodes op)
5069{ 4934{
… …
5408 s_goto (OP_P0LIST); 5273 s_goto (OP_P0LIST);
5409 } 5274 }
5410 } 5275 }
5411 } 5276 }
5412 5277
5413 return S_T; 5278 abort ();
5414} 5279}
5415 5280
5416static pointer 5281static pointer
5417opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5282opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5418{ 5283{
… …
5469 5334
5470 case OP_MACROP: /* macro? */ 5335 case OP_MACROP: /* macro? */
5471 s_retbool (is_macro (car (SCHEME_V->args))); 5336 s_retbool (is_macro (car (SCHEME_V->args)));
5472 } 5337 }
5473 5338
5474 return S_T; /* NOTREACHED */ 5339 abort ();
5475} 5340}
5476 5341
5477typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5342typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);
5478 5343
5479typedef int (*test_predicate) (pointer); 5344typedef int (*test_predicate) (pointer);
… …
5574 int ok = 1; 5439 int ok = 1;
5575 char msg[STRBUFFSIZE]; 5440 char msg[STRBUFFSIZE];
5576 int n = list_length (SCHEME_A_ SCHEME_V->args); 5441 int n = list_length (SCHEME_A_ SCHEME_V->args);
5577 5442
5578 /* Check number of arguments */ 5443 /* Check number of arguments */
5579 if (n < pcd->min_arity) 5444 if (ecb_expect_false (n < pcd->min_arity))
5580 { 5445 {
5581 ok = 0; 5446 ok = 0;
5582 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5447 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5583 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5448 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5584 } 5449 }
5585 5450 else if (ecb_excpect_false (n > pcd->max_arity))
5586 if (ok && n > pcd->max_arity)
5587 { 5451 {
5588 ok = 0; 5452 ok = 0;
5589 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5453 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5590 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5454 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5591 } 5455 }
5592 5456
5593 if (ok) 5457 if (ecb_expect_false (ok))
5594 { 5458 {
5595 if (pcd->arg_tests_encoding) 5459 if (pcd->arg_tests_encoding)
5596 { 5460 {
5597 int i = 0; 5461 int i = 0;
5598 int j; 5462 int j;
… …
5642 } 5506 }
5643#endif 5507#endif
5644 5508
5645 ok_to_freely_gc (SCHEME_A); 5509 ok_to_freely_gc (SCHEME_A);
5646 5510
5647 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5511 if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))
5648 return; 5512 return;
5649 5513
5650 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5514 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5651 { 5515 {
5652 xwrstr ("No memory!\n"); 5516 xwrstr ("No memory!\n");
… …
5710 5574
5711 case 'd': 5575 case 'd':
5712 return OP_COND0; /* cond */ 5576 return OP_COND0; /* cond */
5713 5577
5714 case '*': 5578 case '*':
5715 return OP_LET0AST; /* let* */ 5579 return OP_LET0AST;/* let* */
5716 5580
5717 default: 5581 default:
5718 return OP_SET0; /* set! */ 5582 return OP_SET0; /* set! */
5719 } 5583 }
5720 5584
… …
5742 5606
5743 case 'f': 5607 case 'f':
5744 return OP_DEF0; /* define */ 5608 return OP_DEF0; /* define */
5745 5609
5746 default: 5610 default:
5747 return OP_LET0REC; /* letrec */ 5611 return OP_LET0REC;/* letrec */
5748 } 5612 }
5749 5613
5750 default: 5614 default:
5751 return OP_C0STREAM; /* cons-stream */ 5615 return OP_C0STREAM; /* cons-stream */
5752 } 5616 }

Diff Legend

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