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.52 by root, Tue Dec 1 01:56:22 2015 UTC vs.
Revision 1.59 by root, Tue Dec 1 07:13:25 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{
… …
199#endif 193#endif
200 194
201enum scheme_types 195enum scheme_types
202{ 196{
203 T_INTEGER, 197 T_INTEGER,
198 T_CHARACTER,
204 T_REAL, 199 T_REAL,
205 T_STRING, 200 T_STRING,
206 T_SYMBOL, 201 T_SYMBOL,
207 T_PROC, 202 T_PROC,
208 T_PAIR, /* also used for free cells */ 203 T_PAIR, /* also used for free cells */
209 T_CLOSURE, 204 T_CLOSURE,
205 T_MACRO,
210 T_CONTINUATION, 206 T_CONTINUATION,
211 T_FOREIGN, 207 T_FOREIGN,
212 T_CHARACTER,
213 T_PORT, 208 T_PORT,
214 T_VECTOR, 209 T_VECTOR,
215 T_MACRO,
216 T_PROMISE, 210 T_PROMISE,
217 T_ENVIRONMENT, 211 T_ENVIRONMENT,
218 /* one more... */ 212 /* one more... */
219 T_NUM_SYSTEM_TYPES 213 T_NUM_SYSTEM_TYPES
220}; 214};
… …
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{
… …
1509 return S_F; 1475 return S_F;
1510 else if (*name == '\\') /* #\w (character) */ 1476 else if (*name == '\\') /* #\w (character) */
1511 { 1477 {
1512 int c; 1478 int c;
1513 1479
1480 // TODO: optimise
1514 if (stricmp (name + 1, "space") == 0) 1481 if (stricmp (name + 1, "space") == 0)
1515 c = ' '; 1482 c = ' ';
1516 else if (stricmp (name + 1, "newline") == 0) 1483 else if (stricmp (name + 1, "newline") == 0)
1517 c = '\n'; 1484 c = '\n';
1518 else if (stricmp (name + 1, "return") == 0) 1485 else if (stricmp (name + 1, "return") == 0)
1519 c = '\r'; 1486 c = '\r';
1520 else if (stricmp (name + 1, "tab") == 0) 1487 else if (stricmp (name + 1, "tab") == 0)
1521 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;
1522 else if (name[1] == 'x' && name[2] != 0) 1499 else if (name[1] == 'x' && name[2] != 0)
1523 { 1500 {
1524 long c1 = strtol (name + 2, 0, 16); 1501 long c1 = strtol (name + 2, 0, 16);
1525 1502
1526 if (0 <= c1 && c1 <= UCHAR_MAX) 1503 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1674 clrmark (NIL); 1651 clrmark (NIL);
1675 SCHEME_V->fcells = 0; 1652 SCHEME_V->fcells = 0;
1676 SCHEME_V->free_cell = NIL; 1653 SCHEME_V->free_cell = NIL;
1677 1654
1678 if (SCHEME_V->gc_verbose) 1655 if (SCHEME_V->gc_verbose)
1679 xwrstr ("freeing..."); 1656 putstr (SCHEME_A_ "freeing...");
1680 1657
1681 uint32_t total = 0; 1658 uint32_t total = 0;
1682 1659
1683 /* Here we scan the cells to build the free-list. */ 1660 /* Here we scan the cells to build the free-list. */
1684 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1661 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
… …
1710 } 1687 }
1711 } 1688 }
1712 1689
1713 if (SCHEME_V->gc_verbose) 1690 if (SCHEME_V->gc_verbose)
1714 { 1691 {
1715 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");
1716 } 1693 }
1717} 1694}
1718 1695
1719static void 1696static void
1720finalize_cell (SCHEME_P_ pointer a) 1697finalize_cell (SCHEME_P_ pointer a)
… …
2093 *pt->rep.string.curr++ = *s; 2070 *pt->rep.string.curr++ = *s;
2094 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))
2095 *pt->rep.string.curr++ = *s; 2072 *pt->rep.string.curr++ = *s;
2096 2073
2097#else 2074#else
2098 xwrstr (s); 2075 write (pt->rep.stdio.file, s, strlen (s));
2099#endif 2076#endif
2100} 2077}
2101 2078
2102static void 2079static void
2103putchars (SCHEME_P_ const char *s, int len) 2080putchars (SCHEME_P_ const char *s, int len)
… …
2209 case '7': 2186 case '7':
2210 state = st_oct1; 2187 state = st_oct1;
2211 c1 = c - '0'; 2188 c1 = c - '0';
2212 break; 2189 break;
2213 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
2214 case 'x': 2199 case 'x':
2215 case 'X': 2200 case 'X':
2216 state = st_x1; 2201 state = st_x1;
2217 c1 = 0; 2202 c1 = 0;
2218 break;
2219
2220 case 'n':
2221 *p++ = '\n';
2222 state = st_ok;
2223 break;
2224
2225 case 't':
2226 *p++ = '\t';
2227 state = st_ok;
2228 break;
2229
2230 case 'r':
2231 *p++ = '\r';
2232 state = st_ok;
2233 break; 2203 break;
2234 2204
2235 default: 2205 default:
2236 *p++ = c; 2206 *p++ = c;
2237 state = st_ok; 2207 state = st_ok;
… …
3343 s_return (S_T); 3313 s_return (S_T);
3344#endif 3314#endif
3345 case OP_LOAD: /* load */ 3315 case OP_LOAD: /* load */
3346 if (file_interactive (SCHEME_A)) 3316 if (file_interactive (SCHEME_A))
3347 { 3317 {
3348 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3318 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))); 3319 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3350 } 3320 }
3351 3321
3352 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3322 if (!file_push (SCHEME_A_ strvalue (car (args))))
3353 Error_1 ("unable to open", car (args)); 3323 Error_1 ("unable to open", car (args));
… …
4033 4003
4034 switch (op) 4004 switch (op)
4035 { 4005 {
4036#if USE_MATH 4006#if USE_MATH
4037 case OP_INEX2EX: /* inexact->exact */ 4007 case OP_INEX2EX: /* inexact->exact */
4038 {
4039 if (is_integer (x)) 4008 if (!is_integer (x))
4040 s_return (x); 4009 {
4041
4042 RVALUE r = rvalue_unchecked (x); 4010 RVALUE r = rvalue_unchecked (x);
4043 4011
4044 if (r == (RVALUE)(IVALUE)r) 4012 if (r == (RVALUE)(IVALUE)r)
4045 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4013 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4046 else 4014 else
4047 Error_1 ("inexact->exact: not integral:", x); 4015 Error_1 ("inexact->exact: not integral:", x);
4048 } 4016 }
4049 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))));
4050 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))));
4051 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))))));
4052 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))));
4053 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))));
4054 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))));
4055 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))));
4056 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))));
4057 4034
4058 case OP_ATAN: 4035 case OP_ATAN:
4036 s_return (mk_real (SCHEME_A_
4059 if (cdr (args) == NIL) 4037 cdr (args) == NIL
4060 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4038 ? atan (rvalue (x))
4061 else 4039 : 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
4067 case OP_SQRT:
4068 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4069 4040
4070 case OP_EXPT: 4041 case OP_EXPT:
4071 { 4042 {
4072 RVALUE result; 4043 RVALUE result;
4073 int real_result = 1; 4044 int real_result = 1;
… …
4096 if (real_result) 4067 if (real_result)
4097 s_return (mk_real (SCHEME_A_ result)); 4068 s_return (mk_real (SCHEME_A_ result));
4098 else 4069 else
4099 s_return (mk_integer (SCHEME_A_ result)); 4070 s_return (mk_integer (SCHEME_A_ result));
4100 } 4071 }
4101
4102 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))));
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))));
4116#endif 4072#endif
4117 4073
4118 case OP_ADD: /* + */ 4074 case OP_ADD: /* + */
4119 v = num_zero; 4075 v = num_zero;
4120 4076
… …
4422 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4378 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4423 4379
4424 s_return (newstr); 4380 s_return (newstr);
4425 } 4381 }
4426 4382
4427 case OP_SUBSTR: /* substring */ 4383 case OP_STRING_COPY: /* substring/string-copy */
4428 { 4384 {
4429 char *str = strvalue (x); 4385 char *str = strvalue (x);
4430 int index0 = ivalue_unchecked (cadr (args)); 4386 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4431 int index1; 4387 int index1;
4432 int len; 4388 int len;
4433 4389
4434 if (index0 > strlength (x)) 4390 if (index0 > strlength (x))
4435 Error_1 ("substring: start out of bounds:", cadr (args)); 4391 Error_1 ("string->copy: start out of bounds:", cadr (args));
4436 4392
4437 if (cddr (args) != NIL) 4393 if (cddr (args) != NIL)
4438 { 4394 {
4439 index1 = ivalue_unchecked (caddr (args)); 4395 index1 = ivalue_unchecked (caddr (args));
4440 4396
4441 if (index1 > strlength (x) || index1 < index0) 4397 if (index1 > strlength (x) || index1 < index0)
4442 Error_1 ("substring: end out of bounds:", caddr (args)); 4398 Error_1 ("string->copy: end out of bounds:", caddr (args));
4443 } 4399 }
4444 else 4400 else
4445 index1 = strlength (x); 4401 index1 = strlength (x);
4446 4402
4447 len = index1 - index0; 4403 len = index1 - index0;
4448 x = mk_empty_string (SCHEME_A_ len, ' '); 4404 x = mk_counted_string (SCHEME_A_ str + index0, len);
4449 memcpy (strvalue (x), str + index0, len);
4450 strvalue (x)[len] = 0;
4451 4405
4452 s_return (x); 4406 s_return (x);
4453 } 4407 }
4454 4408
4455 case OP_VECTOR: /* vector */ 4409 case OP_VECTOR: /* vector */
… …
4644 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4598 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4645 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4599 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4646 s_return (SCHEME_V->value); 4600 s_return (SCHEME_V->value);
4647 4601
4648#if USE_PORTS 4602#if USE_PORTS
4603
4604 case OP_EOF_OBJECT: /* eof-object */
4605 s_return (S_EOF);
4649 4606
4650 case OP_WRITE: /* write */ 4607 case OP_WRITE: /* write */
4651 case OP_DISPLAY: /* display */ 4608 case OP_DISPLAY: /* display */
4652 case OP_WRITE_CHAR: /* write-char */ 4609 case OP_WRITE_CHAR: /* write-char */
4653 if (is_pair (cdr (SCHEME_V->args))) 4610 if (is_pair (cdr (SCHEME_V->args)))
… …
5546 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5503 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5547 return; 5504 return;
5548 5505
5549 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5506 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5550 { 5507 {
5551 xwrstr ("No memory!\n"); 5508 putstr (SCHEME_A_ "No memory!\n");
5552 return; 5509 return;
5553 } 5510 }
5554 } 5511 }
5555} 5512}
5556 5513
… …
6040 int isfile = 1; 5997 int isfile = 1;
6041 system ("ps v $PPID");//D 5998 system ("ps v $PPID");//D
6042 5999
6043 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6000 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6044 { 6001 {
6045 xwrstr ("Usage: tinyscheme -?\n"); 6002 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6046 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6003 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6047 xwrstr ("followed by\n"); 6004 putstr (SCHEME_A_ "followed by\n");
6048 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6005 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6049 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6006 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6050 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6007 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6051 xwrstr ("Use - as filename for stdin.\n"); 6008 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6052 return 1; 6009 return 1;
6053 } 6010 }
6054 6011
6055 if (!scheme_init (SCHEME_A)) 6012 if (!scheme_init (SCHEME_A))
6056 { 6013 {
6057 xwrstr ("Could not initialize!\n"); 6014 putstr (SCHEME_A_ "Could not initialize!\n");
6058 return 2; 6015 return 2;
6059 } 6016 }
6060 6017
6061# if USE_PORTS 6018# if USE_PORTS
6062 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6019 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6107 fin = open (file_name, O_RDONLY); 6064 fin = open (file_name, O_RDONLY);
6108#endif 6065#endif
6109 6066
6110 if (isfile && fin < 0) 6067 if (isfile && fin < 0)
6111 { 6068 {
6112 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6069 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6113 } 6070 }
6114 else 6071 else
6115 { 6072 {
6116 if (isfile) 6073 if (isfile)
6117 scheme_load_named_file (SCHEME_A_ fin, file_name); 6074 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6121#if USE_PORTS 6078#if USE_PORTS
6122 if (!isfile || fin != STDIN_FILENO) 6079 if (!isfile || fin != STDIN_FILENO)
6123 { 6080 {
6124 if (SCHEME_V->retcode != 0) 6081 if (SCHEME_V->retcode != 0)
6125 { 6082 {
6126 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6083 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6127 } 6084 }
6128 6085
6129 if (isfile) 6086 if (isfile)
6130 close (fin); 6087 close (fin);
6131 } 6088 }

Diff Legend

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