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.46 by root, Mon Nov 30 09:16:55 2015 UTC vs.
Revision 1.48 by root, Mon Nov 30 13:07:34 2015 UTC

… …
413{ 413{
414 return strvalue (p); 414 return strvalue (p);
415} 415}
416 416
417#if USE_PLIST 417#if USE_PLIST
418#error plists are broken because symbols are no longer pairs
418#define symprop(p) cdr(p) 419#define symprop(p) cdr(p)
419SCHEME_EXPORT int 420SCHEME_EXPORT int
420hasprop (pointer p) 421hasprop (pointer p)
421{ 422{
422 return typeflag (p) & T_SYMBOL; 423 return typeflag (p) & T_SYMBOL;
… …
1200 1201
1201/* returns the new symbol */ 1202/* returns the new symbol */
1202static pointer 1203static pointer
1203oblist_add_by_name (SCHEME_P_ const char *name) 1204oblist_add_by_name (SCHEME_P_ const char *name)
1204{ 1205{
1205 pointer x = mk_string (SCHEME_A_ name); 1206 pointer x = generate_symbol (SCHEME_A_ name);
1206 set_typeflag (x, T_SYMBOL);
1207 setimmutable (x);
1208 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1207 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1209 return x; 1208 return x;
1210} 1209}
1211 1210
1212static pointer 1211static pointer
… …
1233pointer 1232pointer
1234mk_foreign_func (SCHEME_P_ foreign_func f) 1233mk_foreign_func (SCHEME_P_ foreign_func f)
1235{ 1234{
1236 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1235 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1237 1236
1238 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1237 set_typeflag (x, T_FOREIGN | T_ATOM);
1239 x->object.ff = f; 1238 x->object.ff = f;
1240 1239
1241 return x; 1240 return x;
1242} 1241}
1243 1242
1244INTERFACE pointer 1243INTERFACE pointer
1245mk_character (SCHEME_P_ int c) 1244mk_character (SCHEME_P_ int c)
1246{ 1245{
1247 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1246 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1248 1247
1249 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1248 set_typeflag (x, T_CHARACTER | T_ATOM);
1250 set_ivalue (x, c & 0xff); 1249 set_ivalue (x, c & 0xff);
1251 1250
1252 return x; 1251 return x;
1253} 1252}
1254 1253
1255/* get number atom (integer) */ 1254/* get number atom (integer) */
1256INTERFACE pointer 1255INTERFACE pointer
1257mk_integer (SCHEME_P_ long n) 1256mk_integer (SCHEME_P_ long n)
1258{ 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 {
1259 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1268 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1260 1269
1261 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 */
1262 set_ivalue (x, n); 1272 set_ivalue (x, n);
1263 1273
1274 *pp = x;
1275 }
1276
1264 return x; 1277 return *pp;
1265} 1278}
1266 1279
1267INTERFACE pointer 1280INTERFACE pointer
1268mk_real (SCHEME_P_ RVALUE n) 1281mk_real (SCHEME_P_ RVALUE n)
1269{ 1282{
1270#if USE_REAL 1283#if USE_REAL
1271 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1284 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1272 1285
1273 set_typeflag (x, (T_REAL | T_ATOM)); 1286 set_typeflag (x, T_REAL | T_ATOM);
1274 set_rvalue (x, n); 1287 set_rvalue (x, n);
1275 1288
1276 return x; 1289 return x;
1277#else 1290#else
1278 return mk_integer (SCHEME_A_ n); 1291 return mk_integer (SCHEME_A_ n);
… …
1647 /* Mark recent objects the interpreter doesn't know about yet. */ 1660 /* Mark recent objects the interpreter doesn't know about yet. */
1648 mark (car (S_SINK)); 1661 mark (car (S_SINK));
1649 /* Mark any older stuff above nested C calls */ 1662 /* Mark any older stuff above nested C calls */
1650 mark (SCHEME_V->c_nest); 1663 mark (SCHEME_V->c_nest);
1651 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
1652 /* mark variables a, b */ 1672 /* mark variables a, b */
1653 mark (a); 1673 mark (a);
1654 mark (b); 1674 mark (b);
1655 1675
1656 /* garbage collect */ 1676 /* garbage collect */
… …
3565 3585
3566 case OP_DOMACRO: /* do macro */ 3586 case OP_DOMACRO: /* do macro */
3567 SCHEME_V->code = SCHEME_V->value; 3587 SCHEME_V->code = SCHEME_V->value;
3568 s_goto (OP_EVAL); 3588 s_goto (OP_EVAL);
3569 3589
3570#if 1
3571
3572 case OP_LAMBDA: /* lambda */ 3590 case OP_LAMBDA: /* lambda */
3573 /* 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
3574 set SCHEME_V->value fall thru */ 3592 set SCHEME_V->value fall thru */
3575 { 3593 {
3576 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);
… …
3582 SCHEME_V->code = slot_value_in_env (f); 3600 SCHEME_V->code = slot_value_in_env (f);
3583 s_goto (OP_APPLY); 3601 s_goto (OP_APPLY);
3584 } 3602 }
3585 3603
3586 SCHEME_V->value = SCHEME_V->code; 3604 SCHEME_V->value = SCHEME_V->code;
3587 /* Fallthru */
3588 } 3605 }
3606 /* Fallthru */
3589 3607
3590 case OP_LAMBDA1: 3608 case OP_LAMBDA1:
3591 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));
3592
3593#else
3594
3595 case OP_LAMBDA: /* lambda */
3596 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3597
3598#endif
3599 3610
3600 case OP_MKCLOSURE: /* make-closure */ 3611 case OP_MKCLOSURE: /* make-closure */
3601 x = car (args); 3612 x = car (args);
3602 3613
3603 if (car (x) == SCHEME_V->LAMBDA) 3614 if (car (x) == SCHEME_V->LAMBDA)
… …
5662scheme_init (SCHEME_P) 5673scheme_init (SCHEME_P)
5663{ 5674{
5664 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5675 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5665 pointer x; 5676 pointer x;
5666 5677
5678 memset (SCHEME_V, 0, sizeof (*SCHEME_V));//TODO !iso c
5679
5667 num_set_fixnum (num_zero, 1); 5680 num_set_fixnum (num_zero, 1);
5668 num_set_ivalue (num_zero, 0); 5681 num_set_ivalue (num_zero, 0);
5669 num_set_fixnum (num_one, 1); 5682 num_set_fixnum (num_one, 1);
5670 num_set_ivalue (num_one, 1); 5683 num_set_ivalue (num_one, 1);
5671 5684

Diff Legend

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