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.43 by root, Mon Nov 30 06:40:57 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;
… …
969 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 970 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
970 return S_SINK; 971 return S_SINK;
971 972
972 if (SCHEME_V->free_cell == NIL) 973 if (SCHEME_V->free_cell == NIL)
973 { 974 {
974 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 975 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;
975 976
976 gc (SCHEME_A_ a, b); 977 gc (SCHEME_A_ a, b);
977 978
978 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 979 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
979 { 980 {
… …
1030} 1031}
1031 1032
1032static pointer 1033static pointer
1033get_vector_object (SCHEME_P_ uint32_t len, pointer init) 1034get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1034{ 1035{
1035 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1036 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1036 pointer *e = malloc (len * sizeof (pointer)); 1037 pointer *e = malloc (len * sizeof (pointer));
1037 1038
1038 if (!e && USE_ERROR_CHECKING) 1039 if (!e && USE_ERROR_CHECKING)
1039 return S_SINK; 1040 return S_SINK;
1040 1041
… …
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 */
1657 clrmark (NIL); 1677 clrmark (NIL);
1658 SCHEME_V->fcells = 0; 1678 SCHEME_V->fcells = 0;
1659 SCHEME_V->free_cell = NIL; 1679 SCHEME_V->free_cell = NIL;
1660 1680
1661 /* free-list is kept sorted by address so as to maintain consecutive 1681 if (SCHEME_V->gc_verbose)
1662 ranges, if possible, for use with vectors. Here we scan the cells 1682 xwrstr ("freeing...");
1663 (which are also kept sorted by address) downwards to build the 1683
1664 free-list in sorted order. 1684 uint32_t total = 0;
1665 */ 1685
1686 /* Here we scan the cells to build the free-list. */
1666 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1687 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1667 { 1688 {
1668 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; 1689 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1690 total += SCHEME_V->cell_segsize [i];
1669 1691
1670 while (--p >= SCHEME_V->cell_seg[i]) 1692 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1671 { 1693 {
1672 if (is_mark (p)) 1694 if (is_mark (p))
1673 clrmark (p); 1695 clrmark (p);
1674 else 1696 else
1675 { 1697 {
… …
1688 } 1710 }
1689 } 1711 }
1690 1712
1691 if (SCHEME_V->gc_verbose) 1713 if (SCHEME_V->gc_verbose)
1692 { 1714 {
1693 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); 1715 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1694 } 1716 }
1695} 1717}
1696 1718
1697static void 1719static void
1698finalize_cell (SCHEME_P_ pointer a) 1720finalize_cell (SCHEME_P_ pointer a)
… …
3563 3585
3564 case OP_DOMACRO: /* do macro */ 3586 case OP_DOMACRO: /* do macro */
3565 SCHEME_V->code = SCHEME_V->value; 3587 SCHEME_V->code = SCHEME_V->value;
3566 s_goto (OP_EVAL); 3588 s_goto (OP_EVAL);
3567 3589
3568#if 1
3569
3570 case OP_LAMBDA: /* lambda */ 3590 case OP_LAMBDA: /* lambda */
3571 /* 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
3572 set SCHEME_V->value fall thru */ 3592 set SCHEME_V->value fall thru */
3573 { 3593 {
3574 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);
… …
3580 SCHEME_V->code = slot_value_in_env (f); 3600 SCHEME_V->code = slot_value_in_env (f);
3581 s_goto (OP_APPLY); 3601 s_goto (OP_APPLY);
3582 } 3602 }
3583 3603
3584 SCHEME_V->value = SCHEME_V->code; 3604 SCHEME_V->value = SCHEME_V->code;
3585 /* Fallthru */
3586 } 3605 }
3606 /* Fallthru */
3587 3607
3588 case OP_LAMBDA1: 3608 case OP_LAMBDA1:
3589 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));
3590
3591#else
3592
3593 case OP_LAMBDA: /* lambda */
3594 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3595
3596#endif
3597 3610
3598 case OP_MKCLOSURE: /* make-closure */ 3611 case OP_MKCLOSURE: /* make-closure */
3599 x = car (args); 3612 x = car (args);
3600 3613
3601 if (car (x) == SCHEME_V->LAMBDA) 3614 if (car (x) == SCHEME_V->LAMBDA)
… …
4197 else 4210 else
4198 Error_0 ("modulo: division by zero"); 4211 Error_0 ("modulo: division by zero");
4199 4212
4200 s_return (mk_number (SCHEME_A_ v)); 4213 s_return (mk_number (SCHEME_A_ v));
4201 4214
4202 case OP_CAR: /* car */ 4215 /* the compiler will optimize this mess... */
4203 s_return (caar (args)); 4216 case OP_CAR: op_car: s_return (car (x));
4204 4217 case OP_CDR: op_cdr: s_return (cdr (x));
4205 case OP_CDR: /* cdr */ 4218 case OP_CAAR: op_caar: x = car (x); goto op_car;
4206 s_return (cdar (args)); 4219 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4220 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4221 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4222 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4223 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4224 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4225 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4226 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4227 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4228 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4229 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4230 case OP_CAAAAR: x = car (x); goto op_caaar;
4231 case OP_CAAADR: x = cdr (x); goto op_caaar;
4232 case OP_CAADAR: x = car (x); goto op_caadr;
4233 case OP_CAADDR: x = cdr (x); goto op_caadr;
4234 case OP_CADAAR: x = car (x); goto op_cadar;
4235 case OP_CADADR: x = cdr (x); goto op_cadar;
4236 case OP_CADDAR: x = car (x); goto op_caddr;
4237 case OP_CADDDR: x = cdr (x); goto op_caddr;
4238 case OP_CDAAAR: x = car (x); goto op_cdaar;
4239 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4240 case OP_CDADAR: x = car (x); goto op_cdadr;
4241 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4242 case OP_CDDAAR: x = car (x); goto op_cddar;
4243 case OP_CDDADR: x = cdr (x); goto op_cddar;
4244 case OP_CDDDAR: x = car (x); goto op_cdddr;
4245 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4207 4246
4208 case OP_CONS: /* cons */ 4247 case OP_CONS: /* cons */
4209 set_cdr (args, cadr (args)); 4248 set_cdr (args, cadr (args));
4210 s_return (args); 4249 s_return (args);
4211 4250
… …
5634scheme_init (SCHEME_P) 5673scheme_init (SCHEME_P)
5635{ 5674{
5636 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5675 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5637 pointer x; 5676 pointer x;
5638 5677
5678 memset (SCHEME_V, 0, sizeof (*SCHEME_V));//TODO !iso c
5679
5639 num_set_fixnum (num_zero, 1); 5680 num_set_fixnum (num_zero, 1);
5640 num_set_ivalue (num_zero, 0); 5681 num_set_ivalue (num_zero, 0);
5641 num_set_fixnum (num_one, 1); 5682 num_set_fixnum (num_one, 1);
5642 num_set_ivalue (num_one, 1); 5683 num_set_ivalue (num_one, 1);
5643 5684

Diff Legend

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