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.51 by root, Tue Dec 1 01:54:27 2015 UTC vs.
Revision 1.57 by root, Tue Dec 1 04:57:49 2015 UTC

… …
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1 21#define EXPERIMENT 1
22 22
23#if 1
23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
24#include "malloc.c" 25#include "malloc.c"
26#endif
25 27
26#define SCHEME_SOURCE 28#define SCHEME_SOURCE
27#include "scheme-private.h" 29#include "scheme-private.h"
28#ifndef WIN32 30#ifndef WIN32
29# include <unistd.h> 31# include <unistd.h>
… …
101 } 103 }
102 104
103 char *p = s; 105 char *p = s;
104 106
105 do { 107 do {
106 *p++ = '0' + n % base; 108 *p++ = "0123456789abcdef"[n % base];
107 n /= base; 109 n /= base;
108 } while (n); 110 } while (n);
109 111
110 *p-- = 0; 112 *p-- = 0;
111 113
… …
121{ 123{
122 xbase (s, n, 10); 124 xbase (s, n, 10);
123} 125}
124 126
125static void 127static void
126xwrstr (const char *s) 128putnum (SCHEME_P_ long n)
127{
128 write (1, s, strlen (s));
129}
130
131static void
132xwrnum (long n)
133{ 129{
134 char buf[64]; 130 char buf[64];
135 131
136 xnum (buf, n); 132 xnum (buf, n);
137 xwrstr (buf); 133 putstr (SCHEME_A_ buf);
138} 134}
139 135
140static char 136static char
141xtoupper (char c) 137xtoupper (char c)
142{ 138{
… …
254static num num_op (enum num_op op, num a, num b); 250static num num_op (enum num_op op, num a, num b);
255static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
256static num num_rem (num a, num b); 252static num num_rem (num a, num b);
257static num num_mod (num a, num b); 253static num num_mod (num a, num b);
258 254
259#if USE_MATH
260static double round_per_R5RS (double x);
261#endif
262static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
263 256
264static num num_zero; 257static num num_zero;
265static num num_one; 258static num num_one;
266 259
… …
876 } 869 }
877 870
878 return ret; 871 return ret;
879} 872}
880 873
881#if USE_MATH
882
883/* Round to nearest. Round to even if midway */
884static double
885round_per_R5RS (double x)
886{
887 double fl = floor (x);
888 double ce = ceil (x);
889 double dfl = x - fl;
890 double dce = ce - x;
891
892 if (dfl > dce)
893 return ce;
894 else if (dfl < dce)
895 return fl;
896 else
897 {
898 if (fmod (fl, 2) == 0) /* I imagine this holds */
899 return fl;
900 else
901 return ce;
902 }
903}
904#endif
905
906static int 874static int
907is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
908{ 876{
909 return x == 0; 877 return x == 0;
910#if 0 878#if 0
… …
1056static void 1024static void
1057check_cell_alloced (pointer p, int expect_alloced) 1025check_cell_alloced (pointer p, int expect_alloced)
1058{ 1026{
1059 /* 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. */
1060 if (typeflag (p) & !expect_alloced) 1028 if (typeflag (p) & !expect_alloced)
1061 xwrstr ("Cell is already allocated!\n"); 1029 putstr (SCHEME_A_ "Cell is already allocated!\n");
1062 1030
1063 if (!(typeflag (p)) & expect_alloced) 1031 if (!(typeflag (p)) & expect_alloced)
1064 xwrstr ("Cell is not allocated!\n"); 1032 putstr (SCHEME_A_ "Cell is not allocated!\n");
1065} 1033}
1066 1034
1067static void 1035static void
1068check_range_alloced (pointer p, int n, int expect_alloced) 1036check_range_alloced (pointer p, int n, int expect_alloced)
1069{ 1037{
… …
1507 return S_F; 1475 return S_F;
1508 else if (*name == '\\') /* #\w (character) */ 1476 else if (*name == '\\') /* #\w (character) */
1509 { 1477 {
1510 int c; 1478 int c;
1511 1479
1480 // TODO: optimise
1512 if (stricmp (name + 1, "space") == 0) 1481 if (stricmp (name + 1, "space") == 0)
1513 c = ' '; 1482 c = ' ';
1514 else if (stricmp (name + 1, "newline") == 0) 1483 else if (stricmp (name + 1, "newline") == 0)
1515 c = '\n'; 1484 c = '\n';
1516 else if (stricmp (name + 1, "return") == 0) 1485 else if (stricmp (name + 1, "return") == 0)
1517 c = '\r'; 1486 c = '\r';
1518 else if (stricmp (name + 1, "tab") == 0) 1487 else if (stricmp (name + 1, "tab") == 0)
1519 c = '\t'; 1488 c = '\t';
1489 else if (stricmp (name + 1, "alarm") == 0)
1490 c = 0x07;
1491 else if (stricmp (name + 1, "backspace") == 0)
1492 c = 0x08;
1493 else if (stricmp (name + 1, "escape") == 0)
1494 c = 0x1b;
1495 else if (stricmp (name + 1, "delete") == 0)
1496 c = 0x7f;
1497 else if (stricmp (name + 1, "null") == 0)
1498 c = 0;
1520 else if (name[1] == 'x' && name[2] != 0) 1499 else if (name[1] == 'x' && name[2] != 0)
1521 { 1500 {
1522 long c1 = strtol (name + 2, 0, 16); 1501 long c1 = strtol (name + 2, 0, 16);
1523 1502
1524 if (0 <= c1 && c1 <= UCHAR_MAX) 1503 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1672 clrmark (NIL); 1651 clrmark (NIL);
1673 SCHEME_V->fcells = 0; 1652 SCHEME_V->fcells = 0;
1674 SCHEME_V->free_cell = NIL; 1653 SCHEME_V->free_cell = NIL;
1675 1654
1676 if (SCHEME_V->gc_verbose) 1655 if (SCHEME_V->gc_verbose)
1677 xwrstr ("freeing..."); 1656 putstr (SCHEME_A_ "freeing...");
1678 1657
1679 uint32_t total = 0; 1658 uint32_t total = 0;
1680 1659
1681 /* Here we scan the cells to build the free-list. */ 1660 /* Here we scan the cells to build the free-list. */
1682 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1661 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
… …
1708 } 1687 }
1709 } 1688 }
1710 1689
1711 if (SCHEME_V->gc_verbose) 1690 if (SCHEME_V->gc_verbose)
1712 { 1691 {
1713 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n"); 1692 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");
1714 } 1693 }
1715} 1694}
1716 1695
1717static void 1696static void
1718finalize_cell (SCHEME_P_ pointer a) 1697finalize_cell (SCHEME_P_ pointer a)
… …
2091 *pt->rep.string.curr++ = *s; 2070 *pt->rep.string.curr++ = *s;
2092 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) 2071 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2093 *pt->rep.string.curr++ = *s; 2072 *pt->rep.string.curr++ = *s;
2094 2073
2095#else 2074#else
2096 xwrstr (s); 2075 write (pt->rep.stdio.file, s, strlen (s));
2097#endif 2076#endif
2098} 2077}
2099 2078
2100static void 2079static void
2101putchars (SCHEME_P_ const char *s, int len) 2080putchars (SCHEME_P_ const char *s, int len)
… …
2207 case '7': 2186 case '7':
2208 state = st_oct1; 2187 state = st_oct1;
2209 c1 = c - '0'; 2188 c1 = c - '0';
2210 break; 2189 break;
2211 2190
2191 case 'a': *p++ = '\a'; state = st_ok; break;
2192 case 'n': *p++ = '\n'; state = st_ok; break;
2193 case 'r': *p++ = '\r'; state = st_ok; break;
2194 case 't': *p++ = '\t'; state = st_ok; break;
2195
2196 //TODO: \whitespace eol whitespace
2197
2198 //TODO: x should end in ;, not two-digit hex
2212 case 'x': 2199 case 'x':
2213 case 'X': 2200 case 'X':
2214 state = st_x1; 2201 state = st_x1;
2215 c1 = 0; 2202 c1 = 0;
2216 break;
2217
2218 case 'n':
2219 *p++ = '\n';
2220 state = st_ok;
2221 break;
2222
2223 case 't':
2224 *p++ = '\t';
2225 state = st_ok;
2226 break;
2227
2228 case 'r':
2229 *p++ = '\r';
2230 state = st_ok;
2231 break; 2203 break;
2232 2204
2233 default: 2205 default:
2234 *p++ = c; 2206 *p++ = c;
2235 state = st_ok; 2207 state = st_ok;
… …
3341 s_return (S_T); 3313 s_return (S_T);
3342#endif 3314#endif
3343 case OP_LOAD: /* load */ 3315 case OP_LOAD: /* load */
3344 if (file_interactive (SCHEME_A)) 3316 if (file_interactive (SCHEME_A))
3345 { 3317 {
3346 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3318 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3347 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3319 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3348 } 3320 }
3349 3321
3350 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3322 if (!file_push (SCHEME_A_ strvalue (car (args))))
3351 Error_1 ("unable to open", car (args)); 3323 Error_1 ("unable to open", car (args));
… …
4031 4003
4032 switch (op) 4004 switch (op)
4033 { 4005 {
4034#if USE_MATH 4006#if USE_MATH
4035 case OP_INEX2EX: /* inexact->exact */ 4007 case OP_INEX2EX: /* inexact->exact */
4036 {
4037 if (is_integer (x)) 4008 if (!is_integer (x))
4038 s_return (x); 4009 {
4039
4040 RVALUE r = rvalue_unchecked (x); 4010 RVALUE r = rvalue_unchecked (x);
4041 4011
4042 if (r == (RVALUE)(IVALUE)r) 4012 if (r == (RVALUE)(IVALUE)r)
4043 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4013 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4044 else 4014 else
4045 Error_1 ("inexact->exact: not integral:", x); 4015 Error_1 ("inexact->exact: not integral:", x);
4046 } 4016 }
4047 4017
4018 s_return (x);
4019
4020 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4021 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4022 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4023 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4024
4025 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4048 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4026 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4049 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4027 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4028 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4050 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4029 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4051 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4030 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4052 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4031 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4053 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4032 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4054 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4033 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4055 4034
4056 case OP_ATAN: 4035 case OP_ATAN:
4036 s_return (mk_real (SCHEME_A_
4057 if (cdr (args) == NIL) 4037 cdr (args) == NIL
4058 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4038 ? atan (rvalue (x))
4059 else 4039 : atan2 (rvalue (x), rvalue (cadr (args)))));
4060 {
4061 pointer y = cadr (args);
4062 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4063 }
4064
4065 case OP_SQRT:
4066 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4067 4040
4068 case OP_EXPT: 4041 case OP_EXPT:
4069 { 4042 {
4070 RVALUE result; 4043 RVALUE result;
4071 int real_result = 1; 4044 int real_result = 1;
… …
4094 if (real_result) 4067 if (real_result)
4095 s_return (mk_real (SCHEME_A_ result)); 4068 s_return (mk_real (SCHEME_A_ result));
4096 else 4069 else
4097 s_return (mk_integer (SCHEME_A_ result)); 4070 s_return (mk_integer (SCHEME_A_ result));
4098 } 4071 }
4099
4100 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4101 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4102
4103 case OP_TRUNCATE:
4104 {
4105 RVALUE n = rvalue (x);
4106 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4107 }
4108
4109 case OP_ROUND:
4110 if (is_integer (x))
4111 s_return (x);
4112
4113 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4114#endif 4072#endif
4115 4073
4116 case OP_ADD: /* + */ 4074 case OP_ADD: /* + */
4117 v = num_zero; 4075 v = num_zero;
4118 4076
… …
4420 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4378 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4421 4379
4422 s_return (newstr); 4380 s_return (newstr);
4423 } 4381 }
4424 4382
4425 case OP_SUBSTR: /* substring */ 4383 case OP_STRING_COPY: /* substring/string-copy */
4426 { 4384 {
4427 char *str = strvalue (x); 4385 char *str = strvalue (x);
4428 int index0 = ivalue_unchecked (cadr (args)); 4386 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4429 int index1; 4387 int index1;
4430 int len; 4388 int len;
4431 4389
4432 if (index0 > strlength (x)) 4390 if (index0 > strlength (x))
4433 Error_1 ("substring: start out of bounds:", cadr (args)); 4391 Error_1 ("string->copy: start out of bounds:", cadr (args));
4434 4392
4435 if (cddr (args) != NIL) 4393 if (cddr (args) != NIL)
4436 { 4394 {
4437 index1 = ivalue_unchecked (caddr (args)); 4395 index1 = ivalue_unchecked (caddr (args));
4438 4396
4439 if (index1 > strlength (x) || index1 < index0) 4397 if (index1 > strlength (x) || index1 < index0)
4440 Error_1 ("substring: end out of bounds:", caddr (args)); 4398 Error_1 ("string->copy: end out of bounds:", caddr (args));
4441 } 4399 }
4442 else 4400 else
4443 index1 = strlength (x); 4401 index1 = strlength (x);
4444 4402
4445 len = index1 - index0; 4403 len = index1 - index0;
4446 x = mk_empty_string (SCHEME_A_ len, ' '); 4404 x = mk_counted_string (SCHEME_A_ str + index0, len);
4447 memcpy (strvalue (x), str + index0, len);
4448 strvalue (x)[len] = 0;
4449 4405
4450 s_return (x); 4406 s_return (x);
4451 } 4407 }
4452 4408
4453 case OP_VECTOR: /* vector */ 4409 case OP_VECTOR: /* vector */
… …
5544 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))
5545 return; 5501 return;
5546 5502
5547 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5503 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5548 { 5504 {
5549 xwrstr ("No memory!\n"); 5505 putstr (SCHEME_A_ "No memory!\n");
5550 return; 5506 return;
5551 } 5507 }
5552 } 5508 }
5553} 5509}
5554 5510
… …
6038 int isfile = 1; 5994 int isfile = 1;
6039 system ("ps v $PPID");//D 5995 system ("ps v $PPID");//D
6040 5996
6041 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5997 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6042 { 5998 {
6043 xwrstr ("Usage: tinyscheme -?\n"); 5999 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6044 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6000 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6045 xwrstr ("followed by\n"); 6001 putstr (SCHEME_A_ "followed by\n");
6046 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6002 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6047 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6003 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6048 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6004 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6049 xwrstr ("Use - as filename for stdin.\n"); 6005 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6050 return 1; 6006 return 1;
6051 } 6007 }
6052 6008
6053 if (!scheme_init (SCHEME_A)) 6009 if (!scheme_init (SCHEME_A))
6054 { 6010 {
6055 xwrstr ("Could not initialize!\n"); 6011 putstr (SCHEME_A_ "Could not initialize!\n");
6056 return 2; 6012 return 2;
6057 } 6013 }
6058 6014
6059# if USE_PORTS 6015# if USE_PORTS
6060 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6016 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6105 fin = open (file_name, O_RDONLY); 6061 fin = open (file_name, O_RDONLY);
6106#endif 6062#endif
6107 6063
6108 if (isfile && fin < 0) 6064 if (isfile && fin < 0)
6109 { 6065 {
6110 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");
6111 } 6067 }
6112 else 6068 else
6113 { 6069 {
6114 if (isfile) 6070 if (isfile)
6115 scheme_load_named_file (SCHEME_A_ fin, file_name); 6071 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6119#if USE_PORTS 6075#if USE_PORTS
6120 if (!isfile || fin != STDIN_FILENO) 6076 if (!isfile || fin != STDIN_FILENO)
6121 { 6077 {
6122 if (SCHEME_V->retcode != 0) 6078 if (SCHEME_V->retcode != 0)
6123 { 6079 {
6124 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");
6125 } 6081 }
6126 6082
6127 if (isfile) 6083 if (isfile)
6128 close (fin); 6084 close (fin);
6129 } 6085 }

Diff Legend

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