ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/scheme.c
(Generate patch)

Comparing microscheme/scheme.c (file contents):
Revision 1.13 by root, Thu Nov 26 07:59:42 2015 UTC vs.
Revision 1.14 by root, Thu Nov 26 08:56:32 2015 UTC

… …
208#define T_SYNTAX 0x0010 208#define T_SYNTAX 0x0010
209#define T_IMMUTABLE 0x0020 209#define T_IMMUTABLE 0x0020
210#define T_ATOM 0x0040 /* only for gc */ 210#define T_ATOM 0x0040 /* only for gc */
211#define T_MARK 0x0080 /* only for gc */ 211#define T_MARK 0x0080 /* only for gc */
212 212
213enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
214
213static num num_op (char op, num a, num b); 215static num num_op (enum num_op op, num a, num b);
214static num num_intdiv (num a, num b); 216static num num_intdiv (num a, num b);
215static num num_rem (num a, num b); 217static num num_rem (num a, num b);
216static num num_mod (num a, num b); 218static num num_mod (num a, num b);
217static int num_eq (num a, num b);
218static int num_gt (num a, num b);
219static int num_ge (num a, num b);
220static int num_lt (num a, num b);
221static int num_le (num a, num b);
222 219
223#if USE_MATH 220#if USE_MATH
224static double round_per_R5RS (double x); 221static double round_per_R5RS (double x);
225#endif 222#endif
226static int is_zero_rvalue (RVALUE x); 223static int is_zero_rvalue (RVALUE x);
… …
668static pointer ss_get_cont (SCHEME_P); 665static pointer ss_get_cont (SCHEME_P);
669static void ss_set_cont (SCHEME_P_ pointer cont); 666static void ss_set_cont (SCHEME_P_ pointer cont);
670static void dump_stack_mark (SCHEME_P); 667static void dump_stack_mark (SCHEME_P);
671static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); 668static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);
672static 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);
673static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 671static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);
674static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 672static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);
675static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 673static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);
676static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 674static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);
677static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 675static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
678static void assign_syntax (SCHEME_P_ const char *name); 676static void assign_syntax (SCHEME_P_ const char *name);
679static int syntaxnum (pointer p); 677static int syntaxnum (pointer p);
680static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 678static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
681 679
682static num 680static num
683num_op (char op, num a, num b) 681num_op (enum num_op op, num a, num b)
684{ 682{
685 num ret; 683 num ret;
686 684
687 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));
688 686
… …
691 IVALUE av = num_get_ivalue (a); 689 IVALUE av = num_get_ivalue (a);
692 IVALUE bv = num_get_ivalue (b); 690 IVALUE bv = num_get_ivalue (b);
693 691
694 switch (op) 692 switch (op)
695 { 693 {
696 case '+': av += bv; break; 694 case NUM_ADD: av += bv; break;
697 case '-': av -= bv; break; 695 case NUM_SUB: av -= bv; break;
698 case '*': av *= bv; break; 696 case NUM_MUL: av *= bv; break;
699 case '/': av /= bv; break; 697 case NUM_INTDIV: av /= bv; break;
700 } 698 }
701 699
702 num_set_ivalue (ret, av); 700 num_set_ivalue (ret, av);
703 } 701 }
704 else 702 else
… …
706 RVALUE av = num_get_rvalue (a); 704 RVALUE av = num_get_rvalue (a);
707 RVALUE bv = num_get_rvalue (b); 705 RVALUE bv = num_get_rvalue (b);
708 706
709 switch (op) 707 switch (op)
710 { 708 {
711 case '+': av += bv; break; 709 case NUM_ADD: av += bv; break;
712 case '-': av -= bv; break; 710 case NUM_SUB: av -= bv; break;
713 case '*': av *= bv; break; 711 case NUM_MUL: av *= bv; break;
714 case '/': av /= bv; break; 712 case NUM_INTDIV: av /= bv; break;
715 } 713 }
716 714
717 num_set_rvalue (ret, av); 715 num_set_rvalue (ret, av);
718 } 716 }
719 717
… …
779 777
780 num_set_ivalue (ret, res); 778 num_set_ivalue (ret, res);
781 return ret; 779 return ret;
782} 780}
783 781
782/* this completely disrespects NaNs */
784static int 783static int
785num_eq (num a, num b) 784num_cmp (num a, num b)
786{ 785{
786 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
787 int ret; 787 int ret;
788 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
789 788
790 if (is_fixnum) 789 if (is_fixnum)
791 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 }
792 else 796 else
793 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 }
794 803
795 return ret; 804 return ret;
796}
797
798
799static int
800num_gt (num a, num b)
801{
802 int ret;
803 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
804
805 if (is_fixnum)
806 ret = num_get_ivalue (a) > num_get_ivalue (b);
807 else
808 ret = num_get_rvalue (a) > num_get_rvalue (b);
809
810 return ret;
811}
812
813static int
814num_ge (num a, num b)
815{
816 return !num_lt (a, b);
817}
818
819static int
820num_lt (num a, num b)
821{
822 int ret;
823 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
824
825 if (is_fixnum)
826 ret = num_get_ivalue (a) < num_get_ivalue (b);
827 else
828 ret = num_get_rvalue (a) < num_get_rvalue (b);
829
830 return ret;
831}
832
833static int
834num_le (num a, num b)
835{
836 return !num_gt (a, b);
837} 805}
838 806
839#if USE_MATH 807#if USE_MATH
840 808
841/* Round to nearest. Round to even if midway */ 809/* Round to nearest. Round to even if midway */
… …
2774 } 2742 }
2775 else if (is_number (a)) 2743 else if (is_number (a))
2776 { 2744 {
2777 if (is_number (b)) 2745 if (is_number (b))
2778 if (num_is_integer (a) == num_is_integer (b)) 2746 if (num_is_integer (a) == num_is_integer (b))
2779 return num_eq (nvalue (a), nvalue (b)); 2747 return num_cmp (nvalue (a), nvalue (b)) == 0;
2780 2748
2781 return 0; 2749 return 0;
2782 } 2750 }
2783 else if (is_character (a)) 2751 else if (is_character (a))
2784 { 2752 {
… …
3946 SCHEME_V->code = car (SCHEME_V->args); 3914 SCHEME_V->code = car (SCHEME_V->args);
3947 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);
3948 s_goto (OP_APPLY); 3916 s_goto (OP_APPLY);
3949 } 3917 }
3950 3918
3951 return S_T; 3919 abort ();
3952} 3920}
3953 3921
3954static pointer 3922static pointer
3955opexe_2 (SCHEME_P_ enum scheme_opcodes op) 3923opexe_2 (SCHEME_P_ enum scheme_opcodes op)
3956{ 3924{
… …
4549 } 4517 }
4550 } 4518 }
4551} 4519}
4552 4520
4553static 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
4554opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4553opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4555{ 4554{
4556 pointer x; 4555 pointer x = SCHEME_V->args;
4557 num v; 4556 pointer a = car (x);
4558 int (*comp_func) (num, num); 4557 pointer d = cdr (x);
4558 int r;
4559 4559
4560 switch (op) 4560 switch (op)
4561 { 4561 {
4562 case OP_NOT: /* not */ 4562 case OP_NOT: /* not */
4563 s_retbool (is_false (car (SCHEME_V->args))); 4563 r = is_false (a); break;
4564 4564
4565 case OP_BOOLP: /* boolean? */ 4565 case OP_BOOLP: /* boolean? */
4566 s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T); 4566 r = a == S_F || a == S_T; break;
4567 4567
4568 case OP_EOFOBJP: /* boolean? */ 4568 case OP_EOFOBJP: /* eof-object? */
4569 s_retbool (car (SCHEME_V->args) == S_EOF); 4569 r = a == S_EOF; break;
4570 4570
4571 case OP_NULLP: /* null? */ 4571 case OP_NULLP: /* null? */
4572 s_retbool (car (SCHEME_V->args) == NIL); 4572 r = a == NIL; break;
4573
4574 case OP_NUMEQ: /* = */
4575 case OP_LESS: /* < */
4576 case OP_GRE: /* > */
4577 case OP_LEQ: /* <= */
4578 case OP_GEQ: /* >= */
4579 switch (op)
4580 {
4581 case OP_NUMEQ:
4582 comp_func = num_eq;
4583 break;
4584
4585 case OP_LESS:
4586 comp_func = num_lt;
4587 break;
4588
4589 case OP_GRE:
4590 comp_func = num_gt;
4591 break;
4592
4593 case OP_LEQ:
4594 comp_func = num_le;
4595 break;
4596
4597 case OP_GEQ:
4598 comp_func = num_ge;
4599 break;
4600 }
4601
4602 x = SCHEME_V->args;
4603 v = nvalue (car (x));
4604 x = cdr (x);
4605
4606 for (; x != NIL; x = cdr (x))
4607 {
4608 if (!comp_func (v, nvalue (car (x))))
4609 s_retbool (0);
4610
4611 v = nvalue (car (x));
4612 }
4613
4614 s_retbool (1);
4615 4573
4616 case OP_SYMBOLP: /* symbol? */ 4574 case OP_SYMBOLP: /* symbol? */
4617 s_retbool (is_symbol (car (SCHEME_V->args))); 4575 r = is_symbol (a); break;
4618 4576
4619 case OP_NUMBERP: /* number? */ 4577 case OP_NUMBERP: /* number? */
4620 s_retbool (is_number (car (SCHEME_V->args))); 4578 r = is_number (a); break;
4621 4579
4622 case OP_STRINGP: /* string? */ 4580 case OP_STRINGP: /* string? */
4623 s_retbool (is_string (car (SCHEME_V->args))); 4581 r = is_string (a); break;
4624 4582
4625 case OP_INTEGERP: /* integer? */ 4583 case OP_INTEGERP: /* integer? */
4626 s_retbool (is_integer (car (SCHEME_V->args))); 4584 r = is_integer (a); break;
4627 4585
4628 case OP_REALP: /* real? */ 4586 case OP_REALP: /* real? */
4629 s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */ 4587 r = is_number (a); break; /* all numbers are real */
4630 4588
4631 case OP_CHARP: /* char? */ 4589 case OP_CHARP: /* char? */
4632 s_retbool (is_character (car (SCHEME_V->args))); 4590 r = is_character (a); break;
4591
4633#if USE_CHAR_CLASSIFIERS 4592#if USE_CHAR_CLASSIFIERS
4634
4635 case OP_CHARAP: /* char-alphabetic? */ 4593 case OP_CHARAP: /* char-alphabetic? */
4636 s_retbool (Cisalpha (ivalue (car (SCHEME_V->args)))); 4594 r = Cisalpha (ivalue (a)); break;
4637 4595
4638 case OP_CHARNP: /* char-numeric? */ 4596 case OP_CHARNP: /* char-numeric? */
4639 s_retbool (Cisdigit (ivalue (car (SCHEME_V->args)))); 4597 r = Cisdigit (ivalue (a)); break;
4640 4598
4641 case OP_CHARWP: /* char-whitespace? */ 4599 case OP_CHARWP: /* char-whitespace? */
4642 s_retbool (Cisspace (ivalue (car (SCHEME_V->args)))); 4600 r = Cisspace (ivalue (a)); break;
4643 4601
4644 case OP_CHARUP: /* char-upper-case? */ 4602 case OP_CHARUP: /* char-upper-case? */
4645 s_retbool (Cisupper (ivalue (car (SCHEME_V->args)))); 4603 r = Cisupper (ivalue (a)); break;
4646 4604
4647 case OP_CHARLP: /* char-lower-case? */ 4605 case OP_CHARLP: /* char-lower-case? */
4648 s_retbool (Cislower (ivalue (car (SCHEME_V->args)))); 4606 r = Cislower (ivalue (a)); break;
4649#endif 4607#endif
4608
4650#if USE_PORTS 4609#if USE_PORTS
4651
4652 case OP_PORTP: /* port? */ 4610 case OP_PORTP: /* port? */
4653 s_retbool (is_port (car (SCHEME_V->args))); 4611 r = is_port (a); break;
4654 4612
4655 case OP_INPORTP: /* input-port? */ 4613 case OP_INPORTP: /* input-port? */
4656 s_retbool (is_inport (car (SCHEME_V->args))); 4614 r = is_inport (a); break;
4657 4615
4658 case OP_OUTPORTP: /* output-port? */ 4616 case OP_OUTPORTP: /* output-port? */
4659 s_retbool (is_outport (car (SCHEME_V->args))); 4617 r = is_outport (a); break;
4660#endif 4618#endif
4661 4619
4662 case OP_PROCP: /* procedure? */ 4620 case OP_PROCP: /* procedure? */
4663 4621
4664 /*-- 4622 /*--
4665 * continuation should be procedure by the example 4623 * continuation should be procedure by the example
4666 * (call-with-current-continuation procedure?) ==> #t 4624 * (call-with-current-continuation procedure?) ==> #t
4667 * in R^3 report sec. 6.9 4625 * in R^3 report sec. 6.9
4668 */ 4626 */
4669 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);
4670 || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args))); 4628 break;
4671 4629
4672 case OP_PAIRP: /* pair? */ 4630 case OP_PAIRP: /* pair? */
4673 s_retbool (is_pair (car (SCHEME_V->args))); 4631 r = is_pair (a); break;
4674 4632
4675 case OP_LISTP: /* list? */ 4633 case OP_LISTP: /* list? */
4676 s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0); 4634 r = list_length (SCHEME_A_ a) >= 0; break;
4677 4635
4678 case OP_ENVP: /* environment? */ 4636 case OP_ENVP: /* environment? */
4679 s_retbool (is_environment (car (SCHEME_V->args))); 4637 r = is_environment (a); break;
4680 4638
4681 case OP_VECTORP: /* vector? */ 4639 case OP_VECTORP: /* vector? */
4682 s_retbool (is_vector (car (SCHEME_V->args))); 4640 r = is_vector (a); break;
4683 4641
4684 case OP_EQ: /* eq? */ 4642 case OP_EQ: /* eq? */
4685 s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args)); 4643 r = a == cadr (x); break;
4686 4644
4687 case OP_EQV: /* eqv? */ 4645 case OP_EQV: /* eqv? */
4688 s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args))); 4646 r = eqv (a, cadr (x)); break;
4689 } 4647 }
4690 4648
4691 return S_T; 4649 s_retbool (r);
4692} 4650}
4693 4651
4694static pointer 4652static pointer
4695opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4653opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4696{ 4654{
… …
5010 case OP_CURR_ENV: /* current-environment */ 4968 case OP_CURR_ENV: /* current-environment */
5011 s_return (SCHEME_V->envir); 4969 s_return (SCHEME_V->envir);
5012 4970
5013 } 4971 }
5014 4972
5015 return S_T; 4973 abort ();
5016} 4974}
5017 4975
5018static pointer 4976static pointer
5019opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4977opexe_5 (SCHEME_P_ enum scheme_opcodes op)
5020{ 4978{
… …
5359 s_goto (OP_P0LIST); 5317 s_goto (OP_P0LIST);
5360 } 5318 }
5361 } 5319 }
5362 } 5320 }
5363 5321
5364 return S_T; 5322 abort ();
5365} 5323}
5366 5324
5367static pointer 5325static pointer
5368opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5326opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5369{ 5327{
… …
5420 5378
5421 case OP_MACROP: /* macro? */ 5379 case OP_MACROP: /* macro? */
5422 s_retbool (is_macro (car (SCHEME_V->args))); 5380 s_retbool (is_macro (car (SCHEME_V->args)));
5423 } 5381 }
5424 5382
5425 return S_T; /* NOTREACHED */ 5383 abort ();
5426} 5384}
5427 5385
5428typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5386typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);
5429 5387
5430typedef int (*test_predicate) (pointer); 5388typedef int (*test_predicate) (pointer);

Diff Legend

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