--- microscheme/scheme.c 2015/11/30 05:20:10 1.41 +++ microscheme/scheme.c 2015/12/01 01:56:22 1.52 @@ -18,8 +18,12 @@ * */ +#define EXPERIMENT 1 + +#if 1 #define PAGE_SIZE 4096 /* does not work on sparc/alpha */ #include "malloc.c" +#endif #define SCHEME_SOURCE #include "scheme-private.h" @@ -79,11 +83,11 @@ #define WHITESPACE " \t\r\n\v\f" #define DELIMITERS "()\";" WHITESPACE -#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? -#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? -#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? -#define S_SINK (&SCHEME_V->xsink) -#define S_EOF (&SCHEME_V->xEOF_OBJ) +#define NIL POINTER (&SCHEME_V->xNIL) +#define S_T POINTER (&SCHEME_V->xT) +#define S_F POINTER (&SCHEME_V->xF) +#define S_SINK POINTER (&SCHEME_V->xsink) +#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ) #if !USE_MULTIPLICITY static scheme sc; @@ -194,10 +198,6 @@ # define InitFile "init.scm" #endif -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - enum scheme_types { T_INTEGER, @@ -266,9 +266,13 @@ static num num_zero; static num num_one; +/* convert "pointer" to cell* / cell* to pointer */ +#define CELL(p) ((struct cell *)(p) + 0) +#define POINTER(c) ((void *)((c) - 0)) + /* macros for cell operations */ -#define typeflag(p) ((p)->flag + 0) -#define set_typeflag(p,v) ((p)->flag = (v)) +#define typeflag(p) (CELL(p)->flag + 0) +#define set_typeflag(p,v) (CELL(p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) INTERFACE int @@ -277,8 +281,8 @@ return type (p) == T_STRING; } -#define strvalue(p) ((p)->object.string.svalue) -#define strlength(p) ((p)->object.string.length) +#define strvalue(p) (CELL(p)->object.string.svalue) +#define strlength(p) (CELL(p)->object.string.length) INTERFACE int is_vector (pointer p) @@ -286,8 +290,8 @@ return type (p) == T_VECTOR; } -#define vecvalue(p) ((p)->object.vector.vvalue) -#define veclength(p) ((p)->object.vector.length) +#define vecvalue(p) (CELL(p)->object.vector.vvalue) +#define veclength(p) (CELL(p)->object.vector.length) INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); INTERFACE pointer vector_get (pointer vec, uint32_t ielem); INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); @@ -323,15 +327,15 @@ return strvalue (p); } -#define ivalue_unchecked(p) (p)->object.ivalue -#define set_ivalue(p,v) (p)->object.ivalue = (v) +#define ivalue_unchecked(p) CELL(p)->object.ivalue +#define set_ivalue(p,v) CELL(p)->object.ivalue = (v) #if USE_REAL -#define rvalue_unchecked(p) (p)->object.rvalue -#define set_rvalue(p,v) (p)->object.rvalue = (v) +#define rvalue_unchecked(p) CELL(p)->object.rvalue +#define set_rvalue(p,v) CELL(p)->object.rvalue = (v) #else -#define rvalue_unchecked(p) (p)->object.ivalue -#define set_rvalue(p,v) (p)->object.ivalue = (v) +#define rvalue_unchecked(p) CELL(p)->object.ivalue +#define set_rvalue(p,v) CELL(p)->object.ivalue = (v) #endif INTERFACE long @@ -340,6 +344,8 @@ return ivalue_unchecked (p); } +#define port(p) CELL(p)->object.port +#define set_port(p,v) port(p) = (v) INTERFACE int is_port (pointer p) { @@ -349,13 +355,13 @@ INTERFACE int is_inport (pointer p) { - return is_port (p) && p->object.port->kind & port_input; + return is_port (p) && port (p)->kind & port_input; } INTERFACE int is_outport (pointer p) { - return is_port (p) && p->object.port->kind & port_output; + return is_port (p) && port (p)->kind & port_output; } INTERFACE int @@ -364,8 +370,8 @@ return type (p) == T_PAIR; } -#define car(p) ((p)->object.cons.car + 0) -#define cdr(p) ((p)->object.cons.cdr + 0) +#define car(p) (POINTER (CELL(p)->object.cons.car)) +#define cdr(p) (POINTER (CELL(p)->object.cons.cdr)) static pointer caar (pointer p) { return car (car (p)); } static pointer cadr (pointer p) { return car (cdr (p)); } @@ -379,13 +385,13 @@ INTERFACE void set_car (pointer p, pointer q) { - p->object.cons.car = q; + CELL(p)->object.cons.car = CELL (q); } INTERFACE void set_cdr (pointer p, pointer q) { - p->object.cons.cdr = q; + CELL(p)->object.cons.cdr = CELL (q); } INTERFACE pointer @@ -413,13 +419,13 @@ } #if USE_PLIST +#error plists are broken because symbols are no longer pairs +#define symprop(p) cdr(p) SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; } - -# define symprop(p) cdr(p) #endif INTERFACE int @@ -670,7 +676,7 @@ static void file_pop (SCHEME_P); static int file_interactive (SCHEME_P); ecb_inline int is_one_of (const char *s, int c); -static int alloc_cellseg (SCHEME_P_ int n); +static int alloc_cellseg (SCHEME_P); ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); static void finalize_cell (SCHEME_P_ pointer a); static int count_consecutive_cells (pointer x, int needed); @@ -914,11 +920,11 @@ /* allocate new cell segment */ static int -alloc_cellseg (SCHEME_P_ int n) +alloc_cellseg (SCHEME_P) { - pointer newp; - pointer last; - pointer p; + struct cell *newp; + struct cell *last; + struct cell *p; char *cp; long i; int k; @@ -926,37 +932,32 @@ static int segsize = CELL_SEGSIZE >> 1; segsize <<= 1; - for (k = 0; k < n; k++) - { - if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1) - return k; - - cp = malloc (segsize * sizeof (struct cell)); + cp = malloc (segsize * sizeof (struct cell)); - if (!cp && USE_ERROR_CHECKING) - return k; + if (!cp && USE_ERROR_CHECKING) + return k; - i = ++SCHEME_V->last_cell_seg; - SCHEME_V->alloc_seg[i] = cp; + i = ++SCHEME_V->last_cell_seg; + SCHEME_V->alloc_seg[i] = cp; - newp = (pointer)cp; - SCHEME_V->cell_seg[i] = newp; - SCHEME_V->cell_segsize[i] = segsize; - SCHEME_V->fcells += segsize; - last = newp + segsize - 1; + newp = (struct cell *)cp; + SCHEME_V->cell_seg[i] = newp; + SCHEME_V->cell_segsize[i] = segsize; + SCHEME_V->fcells += segsize; + last = newp + segsize - 1; - for (p = newp; p <= last; p++) - { - set_typeflag (p, T_PAIR); - set_car (p, NIL); - set_cdr (p, p + 1); - } - - set_cdr (last, SCHEME_V->free_cell); - SCHEME_V->free_cell = newp; + for (p = newp; p <= last; p++) + { + pointer cp = POINTER (p); + set_typeflag (cp, T_PAIR); + set_car (cp, NIL); + set_cdr (cp, POINTER (p + 1)); } - return n; + set_cdr (POINTER (last), SCHEME_V->free_cell); + SCHEME_V->free_cell = POINTER (newp); + + return 1; } /* get new cell. parameter a, b is marked by gc. */ @@ -970,14 +971,14 @@ if (SCHEME_V->free_cell == NIL) { - const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; + const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; gc (SCHEME_A_ a, b); if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) { /* if only a few recovered, get more to avoid fruitless gc's */ - if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) + if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL) { #if USE_ERROR_CHECKING SCHEME_V->no_memory = 1; @@ -999,7 +1000,6 @@ /* To retain recent allocs before interpreter knows about them - Tehom */ - static void push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) { @@ -1031,7 +1031,7 @@ static pointer get_vector_object (SCHEME_P_ uint32_t len, pointer init) { - pointer v = get_cell_x (SCHEME_A_ 0, 0); + pointer v = get_cell_x (SCHEME_A_ NIL, NIL); pointer *e = malloc (len * sizeof (pointer)); if (!e && USE_ERROR_CHECKING) @@ -1040,8 +1040,8 @@ /* Record it as a vector so that gc understands it. */ set_typeflag (v, T_VECTOR | T_ATOM); - v->object.vector.vvalue = e; - v->object.vector.length = len; + CELL(v)->object.vector.vvalue = e; + CELL(v)->object.vector.length = len; fill_vector (v, 0, init); push_recent_alloc (SCHEME_A_ v, NIL); @@ -1095,8 +1095,6 @@ return x; } -/* ========== oblist implementation ========== */ - static pointer generate_symbol (SCHEME_P_ const char *name) { @@ -1106,6 +1104,8 @@ return x; } +/* ========== oblist implementation ========== */ + #ifndef USE_OBJECT_LIST static int @@ -1201,9 +1201,7 @@ static pointer oblist_add_by_name (SCHEME_P_ const char *name) { - pointer x = mk_string (SCHEME_A_ name); - set_typeflag (x, T_SYMBOL); - setimmutable (x); + pointer x = generate_symbol (SCHEME_A_ name); SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); return x; } @@ -1223,7 +1221,7 @@ pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_PORT | T_ATOM); - x->object.port = p; + set_port (x, p); return x; } @@ -1234,8 +1232,8 @@ { pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_FOREIGN | T_ATOM)); - x->object.ff = f; + set_typeflag (x, T_FOREIGN | T_ATOM); + CELL(x)->object.ff = f; return x; } @@ -1245,7 +1243,7 @@ { pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_CHARACTER | T_ATOM)); + set_typeflag (x, T_CHARACTER | T_ATOM); set_ivalue (x, c & 0xff); return x; @@ -1255,12 +1253,26 @@ INTERFACE pointer mk_integer (SCHEME_P_ long n) { - pointer x = get_cell (SCHEME_A_ NIL, NIL); + pointer p = 0; + pointer *pp = &p; - set_typeflag (x, (T_INTEGER | T_ATOM)); - set_ivalue (x, n); +#if USE_INTCACHE + if (n >= INTCACHE_MIN && n <= INTCACHE_MAX) + pp = &SCHEME_V->intcache[n - INTCACHE_MIN]; +#endif - return x; + if (!*pp) + { + pointer x = get_cell (SCHEME_A_ NIL, NIL); + + set_typeflag (x, T_INTEGER | T_ATOM); + setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */ + set_ivalue (x, n); + + *pp = x; + } + + return *pp; } INTERFACE pointer @@ -1269,7 +1281,7 @@ #if USE_REAL pointer x = get_cell (SCHEME_A_ NIL, NIL); - set_typeflag (x, (T_REAL | T_ATOM)); + set_typeflag (x, T_REAL | T_ATOM); set_rvalue (x, n); return x; @@ -1395,11 +1407,17 @@ { pointer x; char name[40] = "gensym-"; - xnum (name + 7, SCHEME_V->gensym_cnt); + xnum (name + 7, ++SCHEME_V->gensym_cnt); return generate_symbol (SCHEME_A_ name); } +static int +is_gensym (SCHEME_P_ pointer x) +{ + return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; +} + /* make symbol or number atom from string */ static pointer mk_atom (SCHEME_P_ char *q) @@ -1616,7 +1634,6 @@ static void gc (SCHEME_P_ pointer a, pointer b) { - pointer p; int i; if (SCHEME_V->gc_verbose) @@ -1642,6 +1659,13 @@ /* Mark any older stuff above nested C calls */ mark (SCHEME_V->c_nest); +#if USE_INTCACHE + /* mark intcache */ + for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i) + if (SCHEME_V->intcache[i - INTCACHE_MIN]) + mark (SCHEME_V->intcache[i - INTCACHE_MIN]); +#endif + /* mark variables a, b */ mark (a); mark (b); @@ -1651,39 +1675,44 @@ SCHEME_V->fcells = 0; SCHEME_V->free_cell = NIL; - /* free-list is kept sorted by address so as to maintain consecutive - ranges, if possible, for use with vectors. Here we scan the cells - (which are also kept sorted by address) downwards to build the - free-list in sorted order. - */ + if (SCHEME_V->gc_verbose) + xwrstr ("freeing..."); + + uint32_t total = 0; + + /* Here we scan the cells to build the free-list. */ for (i = SCHEME_V->last_cell_seg; i >= 0; i--) { - p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; + struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; + struct cell *p; + total += SCHEME_V->cell_segsize [i]; - while (--p >= SCHEME_V->cell_seg[i]) + for (p = SCHEME_V->cell_seg[i]; p < end; ++p) { - if (is_mark (p)) - clrmark (p); + pointer c = POINTER (p); + + if (is_mark (c)) + clrmark (c); else { /* reclaim cell */ - if (typeflag (p) != T_PAIR) + if (typeflag (c) != T_PAIR) { - finalize_cell (SCHEME_A_ p); - set_typeflag (p, T_PAIR); - set_car (p, NIL); + finalize_cell (SCHEME_A_ c); + set_typeflag (c, T_PAIR); + set_car (c, NIL); } ++SCHEME_V->fcells; - set_cdr (p, SCHEME_V->free_cell); - SCHEME_V->free_cell = p; + set_cdr (c, SCHEME_V->free_cell); + SCHEME_V->free_cell = c; } } } if (SCHEME_V->gc_verbose) { - xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); + xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n"); } } @@ -1698,10 +1727,10 @@ #if USE_PORTS else if (is_port (a)) { - if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) + if (port(a)->kind & port_file && port (a)->rep.stdio.closeit) port_close (SCHEME_A_ a, port_input | port_output); - free (a->object.port); + free (port (a)); } #endif } @@ -1727,7 +1756,7 @@ SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; - SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; + set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); #if SHOW_ERROR_LINE SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; @@ -1754,7 +1783,7 @@ port_close (SCHEME_A_ SCHEME_V->loadport, port_input); #endif SCHEME_V->file_i--; - SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; + set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); } } @@ -1764,7 +1793,7 @@ #if USE_PORTS return SCHEME_V->file_i == 0 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO - && (SCHEME_V->inport->object.port->kind & port_file); + && (port (SCHEME_V->inport)->kind & port_file); #else return 0; #endif @@ -1908,7 +1937,7 @@ static void port_close (SCHEME_P_ pointer p, int flag) { - port *pt = p->object.port; + port *pt = port (p); pt->kind &= ~flag; @@ -1939,9 +1968,7 @@ inchar (SCHEME_P) { int c; - port *pt; - - pt = SCHEME_V->inport->object.port; + port *pt = port (SCHEME_V->inport); if (pt->kind & port_saw_EOF) return EOF; @@ -2018,7 +2045,7 @@ if (c == EOF) return; - pt = SCHEME_V->inport->object.port; + pt = port (SCHEME_V->inport); pt->unget = c; #else if (c == EOF) @@ -2056,7 +2083,7 @@ putstr (SCHEME_P_ const char *s) { #if USE_PORTS - port *pt = SCHEME_V->outport->object.port; + port *pt = port (SCHEME_V->outport); if (pt->kind & port_file) write (pt->rep.stdio.file, s, strlen (s)); @@ -2076,7 +2103,7 @@ putchars (SCHEME_P_ const char *s, int len) { #if USE_PORTS - port *pt = SCHEME_V->outport->object.port; + port *pt = port (SCHEME_V->outport); if (pt->kind & port_file) write (pt->rep.stdio.file, s, len); @@ -2100,7 +2127,7 @@ putcharacter (SCHEME_P_ int c) { #if USE_PORTS - port *pt = SCHEME_V->outport->object.port; + port *pt = port (SCHEME_V->outport); if (pt->kind & port_file) { @@ -3052,7 +3079,7 @@ struct dump_stack_frame *next_frame; /* enough room for the next frame? */ - if (nframes >= SCHEME_V->dump_size) + if (ecb_expect_false (nframes >= SCHEME_V->dump_size)) { SCHEME_V->dump_size += STACK_GROWTH; SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); @@ -3243,7 +3270,7 @@ #define s_retbool(tf) s_return ((tf) ? S_T : S_F) -#if 1 +#if EXPERIMENT static int debug (SCHEME_P_ int indent, pointer x) { @@ -3309,7 +3336,7 @@ switch (op) { -#if 1 //D +#if EXPERIMENT //D case OP_DEBUG: printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); printf ("\n"); @@ -3319,7 +3346,7 @@ if (file_interactive (SCHEME_A)) { xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); - //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); + //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); } if (!file_push (SCHEME_A_ strvalue (car (args)))) @@ -3333,7 +3360,7 @@ case OP_T0LVL: /* top level */ /* If we reached the end of file, this loop is done. */ - if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) + if (port (SCHEME_V->loadport)->kind & port_saw_EOF) { if (SCHEME_V->file_i == 0) { @@ -3421,10 +3448,10 @@ { x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); - if (x != NIL) - s_return (slot_value_in_env (x)); - else + if (x == NIL) Error_1 ("eval: unbound variable:", SCHEME_V->code); + + s_return (slot_value_in_env (x)); } else if (is_pair (SCHEME_V->code)) { @@ -3511,7 +3538,7 @@ { /* Keep nested calls from GC'ing the arglist */ push_recent_alloc (SCHEME_A_ args, NIL); - x = SCHEME_V->code->object.ff (SCHEME_A_ args); + x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args); s_return (x); } @@ -3558,8 +3585,6 @@ SCHEME_V->code = SCHEME_V->value; s_goto (OP_EVAL); -#if 1 - case OP_LAMBDA: /* lambda */ /* If the hook is defined, apply it to SCHEME_V->code, otherwise set SCHEME_V->value fall thru */ @@ -3575,19 +3600,12 @@ } SCHEME_V->value = SCHEME_V->code; - /* Fallthru */ } + /* Fallthru */ case OP_LAMBDA1: s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); -#else - - case OP_LAMBDA: /* lambda */ - s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir)); - -#endif - case OP_MKCLOSURE: /* make-closure */ x = car (args); @@ -4192,11 +4210,37 @@ s_return (mk_number (SCHEME_A_ v)); - case OP_CAR: /* car */ - s_return (caar (args)); - - case OP_CDR: /* cdr */ - s_return (cdar (args)); + /* the compiler will optimize this mess... */ + case OP_CAR: op_car: s_return (car (x)); + case OP_CDR: op_cdr: s_return (cdr (x)); + case OP_CAAR: op_caar: x = car (x); goto op_car; + case OP_CADR: op_cadr: x = cdr (x); goto op_car; + case OP_CDAR: op_cdar: x = car (x); goto op_cdr; + case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr; + case OP_CAAAR: op_caaar: x = car (x); goto op_caar; + case OP_CAADR: op_caadr: x = cdr (x); goto op_caar; + case OP_CADAR: op_cadar: x = car (x); goto op_cadr; + case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr; + case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar; + case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar; + case OP_CDDAR: op_cddar: x = car (x); goto op_cddr; + case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr; + case OP_CAAAAR: x = car (x); goto op_caaar; + case OP_CAAADR: x = cdr (x); goto op_caaar; + case OP_CAADAR: x = car (x); goto op_caadr; + case OP_CAADDR: x = cdr (x); goto op_caadr; + case OP_CADAAR: x = car (x); goto op_cadar; + case OP_CADADR: x = cdr (x); goto op_cadar; + case OP_CADDAR: x = car (x); goto op_caddr; + case OP_CADDDR: x = cdr (x); goto op_caddr; + case OP_CDAAAR: x = car (x); goto op_cdaar; + case OP_CDAADR: x = cdr (x); goto op_cdaar; + case OP_CDADAR: x = car (x); goto op_cdadr; + case OP_CDADDR: x = cdr (x); goto op_cdadr; + case OP_CDDAAR: x = car (x); goto op_cddar; + case OP_CDDADR: x = cdr (x); goto op_cddar; + case OP_CDDDAR: x = car (x); goto op_cdddr; + case OP_CDDDDR: x = cdr (x); goto op_cdddr; case OP_CONS: /* cons */ set_cdr (args, cadr (args)); @@ -4528,16 +4572,17 @@ switch (op) { - case OP_NOT: /* not */ r = is_false (a) ; break; - case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; - case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; - case OP_NULLP: /* null? */ r = a == NIL ; break; - case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; - case OP_NUMBERP: /* number? */ r = is_number (a) ; break; - case OP_STRINGP: /* string? */ r = is_string (a) ; break; - case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; - case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ - case OP_CHARP: /* char? */ r = is_character (a) ; break; + case OP_NOT: /* not */ r = is_false (a) ; break; + case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break; + case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; + case OP_NULLP: /* null? */ r = a == NIL ; break; + case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; + case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break; + case OP_NUMBERP: /* number? */ r = is_number (a) ; break; + case OP_STRINGP: /* string? */ r = is_string (a) ; break; + case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; + case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ + case OP_CHARP: /* char? */ r = is_character (a) ; break; #if USE_CHAR_CLASSIFIERS case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; @@ -4597,7 +4642,7 @@ s_return (SCHEME_V->code); case OP_SAVE_FORCED: /* Save forced value replacing promise */ - memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); + *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); s_return (SCHEME_V->value); #if USE_PORTS @@ -4752,12 +4797,11 @@ } case OP_NEWSEGMENT: /* new-segment */ +#if 0 if (!is_pair (args) || !is_number (a)) Error_0 ("new-segment: argument must be a number"); - - alloc_cellseg (SCHEME_A_ ivalue (a)); - - s_return (S_T); +#endif + s_retbool (alloc_cellseg (SCHEME_A)); case OP_OBLIST: /* oblist */ s_return (oblist_all_symbols (SCHEME_A)); @@ -4837,9 +4881,9 @@ case OP_GET_OUTSTRING: /* get-output-string */ { - port *p; + port *p = port (a); - if ((p = a->object.port)->kind & port_string) + if (p->kind & port_string) { off_t size; char *str; @@ -4954,7 +4998,7 @@ if (is_pair (args)) p = car (args); - res = p->object.port->kind & port_string; + res = port (p)->kind & port_string; s_retbool (res); } @@ -5628,6 +5672,12 @@ int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); pointer x; + /* this memset is not strictly correct, as we assume (intcache) + * that memset 0 will also set pointers to 0, but memset does + * of course not guarantee that. screw such systems. + */ + memset (SCHEME_V, 0, sizeof (*SCHEME_V)); + num_set_fixnum (num_zero, 1); num_set_ivalue (num_zero, 0); num_set_fixnum (num_one, 1); @@ -5648,7 +5698,7 @@ SCHEME_V->nesting = 0; SCHEME_V->interactive_repl = 0; - if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) + if (!alloc_cellseg (SCHEME_A)) { #if USE_ERROR_CHECKING SCHEME_V->no_memory = 1;