*
*/
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#define _SCHEME_SOURCE
#include "scheme-private.h"
#ifndef WIN32
#include <assert.h>
#include <limits.h>
+#include <stdint.h>
#include <float.h>
#include <ctype.h>
}
#endif /* __APPLE__ */
-#if USE_STRLWR
+#if USE_STRLWR && !defined(HAVE_STRLWR)
static const char *strlwr(char *s) {
const char *p=s;
while(*s) {
# define FIRST_CELLSEGS 3
#endif
+\f
+
+/* All types have the LSB set. The garbage collector takes advantage
+ * of that to identify types. */
enum scheme_types {
- T_STRING=1,
- T_NUMBER=2,
- T_SYMBOL=3,
- T_PROC=4,
- T_PAIR=5,
- T_CLOSURE=6,
- T_CONTINUATION=7,
- T_FOREIGN=8,
- T_CHARACTER=9,
- T_PORT=10,
- T_VECTOR=11,
- T_MACRO=12,
- T_PROMISE=13,
- T_ENVIRONMENT=14,
- T_FOREIGN_OBJECT=15,
- T_BOOLEAN=16,
- T_NIL=17,
- T_EOF_OBJ=18,
- T_SINK=19,
- T_LAST_SYSTEM_TYPE=19
+ T_STRING = 1 << 1 | 1,
+ T_NUMBER = 2 << 1 | 1,
+ T_SYMBOL = 3 << 1 | 1,
+ T_PROC = 4 << 1 | 1,
+ T_PAIR = 5 << 1 | 1,
+ T_CLOSURE = 6 << 1 | 1,
+ T_CONTINUATION = 7 << 1 | 1,
+ T_FOREIGN = 8 << 1 | 1,
+ T_CHARACTER = 9 << 1 | 1,
+ T_PORT = 10 << 1 | 1,
+ T_VECTOR = 11 << 1 | 1,
+ T_MACRO = 12 << 1 | 1,
+ T_PROMISE = 13 << 1 | 1,
+ T_ENVIRONMENT = 14 << 1 | 1,
+ T_FOREIGN_OBJECT = 15 << 1 | 1,
+ T_BOOLEAN = 16 << 1 | 1,
+ T_NIL = 17 << 1 | 1,
+ T_EOF_OBJ = 18 << 1 | 1,
+ T_SINK = 19 << 1 | 1,
+ T_FRAME = 20 << 1 | 1,
+ T_LAST_SYSTEM_TYPE = 20 << 1 | 1
};
static const char *
case T_NIL: return "nil";
case T_EOF_OBJ: return "eof object";
case T_SINK: return "sink";
+ case T_FRAME: return "frame";
}
assert (! "not reached");
}
/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
-#define ADJ 32
-#define TYPE_BITS 5
-#define T_MASKTYPE 31 /* 0000000000011111 */
+#define TYPE_BITS 6
+#define ADJ (1 << TYPE_BITS)
+#define T_MASKTYPE (ADJ - 1)
+ /* 0000000000111111 */
+#define T_TAGGED 1024 /* 0000010000000000 */
#define T_FINALIZE 2048 /* 0000100000000000 */
#define T_SYNTAX 4096 /* 0001000000000000 */
#define T_IMMUTABLE 8192 /* 0010000000000000 */
return ((p)->_object._number.is_fixnum);
}
-static num num_zero;
-static num num_one;
+static const struct num num_zero = { 1, {0} };
+static const struct num num_one = { 1, {1} };
/* macros for cell operations */
#define typeflag(p) ((p)->_flag)
#define type(p) (typeflag(p)&T_MASKTYPE)
+#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ))
INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
#define strvalue(p) ((p)->_object._string._svalue)
INTERFACE static int is_list(scheme *sc, pointer p);
INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
+/* Given a vector, return it's length. */
+#define vector_length(v) (v)->_object._vector._length
+/* Given a vector length, compute the amount of cells required to
+ * represent it. */
+#define vector_size(len) (1 + ((len) - 1 + 2) / 3)
INTERFACE static void fill_vector(pointer vec, pointer obj);
+INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem);
INTERFACE static pointer vector_elem(pointer vec, int ielem);
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
#if USE_PLIST
-SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); }
+SCHEME_EXPORT INLINE int hasprop(pointer p) { return (is_symbol(p)); }
#define symprop(p) cdr(p)
#endif
INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
-#define procnum(p) ivalue(p)
+#define procnum(p) ivalue_unchecked(p)
static const char *procname(pointer x);
INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
#define setenvironment(p) typeflag(p) = T_ENVIRONMENT
+INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); }
+#define setframe(p) settype(p, T_FRAME)
+
#define is_atom(p) (typeflag(p)&T_ATOM)
#define setatom(p) typeflag(p) |= T_ATOM
#define clratom(p) typeflag(p) &= CLRATOM
#define cadddr(p) car(cdr(cdr(cdr(p))))
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
+#if USE_HISTORY
+static pointer history_flatten(scheme *sc);
+static void history_mark(scheme *sc);
+#else
+# define history_mark(SC) (void) 0
+# define history_flatten(SC) (SC)->NIL
+#endif
+
#if USE_CHAR_CLASSIFIERS
static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
#endif
#if USE_ASCII_NAMES
-static const char *charnames[32]={
+static const char charnames[32][3]={
"nul",
"soh",
"stx",
static int is_ascii_name(const char *name, int *pc) {
int i;
for(i=0; i<32; i++) {
- if(stricmp(name,charnames[i])==0) {
+ if (strncasecmp(name, charnames[i], 3) == 0) {
*pc=i;
return 1;
}
}
- if(stricmp(name,"del")==0) {
+ if (strcasecmp(name, "del") == 0) {
*pc=127;
return 1;
}
#endif
-static int file_push(scheme *sc, const char *fname);
+static int file_push(scheme *sc, pointer fname);
static void file_pop(scheme *sc);
static int file_interactive(scheme *sc);
static INLINE int is_one_of(char *s, int c);
static pointer reserve_cells(scheme *sc, int n);
static pointer get_consecutive_cells(scheme *sc, int n);
static pointer find_consecutive_cells(scheme *sc, int n);
-static void finalize_cell(scheme *sc, pointer a);
+static int finalize_cell(scheme *sc, pointer a);
static int count_consecutive_cells(pointer x, int needed);
static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
static pointer mk_number(scheme *sc, num n);
static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
static pointer mk_closure(scheme *sc, pointer c, pointer e);
static pointer mk_continuation(scheme *sc, pointer d);
-static pointer reverse(scheme *sc, pointer a);
+static pointer reverse(scheme *sc, pointer term, pointer list);
static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
static pointer revappend(scheme *sc, pointer a, pointer b);
+static void dump_stack_preallocate_frame(scheme *sc);
static void dump_stack_mark(scheme *);
-static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
-static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
-static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
-static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
-static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
-static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
-static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
+struct op_code_info {
+ char name[31]; /* strlen ("call-with-current-continuation") + 1 */
+ unsigned char min_arity;
+ unsigned char max_arity;
+ char arg_tests_encoding[3];
+};
+static const struct op_code_info dispatch_table[];
+static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size);
static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
-static void assign_syntax(scheme *sc, char *name);
-static int syntaxnum(pointer p);
-static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
+static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name);
+static int syntaxnum(scheme *sc, pointer p);
+static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name);
#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
return x;
}
+\f
+
+/*
+ * Copying values.
+ *
+ * Occasionally, we need to copy a value from one location in the
+ * storage to another. Scheme objects are fine. Some primitive
+ * objects, however, require finalization, usually to free resources.
+ *
+ * For these values, we either make a copy or acquire a reference.
+ */
+
+/*
+ * Copy SRC to DST.
+ *
+ * Copies the representation of SRC to DST. This makes SRC
+ * indistinguishable from DST from the perspective of a Scheme
+ * expression modulo the fact that they reside at a different location
+ * in the store.
+ *
+ * Conditions:
+ *
+ * - SRC must not be a vector.
+ * - Caller must ensure that any resources associated with the
+ * value currently stored in DST is accounted for.
+ */
+static void
+copy_value(scheme *sc, pointer dst, pointer src)
+{
+ memcpy(dst, src, sizeof *src);
+
+ /* We may need to make a copy or acquire a reference. */
+ if (typeflag(dst) & T_FINALIZE)
+ switch (type(dst)) {
+ case T_STRING:
+ strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0);
+ break;
+ case T_PORT:
+ /* XXX acquire reference */
+ assert (!"implemented");
+ break;
+ case T_FOREIGN_OBJECT:
+ /* XXX acquire reference */
+ assert (!"implemented");
+ break;
+ case T_VECTOR:
+ assert (!"vectors cannot be copied");
+ }
+}
+
+\f
+
+/* Tags are like property lists, but can be attached to arbitrary
+ * values. */
+
+static pointer
+mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr)
+{
+ pointer r, t;
+
+ assert(! is_vector(v));
+
+ r = get_consecutive_cells(sc, 2);
+ if (r == sc->sink)
+ return sc->sink;
+
+ copy_value(sc, r, v);
+ typeflag(r) |= T_TAGGED;
+
+ t = r + 1;
+ typeflag(t) = T_PAIR;
+ car(t) = tag_car;
+ cdr(t) = tag_cdr;
+
+ return r;
+}
+
+static INLINE int
+has_tag(pointer v)
+{
+ return !! (typeflag(v) & T_TAGGED);
+}
+
+static INLINE pointer
+get_tag(scheme *sc, pointer v)
+{
+ if (has_tag(v))
+ return v + 1;
+ return sc->NIL;
+}
+
+\f
+
+/* Low-level allocator.
+ *
+ * Memory is allocated in segments. Every segment holds a fixed
+ * number of cells. Segments are linked into a list, sorted in
+ * reverse address order (i.e. those with a higher address first).
+ * This is used in the garbage collector to build the freelist in
+ * address order.
+ */
+
+struct cell_segment
+{
+ struct cell_segment *next;
+ void *alloc;
+ pointer cells;
+ size_t cells_len;
+};
+
+/* Allocate a new cell segment but do not make it available yet. */
+static int
+_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment)
+{
+ int adj = ADJ;
+ void *cp;
+
+ if (adj < sizeof(struct cell))
+ adj = sizeof(struct cell);
+
+ /* The segment header is conveniently allocated with the cells. */
+ cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj);
+ if (cp == NULL)
+ return 1;
+
+ *segment = cp;
+ (*segment)->next = NULL;
+ (*segment)->alloc = cp;
+ cp = (void *) ((uintptr_t) cp + sizeof **segment);
+
+ /* adjust in TYPE_BITS-bit boundary */
+ if (((uintptr_t) cp) % adj != 0)
+ cp = (void *) (adj * ((uintptr_t) cp / adj + 1));
+
+ (*segment)->cells = cp;
+ (*segment)->cells_len = len;
+ return 0;
+}
+
+/* Deallocate a cell segment. Returns the next cell segment.
+ * Convenient for deallocation in a loop. */
+static struct cell_segment *
+_dealloc_cellseg(scheme *sc, struct cell_segment *segment)
+{
+
+ struct cell_segment *next;
+
+ if (segment == NULL)
+ return NULL;
+
+ next = segment->next;
+ sc->free(segment->alloc);
+ return next;
+}
+
/* allocate new cell segment */
static int alloc_cellseg(scheme *sc, int n) {
- pointer newp;
pointer last;
pointer p;
- void *cp;
- long i;
int k;
- int adj=ADJ;
-
- if(adj<sizeof(struct cell)) {
- adj=sizeof(struct cell);
- }
for (k = 0; k < n; k++) {
- if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
- return k;
- cp = sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
- if (cp == 0)
- return k;
- i = ++sc->last_cell_seg ;
- sc->alloc_seg[i] = cp;
- /* adjust in TYPE_BITS-bit boundary */
- if(((unsigned long)cp)%adj!=0) {
- cp=(void *)(adj*((unsigned long)cp/adj+1));
- }
- /* insert new segment in address order */
- newp=(pointer)cp;
- sc->cell_seg[i] = newp;
- while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
- p = sc->cell_seg[i];
- sc->cell_seg[i] = sc->cell_seg[i - 1];
- sc->cell_seg[--i] = p;
- }
- sc->fcells += CELL_SEGSIZE;
- last = newp + CELL_SEGSIZE - 1;
- for (p = newp; p <= last; p++) {
+ struct cell_segment *new, **s;
+ if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) {
+ return k;
+ }
+ /* insert new segment in reverse address order */
+ for (s = &sc->cell_segments;
+ *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc;
+ s = &(*s)->next) {
+ /* walk */
+ }
+ new->next = *s;
+ *s = new;
+
+ sc->fcells += new->cells_len;
+ last = new->cells + new->cells_len - 1;
+ for (p = new->cells; p <= last; p++) {
typeflag(p) = 0;
cdr(p) = p + 1;
car(p) = sc->NIL;
/* insert new cells in address order on free list */
if (sc->free_cell == sc->NIL || p < sc->free_cell) {
cdr(last) = sc->free_cell;
- sc->free_cell = newp;
+ sc->free_cell = new->cells;
} else {
p = sc->free_cell;
- while (cdr(p) != sc->NIL && newp > cdr(p))
+ while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p))
p = cdr(p);
cdr(last) = cdr(p);
- cdr(p) = newp;
+ cdr(p) = new->cells;
}
}
return n;
{
#ifdef NDEBUG
fprintf(stderr,
- "insufficient reservation\n")
+ "insufficient reservation\n");
#else
fprintf(stderr,
- "insufficient reservation in line %d\n",
+ "insufficient %s reservation in line %d\n",
+ sc->frame_freelist == sc->NIL ? "frame" : "cell",
sc->reserved_lineno);
#endif
abort();
if (sc->inhibit_gc == 0) {
reserve_cells(sc, (reserve));
sc->reserved_cells = (reserve);
-#ifndef NDEBUG
+#ifdef NDEBUG
(void) lineno;
#else
sc->reserved_lineno = lineno;
sc->inhibit_gc += 1;
}
#define gc_disable(sc, reserve) \
- _gc_disable (sc, reserve, __LINE__)
+ do { \
+ if (sc->frame_freelist == sc->NIL) { \
+ if (gc_enabled(sc)) \
+ dump_stack_preallocate_frame(sc); \
+ else \
+ gc_reservation_failure(sc); \
+ } \
+ _gc_disable (sc, reserve, __LINE__); \
+ } while (0)
/* Enable the garbage collector. */
#define gc_enable(sc) \
#else /* USE_GC_LOCKING */
-#define gc_disable(sc, reserve) (void) 0
+#define gc_reservation_failure(sc) (void) 0
+#define gc_disable(sc, reserve) \
+ do { \
+ if (sc->frame_freelist == sc->NIL) \
+ dump_stack_preallocate_frame(sc); \
+ } while (0)
#define gc_enable(sc) (void) 0
#define gc_enabled(sc) 1
#define gc_consume(sc) (void) 0
assert (gc_enabled (sc));
if (sc->free_cell == sc->NIL) {
- const int min_to_be_recovered = sc->last_cell_seg*8;
gc(sc,a, b);
- if (sc->fcells < min_to_be_recovered
- || sc->free_cell == sc->NIL) {
- /* if only a few recovered, get more to avoid fruitless gc's */
- if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
- sc->no_memory=1;
- return sc->sink;
- }
+ if (sc->free_cell == sc->NIL) {
+ sc->no_memory=1;
+ return sc->sink;
}
}
x = sc->free_cell;
static pointer get_vector_object(scheme *sc, int len, pointer init)
{
- pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
+ pointer cells = get_consecutive_cells(sc, vector_size(len));
+ int i;
+ int alloc_len = 1 + 3 * (vector_size(len) - 1);
if(sc->no_memory) { return sc->sink; }
/* Record it as a vector so that gc understands it. */
- typeflag(cells) = (T_VECTOR | T_ATOM);
- ivalue_unchecked(cells)=len;
- set_num_integer(cells);
+ typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE);
+ vector_length(cells) = len;
fill_vector(cells,init);
+
+ /* Initialize the unused slots at the end. */
+ assert (alloc_len - len < 3);
+ for (i = len; i < alloc_len; i++)
+ cells->_object._vector._elements[i] = sc->NIL;
+
if (gc_enabled (sc))
push_recent_alloc(sc, cells, sc->NIL);
return cells;
}
-#if defined TSGRIND
-static void check_cell_alloced(pointer p, int expect_alloced)
-{
- /* Can't use putstr(sc,str) because callers have no access to
- sc. */
- if(typeflag(p) & !expect_alloced)
- {
- fprintf(stderr,"Cell is already allocated!\n");
- }
- if(!(typeflag(p)) & expect_alloced)
- {
- fprintf(stderr,"Cell is not allocated!\n");
- }
-
-}
-static void check_range_alloced(pointer p, int n, int expect_alloced)
-{
- int i;
- for(i = 0;i<n;i++)
- { (void)check_cell_alloced(p+i,expect_alloced); }
-}
-
-#endif
-
/* Medium level cell allocation */
/* get new cons cell */
return (x);
}
+\f
/* ========== oblist implementation ========== */
#ifndef USE_OBJECT_LIST
static pointer oblist_initial_value(scheme *sc)
{
- return mk_vector(sc, 461); /* probably should be bigger */
-}
-
-/* returns the new symbol */
-static pointer oblist_add_by_name(scheme *sc, const char *name)
-{
-#define oblist_add_by_name_allocates 3
- pointer x;
- int location;
-
- gc_disable(sc, gc_reservations (oblist_add_by_name));
- x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
- typeflag(x) = T_SYMBOL;
- setimmutable(car(x));
-
- location = hash_fn(name, ivalue_unchecked(sc->oblist));
- set_vector_elem(sc->oblist, location,
- immutable_cons(sc, x, vector_elem(sc->oblist, location)));
- gc_enable(sc);
- return x;
+ /* There are about 768 symbols used after loading the
+ * interpreter. */
+ return mk_vector(sc, 1009);
}
-static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
+/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not
+ * exist. In that case, SLOT points to the point where the new symbol
+ * is to be inserted. */
+static INLINE pointer
+oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
{
int location;
pointer x;
char *s;
+ int d;
- location = hash_fn(name, ivalue_unchecked(sc->oblist));
- for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
+ location = hash_fn(name, vector_length(sc->oblist));
+ for (*slot = vector_elem_slot(sc->oblist, location), x = **slot;
+ x != sc->NIL; *slot = &cdr(x), x = **slot) {
s = symname(car(x));
/* case-insensitive, per R5RS section 2. */
- if(stricmp(name, s) == 0) {
- return car(x);
- }
+ d = stricmp(name, s);
+ if (d == 0)
+ return car(x); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
}
return sc->NIL;
}
pointer x;
pointer ob_list = sc->NIL;
- for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
+ for (i = 0; i < vector_length(sc->oblist); i++) {
for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
ob_list = cons(sc, x, ob_list);
}
return sc->NIL;
}
-static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
+/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not
+ * exist. In that case, SLOT points to the point where the new symbol
+ * is to be inserted. */
+static INLINE pointer
+oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
{
pointer x;
char *s;
+ int d;
- for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
+ for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) {
s = symname(car(x));
/* case-insensitive, per R5RS section 2. */
- if(stricmp(name, s) == 0) {
- return car(x);
- }
+ d = stricmp(name, s);
+ if (d == 0)
+ return car(x); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
}
return sc->NIL;
}
-/* returns the new symbol */
-static pointer oblist_add_by_name(scheme *sc, const char *name)
+static pointer oblist_all_symbols(scheme *sc)
+{
+ return sc->oblist;
+}
+
+#endif
+
+/* Add a new symbol NAME at SLOT. SLOT must be obtained using
+ * oblist_find_by_name, and no insertion must be done between
+ * obtaining the SLOT and calling this function. Returns the new
+ * symbol. */
+static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot)
{
+#define oblist_add_by_name_allocates 3
pointer x;
+ gc_disable(sc, gc_reservations (oblist_add_by_name));
x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
typeflag(x) = T_SYMBOL;
setimmutable(car(x));
- sc->oblist = immutable_cons(sc, x, sc->oblist);
+ *slot = immutable_cons(sc, x, *slot);
+ gc_enable(sc);
return x;
}
-static pointer oblist_all_symbols(scheme *sc)
-{
- return sc->oblist;
-}
-#endif
+\f
static pointer mk_port(scheme *sc, port *p) {
pointer x = get_cell(sc, sc->NIL, sc->NIL);
return (x);
}
+\f
+
+#if USE_SMALL_INTEGERS
+
+static const struct cell small_integers[] = {
+#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}},
+#include "small-integers.h"
+#undef DEFINE_INTEGER
+ {0}
+};
+
+#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1)
+
+static INLINE pointer
+mk_small_integer(scheme *sc, long n)
+{
+#define mk_small_integer_allocates 0
+ (void) sc;
+ assert(0 <= n && n < MAX_SMALL_INTEGER);
+ return (pointer) &small_integers[n];
+}
+#else
+
+#define mk_small_integer_allocates 1
+#define mk_small_integer mk_integer
+
+#endif
+
/* get number atom (integer) */
INTERFACE pointer mk_integer(scheme *sc, long n) {
- pointer x = get_cell(sc,sc->NIL, sc->NIL);
+ pointer x;
+
+#if USE_SMALL_INTEGERS
+ if (0 <= n && n < MAX_SMALL_INTEGER)
+ return mk_small_integer(sc, n);
+#endif
+ x = get_cell(sc,sc->NIL, sc->NIL);
typeflag(x) = (T_NUMBER | T_ATOM);
ivalue_unchecked(x)= n;
set_num_integer(x);
return (x);
}
+\f
+
INTERFACE pointer mk_real(scheme *sc, double n) {
pointer x = get_cell(sc,sc->NIL, sc->NIL);
{ return get_vector_object(sc,len,sc->NIL); }
INTERFACE static void fill_vector(pointer vec, pointer obj) {
- int i;
- int n = ivalue(vec)/2+ivalue(vec)%2;
- for(i=0; i < n; i++) {
- typeflag(vec+1+i) = T_PAIR;
- setimmutable(vec+1+i);
- car(vec+1+i)=obj;
- cdr(vec+1+i)=obj;
+ size_t i;
+ assert (is_vector (vec));
+ for(i = 0; i < vector_length(vec); i++) {
+ vec->_object._vector._elements[i] = obj;
}
}
+INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) {
+ assert (is_vector (vec));
+ assert (ielem < vector_length(vec));
+ return &vec->_object._vector._elements[ielem];
+}
+
INTERFACE static pointer vector_elem(pointer vec, int ielem) {
- int n=ielem/2;
- if(ielem%2==0) {
- return car(vec+1+n);
- } else {
- return cdr(vec+1+n);
- }
+ assert (is_vector (vec));
+ assert (ielem < vector_length(vec));
+ return vec->_object._vector._elements[ielem];
}
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
- int n=ielem/2;
- if(ielem%2==0) {
- return car(vec+1+n)=a;
- } else {
- return cdr(vec+1+n)=a;
- }
+ assert (is_vector (vec));
+ assert (ielem < vector_length(vec));
+ vec->_object._vector._elements[ielem] = a;
+ return a;
}
/* get new symbol */
INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
#define mk_symbol_allocates oblist_add_by_name_allocates
pointer x;
+ pointer *slot;
/* first check oblist */
- x = oblist_find_by_name(sc, name);
+ x = oblist_find_by_name(sc, name, &slot);
if (x != sc->NIL) {
return (x);
} else {
- x = oblist_add_by_name(sc, name);
+ x = oblist_add_by_name(sc, name, slot);
return (x);
}
}
INTERFACE pointer gensym(scheme *sc) {
pointer x;
+ pointer *slot;
char name[40];
for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
/* first check oblist */
- x = oblist_find_by_name(sc, name);
+ x = oblist_find_by_name(sc, name, &slot);
if (x != sc->NIL) {
continue;
} else {
- x = oblist_add_by_name(sc, name);
+ x = oblist_add_by_name(sc, name, slot);
return (x);
}
}
int has_fp_exp = 0;
#if USE_COLON_HOOK
- if((p=strstr(q,"::"))!=0) {
+ char *next;
+ next = p = q;
+ while ((next = strstr(next, "::")) != 0) {
+ /* Keep looking for the last occurrence. */
+ p = next;
+ next = next + 2;
+ }
+
+ if (p != q) {
*p=0;
return cons(sc, sc->COLON_HOOK,
cons(sc,
cons(sc,
sc->QUOTE,
- cons(sc, mk_atom(sc,p+2), sc->NIL)),
- cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
+ cons(sc, mk_symbol(sc, strlwr(p + 2)),
+ sc->NIL)),
+ cons(sc, mk_atom(sc, q), sc->NIL)));
}
#endif
/* ========== garbage collector ========== */
+const int frame_length;
+static void dump_stack_deallocate_frame(scheme *sc, pointer frame);
+
/*--
* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
t = (pointer) 0;
p = a;
-E2: setmark(p);
- if(is_vector(p)) {
+E2: if (! is_mark(p))
+ setmark(p);
+ if (is_vector(p) || is_frame(p)) {
int i;
- int n = ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
- for(i=0; i < n; i++) {
- /* Vector cells will be treated like ordinary cells */
- mark(p+1+i);
+ int len = is_vector(p) ? vector_length(p) : frame_length;
+ for (i = 0; i < len; i++) {
+ mark(p->_object._vector._elements[i]);
}
}
+#if SHOW_ERROR_LINE
+ else if (is_port(p)) {
+ port *pt = p->_object._port;
+ mark(pt->curr_line);
+ mark(pt->filename);
+ }
+#endif
+ /* Mark tag if p has one. */
+ if (has_tag(p))
+ mark(p + 1);
if (is_atom(p))
goto E6;
/* E4: down car */
/* garbage collection. parameter a, b is marked. */
static void gc(scheme *sc, pointer a, pointer b) {
pointer p;
+ struct cell_segment *s;
int i;
assert (gc_enabled (sc));
mark(sc->args);
mark(sc->envir);
mark(sc->code);
+ history_mark(sc);
dump_stack_mark(sc);
mark(sc->value);
mark(sc->inport);
mark(sc->save_inport);
mark(sc->outport);
mark(sc->loadport);
+ for (i = 0; i <= sc->file_i; i++) {
+ mark(sc->load_stack[i].filename);
+ mark(sc->load_stack[i].curr_line);
+ }
/* Mark recent objects the interpreter doesn't know about yet. */
mark(car(sc->sink));
(which are also kept sorted by address) downwards to build the
free-list in sorted order.
*/
- for (i = sc->last_cell_seg; i >= 0; i--) {
- p = sc->cell_seg[i] + CELL_SEGSIZE;
- while (--p >= sc->cell_seg[i]) {
+ for (s = sc->cell_segments; s; s = s->next) {
+ p = s->cells + s->cells_len;
+ while (--p >= s->cells) {
+ if ((typeflag(p) & 1) == 0)
+ /* All types have the LSB set. This is not a typeflag. */
+ continue;
if (is_mark(p)) {
clrmark(p);
} else {
- /* reclaim cell */
- if (typeflag(p) & T_FINALIZE) {
- finalize_cell(sc, p);
- typeflag(p) = 0;
- car(p) = sc->NIL;
- }
- ++sc->fcells;
- cdr(p) = sc->free_cell;
- sc->free_cell = p;
+ /* reclaim cell */
+ if ((typeflag(p) & T_FINALIZE) == 0
+ || finalize_cell(sc, p)) {
+ /* Reclaim cell. */
+ ++sc->fcells;
+ typeflag(p) = 0;
+ car(p) = sc->NIL;
+ cdr(p) = sc->free_cell;
+ sc->free_cell = p;
+ }
}
}
}
snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
putstr(sc,msg);
}
+
+ /* if only a few recovered, get more to avoid fruitless gc's */
+ if (sc->fcells < CELL_MINRECOVER
+ && alloc_cellseg(sc, 1) == 0)
+ sc->no_memory = 1;
}
-static void finalize_cell(scheme *sc, pointer a) {
- if(is_string(a)) {
+/* Finalize A. Returns true if a can be added to the list of free
+ * cells. */
+static int
+finalize_cell(scheme *sc, pointer a)
+{
+ switch (type(a)) {
+ case T_STRING:
sc->free(strvalue(a));
- } else if(is_port(a)) {
+ break;
+
+ case T_PORT:
if(a->_object._port->kind&port_file
&& a->_object._port->rep.stdio.closeit) {
port_close(sc,a,port_input|port_output);
sc->free(a->_object._port->rep.string.start);
}
sc->free(a->_object._port);
- } else if(is_foreign_object(a)) {
+ break;
+
+ case T_FOREIGN_OBJECT:
a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
+ break;
+
+ case T_VECTOR:
+ do {
+ int i;
+ for (i = vector_size(vector_length(a)) - 1; i > 0; i--) {
+ pointer p = a + i;
+ typeflag(p) = 0;
+ car(p) = sc->NIL;
+ cdr(p) = sc->free_cell;
+ sc->free_cell = p;
+ sc->fcells += 1;
+ }
+ } while (0);
+ break;
+
+ case T_FRAME:
+ dump_stack_deallocate_frame(sc, a);
+ return 0; /* Do not free cell. */
}
+
+ return 1; /* Free cell. */
+}
+
+#if SHOW_ERROR_LINE
+static void
+port_clear_location (scheme *sc, port *p)
+{
+ p->curr_line = sc->NIL;
+ p->filename = sc->NIL;
+}
+
+static void
+port_increment_current_line (scheme *sc, port *p, long delta)
+{
+ if (delta == 0)
+ return;
+
+ p->curr_line =
+ mk_integer(sc, ivalue_unchecked(p->curr_line) + delta);
+}
+
+static void
+port_init_location (scheme *sc, port *p, pointer name)
+{
+ p->curr_line = mk_integer(sc, 0);
+ p->filename = name ? name : mk_string(sc, "<unknown>");
+}
+
+#else
+
+static void
+port_clear_location (scheme *sc, port *p)
+{
+}
+
+static void
+port_increment_current_line (scheme *sc, port *p, long delta)
+{
+}
+
+static void
+port_init_location (scheme *sc, port *p, pointer name)
+{
}
+#endif
+
/* ========== Routines for Reading ========== */
-static int file_push(scheme *sc, const char *fname) {
+static int file_push(scheme *sc, pointer fname) {
FILE *fin = NULL;
if (sc->file_i == MAXFIL-1)
return 0;
- fin=fopen(fname,"r");
+ fin = fopen(string_value(fname), "r");
if(fin!=0) {
sc->file_i++;
sc->load_stack[sc->file_i].kind=port_file|port_input;
sc->load_stack[sc->file_i].rep.stdio.closeit=1;
sc->nesting_stack[sc->file_i]=0;
sc->loadport->_object._port=sc->load_stack+sc->file_i;
-
-#if SHOW_ERROR_LINE
- sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
- if(fname)
- sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
-#endif
+ port_init_location(sc, &sc->load_stack[sc->file_i], fname);
}
return fin!=0;
}
if(sc->file_i != 0) {
sc->nesting=sc->nesting_stack[sc->file_i];
port_close(sc,sc->loadport,port_input);
+ port_clear_location(sc, &sc->load_stack[sc->file_i]);
sc->file_i--;
sc->loadport->_object._port=sc->load_stack+sc->file_i;
}
}
pt=port_rep_from_file(sc,f,prop);
pt->rep.stdio.closeit=1;
-
-#if SHOW_ERROR_LINE
- if(fn)
- pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
-
- pt->rep.stdio.curr_line = 0;
-#endif
+ port_init_location(sc, pt, mk_string(sc, fn));
return pt;
}
pt->kind = port_file | prop;
pt->rep.stdio.file = f;
pt->rep.stdio.closeit = 0;
+ port_init_location(sc, pt, NULL);
return pt;
}
pt->rep.string.start=start;
pt->rep.string.curr=start;
pt->rep.string.past_the_end=past_the_end;
+ port_init_location(sc, pt, NULL);
return pt;
}
pt->rep.string.start=start;
pt->rep.string.curr=start;
pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
+ port_init_location(sc, pt, NULL);
return pt;
}
port *pt=p->_object._port;
pt->kind&=~flag;
if((pt->kind & (port_input|port_output))==0) {
+ /* Cleanup is here so (close-*-port) functions could work too */
+ port_clear_location(sc, pt);
if(pt->kind&port_file) {
-
-#if SHOW_ERROR_LINE
- /* Cleanup is here so (close-*-port) functions could work too */
- pt->rep.stdio.curr_line = 0;
-
- if(pt->rep.stdio.filename)
- sc->free(pt->rep.stdio.filename);
-#endif
-
fclose(pt->rep.stdio.file);
}
pt->kind=port_free;
#endif
} while (isspace(c));
-/* record it */
-#if SHOW_ERROR_LINE
- if (sc->load_stack[sc->file_i].kind & port_file)
- sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
-#endif
+ /* record it */
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], curr_line);
if(c!=EOF) {
backchar(sc,c);
while ((c=inchar(sc)) != '\n' && c!=EOF)
;
-#if SHOW_ERROR_LINE
- if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
- sc->load_stack[sc->file_i].rep.stdio.curr_line++;
-#endif
+ if(c == '\n')
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
if(c == EOF)
{ return (TOK_EOF); }
while ((c=inchar(sc)) != '\n' && c!=EOF)
;
-#if SHOW_ERROR_LINE
- if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
- sc->load_stack[sc->file_i].rep.stdio.curr_line++;
-#endif
+ if(c == '\n')
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
if(c == EOF)
{ return (TOK_EOF); }
}
/* reverse list -- produce new list */
-static pointer reverse(scheme *sc, pointer a) {
+static pointer reverse(scheme *sc, pointer term, pointer list) {
/* a must be checked by gc */
- pointer p = sc->NIL;
+ pointer a = list, p = term;
for ( ; is_pair(a); a = cdr(a)) {
p = cons(sc, car(a), p);
#define is_true(p) ((p) != sc->F)
#define is_false(p) ((p) == sc->F)
+\f
/* ========== Environment implementation ========== */
#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
}
#endif
+/* Compares A and B. Returns an integer less than, equal to, or
+ * greater than zero if A is stored at a memory location that is
+ * numerical less than, equal to, or greater than that of B. */
+static int
+pointercmp(pointer a, pointer b)
+{
+ uintptr_t a_n = (uintptr_t) a;
+ uintptr_t b_n = (uintptr_t) b;
+
+ if (a_n < b_n)
+ return -1;
+ if (a_n > b_n)
+ return 1;
+ return 0;
+}
+
#ifndef USE_ALIST_ENV
/*
{
pointer new_frame;
- /* The interaction-environment has about 300 variables in it. */
+ /* The interaction-environment has about 480 variables in it. */
if (old_env == sc->NIL) {
- new_frame = mk_vector(sc, 461);
+ new_frame = mk_vector(sc, 751);
} else {
new_frame = sc->NIL;
}
setenvironment(sc->envir);
}
-static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
- pointer variable, pointer value)
-{
-#define new_slot_spec_in_env_allocates 2
- pointer slot;
- gc_disable(sc, gc_reservations (new_slot_spec_in_env));
- slot = immutable_cons(sc, variable, value);
-
- if (is_vector(car(env))) {
- int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
-
- set_vector_elem(car(env), location,
- immutable_cons(sc, slot, vector_elem(car(env), location)));
- } else {
- car(env) = immutable_cons(sc, slot, car(env));
- }
- gc_enable(sc);
-}
-
-static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+/* Find the slot in ENV under the key HDL. If ALL is given, look in
+ * all environments enclosing ENV. If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT. */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
{
pointer x,y;
int location;
+ pointer *sl;
+ int d;
+ assert(is_symbol(hdl));
for (x = env; x != sc->NIL; x = cdr(x)) {
if (is_vector(car(x))) {
- location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
- y = vector_elem(car(x), location);
+ location = hash_fn(symname(hdl), vector_length(car(x)));
+ sl = vector_elem_slot(car(x), location);
} else {
- y = car(x);
- }
- for ( ; y != sc->NIL; y = cdr(y)) {
- if (caar(y) == hdl) {
- break;
- }
- }
- if (y != sc->NIL) {
- break;
- }
- if(!all) {
- return sc->NIL;
- }
+ sl = &car(x);
}
- if (x != sc->NIL) {
- return car(y);
+ for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) {
+ d = pointercmp(caar(y), hdl);
+ if (d == 0)
+ return car(y); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
}
- return sc->NIL;
+
+ if (x == env && sslot)
+ *sslot = sl; /* Insert here. */
+
+ if (!all)
+ return sc->NIL; /* Miss, and stop looking. */
+ }
+
+ return sc->NIL; /* Not found in any environment. */
}
#else /* USE_ALIST_ENV */
setenvironment(sc->envir);
}
-static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
- pointer variable, pointer value)
-{
- car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
-}
-
-static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+/* Find the slot in ENV under the key HDL. If ALL is given, look in
+ * all environments enclosing ENV. If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT. */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
{
pointer x,y;
+ pointer *sl;
+ int d;
+ assert(is_symbol(hdl));
+
for (x = env; x != sc->NIL; x = cdr(x)) {
- for (y = car(x); y != sc->NIL; y = cdr(y)) {
- if (caar(y) == hdl) {
- break;
- }
- }
- if (y != sc->NIL) {
- break;
- }
- if(!all) {
- return sc->NIL;
- }
- }
- if (x != sc->NIL) {
- return car(y);
+ for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) {
+ d = pointercmp(caar(y), hdl);
+ if (d == 0)
+ return car(y); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
+ }
+
+ if (x == env && sslot)
+ *sslot = sl; /* Insert here. */
+
+ if (!all)
+ return sc->NIL; /* Miss, and stop looking. */
}
- return sc->NIL;
+
+ return sc->NIL; /* Not found in any environment. */
}
#endif /* USE_ALIST_ENV else */
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+{
+ return find_slot_spec_in_env(sc, env, hdl, all, NULL);
+}
+
+/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using
+ * find_slot_spec_in_env, and no insertion must be done between
+ * obtaining SSLOT and the call to this function. */
+static INLINE void new_slot_spec_in_env(scheme *sc,
+ pointer variable, pointer value,
+ pointer *sslot)
+{
+#define new_slot_spec_in_env_allocates 2
+ pointer slot;
+ gc_disable(sc, gc_reservations (new_slot_spec_in_env));
+ slot = immutable_cons(sc, variable, value);
+ *sslot = immutable_cons(sc, slot, *sslot);
+ gc_enable(sc);
+}
+
static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
{
#define new_slot_in_env_allocates new_slot_spec_in_env_allocates
- new_slot_spec_in_env(sc, sc->envir, variable, value);
+ pointer slot;
+ pointer *sslot;
+ assert(is_symbol(variable));
+ slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot);
+ assert(slot == sc->NIL);
+ new_slot_spec_in_env(sc, variable, value, sslot);
}
static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
return cdr(slot);
}
+\f
/* ========== Evaluation Cycle ========== */
-static pointer _Error_1(scheme *sc, const char *s, pointer a) {
+static enum scheme_opcodes
+_Error_1(scheme *sc, const char *s, pointer a) {
const char *str = s;
+ pointer history;
#if USE_ERROR_HOOK
pointer x;
pointer hdl=sc->ERROR_HOOK;
#if SHOW_ERROR_LINE
char sbuf[STRBUFFSIZE];
+#endif
+
+ history = history_flatten(sc);
+#if SHOW_ERROR_LINE
/* make sure error is not in REPL */
- if (sc->load_stack[sc->file_i].kind & port_file &&
- sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
- int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
- const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+ if (((sc->load_stack[sc->file_i].kind & port_file) == 0
+ || sc->load_stack[sc->file_i].rep.stdio.file != stdin)) {
+ pointer tag;
+ const char *fname;
+ int ln;
+
+ if (history != sc->NIL && has_tag(car(history))
+ && (tag = get_tag(sc, car(history)))
+ && is_string(car(tag)) && is_integer(cdr(tag))) {
+ fname = string_value(car(tag));
+ ln = ivalue_unchecked(cdr(tag));
+ } else {
+ fname = string_value(sc->load_stack[sc->file_i].filename);
+ ln = ivalue_unchecked(sc->load_stack[sc->file_i].curr_line);
+ }
/* should never happen */
if(!fname) fname = "<unknown>";
/* we started from 0 */
ln++;
- snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
+ snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
str = (const char*)sbuf;
}
#if USE_ERROR_HOOK
x=find_slot_in_env(sc,sc->envir,hdl,1);
if (x != sc->NIL) {
+ sc->code = cons(sc, cons(sc, sc->QUOTE,
+ cons(sc, history, sc->NIL)),
+ sc->NIL);
if(a!=0) {
- sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
+ sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
+ sc->code);
} else {
- sc->code = sc->NIL;
- }
+ sc->code = cons(sc, sc->F, sc->code);
+ }
sc->code = cons(sc, mk_string(sc, str), sc->code);
setimmutable(car(sc->code));
sc->code = cons(sc, slot_value_in_env(x), sc->code);
- sc->op = (int)OP_EVAL;
- return sc->T;
+ return OP_EVAL;
}
#endif
}
sc->args = cons(sc, mk_string(sc, str), sc->args);
setimmutable(car(sc->args));
- sc->op = (int)OP_ERR0;
- return sc->T;
+ return OP_ERR0;
}
-#define Error_1(sc,s, a) return _Error_1(sc,s,a)
-#define Error_0(sc,s) return _Error_1(sc,s,0)
+#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; }
+#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; }
/* Too small to turn into function */
# define BEGIN do {
# define END } while (0)
+\f
+
+/* Flags. The interpreter has a flags field. When the interpreter
+ * pushes a frame to the dump stack, it is encoded with the opcode.
+ * Therefore, we do not use the least significant byte. */
+
+/* Masks used to encode and decode opcode and flags. */
+#define S_OP_MASK 0x000000ff
+#define S_FLAG_MASK 0xffffff00
+
+/* Set if the interpreter evaluates an expression in a tail context
+ * (see R5RS, section 3.5). If a function, procedure, or continuation
+ * is invoked while this flag is set, the call is recorded as tail
+ * call in the history buffer. */
+#define S_FLAG_TAIL_CONTEXT 0x00000100
+
+/* Set flag F. */
+#define s_set_flag(sc, f) \
+ BEGIN \
+ (sc)->flags |= S_FLAG_ ## f; \
+ END
+
+/* Clear flag F. */
+#define s_clear_flag(sc, f) \
+ BEGIN \
+ (sc)->flags &= ~ S_FLAG_ ## f; \
+ END
+
+/* Check if flag F is set. */
+#define s_get_flag(sc, f) \
+ !!((sc)->flags & S_FLAG_ ## f)
+
+\f
+
/* Bounce back to Eval_Cycle and execute A. */
-#define s_goto(sc,a) BEGIN \
- sc->op = (int)(a); \
- return sc->T; END
+#define s_goto(sc, a) { op = (a); goto dispatch; }
#if USE_THREADED_CODE
/* Do not bounce back to Eval_Cycle but execute A by jumping directly
- * to it. Only applicable if A is part of the same dispatch
- * function. */
+ * to it. */
#define s_thread_to(sc, a) \
BEGIN \
- op = (int) (a); \
+ op = (a); \
goto a; \
END
/* Define a label OP and emit a case statement for OP. For use in the
- * dispatch functions. The slightly peculiar goto that is never
+ * dispatch function. The slightly peculiar goto that is never
* executed avoids warnings about unused labels. */
-#define CASE(OP) if (0) goto OP; OP: case OP
+#if __GNUC__ > 6
+#define CASE(OP) OP: __attribute__((unused)); case OP
+#else
+#define CASE(OP) case OP: if (0) goto OP; OP
+#endif
#else /* USE_THREADED_CODE */
#define s_thread_to(sc, a) s_goto(sc, a)
#define CASE(OP) case OP
#endif /* USE_THREADED_CODE */
+#if __GNUC__ > 6
+#define FALLTHROUGH __attribute__ ((fallthrough))
+#else
+#define FALLTHROUGH /* fallthrough */
+#endif
+
/* Return to the previous frame on the dump stack, setting the current
* value to A. */
-#define s_return(sc, a) return _s_return(sc, a, 0)
+#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0))
/* Return to the previous frame on the dump stack, setting the current
* value to A, and re-enable the garbage collector. */
-#define s_return_enable_gc(sc, a) return _s_return(sc, a, 1)
+#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1))
static INLINE void dump_stack_reset(scheme *sc)
{
static INLINE void dump_stack_initialize(scheme *sc)
{
dump_stack_reset(sc);
+ sc->frame_freelist = sc->NIL;
}
static void dump_stack_free(scheme *sc)
{
- sc->dump = sc->NIL;
+ dump_stack_initialize(sc);
+}
+
+const int frame_length = 4;
+
+static pointer
+dump_stack_make_frame(scheme *sc)
+{
+ pointer frame;
+
+ frame = mk_vector(sc, frame_length);
+ if (! sc->no_memory)
+ setframe(frame);
+
+ return frame;
+}
+
+static INLINE pointer *
+frame_slots(pointer frame)
+{
+ return &frame->_object._vector._elements[0];
+}
+
+#define frame_payload vector_length
+
+static pointer
+dump_stack_allocate_frame(scheme *sc)
+{
+ pointer frame = sc->frame_freelist;
+ if (frame == sc->NIL) {
+ if (gc_enabled(sc))
+ frame = dump_stack_make_frame(sc);
+ else
+ gc_reservation_failure(sc);
+ } else
+ sc->frame_freelist = *frame_slots(frame);
+ return frame;
+}
+
+static void
+dump_stack_deallocate_frame(scheme *sc, pointer frame)
+{
+ pointer *p = frame_slots(frame);
+ *p++ = sc->frame_freelist;
+ *p++ = sc->NIL;
+ *p++ = sc->NIL;
+ *p++ = sc->NIL;
+ sc->frame_freelist = frame;
+}
+
+static void
+dump_stack_preallocate_frame(scheme *sc)
+{
+ pointer frame = dump_stack_make_frame(sc);
+ if (! sc->no_memory)
+ dump_stack_deallocate_frame(sc, frame);
}
-static pointer _s_return(scheme *sc, pointer a, int enable_gc) {
+static enum scheme_opcodes
+_s_return(scheme *sc, pointer a, int enable_gc) {
pointer dump = sc->dump;
- pointer op;
+ pointer *p;
+ unsigned long v;
+ enum scheme_opcodes next_op;
sc->value = (a);
if (enable_gc)
gc_enable(sc);
if (dump == sc->NIL)
- return sc->NIL;
- free_cons(sc, dump, &op, &dump);
- sc->op = ivalue(op);
- free_cell(sc, op);
- free_cons(sc, dump, &sc->args, &dump);
- free_cons(sc, dump, &sc->envir, &dump);
- free_cons(sc, dump, &sc->code, &sc->dump);
- return sc->T;
+ return OP_QUIT;
+ v = frame_payload(dump);
+ next_op = (int) (v & S_OP_MASK);
+ sc->flags = v & S_FLAG_MASK;
+ p = frame_slots(dump);
+ sc->args = *p++;
+ sc->envir = *p++;
+ sc->code = *p++;
+ sc->dump = *p++;
+ dump_stack_deallocate_frame(sc, dump);
+ return next_op;
}
static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
-#define s_save_allocates 5
+#define s_save_allocates 0
pointer dump;
+ pointer *p;
gc_disable(sc, gc_reservations (s_save));
- dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
- dump = cons(sc, (args), dump);
- sc->dump = cons(sc, mk_integer(sc, (long)(op)), dump);
+ dump = dump_stack_allocate_frame(sc);
+ frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op);
+ p = frame_slots(dump);
+ *p++ = args;
+ *p++ = sc->envir;
+ *p++ = code;
+ *p++ = sc->dump;
+ sc->dump = dump;
gc_enable(sc);
}
static INLINE void dump_stack_mark(scheme *sc)
{
mark(sc->dump);
+ mark(sc->frame_freelist);
+}
+
+\f
+
+#if USE_HISTORY
+
+static void
+history_free(scheme *sc)
+{
+ sc->free(sc->history.m);
+ sc->history.tailstacks = sc->NIL;
+ sc->history.callstack = sc->NIL;
+}
+
+static pointer
+history_init(scheme *sc, size_t N, size_t M)
+{
+ size_t i;
+ struct history *h = &sc->history;
+
+ h->N = N;
+ h->mask_N = N - 1;
+ h->n = N - 1;
+ assert ((N & h->mask_N) == 0);
+
+ h->M = M;
+ h->mask_M = M - 1;
+ assert ((M & h->mask_M) == 0);
+
+ h->callstack = mk_vector(sc, N);
+ if (h->callstack == sc->sink)
+ goto fail;
+
+ h->tailstacks = mk_vector(sc, N);
+ for (i = 0; i < N; i++) {
+ pointer tailstack = mk_vector(sc, M);
+ if (tailstack == sc->sink)
+ goto fail;
+ set_vector_elem(h->tailstacks, i, tailstack);
+ }
+
+ h->m = sc->malloc(N * sizeof *h->m);
+ if (h->m == NULL)
+ goto fail;
+
+ for (i = 0; i < N; i++)
+ h->m[i] = 0;
+
+ return sc->T;
+
+fail:
+ history_free(sc);
+ return sc->F;
+}
+
+static void
+history_mark(scheme *sc)
+{
+ struct history *h = &sc->history;
+ mark(h->callstack);
+ mark(h->tailstacks);
+}
+
+#define add_mod(a, b, mask) (((a) + (b)) & (mask))
+#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask)
+
+static INLINE void
+tailstack_clear(scheme *sc, pointer v)
+{
+ assert(is_vector(v));
+ /* XXX optimize */
+ fill_vector(v, sc->NIL);
+}
+
+static pointer
+callstack_pop(scheme *sc)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+ pointer item;
+
+ if (h->callstack == sc->NIL)
+ return sc->NIL;
+
+ item = vector_elem(h->callstack, n);
+ /* Clear our frame so that it can be gc'ed and we don't run into it
+ * when walking the history. */
+ set_vector_elem(h->callstack, n, sc->NIL);
+ tailstack_clear(sc, vector_elem(h->tailstacks, n));
+
+ /* Exit from the frame. */
+ h->n = sub_mod(h->n, 1, h->mask_N);
+
+ return item;
+}
+
+static void
+callstack_push(scheme *sc, pointer item)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+
+ if (h->callstack == sc->NIL)
+ return;
+
+ /* Enter a new frame. */
+ n = h->n = add_mod(n, 1, h->mask_N);
+
+ /* Initialize tail stack. */
+ tailstack_clear(sc, vector_elem(h->tailstacks, n));
+ h->m[n] = h->mask_M;
+
+ set_vector_elem(h->callstack, n, item);
+}
+
+static void
+tailstack_push(scheme *sc, pointer item)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+ size_t m = h->m[n];
+
+ if (h->callstack == sc->NIL)
+ return;
+
+ /* Enter a new tail frame. */
+ m = h->m[n] = add_mod(m, 1, h->mask_M);
+ set_vector_elem(vector_elem(h->tailstacks, n), m, item);
+}
+
+static pointer
+tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
+ pointer acc)
+{
+ struct history *h = &sc->history;
+ pointer frame;
+
+ assert(i <= h->M);
+ assert(n < h->M);
+
+ if (acc == sc->sink)
+ return sc->sink;
+
+ if (i == 0) {
+ /* We reached the end, but we did not see a unused frame. Signal
+ this using '... . */
+ return cons(sc, mk_symbol(sc, "..."), acc);
+ }
+
+ frame = vector_elem(tailstack, n);
+ if (frame == sc->NIL) {
+ /* A unused frame. We reached the end of the history. */
+ return acc;
+ }
+
+ /* Add us. */
+ acc = cons(sc, frame, acc);
+
+ return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
+ acc);
+}
+
+static pointer
+callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
+{
+ struct history *h = &sc->history;
+ pointer frame;
+
+ assert(i <= h->N);
+ assert(n < h->N);
+
+ if (acc == sc->sink)
+ return sc->sink;
+
+ if (i == 0) {
+ /* We reached the end, but we did not see a unused frame. Signal
+ this using '... . */
+ return cons(sc, mk_symbol(sc, "..."), acc);
+ }
+
+ frame = vector_elem(h->callstack, n);
+ if (frame == sc->NIL) {
+ /* A unused frame. We reached the end of the history. */
+ return acc;
+ }
+
+ /* First, emit the tail calls. */
+ acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
+ acc);
+
+ /* Then us. */
+ acc = cons(sc, frame, acc);
+
+ return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
+}
+
+static pointer
+history_flatten(scheme *sc)
+{
+ struct history *h = &sc->history;
+ pointer history;
+
+ if (h->callstack == sc->NIL)
+ return sc->NIL;
+
+ history = callstack_flatten(sc, h->N, h->n, sc->NIL);
+ if (history == sc->sink)
+ return sc->sink;
+
+ return reverse_in_place(sc, sc->NIL, history);
+}
+
+#undef add_mod
+#undef sub_mod
+
+#else /* USE_HISTORY */
+
+#define history_init(SC, A, B) (void) 0
+#define history_free(SC) (void) 0
+#define callstack_pop(SC) (void) 0
+#define callstack_push(SC, X) (void) 0
+#define tailstack_push(SC, X) (void) 0
+
+#endif /* USE_HISTORY */
+
+\f
+
+#if USE_PLIST
+static pointer
+get_property(scheme *sc, pointer obj, pointer key)
+{
+ pointer x;
+
+ assert (is_symbol(obj));
+ assert (is_symbol(key));
+
+ for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+ if (caar(x) == key)
+ break;
+ }
+
+ if (x != sc->NIL)
+ return cdar(x);
+
+ return sc->NIL;
+}
+
+static pointer
+set_property(scheme *sc, pointer obj, pointer key, pointer value)
+{
+#define set_property_allocates 2
+ pointer x;
+
+ assert (is_symbol(obj));
+ assert (is_symbol(key));
+
+ for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+ if (caar(x) == key)
+ break;
+ }
+
+ if (x != sc->NIL)
+ cdar(x) = value;
+ else {
+ gc_disable(sc, gc_reservations(set_property));
+ symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj));
+ gc_enable(sc);
+ }
+
+ return sc->T;
+}
+#endif
+
+\f
+
+static int is_list(scheme *sc, pointer a)
+{ return list_length(sc,a) >= 0; }
+
+/* Result is:
+ proper list: length
+ circular list: -1
+ not even a pair: -2
+ dotted list: -2 minus length before dot
+*/
+int list_length(scheme *sc, pointer a) {
+ int i=0;
+ pointer slow, fast;
+
+ slow = fast = a;
+ while (1)
+ {
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ fast = cdr(fast);
+ ++i;
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ ++i;
+ fast = cdr(fast);
+
+ /* Safe because we would have already returned if `fast'
+ encountered a non-pair. */
+ slow = cdr(slow);
+ if (fast == slow)
+ {
+ /* the fast pointer has looped back around and caught up
+ with the slow pointer, hence the structure is circular,
+ not of finite length, and therefore not a list */
+ return -1;
+ }
+ }
}
+\f
+
#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
-static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
+/* kernel of this interpreter */
+static void
+Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
+ for (;;) {
pointer x, y;
+ pointer callsite;
+ num v;
+#if USE_MATH
+ double dd;
+#endif
+ int (*comp_func)(num, num) = NULL;
+ const struct op_code_info *pcd;
+
+ dispatch:
+ pcd = &dispatch_table[op];
+ if (pcd->name[0] != 0) { /* if built-in function, check arguments */
+ char msg[STRBUFFSIZE];
+ if (! check_arguments (sc, pcd, msg, sizeof msg)) {
+ s_goto(sc, _Error_1(sc, msg, 0));
+ }
+ }
+
+ if(sc->no_memory) {
+ fprintf(stderr,"No memory!\n");
+ exit(1);
+ }
+ ok_to_freely_gc(sc);
switch (op) {
CASE(OP_LOAD): /* load */
fprintf(sc->outport->_object._port->rep.stdio.file,
"Loading %s\n", strvalue(car(sc->args)));
}
- if (!file_push(sc,strvalue(car(sc->args)))) {
+ if (!file_push(sc, car(sc->args))) {
Error_1(sc,"unable to open", car(sc->args));
}
else
{
sc->args=sc->NIL;
sc->nesting = sc->nesting_stack[0];
- s_goto(sc,OP_QUIT);
+ s_thread_to(sc,OP_QUIT);
}
else
{
sc->tok = token(sc);
if(sc->tok==TOK_EOF)
{ s_return(sc,sc->EOF_OBJ); }
- s_goto(sc,OP_RDSEXPR);
+ s_thread_to(sc,OP_RDSEXPR);
CASE(OP_GENSYM):
s_return(sc, gensym(sc));
if(file_interactive(sc)) {
sc->print_flag = 1;
sc->args = sc->value;
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else {
s_return(sc,sc->value);
}
s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
sc->args=sc->code;
putstr(sc,"\nEval: ");
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
}
- /* fall through */
+ FALLTHROUGH;
CASE(OP_REAL_EVAL):
#endif
if (is_symbol(sc->code)) { /* symbol */
if (x != sc->NIL) {
s_return(sc,slot_value_in_env(x));
} else {
- Error_1(sc,"eval: unbound variable:", sc->code);
+ Error_1(sc, "eval: unbound variable", sc->code);
}
} else if (is_pair(sc->code)) {
if (is_syntax(x = car(sc->code))) { /* SYNTAX */
sc->code = cdr(sc->code);
- s_goto(sc,syntaxnum(x));
+ s_goto(sc, syntaxnum(sc, x));
} else {/* first, eval top element and eval arguments */
s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
/* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
}
} else {
sc->args = cons(sc,sc->code, sc->NIL);
gc_enable(sc);
sc->code = sc->value;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_APPLY);
} else {
- sc->code = cdr(sc->code);
+ gc_disable(sc, 1);
+ sc->args = cons(sc, sc->code, sc->NIL);
+ gc_enable(sc);
+ sc->code = cdr(sc->code);
s_thread_to(sc,OP_E1ARGS);
}
s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
sc->code = car(sc->code);
sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
- sc->code = car(sc->args);
- sc->args = cdr(sc->args);
- s_thread_to(sc,OP_APPLY);
+ s_thread_to(sc,OP_APPLY_CODE);
}
#if USE_TRACING
}
#endif
+#if USE_HISTORY
+ CASE(OP_CALLSTACK_POP): /* pop the call stack */
+ callstack_pop(sc);
+ s_return(sc, sc->value);
+#endif
+
+ CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
+ * record in the history as invoked from
+ * 'car(args)' */
+ free_cons(sc, sc->args, &callsite, &sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ FALLTHROUGH;
+
CASE(OP_APPLY): /* apply 'code' to 'args' */
#if USE_TRACING
if(sc->tracing) {
sc->print_flag = 1;
/* sc->args=cons(sc,sc->code,sc->args);*/
putstr(sc,"\nApply to: ");
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
}
- /* fall through */
+ FALLTHROUGH;
CASE(OP_REAL_APPLY):
#endif
+#if USE_HISTORY
+ if (op != OP_APPLY_CODE)
+ callsite = sc->code;
+ if (s_get_flag(sc, TAIL_CONTEXT)) {
+ /* We are evaluating a tail call. */
+ tailstack_push(sc, callsite);
+ } else {
+ callstack_push(sc, callsite);
+ s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
+ }
+#endif
+
if (is_proc(sc->code)) {
s_goto(sc,procnum(sc->code)); /* PROCEDURE */
} else if (is_foreign(sc->code))
for (x = car(closure_code(sc->code)), y = sc->args;
is_pair(x); x = cdr(x), y = cdr(y)) {
if (y == sc->NIL) {
- Error_1(sc, "not enough arguments, missing:", x);
- } else {
+ Error_1(sc, "not enough arguments, missing", x);
+ } else if (is_symbol(car(x))) {
new_slot_in_env(sc, car(x), car(y));
- }
+ } else {
+ Error_1(sc, "syntax error in closure: not a symbol", car(x));
+ }
}
+
if (x == sc->NIL) {
- /*--
- * if (y != sc->NIL) {
- * Error_0(sc,"too many arguments");
- * }
- */
+ if (y != sc->NIL) {
+ Error_0(sc, "too many arguments");
+ }
} else if (is_symbol(x))
new_slot_in_env(sc, x, y);
else {
- Error_1(sc,"syntax error in closure: not a symbol:", x);
+ Error_1(sc, "syntax error in closure: not a symbol", x);
}
sc->code = cdr(closure_code(sc->code));
sc->args = sc->NIL;
+ s_set_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_BEGIN);
} else if (is_continuation(sc->code)) { /* CONTINUATION */
sc->dump = cont_dump(sc->code);
s_thread_to(sc,OP_APPLY);
}
}
+#else
+ CASE(OP_LAMBDA): /* lambda */
+ sc->value = sc->code;
+#endif
+ FALLTHROUGH;
CASE(OP_LAMBDA1):
gc_disable(sc, 1);
s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
-#else
- CASE(OP_LAMBDA): /* lambda */
- gc_disable(sc, 1);
- s_return_enable_gc(sc, mk_closure(sc, sc->code, sc->envir));
-
-#endif
CASE(OP_MKCLOSURE): /* make-closure */
x=car(sc->args);
s_save(sc,OP_DEF1, sc->NIL, x);
s_thread_to(sc,OP_EVAL);
- CASE(OP_DEF1): /* define */
- x=find_slot_in_env(sc,sc->envir,sc->code,0);
+ CASE(OP_DEF1): { /* define */
+ pointer *sslot;
+ x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
if (x != sc->NIL) {
set_slot_in_env(sc, x, sc->value);
} else {
- new_slot_in_env(sc, sc->code, sc->value);
+ new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
}
s_return(sc,sc->code);
-
+ }
CASE(OP_DEFP): /* defined? */
x=sc->envir;
set_slot_in_env(sc, y, sc->value);
s_return(sc,sc->value);
} else {
- Error_1(sc,"set!: unbound variable:", sc->code);
+ Error_1(sc, "set!: unbound variable", sc->code);
}
CASE(OP_BEGIN): /* begin */
- if (!is_pair(sc->code)) {
- s_return(sc,sc->code);
- }
- if (cdr(sc->code) != sc->NIL) {
- s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
- }
- sc->code = car(sc->code);
- s_thread_to(sc,OP_EVAL);
+ {
+ int last;
+
+ if (!is_pair(sc->code)) {
+ s_return(sc,sc->code);
+ }
+
+ last = cdr(sc->code) == sc->NIL;
+ if (!last) {
+ s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
+ }
+ sc->code = car(sc->code);
+ if (! last)
+ /* This is not the end of the list. This is not a tail
+ * position. */
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ }
CASE(OP_IF0): /* if */
s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
CASE(OP_IF1): /* if */
if (is_pair(sc->code)) { /* continue */
if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
gc_enable(sc);
- Error_1(sc, "Bad syntax of binding spec in let :",
+ Error_1(sc, "Bad syntax of binding spec in let",
car(sc->code));
}
s_save(sc,OP_LET1, sc->args, cdr(sc->code));
gc_enable(sc);
sc->code = cadar(sc->code);
sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
} else { /* end */
gc_enable(sc);
if (is_symbol(car(sc->code))) { /* named let */
for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
if (!is_pair(x))
- Error_1(sc, "Bad syntax of binding in let :", x);
+ Error_1(sc, "Bad syntax of binding in let", x);
if (!is_list(sc, car(x)))
- Error_1(sc, "Bad syntax of binding in let :", car(x));
+ Error_1(sc, "Bad syntax of binding in let", car(x));
gc_disable(sc, 1);
sc->args = cons(sc, caar(x), sc->args);
gc_enable(sc);
s_thread_to(sc,OP_BEGIN);
}
if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
- Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
+ Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code));
}
s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
sc->code = cadaar(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
CASE(OP_LET1AST): /* let* (make new frame) */
s_save(sc,OP_LET2AST, sc->args, sc->code);
sc->code = cadar(sc->code);
sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->code = sc->args;
sc->args = sc->NIL;
s_thread_to(sc,OP_BEGIN);
}
- default:
- snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
- Error_0(sc,sc->strbuff);
- }
- return sc->T;
-}
-static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
- pointer x, y;
-
- switch (op) {
CASE(OP_LET0REC): /* letrec */
new_frame_in_env(sc, sc->envir);
sc->args = sc->NIL;
gc_enable(sc);
if (is_pair(sc->code)) { /* continue */
if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
- Error_1(sc, "Bad syntax of binding spec in letrec :",
+ Error_1(sc, "Bad syntax of binding spec in letrec",
car(sc->code));
}
s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
sc->code = cadar(sc->code);
sc->args = sc->NIL;
- s_goto(sc,OP_EVAL);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
} else { /* end */
sc->args = reverse_in_place(sc, sc->NIL, sc->args);
sc->code = car(sc->args);
}
sc->code = cdr(sc->code);
sc->args = sc->NIL;
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
CASE(OP_COND0): /* cond */
if (!is_pair(sc->code)) {
}
s_save(sc,OP_COND1, sc->NIL, sc->code);
sc->code = caar(sc->code);
- s_goto(sc,OP_EVAL);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
CASE(OP_COND1): /* cond */
if (is_true(sc->value)) {
x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
gc_enable(sc);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
}
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
} else {
if ((sc->code = cdr(sc->code)) == sc->NIL) {
s_return(sc,sc->NIL);
} else {
s_save(sc,OP_COND1, sc->NIL, sc->code);
sc->code = caar(sc->code);
- s_goto(sc,OP_EVAL);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
}
}
s_return(sc,sc->T);
}
s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
CASE(OP_AND1): /* and */
if (is_false(sc->value)) {
s_return(sc,sc->value);
} else {
s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
}
CASE(OP_OR0): /* or */
s_return(sc,sc->F);
}
s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
CASE(OP_OR1): /* or */
if (is_true(sc->value)) {
s_return(sc,sc->value);
} else {
s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
}
CASE(OP_C0STREAM): /* cons-stream */
s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
CASE(OP_C1STREAM): /* cons-stream */
sc->args = sc->value; /* save sc->value to register sc->args for gc */
Error_0(sc,"variable is not a symbol");
}
s_save(sc,OP_MACRO1, sc->NIL, x);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
- CASE(OP_MACRO1): /* macro */
+ CASE(OP_MACRO1): { /* macro */
+ pointer *sslot;
typeflag(sc->value) = T_MACRO;
- x = find_slot_in_env(sc, sc->envir, sc->code, 0);
+ x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
if (x != sc->NIL) {
set_slot_in_env(sc, x, sc->value);
} else {
- new_slot_in_env(sc, sc->code, sc->value);
+ new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
}
s_return(sc,sc->code);
+ }
CASE(OP_CASE0): /* case */
s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
sc->code = car(sc->code);
- s_goto(sc,OP_EVAL);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
CASE(OP_CASE1): /* case */
for (x = sc->code; x != sc->NIL; x = cdr(x)) {
if (x != sc->NIL) {
if (is_pair(caar(x))) {
sc->code = cdar(x);
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
} else {/* else */
s_save(sc,OP_CASE2, sc->NIL, cdar(x));
sc->code = caar(x);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
}
} else {
s_return(sc,sc->NIL);
CASE(OP_CASE2): /* case */
if (is_true(sc->value)) {
- s_goto(sc,OP_BEGIN);
+ s_thread_to(sc,OP_BEGIN);
} else {
s_return(sc,sc->NIL);
}
sc->code = car(sc->args);
sc->args = list_star(sc,cdr(sc->args));
/*sc->args = cadr(sc->args);*/
- s_goto(sc,OP_APPLY);
+ s_thread_to(sc,OP_APPLY);
CASE(OP_PEVAL): /* eval */
if(cdr(sc->args)!=sc->NIL) {
sc->envir=cadr(sc->args);
}
sc->code = car(sc->args);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
CASE(OP_CONTINUATION): /* call-with-current-continuation */
sc->code = car(sc->args);
gc_disable(sc, 2);
sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
gc_enable(sc);
- s_goto(sc,OP_APPLY);
-
- default:
- snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
- Error_0(sc,sc->strbuff);
- }
- return sc->T;
-}
-
-static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
- pointer x;
- num v;
-#if USE_MATH
- double dd;
-#endif
+ s_thread_to(sc,OP_APPLY);
- switch (op) {
#if USE_MATH
CASE(OP_INEX2EX): /* inexact->exact */
x=car(sc->args);
} else if(modf(rvalue_unchecked(x),&dd)==0.0) {
s_return(sc,mk_integer(sc,ivalue(x)));
} else {
- Error_1(sc,"inexact->exact: not integral:",x);
+ Error_1(sc, "inexact->exact: not integral", x);
}
CASE(OP_EXP):
}
}
if (pf < 0) {
- Error_1(sc, "string->atom: bad base:", cadr(sc->args));
+ Error_1(sc, "string->atom: bad base", cadr(sc->args));
} else if(*s=='#') /* no use of base! */ {
s_return(sc, mk_sharp_const(sc, s+1));
} else {
}
}
if (pf < 0) {
- Error_1(sc, "atom->string: bad base:", cadr(sc->args));
+ Error_1(sc, "atom->string: bad base", cadr(sc->args));
} else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
char *p;
int len;
gc_disable(sc, 1);
s_return_enable_gc(sc, mk_counted_string(sc, p, len));
} else {
- Error_1(sc, "atom->string: not an atom:", x);
+ Error_1(sc, "atom->string: not an atom", x);
}
}
index=ivalue(cadr(sc->args));
if(index>=strlength(car(sc->args))) {
- Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
+ Error_1(sc, "string-ref: out of bounds", cadr(sc->args));
}
gc_disable(sc, 1);
int c;
if(is_immutable(car(sc->args))) {
- Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
+ Error_1(sc, "string-set!: unable to alter immutable string",
+ car(sc->args));
}
str=strvalue(car(sc->args));
index=ivalue(cadr(sc->args));
if(index>=strlength(car(sc->args))) {
- Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
+ Error_1(sc, "string-set!: out of bounds", cadr(sc->args));
}
c=charvalue(caddr(sc->args));
char *str;
int index0;
int index1;
- int len;
str=strvalue(car(sc->args));
index0=ivalue(cadr(sc->args));
if(index0>strlength(car(sc->args))) {
- Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
+ Error_1(sc, "substring: start out of bounds", cadr(sc->args));
}
if(cddr(sc->args)!=sc->NIL) {
index1=ivalue(caddr(sc->args));
if(index1>strlength(car(sc->args)) || index1<index0) {
- Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
+ Error_1(sc, "substring: end out of bounds", caddr(sc->args));
}
} else {
index1=strlength(car(sc->args));
}
- len=index1-index0;
gc_disable(sc, 1);
- x=mk_empty_string(sc,len,' ');
- memcpy(strvalue(x),str+index0,len);
- strvalue(x)[len]=0;
-
- s_return_enable_gc(sc, x);
+ s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0));
}
CASE(OP_VECTOR): { /* vector */
pointer vec;
int len=list_length(sc,sc->args);
if(len<0) {
- Error_1(sc,"vector: not a proper list:",sc->args);
+ Error_1(sc, "vector: not a proper list", sc->args);
}
vec=mk_vector(sc,len);
if(sc->no_memory) { s_return(sc, sc->sink); }
CASE(OP_VECLEN): /* vector-length */
gc_disable(sc, 1);
- s_return_enable_gc(sc, mk_integer(sc, ivalue(car(sc->args))));
+ s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args))));
CASE(OP_VECREF): { /* vector-ref */
int index;
index=ivalue(cadr(sc->args));
- if(index>=ivalue(car(sc->args))) {
- Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
+ if(index >= vector_length(car(sc->args))) {
+ Error_1(sc, "vector-ref: out of bounds", cadr(sc->args));
}
s_return(sc,vector_elem(car(sc->args),index));
int index;
if(is_immutable(car(sc->args))) {
- Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
+ Error_1(sc, "vector-set!: unable to alter immutable vector",
+ car(sc->args));
}
index=ivalue(cadr(sc->args));
- if(index>=ivalue(car(sc->args))) {
- Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
+ if(index >= vector_length(car(sc->args))) {
+ Error_1(sc, "vector-set!: out of bounds", cadr(sc->args));
}
set_vector_elem(car(sc->args),index,caddr(sc->args));
s_return(sc,car(sc->args));
}
- default:
- snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
- Error_0(sc,sc->strbuff);
- }
- return sc->T;
-}
-
-static int is_list(scheme *sc, pointer a)
-{ return list_length(sc,a) >= 0; }
-
-/* Result is:
- proper list: length
- circular list: -1
- not even a pair: -2
- dotted list: -2 minus length before dot
-*/
-int list_length(scheme *sc, pointer a) {
- int i=0;
- pointer slow, fast;
-
- slow = fast = a;
- while (1)
- {
- if (fast == sc->NIL)
- return i;
- if (!is_pair(fast))
- return -2 - i;
- fast = cdr(fast);
- ++i;
- if (fast == sc->NIL)
- return i;
- if (!is_pair(fast))
- return -2 - i;
- ++i;
- fast = cdr(fast);
-
- /* Safe because we would have already returned if `fast'
- encountered a non-pair. */
- slow = cdr(slow);
- if (fast == slow)
- {
- /* the fast pointer has looped back around and caught up
- with the slow pointer, hence the structure is circular,
- not of finite length, and therefore not a list */
- return -1;
- }
- }
-}
-
-static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
- pointer x;
- num v;
- int (*comp_func)(num,num)=0;
-
- switch (op) {
CASE(OP_NOT): /* not */
s_retbool(is_false(car(sc->args)));
CASE(OP_BOOLP): /* boolean? */
s_retbool(car(sc->args) == cadr(sc->args));
CASE(OP_EQV): /* eqv? */
s_retbool(eqv(car(sc->args), cadr(sc->args)));
- default:
- snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
- Error_0(sc,sc->strbuff);
- }
- return sc->T;
-}
-static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
- pointer x, y;
-
- switch (op) {
CASE(OP_FORCE): /* force */
sc->code = car(sc->args);
if (is_promise(sc->code)) {
/* Should change type to closure here */
s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
sc->args = sc->NIL;
- s_goto(sc,OP_APPLY);
+ s_thread_to(sc,OP_APPLY);
} else {
s_return(sc,sc->code);
}
CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */
- memcpy(sc->code,sc->value,sizeof(struct cell));
+ copy_value(sc, sc->code, sc->value);
s_return(sc,sc->value);
CASE(OP_WRITE): /* write */
} else {
sc->print_flag = 0;
}
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
CASE(OP_NEWLINE): /* newline */
if(is_pair(sc->args)) {
s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
sc->args = car(sc->args);
sc->print_flag = 1;
- s_goto(sc,OP_P0LIST);
+ s_thread_to(sc,OP_P0LIST);
} else {
putstr(sc, "\n");
if(sc->interactive_repl) {
- s_goto(sc,OP_T0LVL);
+ s_thread_to(sc,OP_T0LVL);
} else {
- return sc->NIL;
+ return;
}
}
CASE(OP_REVERSE): /* reverse */
- s_return(sc,reverse(sc, car(sc->args)));
+ s_return(sc,reverse(sc, sc->NIL, car(sc->args)));
+
+ CASE(OP_REVERSE_IN_PLACE): /* reverse! */
+ s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args)));
CASE(OP_LIST_STAR): /* list* */
s_return(sc,list_star(sc,sc->args));
s_return(sc, reverse_in_place(sc, car(y), x));
#if USE_PLIST
- CASE(OP_PUT): /* put */
- if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
- Error_0(sc,"illegal use of put");
- }
- for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
- if (caar(x) == y) {
- break;
- }
- }
- if (x != sc->NIL)
- cdar(x) = caddr(sc->args);
- else
- symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
- symprop(car(sc->args)));
- s_return(sc,sc->T);
+ CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */
+ gc_disable(sc, gc_reservations(set_property));
+ s_return_enable_gc(sc,
+ set_property(sc, car(sc->args),
+ cadr(sc->args), caddr(sc->args)));
- CASE(OP_GET): /* get */
- if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
- Error_0(sc,"illegal use of get");
- }
- for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
- if (caar(x) == y) {
- break;
- }
- }
- if (x != sc->NIL) {
- s_return(sc,cdar(x));
- } else {
- s_return(sc,sc->NIL);
- }
+ CASE(OP_SYMBOL_PROPERTY): /* symbol-property */
+ s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
#endif /* USE_PLIST */
+
+ CASE(OP_TAG_VALUE): { /* not exposed */
+ /* This tags sc->value with car(sc->args). Useful to tag
+ * results of opcode evaluations. */
+ pointer a, b, c;
+ free_cons(sc, sc->args, &a, &b);
+ free_cons(sc, b, &b, &c);
+ assert(c == sc->NIL);
+ s_return(sc, mk_tagged_value(sc, sc->value, a, b));
+ }
+
+ CASE(OP_MK_TAGGED): /* make-tagged-value */
+ if (is_vector(car(sc->args)))
+ Error_0(sc, "cannot tag vector");
+ s_return(sc, mk_tagged_value(sc, car(sc->args),
+ car(cadr(sc->args)),
+ cdr(cadr(sc->args))));
+
+ CASE(OP_GET_TAG): /* get-tag */
+ s_return(sc, get_tag(sc, car(sc->args)));
+
CASE(OP_QUIT): /* quit */
if(is_pair(sc->args)) {
sc->retcode=ivalue(car(sc->args));
}
- return (sc->NIL);
+ return;
CASE(OP_GC): /* gc */
gc(sc, sc->NIL, sc->NIL);
}
s_return(sc,p);
break;
- default: assert (! "reached");
}
#if USE_STRING_PORTS
port *p;
if ((p=car(sc->args)->_object._port)->kind&port_string) {
- off_t size;
- char *str;
-
- size=p->rep.string.curr-p->rep.string.start+1;
- str=sc->malloc(size);
- if(str != NULL) {
- pointer s;
-
- memcpy(str,p->rep.string.start,size-1);
- str[size-1]='\0';
- s=mk_string(sc,str);
- sc->free(str);
- s_return(sc,s);
- }
+ gc_disable(sc, 1);
+ s_return_enable_gc(
+ sc,
+ mk_counted_string(sc,
+ p->rep.string.start,
+ p->rep.string.curr - p->rep.string.start));
}
s_return(sc,sc->F);
}
CASE(OP_CURR_ENV): /* current-environment */
s_return(sc,sc->envir);
- }
- return sc->T;
-}
-
-static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
- pointer x;
-
- if(sc->nesting!=0) {
- int n=sc->nesting;
- sc->nesting=0;
- sc->retcode=-1;
- Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
- }
- switch (op) {
/* ========== reading part ========== */
CASE(OP_READ):
if(!is_pair(sc->args)) {
- s_goto(sc,OP_READ_INTERNAL);
+ s_thread_to(sc,OP_READ_INTERNAL);
}
if(!is_inport(car(sc->args))) {
- Error_1(sc,"read: not an input port:",car(sc->args));
+ Error_1(sc, "read: not an input port", car(sc->args));
}
if(car(sc->args)==sc->inport) {
- s_goto(sc,OP_READ_INTERNAL);
+ s_thread_to(sc,OP_READ_INTERNAL);
}
x=sc->inport;
sc->inport=car(sc->args);
x=cons(sc,x,sc->NIL);
s_save(sc,OP_SET_INPORT, x, sc->NIL);
- s_goto(sc,OP_READ_INTERNAL);
+ s_thread_to(sc,OP_READ_INTERNAL);
CASE(OP_READ_CHAR): /* read-char */
CASE(OP_PEEK_CHAR): /* peek-char */ {
if(c==EOF) {
s_return(sc,sc->EOF_OBJ);
}
- if(sc->op==OP_PEEK_CHAR) {
+ if(op==OP_PEEK_CHAR) {
backchar(sc,c);
}
s_return(sc,mk_character(sc,c));
} else if (sc->tok == TOK_DOT) {
Error_0(sc,"syntax error: illegal dot expression");
} else {
+#if SHOW_ERROR_LINE
+ pointer filename;
+ pointer lineno;
+#endif
sc->nesting_stack[sc->file_i]++;
+#if SHOW_ERROR_LINE
+ filename = sc->load_stack[sc->file_i].filename;
+ lineno = sc->load_stack[sc->file_i].curr_line;
+
+ s_save(sc, OP_TAG_VALUE,
+ cons(sc, filename, cons(sc, lineno, sc->NIL)),
+ sc->NIL);
+#endif
s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
s_thread_to(sc,OP_RDSEXPR);
}
Error_0(sc,"undefined sharp expression");
} else {
sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
- s_goto(sc,OP_EVAL);
+ s_thread_to(sc,OP_EVAL);
}
}
case TOK_SHARP_CONST:
int c = inchar(sc);
if (c != '\n')
backchar(sc,c);
-#if SHOW_ERROR_LINE
- else if (sc->load_stack[sc->file_i].kind & port_file)
- sc->load_stack[sc->file_i].rep.stdio.curr_line++;
-#endif
+ else
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
sc->nesting_stack[sc->file_i]--;
s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
} else if (sc->tok == TOK_DOT) {
CASE(OP_RDVEC):
/*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
- s_goto(sc,OP_EVAL); Cannot be quoted*/
+ s_thread_to(sc,OP_EVAL); Cannot be quoted*/
/*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
s_return(sc,x); Cannot be part of pairs*/
/*sc->code=mk_proc(sc,OP_VECTOR);
sc->args=sc->value;
- s_goto(sc,OP_APPLY);*/
+ s_thread_to(sc,OP_APPLY);*/
sc->args=sc->value;
- s_goto(sc,OP_VECTOR);
+ s_thread_to(sc,OP_VECTOR);
/* ========== printing part ========== */
CASE(OP_P0LIST):
CASE(OP_PVECFROM): {
int i=ivalue_unchecked(cdr(sc->args));
pointer vec=car(sc->args);
- int len=ivalue_unchecked(vec);
+ int len = vector_length(vec);
if(i==len) {
putstr(sc,")");
s_return(sc,sc->T);
} else {
pointer elem=vector_elem(vec,i);
- ivalue_unchecked(cdr(sc->args))=i+1;
+ cdr(sc->args) = mk_integer(sc, i + 1);
s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
sc->args=elem;
if (i > 0)
}
}
- default:
- snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
- Error_0(sc,sc->strbuff);
-
- }
- return sc->T;
-}
-
-static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
- pointer x, y;
- long v;
-
- switch (op) {
- CASE(OP_LIST_LENGTH): /* length */ /* a.k */
- v=list_length(sc,car(sc->args));
- if(v<0) {
- Error_1(sc,"length: not a list:",car(sc->args));
+ CASE(OP_LIST_LENGTH): { /* length */ /* a.k */
+ long l = list_length(sc, car(sc->args));
+ if(l<0) {
+ Error_1(sc, "length: not a list", car(sc->args));
}
gc_disable(sc, 1);
- s_return_enable_gc(sc, mk_integer(sc, v));
-
+ s_return_enable_gc(sc, mk_integer(sc, l));
+ }
CASE(OP_ASSQ): /* assq */ /* a.k */
x = car(sc->args);
for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
s_retbool(is_closure(car(sc->args)));
CASE(OP_MACROP): /* macro? */
s_retbool(is_macro(car(sc->args)));
+ CASE(OP_VM_HISTORY): /* *vm-history* */
+ s_return(sc, history_flatten(sc));
default:
- snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op);
Error_0(sc,sc->strbuff);
}
- return sc->T; /* NOTREACHED */
+ }
}
-typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
-
typedef int (*test_predicate)(pointer);
static int is_any(pointer p) {
}
/* Correspond carefully with following defines! */
-static struct {
+static const struct {
test_predicate fct;
const char *kind;
} tests[]={
#define TST_INTEGER "\015"
#define TST_NATURAL "\016"
-typedef struct {
- dispatch_func func;
- char *name;
- int min_arity;
- int max_arity;
- char *arg_tests_encoding;
-} op_code_info;
+#define INF_ARG 0xff
-#define INF_ARG 0xffff
-
-static op_code_info dispatch_table[]= {
-#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
+static const struct op_code_info dispatch_table[]= {
+#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}},
#include "opdefines.h"
- { 0 }
+#undef _OP_DEF
+ {{0},0,0,{0}},
};
static const char *procname(pointer x) {
int n=procnum(x);
const char *name=dispatch_table[n].name;
- if(name==0) {
+ if (name[0] == 0) {
name="ILLEGAL!";
}
return name;
}
-/* kernel of this interpreter */
-static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
- sc->op = op;
- for (;;) {
- op_code_info *pcd=dispatch_table+sc->op;
- if (pcd->name!=0) { /* if built-in function, check arguments */
- char msg[STRBUFFSIZE];
- int ok=1;
- int n=list_length(sc,sc->args);
-
- /* Check number of arguments */
- if(n<pcd->min_arity) {
- ok=0;
- snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
- pcd->name,
- pcd->min_arity==pcd->max_arity?"":" at least",
- pcd->min_arity);
- }
- if(ok && n>pcd->max_arity) {
- ok=0;
- snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
- pcd->name,
- pcd->min_arity==pcd->max_arity?"":" at most",
- pcd->max_arity);
- }
- if(ok) {
- if(pcd->arg_tests_encoding!=0) {
- int i=0;
- int j;
- const char *t=pcd->arg_tests_encoding;
- pointer arglist=sc->args;
- do {
- pointer arg=car(arglist);
- j=(int)t[0];
- if(j==TST_LIST[0]) {
- if(arg!=sc->NIL && !is_pair(arg)) break;
- } else {
- if(!tests[j].fct(arg)) break;
- }
-
- if(t[1]!=0) {/* last test is replicated as necessary */
- t++;
- }
- arglist=cdr(arglist);
- i++;
- } while(i<n);
- if(i<n) {
- ok=0;
- snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s, got: %s",
- pcd->name,
- i+1,
- tests[j].kind,
- type_to_string(type(car(arglist))));
- }
- }
- }
- if(!ok) {
- if(_Error_1(sc,msg,0)==sc->NIL) {
- return;
- }
- pcd=dispatch_table+sc->op;
+static int
+check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size)
+{
+ int ok = 1;
+ int n = list_length(sc, sc->args);
+
+ /* Check number of arguments */
+ if (n < pcd->min_arity) {
+ ok = 0;
+ snprintf(msg, msg_size, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity == pcd->max_arity ? "" : " at least",
+ pcd->min_arity);
+ }
+ if (ok && n>pcd->max_arity) {
+ ok = 0;
+ snprintf(msg, msg_size, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity == pcd->max_arity ? "" : " at most",
+ pcd->max_arity);
+ }
+ if (ok) {
+ if (pcd->arg_tests_encoding[0] != 0) {
+ int i = 0;
+ int j;
+ const char *t = pcd->arg_tests_encoding;
+ pointer arglist = sc->args;
+
+ do {
+ pointer arg = car(arglist);
+ j = (int)t[0];
+ if (j == TST_LIST[0]) {
+ if (arg != sc->NIL && !is_pair(arg)) break;
+ } else {
+ if (!tests[j].fct(arg)) break;
+ }
+
+ if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) {
+ /* last test is replicated as necessary */
+ t++;
+ }
+ arglist = cdr(arglist);
+ i++;
+ } while (i < n);
+
+ if (i < n) {
+ ok = 0;
+ snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s",
+ pcd->name,
+ i + 1,
+ tests[j].kind,
+ type_to_string(type(car(arglist))));
}
}
- ok_to_freely_gc(sc);
- if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
- return;
- }
- if(sc->no_memory) {
- fprintf(stderr,"No memory!\n");
- exit(1);
- }
}
+
+ return ok;
}
/* ========== Initialization of internal keywords ========== */
-static void assign_syntax(scheme *sc, char *name) {
- pointer x;
+/* Symbols representing syntax are tagged with (OP . '()). */
+static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) {
+ pointer x, y;
+ pointer *slot;
- x = oblist_add_by_name(sc, name);
- typeflag(x) |= T_SYNTAX;
+ x = oblist_find_by_name(sc, name, &slot);
+ assert (x == sc->NIL);
+
+ x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
+ typeflag(x) = T_SYMBOL | T_SYNTAX;
+ setimmutable(car(x));
+ y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL);
+ free_cell(sc, x);
+ setimmutable(get_tag(sc, y));
+ *slot = immutable_cons(sc, y, *slot);
+}
+
+/* Returns the opcode for the syntax represented by P. */
+static int syntaxnum(scheme *sc, pointer p) {
+ int op = ivalue_unchecked(car(get_tag(sc, p)));
+ assert (op < OP_MAXDEFINED);
+ return op;
}
-static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
+static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) {
pointer x, y;
x = mk_symbol(sc, name);
return y;
}
-/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
-static int syntaxnum(pointer p) {
- const char *s=strvalue(car(p));
- switch(strlength(car(p))) {
- case 2:
- if(s[0]=='i') return OP_IF0; /* if */
- else return OP_OR0; /* or */
- case 3:
- if(s[0]=='a') return OP_AND0; /* and */
- else return OP_LET0; /* let */
- case 4:
- switch(s[3]) {
- case 'e': return OP_CASE0; /* case */
- case 'd': return OP_COND0; /* cond */
- case '*': return OP_LET0AST; /* let* */
- default: return OP_SET0; /* set! */
- }
- case 5:
- switch(s[2]) {
- case 'g': return OP_BEGIN; /* begin */
- case 'l': return OP_DELAY; /* delay */
- case 'c': return OP_MACRO0; /* macro */
- default: return OP_QUOTE; /* quote */
- }
- case 6:
- switch(s[2]) {
- case 'm': return OP_LAMBDA; /* lambda */
- case 'f': return OP_DEF0; /* define */
- default: return OP_LET0REC; /* letrec */
- }
- default:
- return OP_C0STREAM; /* cons-stream */
- }
-}
-
/* initialization of TinyScheme */
#if USE_INTERFACE
INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
return immutable_cons(sc,a,b);
}
-static struct scheme_interface vtbl ={
+static const struct scheme_interface vtbl = {
scheme_define,
s_cons,
s_immutable_cons,
};
#endif
-scheme *scheme_init_new() {
+scheme *scheme_init_new(void) {
scheme *sc=(scheme*)malloc(sizeof(scheme));
if(!scheme_init(sc)) {
free(sc);
int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
pointer x;
- num_zero.is_fixnum=1;
- num_zero.value.ivalue=0;
- num_one.is_fixnum=1;
- num_one.value.ivalue=1;
-
#if USE_INTERFACE
sc->vptr=&vtbl;
#endif
sc->gensym_cnt=0;
sc->malloc=malloc;
sc->free=free;
- sc->last_cell_seg = -1;
sc->sink = &sc->_sink;
sc->NIL = &sc->_NIL;
sc->T = &sc->_HASHT;
sc->F = &sc->_HASHF;
sc->EOF_OBJ=&sc->_EOF_OBJ;
+
sc->free_cell = &sc->_NIL;
sc->fcells = 0;
sc->inhibit_gc = GC_ENABLED;
sc->reserved_cells = 0;
+#ifndef NDEBUG
sc->reserved_lineno = 0;
+#endif
sc->no_memory=0;
sc->inport=sc->NIL;
sc->outport=sc->NIL;
}
sc->strbuff_size = STRBUFFSIZE;
+ sc->cell_segments = NULL;
if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
sc->no_memory=1;
return 0;
dump_stack_initialize(sc);
sc->code = sc->NIL;
sc->tracing=0;
+ sc->flags = 0;
/* init sc->NIL */
typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
/* init sink */
typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
- car(sc->sink) = sc->NIL;
+ car(sc->sink) = cdr(sc->sink) = sc->NIL;
/* init c_nest */
sc->c_nest = sc->NIL;
x = mk_symbol(sc,"else");
new_slot_in_env(sc, x, sc->T);
- assign_syntax(sc, "lambda");
- assign_syntax(sc, "quote");
- assign_syntax(sc, "define");
- assign_syntax(sc, "if");
- assign_syntax(sc, "begin");
- assign_syntax(sc, "set!");
- assign_syntax(sc, "let");
- assign_syntax(sc, "let*");
- assign_syntax(sc, "letrec");
- assign_syntax(sc, "cond");
- assign_syntax(sc, "delay");
- assign_syntax(sc, "and");
- assign_syntax(sc, "or");
- assign_syntax(sc, "cons-stream");
- assign_syntax(sc, "macro");
- assign_syntax(sc, "case");
+ assign_syntax(sc, OP_LAMBDA, "lambda");
+ assign_syntax(sc, OP_QUOTE, "quote");
+ assign_syntax(sc, OP_DEF0, "define");
+ assign_syntax(sc, OP_IF0, "if");
+ assign_syntax(sc, OP_BEGIN, "begin");
+ assign_syntax(sc, OP_SET0, "set!");
+ assign_syntax(sc, OP_LET0, "let");
+ assign_syntax(sc, OP_LET0AST, "let*");
+ assign_syntax(sc, OP_LET0REC, "letrec");
+ assign_syntax(sc, OP_COND0, "cond");
+ assign_syntax(sc, OP_DELAY, "delay");
+ assign_syntax(sc, OP_AND0, "and");
+ assign_syntax(sc, OP_OR0, "or");
+ assign_syntax(sc, OP_C0STREAM, "cons-stream");
+ assign_syntax(sc, OP_MACRO0, "macro");
+ assign_syntax(sc, OP_CASE0, "case");
for(i=0; i<n; i++) {
- if(dispatch_table[i].name!=0) {
+ if (dispatch_table[i].name[0] != 0) {
assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
}
}
+ history_init(sc, 8, 8);
+
/* initialization of global pointers to special symbols */
sc->LAMBDA = mk_symbol(sc, "lambda");
sc->QUOTE = mk_symbol(sc, "quote");
}
void scheme_deinit(scheme *sc) {
+ struct cell_segment *s;
int i;
-#if SHOW_ERROR_LINE
- char *fname;
-#endif
-
sc->oblist=sc->NIL;
sc->global_env=sc->NIL;
dump_stack_free(sc);
sc->envir=sc->NIL;
sc->code=sc->NIL;
+ history_free(sc);
sc->args=sc->NIL;
sc->value=sc->NIL;
if(is_port(sc->inport)) {
typeflag(sc->loadport) = T_ATOM;
}
sc->loadport=sc->NIL;
+
+ for(i=0; i<=sc->file_i; i++) {
+ port_clear_location(sc, &sc->load_stack[i]);
+ }
+
sc->gc_verbose=0;
gc(sc,sc->NIL,sc->NIL);
- for(i=0; i<=sc->last_cell_seg; i++) {
- sc->free(sc->alloc_seg[i]);
+ for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) {
+ /* nop */
}
sc->free(sc->strbuff);
-
-#if SHOW_ERROR_LINE
- for(i=0; i<=sc->file_i; i++) {
- if (sc->load_stack[i].kind & port_file) {
- fname = sc->load_stack[i].rep.stdio.filename;
- if(fname)
- sc->free(fname);
- }
- }
-#endif
}
void scheme_load_file(scheme *sc, FILE *fin)
sc->interactive_repl=1;
}
-#if SHOW_ERROR_LINE
- sc->load_stack[0].rep.stdio.curr_line = 0;
- if(fin!=stdin && filename)
- sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
- else
- sc->load_stack[0].rep.stdio.filename = NULL;
-#endif
+ port_init_location(sc, &sc->load_stack[0],
+ (fin != stdin && filename)
+ ? mk_string(sc, filename)
+ : NULL);
sc->inport=sc->loadport;
sc->args = mk_integer(sc,sc->file_i);
sc->retcode=sc->nesting!=0;
}
-#if SHOW_ERROR_LINE
- sc->free(sc->load_stack[0].rep.stdio.filename);
- sc->load_stack[0].rep.stdio.filename = NULL;
-#endif
+ port_clear_location(sc, &sc->load_stack[0]);
}
void scheme_load_string(scheme *sc, const char *cmd) {
+ scheme_load_memory(sc, cmd, strlen(cmd), NULL);
+}
+
+void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) {
dump_stack_reset(sc);
sc->envir = sc->global_env;
sc->file_i=0;
sc->load_stack[0].kind=port_input|port_string;
- sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
- sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
- sc->load_stack[0].rep.string.curr=(char*)cmd;
+ sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */
+ sc->load_stack[0].rep.string.past_the_end = (char *) buf + len;
+ sc->load_stack[0].rep.string.curr = (char *) buf;
+ port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL);
sc->loadport=mk_port(sc,sc->load_stack);
sc->retcode=0;
sc->interactive_repl=0;
if(sc->retcode==0) {
sc->retcode=sc->nesting!=0;
}
+
+ port_clear_location(sc, &sc->load_stack[0]);
}
void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
pointer x;
-
- x=find_slot_in_env(sc,envir,symbol,0);
+ pointer *sslot;
+ x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot);
if (x != sc->NIL) {
set_slot_in_env(sc, x, value);
} else {
- new_slot_spec_in_env(sc, envir, symbol, value);
+ new_slot_spec_in_env(sc, symbol, value, sslot);
}
}
projects / platform / upstream / gpg2.git / blobdiff