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.54 by root, Tue Dec 1 02:42:35 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};
… …
1475 return S_F; 1475 return S_F;
1476 else if (*name == '\\') /* #\w (character) */ 1476 else if (*name == '\\') /* #\w (character) */
1477 { 1477 {
1478 int c; 1478 int c;
1479 1479
1480 // TODO: optimise
1480 if (stricmp (name + 1, "space") == 0) 1481 if (stricmp (name + 1, "space") == 0)
1481 c = ' '; 1482 c = ' ';
1482 else if (stricmp (name + 1, "newline") == 0) 1483 else if (stricmp (name + 1, "newline") == 0)
1483 c = '\n'; 1484 c = '\n';
1484 else if (stricmp (name + 1, "return") == 0) 1485 else if (stricmp (name + 1, "return") == 0)
1485 c = '\r'; 1486 c = '\r';
1486 else if (stricmp (name + 1, "tab") == 0) 1487 else if (stricmp (name + 1, "tab") == 0)
1487 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;
1488 else if (name[1] == 'x' && name[2] != 0) 1499 else if (name[1] == 'x' && name[2] != 0)
1489 { 1500 {
1490 long c1 = strtol (name + 2, 0, 16); 1501 long c1 = strtol (name + 2, 0, 16);
1491 1502
1492 if (0 <= c1 && c1 <= UCHAR_MAX) 1503 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
2175 case '7': 2186 case '7':
2176 state = st_oct1; 2187 state = st_oct1;
2177 c1 = c - '0'; 2188 c1 = c - '0';
2178 break; 2189 break;
2179 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
2180 case 'x': 2199 case 'x':
2181 case 'X': 2200 case 'X':
2182 state = st_x1; 2201 state = st_x1;
2183 c1 = 0; 2202 c1 = 0;
2184 break;
2185
2186 case 'n':
2187 *p++ = '\n';
2188 state = st_ok;
2189 break;
2190
2191 case 't':
2192 *p++ = '\t';
2193 state = st_ok;
2194 break;
2195
2196 case 'r':
2197 *p++ = '\r';
2198 state = st_ok;
2199 break; 2203 break;
2200 2204
2201 default: 2205 default:
2202 *p++ = c; 2206 *p++ = c;
2203 state = st_ok; 2207 state = st_ok;
… …
3999 4003
4000 switch (op) 4004 switch (op)
4001 { 4005 {
4002#if USE_MATH 4006#if USE_MATH
4003 case OP_INEX2EX: /* inexact->exact */ 4007 case OP_INEX2EX: /* inexact->exact */
4004 {
4005 if (is_integer (x)) 4008 if (!is_integer (x))
4006 s_return (x); 4009 {
4007
4008 RVALUE r = rvalue_unchecked (x); 4010 RVALUE r = rvalue_unchecked (x);
4009 4011
4010 if (r == (RVALUE)(IVALUE)r) 4012 if (r == (RVALUE)(IVALUE)r)
4011 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4013 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4012 else 4014 else
4013 Error_1 ("inexact->exact: not integral:", x); 4015 Error_1 ("inexact->exact: not integral:", x);
4014 } 4016 }
4015 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))));
4016 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))));
4017 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))))));
4018 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))));
4019 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))));
4020 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))));
4021 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))));
4022 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))));
4023 4034
4024 case OP_ATAN: 4035 case OP_ATAN:
4036 s_return (mk_real (SCHEME_A_
4025 if (cdr (args) == NIL) 4037 cdr (args) == NIL
4026 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4038 ? atan (rvalue (x))
4027 else 4039 : atan2 (rvalue (x), rvalue (cadr (args)))));
4028 {
4029 pointer y = cadr (args);
4030 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4031 }
4032
4033 case OP_SQRT:
4034 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4035 4040
4036 case OP_EXPT: 4041 case OP_EXPT:
4037 { 4042 {
4038 RVALUE result; 4043 RVALUE result;
4039 int real_result = 1; 4044 int real_result = 1;
… …
4062 if (real_result) 4067 if (real_result)
4063 s_return (mk_real (SCHEME_A_ result)); 4068 s_return (mk_real (SCHEME_A_ result));
4064 else 4069 else
4065 s_return (mk_integer (SCHEME_A_ result)); 4070 s_return (mk_integer (SCHEME_A_ result));
4066 } 4071 }
4067
4068 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4069 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4070 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4071 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4072#endif 4072#endif
4073 4073
4074 case OP_ADD: /* + */ 4074 case OP_ADD: /* + */
4075 v = num_zero; 4075 v = num_zero;
4076 4076
… …
4378 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4378 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4379 4379
4380 s_return (newstr); 4380 s_return (newstr);
4381 } 4381 }
4382 4382
4383 case OP_SUBSTR: /* substring */ 4383 case OP_STRING_COPY: /* substring/string-copy */
4384 { 4384 {
4385 char *str = strvalue (x); 4385 char *str = strvalue (x);
4386 int index0 = ivalue_unchecked (cadr (args)); 4386 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4387 int index1; 4387 int index1;
4388 int len; 4388 int len;
4389 4389
4390 if (index0 > strlength (x)) 4390 if (index0 > strlength (x))
4391 Error_1 ("substring: start out of bounds:", cadr (args)); 4391 Error_1 ("string->copy: start out of bounds:", cadr (args));
4392 4392
4393 if (cddr (args) != NIL) 4393 if (cddr (args) != NIL)
4394 { 4394 {
4395 index1 = ivalue_unchecked (caddr (args)); 4395 index1 = ivalue_unchecked (caddr (args));
4396 4396
4397 if (index1 > strlength (x) || index1 < index0) 4397 if (index1 > strlength (x) || index1 < index0)
4398 Error_1 ("substring: end out of bounds:", caddr (args)); 4398 Error_1 ("string->copy: end out of bounds:", caddr (args));
4399 } 4399 }
4400 else 4400 else
4401 index1 = strlength (x); 4401 index1 = strlength (x);
4402 4402
4403 len = index1 - index0; 4403 len = index1 - index0;
4404 x = mk_empty_string (SCHEME_A_ len, ' '); 4404 x = mk_counted_string (SCHEME_A_ str + index0, len);
4405 memcpy (strvalue (x), str + index0, len);
4406 strvalue (x)[len] = 0;
4407 4405
4408 s_return (x); 4406 s_return (x);
4409 } 4407 }
4410 4408
4411 case OP_VECTOR: /* vector */ 4409 case OP_VECTOR: /* vector */
… …
4600 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4598 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4601 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4599 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4602 s_return (SCHEME_V->value); 4600 s_return (SCHEME_V->value);
4603 4601
4604#if USE_PORTS 4602#if USE_PORTS
4603
4604 case OP_EOF_OBJECT: /* eof-object */
4605 s_return (S_EOF);
4605 4606
4606 case OP_WRITE: /* write */ 4607 case OP_WRITE: /* write */
4607 case OP_DISPLAY: /* display */ 4608 case OP_DISPLAY: /* display */
4608 case OP_WRITE_CHAR: /* write-char */ 4609 case OP_WRITE_CHAR: /* write-char */
4609 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