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

Comparing microscheme/scheme.c (file contents):
Revision 1.52 by root, Tue Dec 1 01:56:22 2015 UTC vs.
Revision 1.55 by root, Tue Dec 1 03:03:11 2015 UTC

… …
103 } 103 }
104 104
105 char *p = s; 105 char *p = s;
106 106
107 do { 107 do {
108 *p++ = '0' + n % base; 108 *p++ = "0123456789abcdef"[n % base];
109 n /= base; 109 n /= base;
110 } while (n); 110 } while (n);
111 111
112 *p-- = 0; 112 *p-- = 0;
113 113
… …
123{ 123{
124 xbase (s, n, 10); 124 xbase (s, n, 10);
125} 125}
126 126
127static void 127static void
128xwrstr (const char *s) 128putnum (SCHEME_P_ long n)
129{
130 write (1, s, strlen (s));
131}
132
133static void
134xwrnum (long n)
135{ 129{
136 char buf[64]; 130 char buf[64];
137 131
138 xnum (buf, n); 132 xnum (buf, n);
139 xwrstr (buf); 133 putstr (SCHEME_A_ buf);
140} 134}
141 135
142static char 136static char
143xtoupper (char c) 137xtoupper (char c)
144{ 138{
… …
256static num num_op (enum num_op op, num a, num b); 250static num num_op (enum num_op op, num a, num b);
257static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
258static num num_rem (num a, num b); 252static num num_rem (num a, num b);
259static num num_mod (num a, num b); 253static num num_mod (num a, num b);
260 254
261#if USE_MATH
262static double round_per_R5RS (double x);
263#endif
264static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
265 256
266static num num_zero; 257static num num_zero;
267static num num_one; 258static num num_one;
268 259
… …
878 } 869 }
879 870
880 return ret; 871 return ret;
881} 872}
882 873
883#if USE_MATH
884
885/* Round to nearest. Round to even if midway */
886static double
887round_per_R5RS (double x)
888{
889 double fl = floor (x);
890 double ce = ceil (x);
891 double dfl = x - fl;
892 double dce = ce - x;
893
894 if (dfl > dce)
895 return ce;
896 else if (dfl < dce)
897 return fl;
898 else
899 {
900 if (fmod (fl, 2) == 0) /* I imagine this holds */
901 return fl;
902 else
903 return ce;
904 }
905}
906#endif
907
908static int 874static int
909is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
910{ 876{
911 return x == 0; 877 return x == 0;
912#if 0 878#if 0
… …
1058static void 1024static void
1059check_cell_alloced (pointer p, int expect_alloced) 1025check_cell_alloced (pointer p, int expect_alloced)
1060{ 1026{
1061 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1027 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1062 if (typeflag (p) & !expect_alloced) 1028 if (typeflag (p) & !expect_alloced)
1063 xwrstr ("Cell is already allocated!\n"); 1029 putstr (SCHEME_A_ "Cell is already allocated!\n");
1064 1030
1065 if (!(typeflag (p)) & expect_alloced) 1031 if (!(typeflag (p)) & expect_alloced)
1066 xwrstr ("Cell is not allocated!\n"); 1032 putstr (SCHEME_A_ "Cell is not allocated!\n");
1067} 1033}
1068 1034
1069static void 1035static void
1070check_range_alloced (pointer p, int n, int expect_alloced) 1036check_range_alloced (pointer p, int n, int expect_alloced)
1071{ 1037{
… …
1674 clrmark (NIL); 1640 clrmark (NIL);
1675 SCHEME_V->fcells = 0; 1641 SCHEME_V->fcells = 0;
1676 SCHEME_V->free_cell = NIL; 1642 SCHEME_V->free_cell = NIL;
1677 1643
1678 if (SCHEME_V->gc_verbose) 1644 if (SCHEME_V->gc_verbose)
1679 xwrstr ("freeing..."); 1645 putstr (SCHEME_A_ "freeing...");
1680 1646
1681 uint32_t total = 0; 1647 uint32_t total = 0;
1682 1648
1683 /* Here we scan the cells to build the free-list. */ 1649 /* Here we scan the cells to build the free-list. */
1684 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1650 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
… …
1710 } 1676 }
1711 } 1677 }
1712 1678
1713 if (SCHEME_V->gc_verbose) 1679 if (SCHEME_V->gc_verbose)
1714 { 1680 {
1715 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n"); 1681 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1716 } 1682 }
1717} 1683}
1718 1684
1719static void 1685static void
1720finalize_cell (SCHEME_P_ pointer a) 1686finalize_cell (SCHEME_P_ pointer a)
… …
2093 *pt->rep.string.curr++ = *s; 2059 *pt->rep.string.curr++ = *s;
2094 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) 2060 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2095 *pt->rep.string.curr++ = *s; 2061 *pt->rep.string.curr++ = *s;
2096 2062
2097#else 2063#else
2098 xwrstr (s); 2064 write (pt->rep.stdio.file, s, strlen (s));
2099#endif 2065#endif
2100} 2066}
2101 2067
2102static void 2068static void
2103putchars (SCHEME_P_ const char *s, int len) 2069putchars (SCHEME_P_ const char *s, int len)
… …
3343 s_return (S_T); 3309 s_return (S_T);
3344#endif 3310#endif
3345 case OP_LOAD: /* load */ 3311 case OP_LOAD: /* load */
3346 if (file_interactive (SCHEME_A)) 3312 if (file_interactive (SCHEME_A))
3347 { 3313 {
3348 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3314 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3349 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3315 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3350 } 3316 }
3351 3317
3352 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3318 if (!file_push (SCHEME_A_ strvalue (car (args))))
3353 Error_1 ("unable to open", car (args)); 3319 Error_1 ("unable to open", car (args));
… …
4033 3999
4034 switch (op) 4000 switch (op)
4035 { 4001 {
4036#if USE_MATH 4002#if USE_MATH
4037 case OP_INEX2EX: /* inexact->exact */ 4003 case OP_INEX2EX: /* inexact->exact */
4038 {
4039 if (is_integer (x)) 4004 if (!is_integer (x))
4040 s_return (x); 4005 {
4041
4042 RVALUE r = rvalue_unchecked (x); 4006 RVALUE r = rvalue_unchecked (x);
4043 4007
4044 if (r == (RVALUE)(IVALUE)r) 4008 if (r == (RVALUE)(IVALUE)r)
4045 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4009 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4046 else 4010 else
4047 Error_1 ("inexact->exact: not integral:", x); 4011 Error_1 ("inexact->exact: not integral:", x);
4048 } 4012 }
4013
4014 s_return (x);
4049 4015
4050 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4016 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4051 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4017 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4018 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4052 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4019 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4053 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4020 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4054 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4021 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4055 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4022 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4056 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4023 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4057 4024
4058 case OP_ATAN: 4025 case OP_ATAN:
4026 s_return (mk_real (SCHEME_A_
4059 if (cdr (args) == NIL) 4027 cdr (args) == NIL
4060 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4028 ? atan (rvalue (x))
4061 else 4029 : atan2 (rvalue (x), rvalue (cadr (args)))));
4062 {
4063 pointer y = cadr (args);
4064 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4065 }
4066 4030
4067 case OP_SQRT: 4031 case OP_SQRT:
4068 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); 4032 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4069 4033
4070 case OP_EXPT: 4034 case OP_EXPT:
… …
4097 s_return (mk_real (SCHEME_A_ result)); 4061 s_return (mk_real (SCHEME_A_ result));
4098 else 4062 else
4099 s_return (mk_integer (SCHEME_A_ result)); 4063 s_return (mk_integer (SCHEME_A_ result));
4100 } 4064 }
4101 4065
4102 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); 4066 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4103 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); 4067 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4104
4105 case OP_TRUNCATE:
4106 {
4107 RVALUE n = rvalue (x);
4108 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4109 }
4110
4111 case OP_ROUND:
4112 if (is_integer (x))
4113 s_return (x);
4114
4115 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); 4068 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4069 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4116#endif 4070#endif
4117 4071
4118 case OP_ADD: /* + */ 4072 case OP_ADD: /* + */
4119 v = num_zero; 4073 v = num_zero;
4120 4074
… …
5546 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5500 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5547 return; 5501 return;
5548 5502
5549 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5503 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5550 { 5504 {
5551 xwrstr ("No memory!\n"); 5505 putstr (SCHEME_A_ "No memory!\n");
5552 return; 5506 return;
5553 } 5507 }
5554 } 5508 }
5555} 5509}
5556 5510
… …
6040 int isfile = 1; 5994 int isfile = 1;
6041 system ("ps v $PPID");//D 5995 system ("ps v $PPID");//D
6042 5996
6043 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5997 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6044 { 5998 {
6045 xwrstr ("Usage: tinyscheme -?\n"); 5999 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6046 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6000 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6047 xwrstr ("followed by\n"); 6001 putstr (SCHEME_A_ "followed by\n");
6048 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6002 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6049 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6003 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6050 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6004 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6051 xwrstr ("Use - as filename for stdin.\n"); 6005 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6052 return 1; 6006 return 1;
6053 } 6007 }
6054 6008
6055 if (!scheme_init (SCHEME_A)) 6009 if (!scheme_init (SCHEME_A))
6056 { 6010 {
6057 xwrstr ("Could not initialize!\n"); 6011 putstr (SCHEME_A_ "Could not initialize!\n");
6058 return 2; 6012 return 2;
6059 } 6013 }
6060 6014
6061# if USE_PORTS 6015# if USE_PORTS
6062 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6016 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6107 fin = open (file_name, O_RDONLY); 6061 fin = open (file_name, O_RDONLY);
6108#endif 6062#endif
6109 6063
6110 if (isfile && fin < 0) 6064 if (isfile && fin < 0)
6111 { 6065 {
6112 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6066 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6113 } 6067 }
6114 else 6068 else
6115 { 6069 {
6116 if (isfile) 6070 if (isfile)
6117 scheme_load_named_file (SCHEME_A_ fin, file_name); 6071 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6121#if USE_PORTS 6075#if USE_PORTS
6122 if (!isfile || fin != STDIN_FILENO) 6076 if (!isfile || fin != STDIN_FILENO)
6123 { 6077 {
6124 if (SCHEME_V->retcode != 0) 6078 if (SCHEME_V->retcode != 0)
6125 { 6079 {
6126 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6080 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6127 } 6081 }
6128 6082
6129 if (isfile) 6083 if (isfile)
6130 close (fin); 6084 close (fin);
6131 } 6085 }

Diff Legend

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