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.53 by root, Tue Dec 1 02:21:49 2015 UTC vs.
Revision 1.59 by root, Tue Dec 1 07:13:25 2015 UTC

… …
193#endif 193#endif
194 194
195enum scheme_types 195enum scheme_types
196{ 196{
197 T_INTEGER, 197 T_INTEGER,
198 T_CHARACTER,
198 T_REAL, 199 T_REAL,
199 T_STRING, 200 T_STRING,
200 T_SYMBOL, 201 T_SYMBOL,
201 T_PROC, 202 T_PROC,
202 T_PAIR, /* also used for free cells */ 203 T_PAIR, /* also used for free cells */
203 T_CLOSURE, 204 T_CLOSURE,
205 T_MACRO,
204 T_CONTINUATION, 206 T_CONTINUATION,
205 T_FOREIGN, 207 T_FOREIGN,
206 T_CHARACTER,
207 T_PORT, 208 T_PORT,
208 T_VECTOR, 209 T_VECTOR,
209 T_MACRO,
210 T_PROMISE, 210 T_PROMISE,
211 T_ENVIRONMENT, 211 T_ENVIRONMENT,
212 /* one more... */ 212 /* one more... */
213 T_NUM_SYSTEM_TYPES 213 T_NUM_SYSTEM_TYPES
214}; 214};
… …
250static num num_op (enum num_op op, num a, num b); 250static num num_op (enum num_op op, num a, num b);
251static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
252static num num_rem (num a, num b); 252static num num_rem (num a, num b);
253static num num_mod (num a, num b); 253static num num_mod (num a, num b);
254 254
255#if USE_MATH
256static double round_per_R5RS (double x);
257#endif
258static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
259 256
260static num num_zero; 257static num num_zero;
261static num num_one; 258static num num_one;
262 259
… …
872 } 869 }
873 870
874 return ret; 871 return ret;
875} 872}
876 873
877#if USE_MATH
878
879/* Round to nearest. Round to even if midway */
880static double
881round_per_R5RS (double x)
882{
883 double fl = floor (x);
884 double ce = ceil (x);
885 double dfl = x - fl;
886 double dce = ce - x;
887
888 if (dfl > dce)
889 return ce;
890 else if (dfl < dce)
891 return fl;
892 else
893 {
894 if (fmod (fl, 2) == 0) /* I imagine this holds */
895 return fl;
896 else
897 return ce;
898 }
899}
900#endif
901
902static int 874static int
903is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
904{ 876{
905 return x == 0; 877 return x == 0;
906#if 0 878#if 0
… …
1503 return S_F; 1475 return S_F;
1504 else if (*name == '\\') /* #\w (character) */ 1476 else if (*name == '\\') /* #\w (character) */
1505 { 1477 {
1506 int c; 1478 int c;
1507 1479
1480 // TODO: optimise
1508 if (stricmp (name + 1, "space") == 0) 1481 if (stricmp (name + 1, "space") == 0)
1509 c = ' '; 1482 c = ' ';
1510 else if (stricmp (name + 1, "newline") == 0) 1483 else if (stricmp (name + 1, "newline") == 0)
1511 c = '\n'; 1484 c = '\n';
1512 else if (stricmp (name + 1, "return") == 0) 1485 else if (stricmp (name + 1, "return") == 0)
1513 c = '\r'; 1486 c = '\r';
1514 else if (stricmp (name + 1, "tab") == 0) 1487 else if (stricmp (name + 1, "tab") == 0)
1515 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;
1516 else if (name[1] == 'x' && name[2] != 0) 1499 else if (name[1] == 'x' && name[2] != 0)
1517 { 1500 {
1518 long c1 = strtol (name + 2, 0, 16); 1501 long c1 = strtol (name + 2, 0, 16);
1519 1502
1520 if (0 <= c1 && c1 <= UCHAR_MAX) 1503 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
2203 case '7': 2186 case '7':
2204 state = st_oct1; 2187 state = st_oct1;
2205 c1 = c - '0'; 2188 c1 = c - '0';
2206 break; 2189 break;
2207 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
2208 case 'x': 2199 case 'x':
2209 case 'X': 2200 case 'X':
2210 state = st_x1; 2201 state = st_x1;
2211 c1 = 0; 2202 c1 = 0;
2212 break;
2213
2214 case 'n':
2215 *p++ = '\n';
2216 state = st_ok;
2217 break;
2218
2219 case 't':
2220 *p++ = '\t';
2221 state = st_ok;
2222 break;
2223
2224 case 'r':
2225 *p++ = '\r';
2226 state = st_ok;
2227 break; 2203 break;
2228 2204
2229 default: 2205 default:
2230 *p++ = c; 2206 *p++ = c;
2231 state = st_ok; 2207 state = st_ok;
… …
4027 4003
4028 switch (op) 4004 switch (op)
4029 { 4005 {
4030#if USE_MATH 4006#if USE_MATH
4031 case OP_INEX2EX: /* inexact->exact */ 4007 case OP_INEX2EX: /* inexact->exact */
4032 {
4033 if (is_integer (x)) 4008 if (!is_integer (x))
4034 s_return (x); 4009 {
4035
4036 RVALUE r = rvalue_unchecked (x); 4010 RVALUE r = rvalue_unchecked (x);
4037 4011
4038 if (r == (RVALUE)(IVALUE)r) 4012 if (r == (RVALUE)(IVALUE)r)
4039 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4013 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4040 else 4014 else
4041 Error_1 ("inexact->exact: not integral:", x); 4015 Error_1 ("inexact->exact: not integral:", x);
4042 } 4016 }
4043 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))));
4044 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))));
4045 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))))));
4046 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))));
4047 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))));
4048 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))));
4049 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))));
4050 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))));
4051 4034
4052 case OP_ATAN: 4035 case OP_ATAN:
4036 s_return (mk_real (SCHEME_A_
4053 if (cdr (args) == NIL) 4037 cdr (args) == NIL
4054 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4038 ? atan (rvalue (x))
4055 else 4039 : atan2 (rvalue (x), rvalue (cadr (args)))));
4056 {
4057 pointer y = cadr (args);
4058 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4059 }
4060
4061 case OP_SQRT:
4062 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4063 4040
4064 case OP_EXPT: 4041 case OP_EXPT:
4065 { 4042 {
4066 RVALUE result; 4043 RVALUE result;
4067 int real_result = 1; 4044 int real_result = 1;
… …
4090 if (real_result) 4067 if (real_result)
4091 s_return (mk_real (SCHEME_A_ result)); 4068 s_return (mk_real (SCHEME_A_ result));
4092 else 4069 else
4093 s_return (mk_integer (SCHEME_A_ result)); 4070 s_return (mk_integer (SCHEME_A_ result));
4094 } 4071 }
4095
4096 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4097 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4098
4099 case OP_TRUNCATE:
4100 {
4101 RVALUE n = rvalue (x);
4102 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4103 }
4104
4105 case OP_ROUND:
4106 if (is_integer (x))
4107 s_return (x);
4108
4109 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4110#endif 4072#endif
4111 4073
4112 case OP_ADD: /* + */ 4074 case OP_ADD: /* + */
4113 v = num_zero; 4075 v = num_zero;
4114 4076
… …
4416 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4378 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4417 4379
4418 s_return (newstr); 4380 s_return (newstr);
4419 } 4381 }
4420 4382
4421 case OP_SUBSTR: /* substring */ 4383 case OP_STRING_COPY: /* substring/string-copy */
4422 { 4384 {
4423 char *str = strvalue (x); 4385 char *str = strvalue (x);
4424 int index0 = ivalue_unchecked (cadr (args)); 4386 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4425 int index1; 4387 int index1;
4426 int len; 4388 int len;
4427 4389
4428 if (index0 > strlength (x)) 4390 if (index0 > strlength (x))
4429 Error_1 ("substring: start out of bounds:", cadr (args)); 4391 Error_1 ("string->copy: start out of bounds:", cadr (args));
4430 4392
4431 if (cddr (args) != NIL) 4393 if (cddr (args) != NIL)
4432 { 4394 {
4433 index1 = ivalue_unchecked (caddr (args)); 4395 index1 = ivalue_unchecked (caddr (args));
4434 4396
4435 if (index1 > strlength (x) || index1 < index0) 4397 if (index1 > strlength (x) || index1 < index0)
4436 Error_1 ("substring: end out of bounds:", caddr (args)); 4398 Error_1 ("string->copy: end out of bounds:", caddr (args));
4437 } 4399 }
4438 else 4400 else
4439 index1 = strlength (x); 4401 index1 = strlength (x);
4440 4402
4441 len = index1 - index0; 4403 len = index1 - index0;
4442 x = mk_empty_string (SCHEME_A_ len, ' '); 4404 x = mk_counted_string (SCHEME_A_ str + index0, len);
4443 memcpy (strvalue (x), str + index0, len);
4444 strvalue (x)[len] = 0;
4445 4405
4446 s_return (x); 4406 s_return (x);
4447 } 4407 }
4448 4408
4449 case OP_VECTOR: /* vector */ 4409 case OP_VECTOR: /* vector */
… …
4638 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4598 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4639 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4599 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4640 s_return (SCHEME_V->value); 4600 s_return (SCHEME_V->value);
4641 4601
4642#if USE_PORTS 4602#if USE_PORTS
4603
4604 case OP_EOF_OBJECT: /* eof-object */
4605 s_return (S_EOF);
4643 4606
4644 case OP_WRITE: /* write */ 4607 case OP_WRITE: /* write */
4645 case OP_DISPLAY: /* display */ 4608 case OP_DISPLAY: /* display */
4646 case OP_WRITE_CHAR: /* write-char */ 4609 case OP_WRITE_CHAR: /* write-char */
4647 if (is_pair (cdr (SCHEME_V->args))) 4610 if (is_pair (cdr (SCHEME_V->args)))

Diff Legend

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