ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/microscheme/scheme.c
(Generate patch)

Comparing microscheme/scheme.c (file contents):
Revision 1.41 by root, Mon Nov 30 05:20:10 2015 UTC vs.
Revision 1.52 by root, Tue Dec 1 01:56:22 2015 UTC

… …
16 * (MINISCM) This is a revised and modified version by Akira KIDA. 16 * (MINISCM) This is a revised and modified version by Akira KIDA.
17 * (MINISCM) current version is 0.85k4 (15 May 1994) 17 * (MINISCM) current version is 0.85k4 (15 May 1994)
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1
22
23#if 1
21#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
22#include "malloc.c" 25#include "malloc.c"
26#endif
23 27
24#define SCHEME_SOURCE 28#define SCHEME_SOURCE
25#include "scheme-private.h" 29#include "scheme-private.h"
26#ifndef WIN32 30#ifndef WIN32
27# include <unistd.h> 31# include <unistd.h>
… …
77 81
78#define BACKQUOTE '`' 82#define BACKQUOTE '`'
79#define WHITESPACE " \t\r\n\v\f" 83#define WHITESPACE " \t\r\n\v\f"
80#define DELIMITERS "()\";" WHITESPACE 84#define DELIMITERS "()\";" WHITESPACE
81 85
82#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 86#define NIL POINTER (&SCHEME_V->xNIL)
83#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 87#define S_T POINTER (&SCHEME_V->xT)
84#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 88#define S_F POINTER (&SCHEME_V->xF)
85#define S_SINK (&SCHEME_V->xsink) 89#define S_SINK POINTER (&SCHEME_V->xsink)
86#define S_EOF (&SCHEME_V->xEOF_OBJ) 90#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
87 91
88#if !USE_MULTIPLICITY 92#if !USE_MULTIPLICITY
89static scheme sc; 93static scheme sc;
90#endif 94#endif
91 95
… …
190# define prompt "ts> " 194# define prompt "ts> "
191#endif 195#endif
192 196
193#ifndef InitFile 197#ifndef InitFile
194# define InitFile "init.scm" 198# define InitFile "init.scm"
195#endif
196
197#ifndef FIRST_CELLSEGS
198# define FIRST_CELLSEGS 3
199#endif 199#endif
200 200
201enum scheme_types 201enum scheme_types
202{ 202{
203 T_INTEGER, 203 T_INTEGER,
… …
264static int is_zero_rvalue (RVALUE x); 264static int is_zero_rvalue (RVALUE x);
265 265
266static num num_zero; 266static num num_zero;
267static num num_one; 267static num num_one;
268 268
269/* convert "pointer" to cell* / cell* to pointer */
270#define CELL(p) ((struct cell *)(p) + 0)
271#define POINTER(c) ((void *)((c) - 0))
272
269/* macros for cell operations */ 273/* macros for cell operations */
270#define typeflag(p) ((p)->flag + 0) 274#define typeflag(p) (CELL(p)->flag + 0)
271#define set_typeflag(p,v) ((p)->flag = (v)) 275#define set_typeflag(p,v) (CELL(p)->flag = (v))
272#define type(p) (typeflag (p) & T_MASKTYPE) 276#define type(p) (typeflag (p) & T_MASKTYPE)
273 277
274INTERFACE int 278INTERFACE int
275is_string (pointer p) 279is_string (pointer p)
276{ 280{
277 return type (p) == T_STRING; 281 return type (p) == T_STRING;
278} 282}
279 283
280#define strvalue(p) ((p)->object.string.svalue) 284#define strvalue(p) (CELL(p)->object.string.svalue)
281#define strlength(p) ((p)->object.string.length) 285#define strlength(p) (CELL(p)->object.string.length)
282 286
283INTERFACE int 287INTERFACE int
284is_vector (pointer p) 288is_vector (pointer p)
285{ 289{
286 return type (p) == T_VECTOR; 290 return type (p) == T_VECTOR;
287} 291}
288 292
289#define vecvalue(p) ((p)->object.vector.vvalue) 293#define vecvalue(p) (CELL(p)->object.vector.vvalue)
290#define veclength(p) ((p)->object.vector.length) 294#define veclength(p) (CELL(p)->object.vector.length)
291INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 295INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
292INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 296INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
293INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 297INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
294 298
295INTERFACE int 299INTERFACE int
… …
321string_value (pointer p) 325string_value (pointer p)
322{ 326{
323 return strvalue (p); 327 return strvalue (p);
324} 328}
325 329
326#define ivalue_unchecked(p) (p)->object.ivalue 330#define ivalue_unchecked(p) CELL(p)->object.ivalue
327#define set_ivalue(p,v) (p)->object.ivalue = (v) 331#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
328 332
329#if USE_REAL 333#if USE_REAL
330#define rvalue_unchecked(p) (p)->object.rvalue 334#define rvalue_unchecked(p) CELL(p)->object.rvalue
331#define set_rvalue(p,v) (p)->object.rvalue = (v) 335#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
332#else 336#else
333#define rvalue_unchecked(p) (p)->object.ivalue 337#define rvalue_unchecked(p) CELL(p)->object.ivalue
334#define set_rvalue(p,v) (p)->object.ivalue = (v) 338#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
335#endif 339#endif
336 340
337INTERFACE long 341INTERFACE long
338charvalue (pointer p) 342charvalue (pointer p)
339{ 343{
340 return ivalue_unchecked (p); 344 return ivalue_unchecked (p);
341} 345}
342 346
347#define port(p) CELL(p)->object.port
348#define set_port(p,v) port(p) = (v)
343INTERFACE int 349INTERFACE int
344is_port (pointer p) 350is_port (pointer p)
345{ 351{
346 return type (p) == T_PORT; 352 return type (p) == T_PORT;
347} 353}
348 354
349INTERFACE int 355INTERFACE int
350is_inport (pointer p) 356is_inport (pointer p)
351{ 357{
352 return is_port (p) && p->object.port->kind & port_input; 358 return is_port (p) && port (p)->kind & port_input;
353} 359}
354 360
355INTERFACE int 361INTERFACE int
356is_outport (pointer p) 362is_outport (pointer p)
357{ 363{
358 return is_port (p) && p->object.port->kind & port_output; 364 return is_port (p) && port (p)->kind & port_output;
359} 365}
360 366
361INTERFACE int 367INTERFACE int
362is_pair (pointer p) 368is_pair (pointer p)
363{ 369{
364 return type (p) == T_PAIR; 370 return type (p) == T_PAIR;
365} 371}
366 372
367#define car(p) ((p)->object.cons.car + 0) 373#define car(p) (POINTER (CELL(p)->object.cons.car))
368#define cdr(p) ((p)->object.cons.cdr + 0) 374#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
369 375
370static pointer caar (pointer p) { return car (car (p)); } 376static pointer caar (pointer p) { return car (car (p)); }
371static pointer cadr (pointer p) { return car (cdr (p)); } 377static pointer cadr (pointer p) { return car (cdr (p)); }
372static pointer cdar (pointer p) { return cdr (car (p)); } 378static pointer cdar (pointer p) { return cdr (car (p)); }
373static pointer cddr (pointer p) { return cdr (cdr (p)); } 379static pointer cddr (pointer p) { return cdr (cdr (p)); }
… …
377static pointer cdaar (pointer p) { return cdr (car (car (p))); } 383static pointer cdaar (pointer p) { return cdr (car (car (p))); }
378 384
379INTERFACE void 385INTERFACE void
380set_car (pointer p, pointer q) 386set_car (pointer p, pointer q)
381{ 387{
382 p->object.cons.car = q; 388 CELL(p)->object.cons.car = CELL (q);
383} 389}
384 390
385INTERFACE void 391INTERFACE void
386set_cdr (pointer p, pointer q) 392set_cdr (pointer p, pointer q)
387{ 393{
388 p->object.cons.cdr = q; 394 CELL(p)->object.cons.cdr = CELL (q);
389} 395}
390 396
391INTERFACE pointer 397INTERFACE pointer
392pair_car (pointer p) 398pair_car (pointer p)
393{ 399{
… …
411{ 417{
412 return strvalue (p); 418 return strvalue (p);
413} 419}
414 420
415#if USE_PLIST 421#if USE_PLIST
422#error plists are broken because symbols are no longer pairs
423#define symprop(p) cdr(p)
416SCHEME_EXPORT int 424SCHEME_EXPORT int
417hasprop (pointer p) 425hasprop (pointer p)
418{ 426{
419 return typeflag (p) & T_SYMBOL; 427 return typeflag (p) & T_SYMBOL;
420} 428}
421
422# define symprop(p) cdr(p)
423#endif 429#endif
424 430
425INTERFACE int 431INTERFACE int
426is_syntax (pointer p) 432is_syntax (pointer p)
427{ 433{
… …
668 674
669static int file_push (SCHEME_P_ const char *fname); 675static int file_push (SCHEME_P_ const char *fname);
670static void file_pop (SCHEME_P); 676static void file_pop (SCHEME_P);
671static int file_interactive (SCHEME_P); 677static int file_interactive (SCHEME_P);
672ecb_inline int is_one_of (const char *s, int c); 678ecb_inline int is_one_of (const char *s, int c);
673static int alloc_cellseg (SCHEME_P_ int n); 679static int alloc_cellseg (SCHEME_P);
674ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 680ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
675static void finalize_cell (SCHEME_P_ pointer a); 681static void finalize_cell (SCHEME_P_ pointer a);
676static int count_consecutive_cells (pointer x, int needed); 682static int count_consecutive_cells (pointer x, int needed);
677static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 683static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
678static pointer mk_number (SCHEME_P_ const num n); 684static pointer mk_number (SCHEME_P_ const num n);
… …
912#endif 918#endif
913} 919}
914 920
915/* allocate new cell segment */ 921/* allocate new cell segment */
916static int 922static int
917alloc_cellseg (SCHEME_P_ int n) 923alloc_cellseg (SCHEME_P)
918{ 924{
919 pointer newp; 925 struct cell *newp;
920 pointer last; 926 struct cell *last;
921 pointer p; 927 struct cell *p;
922 char *cp; 928 char *cp;
923 long i; 929 long i;
924 int k; 930 int k;
925 931
926 static int segsize = CELL_SEGSIZE >> 1; 932 static int segsize = CELL_SEGSIZE >> 1;
927 segsize <<= 1; 933 segsize <<= 1;
928 934
929 for (k = 0; k < n; k++)
930 {
931 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
932 return k;
933
934 cp = malloc (segsize * sizeof (struct cell)); 935 cp = malloc (segsize * sizeof (struct cell));
935 936
936 if (!cp && USE_ERROR_CHECKING) 937 if (!cp && USE_ERROR_CHECKING)
937 return k; 938 return k;
938 939
939 i = ++SCHEME_V->last_cell_seg; 940 i = ++SCHEME_V->last_cell_seg;
940 SCHEME_V->alloc_seg[i] = cp; 941 SCHEME_V->alloc_seg[i] = cp;
941 942
942 newp = (pointer)cp; 943 newp = (struct cell *)cp;
943 SCHEME_V->cell_seg[i] = newp; 944 SCHEME_V->cell_seg[i] = newp;
944 SCHEME_V->cell_segsize[i] = segsize; 945 SCHEME_V->cell_segsize[i] = segsize;
945 SCHEME_V->fcells += segsize; 946 SCHEME_V->fcells += segsize;
946 last = newp + segsize - 1; 947 last = newp + segsize - 1;
947 948
948 for (p = newp; p <= last; p++) 949 for (p = newp; p <= last; p++)
949 { 950 {
951 pointer cp = POINTER (p);
950 set_typeflag (p, T_PAIR); 952 set_typeflag (cp, T_PAIR);
951 set_car (p, NIL); 953 set_car (cp, NIL);
952 set_cdr (p, p + 1); 954 set_cdr (cp, POINTER (p + 1));
953 } 955 }
954 956
955 set_cdr (last, SCHEME_V->free_cell); 957 set_cdr (POINTER (last), SCHEME_V->free_cell);
956 SCHEME_V->free_cell = newp; 958 SCHEME_V->free_cell = POINTER (newp);
957 }
958 959
959 return n; 960 return 1;
960} 961}
961 962
962/* get new cell. parameter a, b is marked by gc. */ 963/* get new cell. parameter a, b is marked by gc. */
963ecb_inline pointer 964ecb_inline pointer
964get_cell_x (SCHEME_P_ pointer a, pointer b) 965get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
968 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 969 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
969 return S_SINK; 970 return S_SINK;
970 971
971 if (SCHEME_V->free_cell == NIL) 972 if (SCHEME_V->free_cell == NIL)
972 { 973 {
973 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 974 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;
974 975
975 gc (SCHEME_A_ a, b); 976 gc (SCHEME_A_ a, b);
976 977
977 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 978 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
978 { 979 {
979 /* if only a few recovered, get more to avoid fruitless gc's */ 980 /* if only a few recovered, get more to avoid fruitless gc's */
980 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 981 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
981 { 982 {
982#if USE_ERROR_CHECKING 983#if USE_ERROR_CHECKING
983 SCHEME_V->no_memory = 1; 984 SCHEME_V->no_memory = 1;
984 return S_SINK; 985 return S_SINK;
985#endif 986#endif
… …
997 } 998 }
998} 999}
999 1000
1000/* To retain recent allocs before interpreter knows about them - 1001/* To retain recent allocs before interpreter knows about them -
1001 Tehom */ 1002 Tehom */
1002
1003static void 1003static void
1004push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 1004push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1005{ 1005{
1006 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 1006 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1007 1007
… …
1029} 1029}
1030 1030
1031static pointer 1031static pointer
1032get_vector_object (SCHEME_P_ uint32_t len, pointer init) 1032get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1033{ 1033{
1034 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1034 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1035 pointer *e = malloc (len * sizeof (pointer)); 1035 pointer *e = malloc (len * sizeof (pointer));
1036 1036
1037 if (!e && USE_ERROR_CHECKING) 1037 if (!e && USE_ERROR_CHECKING)
1038 return S_SINK; 1038 return S_SINK;
1039 1039
1040 /* Record it as a vector so that gc understands it. */ 1040 /* Record it as a vector so that gc understands it. */
1041 set_typeflag (v, T_VECTOR | T_ATOM); 1041 set_typeflag (v, T_VECTOR | T_ATOM);
1042 1042
1043 v->object.vector.vvalue = e; 1043 CELL(v)->object.vector.vvalue = e;
1044 v->object.vector.length = len; 1044 CELL(v)->object.vector.length = len;
1045 fill_vector (v, 0, init); 1045 fill_vector (v, 0, init);
1046 push_recent_alloc (SCHEME_A_ v, NIL); 1046 push_recent_alloc (SCHEME_A_ v, NIL);
1047 1047
1048 return v; 1048 return v;
1049} 1049}
… …
1092 set_car (x, a); 1092 set_car (x, a);
1093 set_cdr (x, b); 1093 set_cdr (x, b);
1094 1094
1095 return x; 1095 return x;
1096} 1096}
1097
1098/* ========== oblist implementation ========== */
1099 1097
1100static pointer 1098static pointer
1101generate_symbol (SCHEME_P_ const char *name) 1099generate_symbol (SCHEME_P_ const char *name)
1102{ 1100{
1103 pointer x = mk_string (SCHEME_A_ name); 1101 pointer x = mk_string (SCHEME_A_ name);
1104 setimmutable (x); 1102 setimmutable (x);
1105 set_typeflag (x, T_SYMBOL | T_ATOM); 1103 set_typeflag (x, T_SYMBOL | T_ATOM);
1106 return x; 1104 return x;
1107} 1105}
1108 1106
1107/* ========== oblist implementation ========== */
1108
1109#ifndef USE_OBJECT_LIST 1109#ifndef USE_OBJECT_LIST
1110 1110
1111static int 1111static int
1112hash_fn (const char *key, int table_size) 1112hash_fn (const char *key, int table_size)
1113{ 1113{
… …
1199 1199
1200/* returns the new symbol */ 1200/* returns the new symbol */
1201static pointer 1201static pointer
1202oblist_add_by_name (SCHEME_P_ const char *name) 1202oblist_add_by_name (SCHEME_P_ const char *name)
1203{ 1203{
1204 pointer x = mk_string (SCHEME_A_ name); 1204 pointer x = generate_symbol (SCHEME_A_ name);
1205 set_typeflag (x, T_SYMBOL);
1206 setimmutable (x);
1207 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1205 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1208 return x; 1206 return x;
1209} 1207}
1210 1208
1211static pointer 1209static pointer
… …
1221mk_port (SCHEME_P_ port *p) 1219mk_port (SCHEME_P_ port *p)
1222{ 1220{
1223 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1221 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1224 1222
1225 set_typeflag (x, T_PORT | T_ATOM); 1223 set_typeflag (x, T_PORT | T_ATOM);
1226 x->object.port = p; 1224 set_port (x, p);
1227 1225
1228 return x; 1226 return x;
1229} 1227}
1230#endif 1228#endif
1231 1229
1232pointer 1230pointer
1233mk_foreign_func (SCHEME_P_ foreign_func f) 1231mk_foreign_func (SCHEME_P_ foreign_func f)
1234{ 1232{
1235 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1233 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1236 1234
1237 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1235 set_typeflag (x, T_FOREIGN | T_ATOM);
1238 x->object.ff = f; 1236 CELL(x)->object.ff = f;
1239 1237
1240 return x; 1238 return x;
1241} 1239}
1242 1240
1243INTERFACE pointer 1241INTERFACE pointer
1244mk_character (SCHEME_P_ int c) 1242mk_character (SCHEME_P_ int c)
1245{ 1243{
1246 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1244 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1247 1245
1248 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1246 set_typeflag (x, T_CHARACTER | T_ATOM);
1249 set_ivalue (x, c & 0xff); 1247 set_ivalue (x, c & 0xff);
1250 1248
1251 return x; 1249 return x;
1252} 1250}
1253 1251
1254/* get number atom (integer) */ 1252/* get number atom (integer) */
1255INTERFACE pointer 1253INTERFACE pointer
1256mk_integer (SCHEME_P_ long n) 1254mk_integer (SCHEME_P_ long n)
1257{ 1255{
1256 pointer p = 0;
1257 pointer *pp = &p;
1258
1259#if USE_INTCACHE
1260 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1261 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1262#endif
1263
1264 if (!*pp)
1265 {
1258 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1266 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1259 1267
1260 set_typeflag (x, (T_INTEGER | T_ATOM)); 1268 set_typeflag (x, T_INTEGER | T_ATOM);
1269 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1261 set_ivalue (x, n); 1270 set_ivalue (x, n);
1262 1271
1272 *pp = x;
1273 }
1274
1263 return x; 1275 return *pp;
1264} 1276}
1265 1277
1266INTERFACE pointer 1278INTERFACE pointer
1267mk_real (SCHEME_P_ RVALUE n) 1279mk_real (SCHEME_P_ RVALUE n)
1268{ 1280{
1269#if USE_REAL 1281#if USE_REAL
1270 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1282 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1271 1283
1272 set_typeflag (x, (T_REAL | T_ATOM)); 1284 set_typeflag (x, T_REAL | T_ATOM);
1273 set_rvalue (x, n); 1285 set_rvalue (x, n);
1274 1286
1275 return x; 1287 return x;
1276#else 1288#else
1277 return mk_integer (SCHEME_A_ n); 1289 return mk_integer (SCHEME_A_ n);
… …
1393INTERFACE pointer 1405INTERFACE pointer
1394gensym (SCHEME_P) 1406gensym (SCHEME_P)
1395{ 1407{
1396 pointer x; 1408 pointer x;
1397 char name[40] = "gensym-"; 1409 char name[40] = "gensym-";
1398 xnum (name + 7, SCHEME_V->gensym_cnt); 1410 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1399 1411
1400 return generate_symbol (SCHEME_A_ name); 1412 return generate_symbol (SCHEME_A_ name);
1413}
1414
1415static int
1416is_gensym (SCHEME_P_ pointer x)
1417{
1418 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1401} 1419}
1402 1420
1403/* make symbol or number atom from string */ 1421/* make symbol or number atom from string */
1404static pointer 1422static pointer
1405mk_atom (SCHEME_P_ char *q) 1423mk_atom (SCHEME_P_ char *q)
… …
1614 1632
1615/* garbage collection. parameter a, b is marked. */ 1633/* garbage collection. parameter a, b is marked. */
1616static void 1634static void
1617gc (SCHEME_P_ pointer a, pointer b) 1635gc (SCHEME_P_ pointer a, pointer b)
1618{ 1636{
1619 pointer p;
1620 int i; 1637 int i;
1621 1638
1622 if (SCHEME_V->gc_verbose) 1639 if (SCHEME_V->gc_verbose)
1623 putstr (SCHEME_A_ "gc..."); 1640 putstr (SCHEME_A_ "gc...");
1624 1641
… …
1640 /* Mark recent objects the interpreter doesn't know about yet. */ 1657 /* Mark recent objects the interpreter doesn't know about yet. */
1641 mark (car (S_SINK)); 1658 mark (car (S_SINK));
1642 /* Mark any older stuff above nested C calls */ 1659 /* Mark any older stuff above nested C calls */
1643 mark (SCHEME_V->c_nest); 1660 mark (SCHEME_V->c_nest);
1644 1661
1662#if USE_INTCACHE
1663 /* mark intcache */
1664 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1665 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1666 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1667#endif
1668
1645 /* mark variables a, b */ 1669 /* mark variables a, b */
1646 mark (a); 1670 mark (a);
1647 mark (b); 1671 mark (b);
1648 1672
1649 /* garbage collect */ 1673 /* garbage collect */
1650 clrmark (NIL); 1674 clrmark (NIL);
1651 SCHEME_V->fcells = 0; 1675 SCHEME_V->fcells = 0;
1652 SCHEME_V->free_cell = NIL; 1676 SCHEME_V->free_cell = NIL;
1653 1677
1654 /* free-list is kept sorted by address so as to maintain consecutive 1678 if (SCHEME_V->gc_verbose)
1655 ranges, if possible, for use with vectors. Here we scan the cells 1679 xwrstr ("freeing...");
1656 (which are also kept sorted by address) downwards to build the 1680
1657 free-list in sorted order. 1681 uint32_t total = 0;
1658 */ 1682
1683 /* Here we scan the cells to build the free-list. */
1659 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1684 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1660 { 1685 {
1661 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; 1686 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1687 struct cell *p;
1688 total += SCHEME_V->cell_segsize [i];
1662 1689
1663 while (--p >= SCHEME_V->cell_seg[i]) 1690 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1664 { 1691 {
1692 pointer c = POINTER (p);
1693
1665 if (is_mark (p)) 1694 if (is_mark (c))
1666 clrmark (p); 1695 clrmark (c);
1667 else 1696 else
1668 { 1697 {
1669 /* reclaim cell */ 1698 /* reclaim cell */
1670 if (typeflag (p) != T_PAIR) 1699 if (typeflag (c) != T_PAIR)
1671 { 1700 {
1672 finalize_cell (SCHEME_A_ p); 1701 finalize_cell (SCHEME_A_ c);
1673 set_typeflag (p, T_PAIR); 1702 set_typeflag (c, T_PAIR);
1674 set_car (p, NIL); 1703 set_car (c, NIL);
1675 } 1704 }
1676 1705
1677 ++SCHEME_V->fcells; 1706 ++SCHEME_V->fcells;
1678 set_cdr (p, SCHEME_V->free_cell); 1707 set_cdr (c, SCHEME_V->free_cell);
1679 SCHEME_V->free_cell = p; 1708 SCHEME_V->free_cell = c;
1680 } 1709 }
1681 } 1710 }
1682 } 1711 }
1683 1712
1684 if (SCHEME_V->gc_verbose) 1713 if (SCHEME_V->gc_verbose)
1685 { 1714 {
1686 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");
1687 } 1716 }
1688} 1717}
1689 1718
1690static void 1719static void
1691finalize_cell (SCHEME_P_ pointer a) 1720finalize_cell (SCHEME_P_ pointer a)
… …
1696 else if (is_vector (a)) 1725 else if (is_vector (a))
1697 free (vecvalue (a)); 1726 free (vecvalue (a));
1698#if USE_PORTS 1727#if USE_PORTS
1699 else if (is_port (a)) 1728 else if (is_port (a))
1700 { 1729 {
1701 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1730 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1702 port_close (SCHEME_A_ a, port_input | port_output); 1731 port_close (SCHEME_A_ a, port_input | port_output);
1703 1732
1704 free (a->object.port); 1733 free (port (a));
1705 } 1734 }
1706#endif 1735#endif
1707} 1736}
1708 1737
1709/* ========== Routines for Reading ========== */ 1738/* ========== Routines for Reading ========== */
… …
1725 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1754 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1726 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1755 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1727 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1756 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1728 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1757 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1729 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1758 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1730 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1759 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1731 1760
1732#if SHOW_ERROR_LINE 1761#if SHOW_ERROR_LINE
1733 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1762 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1734 1763
1735 if (fname) 1764 if (fname)
… …
1752 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1781 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1753#if USE_PORTS 1782#if USE_PORTS
1754 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1783 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1755#endif 1784#endif
1756 SCHEME_V->file_i--; 1785 SCHEME_V->file_i--;
1757 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1786 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1758 } 1787 }
1759} 1788}
1760 1789
1761static int 1790static int
1762file_interactive (SCHEME_P) 1791file_interactive (SCHEME_P)
1763{ 1792{
1764#if USE_PORTS 1793#if USE_PORTS
1765 return SCHEME_V->file_i == 0 1794 return SCHEME_V->file_i == 0
1766 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1795 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1767 && (SCHEME_V->inport->object.port->kind & port_file); 1796 && (port (SCHEME_V->inport)->kind & port_file);
1768#else 1797#else
1769 return 0; 1798 return 0;
1770#endif 1799#endif
1771} 1800}
1772 1801
… …
1906} 1935}
1907 1936
1908static void 1937static void
1909port_close (SCHEME_P_ pointer p, int flag) 1938port_close (SCHEME_P_ pointer p, int flag)
1910{ 1939{
1911 port *pt = p->object.port; 1940 port *pt = port (p);
1912 1941
1913 pt->kind &= ~flag; 1942 pt->kind &= ~flag;
1914 1943
1915 if ((pt->kind & (port_input | port_output)) == 0) 1944 if ((pt->kind & (port_input | port_output)) == 0)
1916 { 1945 {
… …
1937/* get new character from input file */ 1966/* get new character from input file */
1938static int 1967static int
1939inchar (SCHEME_P) 1968inchar (SCHEME_P)
1940{ 1969{
1941 int c; 1970 int c;
1942 port *pt; 1971 port *pt = port (SCHEME_V->inport);
1943
1944 pt = SCHEME_V->inport->object.port;
1945 1972
1946 if (pt->kind & port_saw_EOF) 1973 if (pt->kind & port_saw_EOF)
1947 return EOF; 1974 return EOF;
1948 1975
1949 c = basic_inchar (pt); 1976 c = basic_inchar (pt);
… …
2016 port *pt; 2043 port *pt;
2017 2044
2018 if (c == EOF) 2045 if (c == EOF)
2019 return; 2046 return;
2020 2047
2021 pt = SCHEME_V->inport->object.port; 2048 pt = port (SCHEME_V->inport);
2022 pt->unget = c; 2049 pt->unget = c;
2023#else 2050#else
2024 if (c == EOF) 2051 if (c == EOF)
2025 return; 2052 return;
2026 2053
… …
2054 2081
2055INTERFACE void 2082INTERFACE void
2056putstr (SCHEME_P_ const char *s) 2083putstr (SCHEME_P_ const char *s)
2057{ 2084{
2058#if USE_PORTS 2085#if USE_PORTS
2059 port *pt = SCHEME_V->outport->object.port; 2086 port *pt = port (SCHEME_V->outport);
2060 2087
2061 if (pt->kind & port_file) 2088 if (pt->kind & port_file)
2062 write (pt->rep.stdio.file, s, strlen (s)); 2089 write (pt->rep.stdio.file, s, strlen (s));
2063 else 2090 else
2064 for (; *s; s++) 2091 for (; *s; s++)
… …
2074 2101
2075static void 2102static void
2076putchars (SCHEME_P_ const char *s, int len) 2103putchars (SCHEME_P_ const char *s, int len)
2077{ 2104{
2078#if USE_PORTS 2105#if USE_PORTS
2079 port *pt = SCHEME_V->outport->object.port; 2106 port *pt = port (SCHEME_V->outport);
2080 2107
2081 if (pt->kind & port_file) 2108 if (pt->kind & port_file)
2082 write (pt->rep.stdio.file, s, len); 2109 write (pt->rep.stdio.file, s, len);
2083 else 2110 else
2084 { 2111 {
… …
2098 2125
2099INTERFACE void 2126INTERFACE void
2100putcharacter (SCHEME_P_ int c) 2127putcharacter (SCHEME_P_ int c)
2101{ 2128{
2102#if USE_PORTS 2129#if USE_PORTS
2103 port *pt = SCHEME_V->outport->object.port; 2130 port *pt = port (SCHEME_V->outport);
2104 2131
2105 if (pt->kind & port_file) 2132 if (pt->kind & port_file)
2106 { 2133 {
2107 char cc = c; 2134 char cc = c;
2108 write (pt->rep.stdio.file, &cc, 1); 2135 write (pt->rep.stdio.file, &cc, 1);
… …
3050{ 3077{
3051 int nframes = (uintptr_t)SCHEME_V->dump; 3078 int nframes = (uintptr_t)SCHEME_V->dump;
3052 struct dump_stack_frame *next_frame; 3079 struct dump_stack_frame *next_frame;
3053 3080
3054 /* enough room for the next frame? */ 3081 /* enough room for the next frame? */
3055 if (nframes >= SCHEME_V->dump_size) 3082 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3056 { 3083 {
3057 SCHEME_V->dump_size += STACK_GROWTH; 3084 SCHEME_V->dump_size += STACK_GROWTH;
3058 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3085 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3059 } 3086 }
3060 3087
… …
3241 3268
3242#endif 3269#endif
3243 3270
3244#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3271#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3245 3272
3246#if 1 3273#if EXPERIMENT
3247static int 3274static int
3248debug (SCHEME_P_ int indent, pointer x) 3275debug (SCHEME_P_ int indent, pointer x)
3249{ 3276{
3250 int c; 3277 int c;
3251 3278
… …
3307 pointer args = SCHEME_V->args; 3334 pointer args = SCHEME_V->args;
3308 pointer x, y; 3335 pointer x, y;
3309 3336
3310 switch (op) 3337 switch (op)
3311 { 3338 {
3312#if 1 //D 3339#if EXPERIMENT //D
3313 case OP_DEBUG: 3340 case OP_DEBUG:
3314 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3341 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3315 printf ("\n"); 3342 printf ("\n");
3316 s_return (S_T); 3343 s_return (S_T);
3317#endif 3344#endif
3318 case OP_LOAD: /* load */ 3345 case OP_LOAD: /* load */
3319 if (file_interactive (SCHEME_A)) 3346 if (file_interactive (SCHEME_A))
3320 { 3347 {
3321 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3348 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3322 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3349 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3323 } 3350 }
3324 3351
3325 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3352 if (!file_push (SCHEME_A_ strvalue (car (args))))
3326 Error_1 ("unable to open", car (args)); 3353 Error_1 ("unable to open", car (args));
3327 else 3354 else
… …
3331 } 3358 }
3332 3359
3333 case OP_T0LVL: /* top level */ 3360 case OP_T0LVL: /* top level */
3334 3361
3335 /* If we reached the end of file, this loop is done. */ 3362 /* If we reached the end of file, this loop is done. */
3336 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3363 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3337 { 3364 {
3338 if (SCHEME_V->file_i == 0) 3365 if (SCHEME_V->file_i == 0)
3339 { 3366 {
3340 SCHEME_V->args = NIL; 3367 SCHEME_V->args = NIL;
3341 s_goto (OP_QUIT); 3368 s_goto (OP_QUIT);
… …
3419#endif 3446#endif
3420 if (is_symbol (SCHEME_V->code)) /* symbol */ 3447 if (is_symbol (SCHEME_V->code)) /* symbol */
3421 { 3448 {
3422 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3449 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3423 3450
3424 if (x != NIL) 3451 if (x == NIL)
3425 s_return (slot_value_in_env (x));
3426 else
3427 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3452 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3453
3454 s_return (slot_value_in_env (x));
3428 } 3455 }
3429 else if (is_pair (SCHEME_V->code)) 3456 else if (is_pair (SCHEME_V->code))
3430 { 3457 {
3431 x = car (SCHEME_V->code); 3458 x = car (SCHEME_V->code);
3432 3459
… …
3509 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3536 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3510 else if (is_foreign (SCHEME_V->code)) 3537 else if (is_foreign (SCHEME_V->code))
3511 { 3538 {
3512 /* Keep nested calls from GC'ing the arglist */ 3539 /* Keep nested calls from GC'ing the arglist */
3513 push_recent_alloc (SCHEME_A_ args, NIL); 3540 push_recent_alloc (SCHEME_A_ args, NIL);
3514 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3541 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3515 3542
3516 s_return (x); 3543 s_return (x);
3517 } 3544 }
3518 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3545 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3519 { 3546 {
… …
3556 3583
3557 case OP_DOMACRO: /* do macro */ 3584 case OP_DOMACRO: /* do macro */
3558 SCHEME_V->code = SCHEME_V->value; 3585 SCHEME_V->code = SCHEME_V->value;
3559 s_goto (OP_EVAL); 3586 s_goto (OP_EVAL);
3560 3587
3561#if 1
3562
3563 case OP_LAMBDA: /* lambda */ 3588 case OP_LAMBDA: /* lambda */
3564 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3589 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3565 set SCHEME_V->value fall thru */ 3590 set SCHEME_V->value fall thru */
3566 { 3591 {
3567 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1); 3592 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
… …
3573 SCHEME_V->code = slot_value_in_env (f); 3598 SCHEME_V->code = slot_value_in_env (f);
3574 s_goto (OP_APPLY); 3599 s_goto (OP_APPLY);
3575 } 3600 }
3576 3601
3577 SCHEME_V->value = SCHEME_V->code; 3602 SCHEME_V->value = SCHEME_V->code;
3578 /* Fallthru */
3579 } 3603 }
3604 /* Fallthru */
3580 3605
3581 case OP_LAMBDA1: 3606 case OP_LAMBDA1:
3582 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3607 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3583
3584#else
3585
3586 case OP_LAMBDA: /* lambda */
3587 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3588
3589#endif
3590 3608
3591 case OP_MKCLOSURE: /* make-closure */ 3609 case OP_MKCLOSURE: /* make-closure */
3592 x = car (args); 3610 x = car (args);
3593 3611
3594 if (car (x) == SCHEME_V->LAMBDA) 3612 if (car (x) == SCHEME_V->LAMBDA)
… …
4190 else 4208 else
4191 Error_0 ("modulo: division by zero"); 4209 Error_0 ("modulo: division by zero");
4192 4210
4193 s_return (mk_number (SCHEME_A_ v)); 4211 s_return (mk_number (SCHEME_A_ v));
4194 4212
4195 case OP_CAR: /* car */ 4213 /* the compiler will optimize this mess... */
4196 s_return (caar (args)); 4214 case OP_CAR: op_car: s_return (car (x));
4197 4215 case OP_CDR: op_cdr: s_return (cdr (x));
4198 case OP_CDR: /* cdr */ 4216 case OP_CAAR: op_caar: x = car (x); goto op_car;
4199 s_return (cdar (args)); 4217 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4218 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4219 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4220 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4221 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4222 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4223 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4224 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4225 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4226 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4227 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4228 case OP_CAAAAR: x = car (x); goto op_caaar;
4229 case OP_CAAADR: x = cdr (x); goto op_caaar;
4230 case OP_CAADAR: x = car (x); goto op_caadr;
4231 case OP_CAADDR: x = cdr (x); goto op_caadr;
4232 case OP_CADAAR: x = car (x); goto op_cadar;
4233 case OP_CADADR: x = cdr (x); goto op_cadar;
4234 case OP_CADDAR: x = car (x); goto op_caddr;
4235 case OP_CADDDR: x = cdr (x); goto op_caddr;
4236 case OP_CDAAAR: x = car (x); goto op_cdaar;
4237 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4238 case OP_CDADAR: x = car (x); goto op_cdadr;
4239 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4240 case OP_CDDAAR: x = car (x); goto op_cddar;
4241 case OP_CDDADR: x = cdr (x); goto op_cddar;
4242 case OP_CDDDAR: x = car (x); goto op_cdddr;
4243 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4200 4244
4201 case OP_CONS: /* cons */ 4245 case OP_CONS: /* cons */
4202 set_cdr (args, cadr (args)); 4246 set_cdr (args, cadr (args));
4203 s_return (args); 4247 s_return (args);
4204 4248
… …
4526 pointer d = cdr (args); 4570 pointer d = cdr (args);
4527 int r; 4571 int r;
4528 4572
4529 switch (op) 4573 switch (op)
4530 { 4574 {
4531 case OP_NOT: /* not */ r = is_false (a) ; break; 4575 case OP_NOT: /* not */ r = is_false (a) ; break;
4532 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; 4576 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4533 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; 4577 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4534 case OP_NULLP: /* null? */ r = a == NIL ; break; 4578 case OP_NULLP: /* null? */ r = a == NIL ; break;
4535 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; 4579 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4580 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4536 case OP_NUMBERP: /* number? */ r = is_number (a) ; break; 4581 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4537 case OP_STRINGP: /* string? */ r = is_string (a) ; break; 4582 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4538 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4583 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4539 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ 4584 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4540 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4585 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4541 4586
4542#if USE_CHAR_CLASSIFIERS 4587#if USE_CHAR_CLASSIFIERS
4543 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 4588 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4544 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; 4589 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4545 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; 4590 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
… …
4595 } 4640 }
4596 else 4641 else
4597 s_return (SCHEME_V->code); 4642 s_return (SCHEME_V->code);
4598 4643
4599 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4644 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4600 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4645 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4601 s_return (SCHEME_V->value); 4646 s_return (SCHEME_V->value);
4602 4647
4603#if USE_PORTS 4648#if USE_PORTS
4604 4649
4605 case OP_WRITE: /* write */ 4650 case OP_WRITE: /* write */
… …
4750 SCHEME_V->gc_verbose = (a != S_F); 4795 SCHEME_V->gc_verbose = (a != S_F);
4751 s_retbool (was); 4796 s_retbool (was);
4752 } 4797 }
4753 4798
4754 case OP_NEWSEGMENT: /* new-segment */ 4799 case OP_NEWSEGMENT: /* new-segment */
4800#if 0
4755 if (!is_pair (args) || !is_number (a)) 4801 if (!is_pair (args) || !is_number (a))
4756 Error_0 ("new-segment: argument must be a number"); 4802 Error_0 ("new-segment: argument must be a number");
4757 4803#endif
4758 alloc_cellseg (SCHEME_A_ ivalue (a)); 4804 s_retbool (alloc_cellseg (SCHEME_A));
4759
4760 s_return (S_T);
4761 4805
4762 case OP_OBLIST: /* oblist */ 4806 case OP_OBLIST: /* oblist */
4763 s_return (oblist_all_symbols (SCHEME_A)); 4807 s_return (oblist_all_symbols (SCHEME_A));
4764 4808
4765#if USE_PORTS 4809#if USE_PORTS
… …
4835 s_return (p == NIL ? S_F : p); 4879 s_return (p == NIL ? S_F : p);
4836 } 4880 }
4837 4881
4838 case OP_GET_OUTSTRING: /* get-output-string */ 4882 case OP_GET_OUTSTRING: /* get-output-string */
4839 { 4883 {
4840 port *p; 4884 port *p = port (a);
4841 4885
4842 if ((p = a->object.port)->kind & port_string) 4886 if (p->kind & port_string)
4843 { 4887 {
4844 off_t size; 4888 off_t size;
4845 char *str; 4889 char *str;
4846 4890
4847 size = p->rep.string.curr - p->rep.string.start + 1; 4891 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4952 int res; 4996 int res;
4953 4997
4954 if (is_pair (args)) 4998 if (is_pair (args))
4955 p = car (args); 4999 p = car (args);
4956 5000
4957 res = p->object.port->kind & port_string; 5001 res = port (p)->kind & port_string;
4958 5002
4959 s_retbool (res); 5003 s_retbool (res);
4960 } 5004 }
4961 5005
4962 case OP_SET_INPORT: /* set-input-port */ 5006 case OP_SET_INPORT: /* set-input-port */
… …
5626scheme_init (SCHEME_P) 5670scheme_init (SCHEME_P)
5627{ 5671{
5628 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5672 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5629 pointer x; 5673 pointer x;
5630 5674
5675 /* this memset is not strictly correct, as we assume (intcache)
5676 * that memset 0 will also set pointers to 0, but memset does
5677 * of course not guarantee that. screw such systems.
5678 */
5679 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5680
5631 num_set_fixnum (num_zero, 1); 5681 num_set_fixnum (num_zero, 1);
5632 num_set_ivalue (num_zero, 0); 5682 num_set_ivalue (num_zero, 0);
5633 num_set_fixnum (num_one, 1); 5683 num_set_fixnum (num_one, 1);
5634 num_set_ivalue (num_one, 1); 5684 num_set_ivalue (num_one, 1);
5635 5685
… …
5646 SCHEME_V->save_inport = NIL; 5696 SCHEME_V->save_inport = NIL;
5647 SCHEME_V->loadport = NIL; 5697 SCHEME_V->loadport = NIL;
5648 SCHEME_V->nesting = 0; 5698 SCHEME_V->nesting = 0;
5649 SCHEME_V->interactive_repl = 0; 5699 SCHEME_V->interactive_repl = 0;
5650 5700
5651 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5701 if (!alloc_cellseg (SCHEME_A))
5652 { 5702 {
5653#if USE_ERROR_CHECKING 5703#if USE_ERROR_CHECKING
5654 SCHEME_V->no_memory = 1; 5704 SCHEME_V->no_memory = 1;
5655 return 0; 5705 return 0;
5656#endif 5706#endif

Diff Legend

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