… | |
… | |
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) |
419 | SCHEME_EXPORT int |
420 | SCHEME_EXPORT int |
420 | hasprop (pointer p) |
421 | hasprop (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 | |
1032 | static pointer |
1033 | static pointer |
1033 | get_vector_object (SCHEME_P_ uint32_t len, pointer init) |
1034 | get_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 */ |
1202 | static pointer |
1203 | static pointer |
1203 | oblist_add_by_name (SCHEME_P_ const char *name) |
1204 | oblist_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 | |
1212 | static pointer |
1211 | static pointer |
… | |
… | |
1233 | pointer |
1232 | pointer |
1234 | mk_foreign_func (SCHEME_P_ foreign_func f) |
1233 | mk_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 | |
1244 | INTERFACE pointer |
1243 | INTERFACE pointer |
1245 | mk_character (SCHEME_P_ int c) |
1244 | mk_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) */ |
1256 | INTERFACE pointer |
1255 | INTERFACE pointer |
1257 | mk_integer (SCHEME_P_ long n) |
1256 | mk_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 | |
1267 | INTERFACE pointer |
1280 | INTERFACE pointer |
1268 | mk_real (SCHEME_P_ RVALUE n) |
1281 | mk_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 | |
… | |
… | |
5633 | scheme_init (SCHEME_P) |
5673 | scheme_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 | memset (SCHEME_V, 0, sizeof (*SCHEME_V));//TODO !iso c |
|
|
5679 | |
5638 | num_set_fixnum (num_zero, 1); |
5680 | num_set_fixnum (num_zero, 1); |
5639 | num_set_ivalue (num_zero, 0); |
5681 | num_set_ivalue (num_zero, 0); |
5640 | num_set_fixnum (num_one, 1); |
5682 | num_set_fixnum (num_one, 1); |
5641 | num_set_ivalue (num_one, 1); |
5683 | num_set_ivalue (num_one, 1); |
5642 | |
5684 | |