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.55 by root, Tue Dec 1 03:03:11 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;
… …
4011 Error_1 ("inexact->exact: not integral:", x); 4015 Error_1 ("inexact->exact: not integral:", x);
4012 } 4016 }
4013 4017
4014 s_return (x); 4018 s_return (x);
4015 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))
4018 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args)))))); 4028 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4019 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))));
4020 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))));
… …
4026 s_return (mk_real (SCHEME_A_ 4036 s_return (mk_real (SCHEME_A_
4027 cdr (args) == NIL 4037 cdr (args) == NIL
4028 ? atan (rvalue (x)) 4038 ? atan (rvalue (x))
4029 : atan2 (rvalue (x), rvalue (cadr (args))))); 4039 : atan2 (rvalue (x), rvalue (cadr (args)))));
4030 4040
4031 case OP_SQRT:
4032 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4033
4034 case OP_EXPT: 4041 case OP_EXPT:
4035 { 4042 {
4036 RVALUE result; 4043 RVALUE result;
4037 int real_result = 1; 4044 int real_result = 1;
4038 pointer y = cadr (args); 4045 pointer y = cadr (args);
… …
4060 if (real_result) 4067 if (real_result)
4061 s_return (mk_real (SCHEME_A_ result)); 4068 s_return (mk_real (SCHEME_A_ result));
4062 else 4069 else
4063 s_return (mk_integer (SCHEME_A_ result)); 4070 s_return (mk_integer (SCHEME_A_ result));
4064 } 4071 }
4065
4066 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4067 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (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))));
4070#endif 4072#endif
4071 4073
4072 case OP_ADD: /* + */ 4074 case OP_ADD: /* + */
4073 v = num_zero; 4075 v = num_zero;
4074 4076
… …
4376 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4378 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4377 4379
4378 s_return (newstr); 4380 s_return (newstr);
4379 } 4381 }
4380 4382
4381 case OP_SUBSTR: /* substring */ 4383 case OP_STRING_COPY: /* substring/string-copy */
4382 { 4384 {
4383 char *str = strvalue (x); 4385 char *str = strvalue (x);
4384 int index0 = ivalue_unchecked (cadr (args)); 4386 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4385 int index1; 4387 int index1;
4386 int len; 4388 int len;
4387 4389
4388 if (index0 > strlength (x)) 4390 if (index0 > strlength (x))
4389 Error_1 ("substring: start out of bounds:", cadr (args)); 4391 Error_1 ("string->copy: start out of bounds:", cadr (args));
4390 4392
4391 if (cddr (args) != NIL) 4393 if (cddr (args) != NIL)
4392 { 4394 {
4393 index1 = ivalue_unchecked (caddr (args)); 4395 index1 = ivalue_unchecked (caddr (args));
4394 4396
4395 if (index1 > strlength (x) || index1 < index0) 4397 if (index1 > strlength (x) || index1 < index0)
4396 Error_1 ("substring: end out of bounds:", caddr (args)); 4398 Error_1 ("string->copy: end out of bounds:", caddr (args));
4397 } 4399 }
4398 else 4400 else
4399 index1 = strlength (x); 4401 index1 = strlength (x);
4400 4402
4401 len = index1 - index0; 4403 len = index1 - index0;
4402 x = mk_empty_string (SCHEME_A_ len, ' '); 4404 x = mk_counted_string (SCHEME_A_ str + index0, len);
4403 memcpy (strvalue (x), str + index0, len);
4404 strvalue (x)[len] = 0;
4405 4405
4406 s_return (x); 4406 s_return (x);
4407 } 4407 }
4408 4408
4409 case OP_VECTOR: /* vector */ 4409 case OP_VECTOR: /* vector */
… …
4598 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4598 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4599 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4599 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4600 s_return (SCHEME_V->value); 4600 s_return (SCHEME_V->value);
4601 4601
4602#if USE_PORTS 4602#if USE_PORTS
4603
4604 case OP_EOF_OBJECT: /* eof-object */
4605 s_return (S_EOF);
4603 4606
4604 case OP_WRITE: /* write */ 4607 case OP_WRITE: /* write */
4605 case OP_DISPLAY: /* display */ 4608 case OP_DISPLAY: /* display */
4606 case OP_WRITE_CHAR: /* write-char */ 4609 case OP_WRITE_CHAR: /* write-char */
4607 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