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.47 by root, Mon Nov 30 09:25:19 2015 UTC vs.
Revision 1.50 by root, Tue Dec 1 00:47:54 2015 UTC

… …
79 79
80#define BACKQUOTE '`' 80#define BACKQUOTE '`'
81#define WHITESPACE " \t\r\n\v\f" 81#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE 82#define DELIMITERS "()\";" WHITESPACE
83 83
84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 84#define NIL (&SCHEME_V->xNIL)
85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 85#define S_T (&SCHEME_V->xT)
86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 86#define S_F (&SCHEME_V->xF)
87#define S_SINK (&SCHEME_V->xsink) 87#define S_SINK (&SCHEME_V->xsink)
88#define S_EOF (&SCHEME_V->xEOF_OBJ) 88#define S_EOF (&SCHEME_V->xEOF_OBJ)
89 89
90#if !USE_MULTIPLICITY 90#if !USE_MULTIPLICITY
91static scheme sc; 91static scheme sc;
… …
1201 1201
1202/* returns the new symbol */ 1202/* returns the new symbol */
1203static pointer 1203static pointer
1204oblist_add_by_name (SCHEME_P_ const char *name) 1204oblist_add_by_name (SCHEME_P_ const char *name)
1205{ 1205{
1206 pointer x = mk_string (SCHEME_A_ name); 1206 pointer x = generate_symbol (SCHEME_A_ name);
1207 set_typeflag (x, T_SYMBOL);
1208 setimmutable (x);
1209 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1207 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1210 return x; 1208 return x;
1211} 1209}
1212 1210
1213static pointer 1211static pointer
… …
1234pointer 1232pointer
1235mk_foreign_func (SCHEME_P_ foreign_func f) 1233mk_foreign_func (SCHEME_P_ foreign_func f)
1236{ 1234{
1237 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1235 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1238 1236
1239 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1237 set_typeflag (x, T_FOREIGN | T_ATOM);
1240 x->object.ff = f; 1238 x->object.ff = f;
1241 1239
1242 return x; 1240 return x;
1243} 1241}
1244 1242
1245INTERFACE pointer 1243INTERFACE pointer
1246mk_character (SCHEME_P_ int c) 1244mk_character (SCHEME_P_ int c)
1247{ 1245{
1248 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1246 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1249 1247
1250 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1248 set_typeflag (x, T_CHARACTER | T_ATOM);
1251 set_ivalue (x, c & 0xff); 1249 set_ivalue (x, c & 0xff);
1252 1250
1253 return x; 1251 return x;
1254} 1252}
1255 1253
1256/* get number atom (integer) */ 1254/* get number atom (integer) */
1257INTERFACE pointer 1255INTERFACE pointer
1258mk_integer (SCHEME_P_ long n) 1256mk_integer (SCHEME_P_ long n)
1259{ 1257{
1258 pointer p = 0;
1259 pointer *pp = &p;
1260
1261#if USE_INTCACHE
1262 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1263 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1264#endif
1265
1266 if (!*pp)
1267 {
1260 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1268 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1261 1269
1262 set_typeflag (x, (T_INTEGER | T_ATOM)); 1270 set_typeflag (x, T_INTEGER | T_ATOM);
1271 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1263 set_ivalue (x, n); 1272 set_ivalue (x, n);
1264 1273
1274 *pp = x;
1275 }
1276
1265 return x; 1277 return *pp;
1266} 1278}
1267 1279
1268INTERFACE pointer 1280INTERFACE pointer
1269mk_real (SCHEME_P_ RVALUE n) 1281mk_real (SCHEME_P_ RVALUE n)
1270{ 1282{
1271#if USE_REAL 1283#if USE_REAL
1272 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1284 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1273 1285
1274 set_typeflag (x, (T_REAL | T_ATOM)); 1286 set_typeflag (x, T_REAL | T_ATOM);
1275 set_rvalue (x, n); 1287 set_rvalue (x, n);
1276 1288
1277 return x; 1289 return x;
1278#else 1290#else
1279 return mk_integer (SCHEME_A_ n); 1291 return mk_integer (SCHEME_A_ n);
… …
1648 /* Mark recent objects the interpreter doesn't know about yet. */ 1660 /* Mark recent objects the interpreter doesn't know about yet. */
1649 mark (car (S_SINK)); 1661 mark (car (S_SINK));
1650 /* Mark any older stuff above nested C calls */ 1662 /* Mark any older stuff above nested C calls */
1651 mark (SCHEME_V->c_nest); 1663 mark (SCHEME_V->c_nest);
1652 1664
1665#if USE_INTCACHE
1666 /* mark intcache */
1667 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1668 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1669 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1670#endif
1671
1653 /* mark variables a, b */ 1672 /* mark variables a, b */
1654 mark (a); 1673 mark (a);
1655 mark (b); 1674 mark (b);
1656 1675
1657 /* garbage collect */ 1676 /* garbage collect */
… …
3566 3585
3567 case OP_DOMACRO: /* do macro */ 3586 case OP_DOMACRO: /* do macro */
3568 SCHEME_V->code = SCHEME_V->value; 3587 SCHEME_V->code = SCHEME_V->value;
3569 s_goto (OP_EVAL); 3588 s_goto (OP_EVAL);
3570 3589
3571#if 1
3572
3573 case OP_LAMBDA: /* lambda */ 3590 case OP_LAMBDA: /* lambda */
3574 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3591 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3575 set SCHEME_V->value fall thru */ 3592 set SCHEME_V->value fall thru */
3576 { 3593 {
3577 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1); 3594 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
… …
3583 SCHEME_V->code = slot_value_in_env (f); 3600 SCHEME_V->code = slot_value_in_env (f);
3584 s_goto (OP_APPLY); 3601 s_goto (OP_APPLY);
3585 } 3602 }
3586 3603
3587 SCHEME_V->value = SCHEME_V->code; 3604 SCHEME_V->value = SCHEME_V->code;
3588 /* Fallthru */
3589 } 3605 }
3606 /* Fallthru */
3590 3607
3591 case OP_LAMBDA1: 3608 case OP_LAMBDA1:
3592 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3609 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3593
3594#else
3595
3596 case OP_LAMBDA: /* lambda */
3597 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3598
3599#endif
3600 3610
3601 case OP_MKCLOSURE: /* make-closure */ 3611 case OP_MKCLOSURE: /* make-closure */
3602 x = car (args); 3612 x = car (args);
3603 3613
3604 if (car (x) == SCHEME_V->LAMBDA) 3614 if (car (x) == SCHEME_V->LAMBDA)
… …
5663scheme_init (SCHEME_P) 5673scheme_init (SCHEME_P)
5664{ 5674{
5665 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5675 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5666 pointer x; 5676 pointer x;
5667 5677
5678 /* this memset is not strictly correct, as we assume (intcache)
5679 * that memset 0 will also set pointers to 0, but memset does
5680 * of course not guarantee that. screw such systems.
5681 */
5682 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5683
5668 num_set_fixnum (num_zero, 1); 5684 num_set_fixnum (num_zero, 1);
5669 num_set_ivalue (num_zero, 0); 5685 num_set_ivalue (num_zero, 0);
5670 num_set_fixnum (num_one, 1); 5686 num_set_fixnum (num_one, 1);
5671 num_set_ivalue (num_one, 1); 5687 num_set_ivalue (num_one, 1);
5672 5688

Diff Legend

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