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.44 by root, Mon Nov 30 06:49:11 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;
… …
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;
1680
1681 if (SCHEME_V->gc_verbose)
1682 xwrstr ("freeing...");
1660 1683
1661 uint32_t total = 0; 1684 uint32_t total = 0;
1662 1685
1663 /* Here we scan the cells to build the free-list. */ 1686 /* Here we scan the cells to build the free-list. */
1664 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1687 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
… …
3562 3585
3563 case OP_DOMACRO: /* do macro */ 3586 case OP_DOMACRO: /* do macro */
3564 SCHEME_V->code = SCHEME_V->value; 3587 SCHEME_V->code = SCHEME_V->value;
3565 s_goto (OP_EVAL); 3588 s_goto (OP_EVAL);
3566 3589
3567#if 1
3568
3569 case OP_LAMBDA: /* lambda */ 3590 case OP_LAMBDA: /* lambda */
3570 /* 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
3571 set SCHEME_V->value fall thru */ 3592 set SCHEME_V->value fall thru */
3572 { 3593 {
3573 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);
… …
3579 SCHEME_V->code = slot_value_in_env (f); 3600 SCHEME_V->code = slot_value_in_env (f);
3580 s_goto (OP_APPLY); 3601 s_goto (OP_APPLY);
3581 } 3602 }
3582 3603
3583 SCHEME_V->value = SCHEME_V->code; 3604 SCHEME_V->value = SCHEME_V->code;
3584 /* Fallthru */
3585 } 3605 }
3606 /* Fallthru */
3586 3607
3587 case OP_LAMBDA1: 3608 case OP_LAMBDA1:
3588 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));
3589
3590#else
3591
3592 case OP_LAMBDA: /* lambda */
3593 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3594
3595#endif
3596 3610
3597 case OP_MKCLOSURE: /* make-closure */ 3611 case OP_MKCLOSURE: /* make-closure */
3598 x = car (args); 3612 x = car (args);
3599 3613
3600 if (car (x) == SCHEME_V->LAMBDA) 3614 if (car (x) == SCHEME_V->LAMBDA)
… …
4196 else 4210 else
4197 Error_0 ("modulo: division by zero"); 4211 Error_0 ("modulo: division by zero");
4198 4212
4199 s_return (mk_number (SCHEME_A_ v)); 4213 s_return (mk_number (SCHEME_A_ v));
4200 4214
4201 case OP_CAR: /* car */ 4215 /* the compiler will optimize this mess... */
4202 s_return (caar (args)); 4216 case OP_CAR: op_car: s_return (car (x));
4203 4217 case OP_CDR: op_cdr: s_return (cdr (x));
4204 case OP_CDR: /* cdr */ 4218 case OP_CAAR: op_caar: x = car (x); goto op_car;
4205 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;
4206 4246
4207 case OP_CONS: /* cons */ 4247 case OP_CONS: /* cons */
4208 set_cdr (args, cadr (args)); 4248 set_cdr (args, cadr (args));
4209 s_return (args); 4249 s_return (args);
4210 4250
… …
5633scheme_init (SCHEME_P) 5673scheme_init (SCHEME_P)
5634{ 5674{
5635 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5675 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5636 pointer x; 5676 pointer x;
5637 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
5638 num_set_fixnum (num_zero, 1); 5684 num_set_fixnum (num_zero, 1);
5639 num_set_ivalue (num_zero, 0); 5685 num_set_ivalue (num_zero, 0);
5640 num_set_fixnum (num_one, 1); 5686 num_set_fixnum (num_one, 1);
5641 num_set_ivalue (num_one, 1); 5687 num_set_ivalue (num_one, 1);
5642 5688

Diff Legend

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