/* * µscheme * * Copyright (C) 2015 Marc Alexander Lehmann * do as you want with this, attribution appreciated. * * Based opn tinyscheme-1.41 (original credits follow) * Dimitrios Souflis (dsouflis@acm.org) * Based on MiniScheme (original credits follow) * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp * (MINISCM) This version has been modified by R.C. Secrist. * (MINISCM) * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. * (MINISCM) * (MINISCM) This is a revised and modified version by Akira KIDA. * (MINISCM) current version is 0.85k4 (15 May 1994) * */ #define PAGE_SIZE 4096 /* does not work on sparc/alpha */ #include "malloc.c" #define SCHEME_SOURCE #include "scheme-private.h" #ifndef WIN32 # include #endif #if USE_MATH # include #endif #include "ecb.h" #include #include #include #if !USE_ERROR_CHECKING # define NDEBUG #endif #include #include #include #include #include #include //#include #if '1' != '0' + 1 \ || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ || 'f' != 'a' + 5 # error "execution character set digits not consecutive" #endif enum { TOK_EOF, TOK_LPAREN, TOK_RPAREN, TOK_DOT, TOK_ATOM, TOK_DOTATOM, /* atom name starting with '.' */ TOK_STRATOM, /* atom name enclosed in | */ TOK_QUOTE, TOK_DQUOTE, TOK_BQUOTE, TOK_COMMA, TOK_ATMARK, TOK_SHARP, TOK_SHARP_CONST, TOK_VEC }; #define BACKQUOTE '`' #define DELIMITERS "()\";\f\t\v\n\r " #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) #if !USE_MULTIPLICITY static scheme sc; #endif static void xbase (char *s, long n, int base) { if (n < 0) { *s++ = '-'; n = -n; } char *p = s; do { *p++ = '0' + n % base; n /= base; } while (n); *p-- = 0; while (p > s) { char x = *s; *s = *p; *p = x; --p; ++s; } } static void xnum (char *s, long n) { xbase (s, n, 10); } static void xwrstr (const char *s) { write (1, s, strlen (s)); } static void xwrnum (long n) { char buf[64]; xnum (buf, n); xwrstr (buf); } static char xtoupper (char c) { if (c >= 'a' && c <= 'z') c -= 'a' - 'A'; return c; } static char xtolower (char c) { if (c >= 'A' && c <= 'Z') c += 'a' - 'A'; return c; } static int xisdigit (char c) { return c >= '0' && c <= '9'; } #define toupper(c) xtoupper (c) #define tolower(c) xtolower (c) #define isdigit(c) xisdigit (c) #if USE_IGNORECASE static const char * xstrlwr (char *s) { const char *p = s; while (*s) { *s = tolower (*s); s++; } return p; } #define stricmp(a,b) strcasecmp (a, b) #define strlwr(s) xstrlwr (s) #else # define stricmp(a,b) strcmp (a, b) # define strlwr(s) (s) #endif #ifndef prompt # define prompt "ts> " #endif #ifndef InitFile # define InitFile "init.scm" #endif #ifndef FIRST_CELLSEGS # define FIRST_CELLSEGS 3 #endif enum scheme_types { T_INTEGER, T_REAL, T_STRING, T_SYMBOL, T_PROC, T_PAIR, /* also used for free cells */ T_CLOSURE, T_CONTINUATION, T_FOREIGN, T_CHARACTER, T_PORT, T_VECTOR, T_MACRO, T_PROMISE, T_ENVIRONMENT, /* one more... */ T_NUM_SYSTEM_TYPES }; #define T_MASKTYPE 0x000f #define T_SYNTAX 0x0010 #define T_IMMUTABLE 0x0020 #define T_ATOM 0x0040 /* only for gc */ #define T_MARK 0x0080 /* only for gc */ /* num, for generic arithmetic */ struct num { IVALUE ivalue; #if USE_REAL RVALUE rvalue; char is_fixnum; #endif }; #if USE_REAL # define num_is_fixnum(n) (n).is_fixnum # define num_set_fixnum(n,f) (n).is_fixnum = (f) # define num_ivalue(n) (n).ivalue # define num_rvalue(n) (n).rvalue # define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i) # define num_set_rvalue(n,r) (n).rvalue = (r) #else # define num_is_fixnum(n) 1 # define num_set_fixnum(n,f) 0 # define num_ivalue(n) (n).ivalue # define num_rvalue(n) (n).ivalue # define num_set_ivalue(n,i) (n).ivalue = (i) # define num_set_rvalue(n,r) (n).ivalue = (r) #endif enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV }; static num num_op (enum num_op op, num a, num b); static num num_intdiv (num a, num b); static num num_rem (num a, num b); static num num_mod (num a, num b); #if USE_MATH static double round_per_R5RS (double x); #endif static int is_zero_rvalue (RVALUE x); static num num_zero; static num num_one; /* macros for cell operations */ #define typeflag(p) ((p)->flag + 0) #define set_typeflag(p,v) ((p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) INTERFACE int is_string (pointer p) { return type (p) == T_STRING; } #define strvalue(p) ((p)->object.string.svalue) #define strlength(p) ((p)->object.string.length) INTERFACE int is_vector (pointer p) { return type (p) == T_VECTOR; } #define vecvalue(p) ((p)->object.vector.vvalue) #define veclength(p) ((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); INTERFACE int is_integer (pointer p) { return type (p) == T_INTEGER; } /* not the same as in scheme, where integers are (correctly :) reals */ INTERFACE int is_real (pointer p) { return type (p) == T_REAL; } INTERFACE int is_number (pointer p) { return is_integer (p) || is_real (p); } INTERFACE int is_character (pointer p) { return type (p) == T_CHARACTER; } INTERFACE char * string_value (pointer p) { return strvalue (p); } #define ivalue_unchecked(p) (p)->object.ivalue #define set_ivalue(p,v) (p)->object.ivalue = (v) #if USE_REAL #define rvalue_unchecked(p) (p)->object.rvalue #define set_rvalue(p,v) (p)->object.rvalue = (v) #else #define rvalue_unchecked(p) (p)->object.ivalue #define set_rvalue(p,v) (p)->object.ivalue = (v) #endif INTERFACE long charvalue (pointer p) { return ivalue_unchecked (p); } INTERFACE int is_port (pointer p) { return type (p) == T_PORT; } INTERFACE int is_inport (pointer p) { return is_port (p) && p->object.port->kind & port_input; } INTERFACE int is_outport (pointer p) { return is_port (p) && p->object.port->kind & port_output; } INTERFACE int is_pair (pointer p) { return type (p) == T_PAIR; } #define car(p) ((p)->object.cons.car + 0) #define cdr(p) ((p)->object.cons.cdr + 0) static pointer caar (pointer p) { return car (car (p)); } static pointer cadr (pointer p) { return car (cdr (p)); } static pointer cdar (pointer p) { return cdr (car (p)); } static pointer cddr (pointer p) { return cdr (cdr (p)); } static pointer cadar (pointer p) { return car (cdr (car (p))); } static pointer caddr (pointer p) { return car (cdr (cdr (p))); } static pointer cdaar (pointer p) { return cdr (car (car (p))); } INTERFACE void set_car (pointer p, pointer q) { p->object.cons.car = q; } INTERFACE void set_cdr (pointer p, pointer q) { p->object.cons.cdr = q; } INTERFACE pointer pair_car (pointer p) { return car (p); } INTERFACE pointer pair_cdr (pointer p) { return cdr (p); } INTERFACE int is_symbol (pointer p) { return type (p) == T_SYMBOL; } INTERFACE char * symname (pointer p) { return strvalue (car (p)); } #if USE_PLIST SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; } # define symprop(p) cdr(p) #endif INTERFACE int is_syntax (pointer p) { return typeflag (p) & T_SYNTAX; } INTERFACE int is_proc (pointer p) { return type (p) == T_PROC; } INTERFACE int is_foreign (pointer p) { return type (p) == T_FOREIGN; } INTERFACE char * syntaxname (pointer p) { return strvalue (car (p)); } #define procnum(p) ivalue_unchecked (p) static const char *procname (pointer x); INTERFACE int is_closure (pointer p) { return type (p) == T_CLOSURE; } INTERFACE int is_macro (pointer p) { return type (p) == T_MACRO; } INTERFACE pointer closure_code (pointer p) { return car (p); } INTERFACE pointer closure_env (pointer p) { return cdr (p); } INTERFACE int is_continuation (pointer p) { return type (p) == T_CONTINUATION; } #define cont_dump(p) cdr (p) #define set_cont_dump(p,v) set_cdr ((p), (v)) /* To do: promise should be forced ONCE only */ INTERFACE int is_promise (pointer p) { return type (p) == T_PROMISE; } INTERFACE int is_environment (pointer p) { return type (p) == T_ENVIRONMENT; } #define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) #define is_atom(p) (typeflag (p) & T_ATOM) #define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) #define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) #define is_mark(p) (typeflag (p) & T_MARK) #define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) #define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) INTERFACE int is_immutable (pointer p) { return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; } INTERFACE void setimmutable (pointer p) { #if USE_ERROR_CHECKING set_typeflag (p, typeflag (p) | T_IMMUTABLE); #endif } /* Result is: proper list: length circular list: -1 not even a pair: -2 dotted list: -2 minus length before dot */ INTERFACE int list_length (SCHEME_P_ pointer a) { int i = 0; pointer slow, fast; slow = fast = a; while (1) { if (fast == NIL) return i; if (!is_pair (fast)) return -2 - i; fast = cdr (fast); ++i; if (fast == 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; } } } INTERFACE int is_list (SCHEME_P_ pointer a) { return list_length (SCHEME_A_ a) >= 0; } #if USE_CHAR_CLASSIFIERS ecb_inline int Cisalpha (int c) { return isascii (c) && isalpha (c); } ecb_inline int Cisdigit (int c) { return isascii (c) && isdigit (c); } ecb_inline int Cisspace (int c) { return isascii (c) && isspace (c); } ecb_inline int Cisupper (int c) { return isascii (c) && isupper (c); } ecb_inline int Cislower (int c) { return isascii (c) && islower (c); } #endif #if USE_ASCII_NAMES static const char *charnames[32] = { "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", "bs", "ht", "lf", "vt", "ff", "cr", "so", "si", "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", "can", "em", "sub", "esc", "fs", "gs", "rs", "us" }; static int is_ascii_name (const char *name, int *pc) { int i; for (i = 0; i < 32; i++) { if (stricmp (name, charnames[i]) == 0) { *pc = i; return 1; } } if (stricmp (name, "del") == 0) { *pc = 127; return 1; } return 0; } #endif static int file_push (SCHEME_P_ const char *fname); 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); 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); static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); static pointer mk_number (SCHEME_P_ const num n); static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); static pointer mk_vector (SCHEME_P_ uint32_t len); static pointer mk_atom (SCHEME_P_ char *q); static pointer mk_sharp_const (SCHEME_P_ char *name); #if USE_PORTS static pointer mk_port (SCHEME_P_ port *p); static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); static pointer port_from_file (SCHEME_P_ int, int prop); static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop); static port *port_rep_from_file (SCHEME_P_ int, int prop); static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); static void port_close (SCHEME_P_ pointer p, int flag); #endif static void mark (pointer a); static void gc (SCHEME_P_ pointer a, pointer b); static int basic_inchar (port *pt); static int inchar (SCHEME_P); static void backchar (SCHEME_P_ int c); static char *readstr_upto (SCHEME_P_ int skip, const char *delim); static pointer readstrexp (SCHEME_P_ char delim); ecb_inline int skipspace (SCHEME_P); static int token (SCHEME_P); static void printslashstring (SCHEME_P_ char *s, int len); static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); static void printatom (SCHEME_P_ pointer l, int f); static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); static pointer mk_closure (SCHEME_P_ pointer c, pointer e); static pointer mk_continuation (SCHEME_P_ pointer d); static pointer reverse (SCHEME_P_ pointer a); static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list); static pointer revappend (SCHEME_P_ pointer a, pointer b); static pointer ss_get_cont (SCHEME_P); static void ss_set_cont (SCHEME_P_ pointer cont); static void dump_stack_mark (SCHEME_P); static int opexe_0 (SCHEME_P_ enum scheme_opcodes op); static int opexe_1 (SCHEME_P_ enum scheme_opcodes op); static int opexe_2 (SCHEME_P_ enum scheme_opcodes op); static int opexe_3 (SCHEME_P_ enum scheme_opcodes op); static int opexe_4 (SCHEME_P_ enum scheme_opcodes op); static int opexe_5 (SCHEME_P_ enum scheme_opcodes op); static int opexe_6 (SCHEME_P_ enum scheme_opcodes op); static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); static void assign_syntax (SCHEME_P_ const char *name); static int syntaxnum (pointer p); static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); static IVALUE ivalue (pointer x) { return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); } static RVALUE rvalue (pointer x) { return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x); } INTERFACE num nvalue (pointer x) { num n; num_set_fixnum (n, is_integer (x)); if (num_is_fixnum (n)) num_set_ivalue (n, ivalue_unchecked (x)); else num_set_rvalue (n, rvalue_unchecked (x)); return n; } static num num_op (enum num_op op, num a, num b) { num ret; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); if (num_is_fixnum (ret)) { switch (op) { case NUM_ADD: a.ivalue += b.ivalue; break; case NUM_SUB: a.ivalue -= b.ivalue; break; case NUM_MUL: a.ivalue *= b.ivalue; break; case NUM_INTDIV: a.ivalue /= b.ivalue; break; } num_set_ivalue (ret, a.ivalue); } #if USE_REAL else { switch (op) { case NUM_ADD: a.rvalue += b.rvalue; break; case NUM_SUB: a.rvalue -= b.rvalue; break; case NUM_MUL: a.rvalue *= b.rvalue; break; case NUM_INTDIV: a.rvalue /= b.rvalue; break; } num_set_rvalue (ret, a.rvalue); } #endif return ret; } static num num_div (num a, num b) { num ret; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0); if (num_is_fixnum (ret)) num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b)); else num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b)); return ret; } static num num_rem (num a, num b) { num ret; long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); e1 = num_ivalue (a); e2 = num_ivalue (b); res = e1 % e2; /* remainder should have same sign as second operand */ if (res > 0) { if (e1 < 0) res -= labs (e2); } else if (res < 0) { if (e1 > 0) res += labs (e2); } num_set_ivalue (ret, res); return ret; } static num num_mod (num a, num b) { num ret; long e1, e2, res; num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); e1 = num_ivalue (a); e2 = num_ivalue (b); res = e1 % e2; /* modulo should have same sign as second operand */ if (res * e2 < 0) res += e2; num_set_ivalue (ret, res); return ret; } /* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */ static int num_cmp (num a, num b) { int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b); int ret; if (is_fixnum) { IVALUE av = num_ivalue (a); IVALUE bv = num_ivalue (b); ret = av == bv ? 0 : av < bv ? -1 : +1; } else { RVALUE av = num_rvalue (a); RVALUE bv = num_rvalue (b); ret = av == bv ? 0 : av < bv ? -1 : +1; } return ret; } #if USE_MATH /* Round to nearest. Round to even if midway */ static double round_per_R5RS (double x) { double fl = floor (x); double ce = ceil (x); double dfl = x - fl; double dce = ce - x; if (dfl > dce) return ce; else if (dfl < dce) return fl; else { if (fmod (fl, 2) == 0) /* I imagine this holds */ return fl; else return ce; } } #endif static int is_zero_rvalue (RVALUE x) { return x == 0; #if 0 #if USE_REAL return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ #else return x == 0; #endif #endif } /* allocate new cell segment */ static int alloc_cellseg (SCHEME_P_ int n) { pointer newp; pointer last; pointer p; char *cp; long i; int k; 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)); if (!cp && USE_ERROR_CHECKING) return k; 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; 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; } return n; } /* get new cell. parameter a, b is marked by gc. */ ecb_inline pointer get_cell_x (SCHEME_P_ pointer a, pointer b) { if (ecb_expect_false (SCHEME_V->free_cell == NIL)) { if (SCHEME_V->no_memory && USE_ERROR_CHECKING) return S_SINK; 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; 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 USE_ERROR_CHECKING SCHEME_V->no_memory = 1; return S_SINK; #endif } } } } { pointer x = SCHEME_V->free_cell; SCHEME_V->free_cell = cdr (x); --SCHEME_V->fcells; return x; } } /* To retain recent allocs before interpreter knows about them - Tehom */ static void push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) { pointer holder = get_cell_x (SCHEME_A_ recent, extra); set_typeflag (holder, T_PAIR); setimmutable (holder); set_car (holder, recent); set_cdr (holder, car (S_SINK)); set_car (S_SINK, holder); } static pointer get_cell (SCHEME_P_ pointer a, pointer b) { pointer cell = get_cell_x (SCHEME_A_ a, b); /* For right now, include "a" and "b" in "cell" so that gc doesn't think they are garbage. */ /* Tentatively record it as a pair so gc understands it. */ set_typeflag (cell, T_PAIR); set_car (cell, a); set_cdr (cell, b); push_recent_alloc (SCHEME_A_ cell, NIL); return cell; } static pointer get_vector_object (SCHEME_P_ uint32_t len, pointer init) { pointer v = get_cell_x (SCHEME_A_ 0, 0); pointer *e = malloc (len * sizeof (pointer)); if (!e && USE_ERROR_CHECKING) return S_SINK; /* 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; fill_vector (v, 0, init); push_recent_alloc (SCHEME_A_ v, NIL); return v; } ecb_inline void ok_to_freely_gc (SCHEME_P) { set_car (S_SINK, NIL); } #if defined TSGRIND static void check_cell_alloced (pointer p, int expect_alloced) { /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ if (typeflag (p) & !expect_alloced) xwrstr ("Cell is already allocated!\n"); if (!(typeflag (p)) & expect_alloced) xwrstr ("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++) check_cell_alloced (p + i, expect_alloced); } #endif /* Medium level cell allocation */ /* get new cons cell */ pointer xcons (SCHEME_P_ pointer a, pointer b, int immutable) { pointer x = get_cell (SCHEME_A_ a, b); set_typeflag (x, T_PAIR); if (immutable) setimmutable (x); set_car (x, a); set_cdr (x, b); return x; } /* ========== oblist implementation ========== */ static pointer generate_symbol (SCHEME_P_ const char *name) { pointer x = mk_string (SCHEME_A_ name); setimmutable (x); x = immutable_cons (x, NIL); set_typeflag (x, T_SYMBOL); return x; } #ifndef USE_OBJECT_LIST static int hash_fn (const char *key, int table_size) { const unsigned char *p = key; uint32_t hash = 2166136261; while (*p) hash = (hash ^ *p++) * 16777619; return hash % table_size; } static pointer oblist_initial_value (SCHEME_P) { return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ } /* returns the new symbol */ static pointer oblist_add_by_name (SCHEME_P_ const char *name) { pointer x = generate_symbol (SCHEME_A_ name); int location = hash_fn (name, veclength (SCHEME_V->oblist)); vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); return x; } ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { int location; pointer x; char *s; location = hash_fn (name, veclength (SCHEME_V->oblist)); for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) { s = symname (car (x)); /* case-insensitive, per R5RS section 2 */ if (stricmp (name, s) == 0) return car (x); } return NIL; } static pointer oblist_all_symbols (SCHEME_P) { int i; pointer x; pointer ob_list = NIL; for (i = 0; i < veclength (SCHEME_V->oblist); i++) for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) ob_list = cons (x, ob_list); return ob_list; } #else static pointer oblist_initial_value (SCHEME_P) { return NIL; } ecb_inline pointer oblist_find_by_name (SCHEME_P_ const char *name) { pointer x; char *s; for (x = SCHEME_V->oblist; x != NIL; x = cdr (x)) { s = symname (car (x)); /* case-insensitive, per R5RS section 2 */ if (stricmp (name, s) == 0) return car (x); } return NIL; } /* returns the new symbol */ 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); SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); return x; } static pointer oblist_all_symbols (SCHEME_P) { return SCHEME_V->oblist; } #endif #if USE_PORTS static pointer mk_port (SCHEME_P_ port *p) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_PORT | T_ATOM); x->object.port = p; return x; } #endif pointer mk_foreign_func (SCHEME_P_ foreign_func f) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, (T_FOREIGN | T_ATOM)); x->object.ff = f; return x; } INTERFACE pointer mk_character (SCHEME_P_ int c) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, (T_CHARACTER | T_ATOM)); set_ivalue (x, c & 0xff); return x; } /* get number atom (integer) */ INTERFACE pointer mk_integer (SCHEME_P_ long n) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, (T_INTEGER | T_ATOM)); set_ivalue (x, n); return x; } INTERFACE pointer mk_real (SCHEME_P_ RVALUE n) { #if USE_REAL pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, (T_REAL | T_ATOM)); set_rvalue (x, n); return x; #else return mk_integer (SCHEME_A_ n); #endif } static pointer mk_number (SCHEME_P_ const num n) { #if USE_REAL return num_is_fixnum (n) ? mk_integer (SCHEME_A_ num_ivalue (n)) : mk_real (SCHEME_A_ num_rvalue (n)); #else return mk_integer (SCHEME_A_ num_ivalue (n)); #endif } /* allocate name to string area */ static char * store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill) { char *q = malloc (len_str + 1); if (q == 0 && USE_ERROR_CHECKING) { SCHEME_V->no_memory = 1; return SCHEME_V->strbuff; } if (str) memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */ else memset (q, fill, len_str); q[len_str] = 0; return q; } INTERFACE pointer mk_empty_string (SCHEME_P_ uint32_t len, char fill) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, 0, fill); strlength (x) = len; return x; } INTERFACE pointer mk_counted_string (SCHEME_P_ const char *str, uint32_t len) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_STRING | T_ATOM); strvalue (x) = store_string (SCHEME_A_ len, str, 0); strlength (x) = len; return x; } INTERFACE pointer mk_string (SCHEME_P_ const char *str) { return mk_counted_string (SCHEME_A_ str, strlen (str)); } INTERFACE pointer mk_vector (SCHEME_P_ uint32_t len) { return get_vector_object (SCHEME_A_ len, NIL); } INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj) { int i; for (i = start; i < veclength (vec); i++) vecvalue (vec)[i] = obj; } INTERFACE pointer vector_get (pointer vec, uint32_t ielem) { return vecvalue(vec)[ielem]; } INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a) { vecvalue(vec)[ielem] = a; } /* get new symbol */ INTERFACE pointer mk_symbol (SCHEME_P_ const char *name) { /* first check oblist */ pointer x = oblist_find_by_name (SCHEME_A_ name); if (x == NIL) x = oblist_add_by_name (SCHEME_A_ name); return x; } INTERFACE pointer gensym (SCHEME_P) { pointer x; char name[40] = "gensym-"; xnum (name + 7, SCHEME_V->gensym_cnt); return generate_symbol (SCHEME_A_ name); } /* make symbol or number atom from string */ static pointer mk_atom (SCHEME_P_ char *q) { char c, *p; int has_dec_point = 0; int has_fp_exp = 0; #if USE_COLON_HOOK if ((p = strstr (q, "::")) != 0) { *p = 0; return cons (SCHEME_V->COLON_HOOK, cons (cons (SCHEME_V->QUOTE, cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); } #endif p = q; c = *p++; if ((c == '+') || (c == '-')) { c = *p++; if (c == '.') { has_dec_point = 1; c = *p++; } if (!isdigit (c)) return mk_symbol (SCHEME_A_ strlwr (q)); } else if (c == '.') { has_dec_point = 1; c = *p++; if (!isdigit (c)) return mk_symbol (SCHEME_A_ strlwr (q)); } else if (!isdigit (c)) return mk_symbol (SCHEME_A_ strlwr (q)); for (; (c = *p) != 0; ++p) { if (!isdigit (c)) { if (c == '.') { if (!has_dec_point) { has_dec_point = 1; continue; } } else if ((c == 'e') || (c == 'E')) { if (!has_fp_exp) { has_dec_point = 1; /* decimal point illegal from now on */ p++; if ((*p == '-') || (*p == '+') || isdigit (*p)) continue; } } return mk_symbol (SCHEME_A_ strlwr (q)); } } #if USE_REAL if (has_dec_point) return mk_real (SCHEME_A_ atof (q)); #endif return mk_integer (SCHEME_A_ strtol (q, 0, 10)); } /* make constant */ static pointer mk_sharp_const (SCHEME_P_ char *name) { if (!strcmp (name, "t")) return S_T; else if (!strcmp (name, "f")) return S_F; else if (*name == '\\') /* #\w (character) */ { int c; if (stricmp (name + 1, "space") == 0) c = ' '; else if (stricmp (name + 1, "newline") == 0) c = '\n'; else if (stricmp (name + 1, "return") == 0) c = '\r'; else if (stricmp (name + 1, "tab") == 0) c = '\t'; else if (name[1] == 'x' && name[2] != 0) { long c1 = strtol (name + 2, 0, 16); if (0 <= c1 && c1 <= UCHAR_MAX) c = c1; else return NIL; } #if USE_ASCII_NAMES else if (is_ascii_name (name + 1, &c)) /* nothing */; #endif else if (name[2] == 0) c = name[1]; else return NIL; return mk_character (SCHEME_A_ c); } else { /* identify base by string index */ const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x"; char *base = strchr (baseidx, *name); if (base) return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx)); return NIL; } } /* ========== garbage collector ========== */ /*-- * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, * for marking. * * The exception is vectors - vectors are currently marked recursively, * which is inherited form tinyscheme and could be fixed by having another * word of context in the vector */ static void mark (pointer a) { pointer t, q, p; t = 0; p = a; E2: setmark (p); if (ecb_expect_false (is_vector (p))) { int i; for (i = 0; i < veclength (p); i++) mark (vecvalue (p)[i]); } if (is_atom (p)) goto E6; /* E4: down car */ q = car (p); if (q && !is_mark (q)) { setatom (p); /* a note that we have moved car */ set_car (p, t); t = p; p = q; goto E2; } E5: q = cdr (p); /* down cdr */ if (q && !is_mark (q)) { set_cdr (p, t); t = p; p = q; goto E2; } E6: /* up. Undo the link switching from steps E4 and E5. */ if (!t) return; q = t; if (is_atom (q)) { clratom (q); t = car (q); set_car (q, p); p = q; goto E5; } else { t = cdr (q); set_cdr (q, p); p = q; goto E6; } } /* garbage collection. parameter a, b is marked. */ static void gc (SCHEME_P_ pointer a, pointer b) { pointer p; int i; if (SCHEME_V->gc_verbose) putstr (SCHEME_A_ "gc..."); /* mark system globals */ mark (SCHEME_V->oblist); mark (SCHEME_V->global_env); /* mark current registers */ mark (SCHEME_V->args); mark (SCHEME_V->envir); mark (SCHEME_V->code); dump_stack_mark (SCHEME_A); mark (SCHEME_V->value); mark (SCHEME_V->inport); mark (SCHEME_V->save_inport); mark (SCHEME_V->outport); mark (SCHEME_V->loadport); /* Mark recent objects the interpreter doesn't know about yet. */ mark (car (S_SINK)); /* Mark any older stuff above nested C calls */ mark (SCHEME_V->c_nest); /* mark variables a, b */ mark (a); mark (b); /* garbage collect */ clrmark (NIL); 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. */ for (i = SCHEME_V->last_cell_seg; i >= 0; i--) { p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; while (--p >= SCHEME_V->cell_seg[i]) { if (is_mark (p)) clrmark (p); else { /* reclaim cell */ if (typeflag (p) != T_PAIR) { finalize_cell (SCHEME_A_ p); set_typeflag (p, T_PAIR); set_car (p, NIL); } ++SCHEME_V->fcells; set_cdr (p, SCHEME_V->free_cell); SCHEME_V->free_cell = p; } } } if (SCHEME_V->gc_verbose) { xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); } } static void finalize_cell (SCHEME_P_ pointer a) { /* TODO, fast bitmap check? */ if (is_string (a)) free (strvalue (a)); else if (is_vector (a)) free (vecvalue (a)); #if USE_PORTS else if (is_port (a)) { if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) port_close (SCHEME_A_ a, port_input | port_output); free (a->object.port); } #endif } /* ========== Routines for Reading ========== */ static int file_push (SCHEME_P_ const char *fname) { #if USE_PORTS int fin; if (SCHEME_V->file_i == MAXFIL - 1) return 0; fin = open (fname, O_RDONLY); if (fin >= 0) { SCHEME_V->file_i++; SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 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; #if SHOW_ERROR_LINE SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; if (fname) SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); #endif } return fin >= 0; #else return 1; #endif } static void file_pop (SCHEME_P) { if (SCHEME_V->file_i != 0) { SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; #if USE_PORTS 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; } } static int file_interactive (SCHEME_P) { #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); #else return 0; #endif } #if USE_PORTS static port * port_rep_from_filename (SCHEME_P_ const char *fn, int prop) { int fd; int flags; char *rw; port *pt; if (prop == (port_input | port_output)) flags = O_RDWR | O_APPEND | O_CREAT; else if (prop == port_output) flags = O_WRONLY | O_TRUNC | O_CREAT; else flags = O_RDONLY; fd = open (fn, flags, 0666); if (fd < 0) return 0; pt = port_rep_from_file (SCHEME_A_ fd, prop); pt->rep.stdio.closeit = 1; # if SHOW_ERROR_LINE if (fn) pt->rep.stdio.filename = store_string (SCHEME_A_ strlen (fn), fn, 0); pt->rep.stdio.curr_line = 0; # endif return pt; } static pointer port_from_filename (SCHEME_P_ const char *fn, int prop) { port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); if (!pt && USE_ERROR_CHECKING) return NIL; return mk_port (SCHEME_A_ pt); } static port * port_rep_from_file (SCHEME_P_ int f, int prop) { port *pt = malloc (sizeof *pt); if (!pt && USE_ERROR_CHECKING) return NULL; pt->unget = -1; pt->kind = port_file | prop; pt->rep.stdio.file = f; pt->rep.stdio.closeit = 0; return pt; } static pointer port_from_file (SCHEME_P_ int f, int prop) { port *pt = port_rep_from_file (SCHEME_A_ f, prop); if (!pt && USE_ERROR_CHECKING) return NIL; return mk_port (SCHEME_A_ pt); } static port * port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) { port *pt = malloc (sizeof (port)); if (!pt && USE_ERROR_CHECKING) return 0; pt->unget = -1; pt->kind = port_string | prop; pt->rep.string.start = start; pt->rep.string.curr = start; pt->rep.string.past_the_end = past_the_end; return pt; } static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) { port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); if (!pt && USE_ERROR_CHECKING) return NIL; return mk_port (SCHEME_A_ pt); } # define BLOCK_SIZE 256 static port * port_rep_from_scratch (SCHEME_P) { char *start; port *pt = malloc (sizeof (port)); if (!pt && USE_ERROR_CHECKING) return 0; start = malloc (BLOCK_SIZE); if (start == 0) return 0; memset (start, ' ', BLOCK_SIZE - 1); start[BLOCK_SIZE - 1] = '\0'; pt->unget = -1; pt->kind = port_string | port_output | port_srfi6; pt->rep.string.start = start; pt->rep.string.curr = start; pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; return pt; } static pointer port_from_scratch (SCHEME_P) { port *pt = port_rep_from_scratch (SCHEME_A); if (!pt && USE_ERROR_CHECKING) return NIL; return mk_port (SCHEME_A_ pt); } static void port_close (SCHEME_P_ pointer p, int flag) { port *pt = p->object.port; pt->kind &= ~flag; if ((pt->kind & (port_input | port_output)) == 0) { 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) free (pt->rep.stdio.filename); # endif close (pt->rep.stdio.file); } pt->kind = port_free; } } #endif /* get new character from input file */ static int inchar (SCHEME_P) { int c; port *pt; pt = SCHEME_V->inport->object.port; if (pt->kind & port_saw_EOF) return EOF; c = basic_inchar (pt); if (c == EOF && SCHEME_V->inport == SCHEME_V->loadport) { /* Instead, set port_saw_EOF */ pt->kind |= port_saw_EOF; /* file_pop(SCHEME_A); */ return EOF; /* NOTREACHED */ } return c; } static int ungot = -1; static int basic_inchar (port *pt) { #if USE_PORTS if (pt->unget != -1) { int r = pt->unget; pt->unget = -1; return r; } if (pt->kind & port_file) { char c; if (!read (pt->rep.stdio.file, &c, 1)) return EOF; return c; } else { if (*pt->rep.string.curr == 0 || pt->rep.string.curr == pt->rep.string.past_the_end) return EOF; else return *pt->rep.string.curr++; } #else if (ungot == -1) { char c; if (!read (0, &c, 1)) return EOF; ungot = c; } { int r = ungot; ungot = -1; return r; } #endif } /* back character to input buffer */ static void backchar (SCHEME_P_ int c) { #if USE_PORTS port *pt; if (c == EOF) return; pt = SCHEME_V->inport->object.port; pt->unget = c; #else if (c == EOF) return; ungot = c; #endif } #if USE_PORTS static int realloc_port_string (SCHEME_P_ port *p) { char *start = p->rep.string.start; size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; char *str = malloc (new_size); if (str) { memset (str, ' ', new_size - 1); str[new_size - 1] = '\0'; strcpy (str, start); p->rep.string.start = str; p->rep.string.past_the_end = str + new_size - 1; p->rep.string.curr -= start - str; free (start); return 1; } else return 0; } #endif INTERFACE void putstr (SCHEME_P_ const char *s) { #if USE_PORTS port *pt = SCHEME_V->outport->object.port; if (pt->kind & port_file) write (pt->rep.stdio.file, s, strlen (s)); else for (; *s; s++) if (pt->rep.string.curr != pt->rep.string.past_the_end) *pt->rep.string.curr++ = *s; else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) *pt->rep.string.curr++ = *s; #else xwrstr (s); #endif } static void putchars (SCHEME_P_ const char *s, int len) { #if USE_PORTS port *pt = SCHEME_V->outport->object.port; if (pt->kind & port_file) write (pt->rep.stdio.file, s, len); else { for (; len; len--) { if (pt->rep.string.curr != pt->rep.string.past_the_end) *pt->rep.string.curr++ = *s++; else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) *pt->rep.string.curr++ = *s++; } } #else write (1, s, len); #endif } INTERFACE void putcharacter (SCHEME_P_ int c) { #if USE_PORTS port *pt = SCHEME_V->outport->object.port; if (pt->kind & port_file) { char cc = c; write (pt->rep.stdio.file, &cc, 1); } else { if (pt->rep.string.curr != pt->rep.string.past_the_end) *pt->rep.string.curr++ = c; else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) *pt->rep.string.curr++ = c; } #else char cc = c; write (1, &c, 1); #endif } /* read characters up to delimiter, but cater to character constants */ static char * readstr_upto (SCHEME_P_ int skip, const char *delim) { char *p = SCHEME_V->strbuff + skip; while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') *p = 0; else { backchar (SCHEME_A_ p[-1]); *--p = '\0'; } return SCHEME_V->strbuff; } /* read string expression "xxx...xxx" */ static pointer readstrexp (SCHEME_P_ char delim) { char *p = SCHEME_V->strbuff; int c; int c1 = 0; enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; for (;;) { c = inchar (SCHEME_A); if (c == EOF || p - SCHEME_V->strbuff > sizeof (SCHEME_V->strbuff) - 1) return S_F; switch (state) { case st_ok: if (ecb_expect_false (c == delim)) return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); if (ecb_expect_false (c == '\\')) state = st_bsl; else *p++ = c; break; case st_bsl: switch (c) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': state = st_oct1; c1 = c - '0'; break; case 'x': case 'X': state = st_x1; c1 = 0; break; case 'n': *p++ = '\n'; state = st_ok; break; case 't': *p++ = '\t'; state = st_ok; break; case 'r': *p++ = '\r'; state = st_ok; break; default: *p++ = c; state = st_ok; break; } break; case st_x1: case st_x2: c = tolower (c); if (c >= '0' && c <= '9') c1 = (c1 << 4) + c - '0'; else if (c >= 'a' && c <= 'f') c1 = (c1 << 4) + c - 'a' + 10; else return S_F; if (state == st_x1) state = st_x2; else { *p++ = c1; state = st_ok; } break; case st_oct1: case st_oct2: if (c < '0' || c > '7') { *p++ = c1; backchar (SCHEME_A_ c); state = st_ok; } else { if (state == st_oct2 && c1 >= ' ') return S_F; c1 = (c1 << 3) + (c - '0'); if (state == st_oct1) state = st_oct2; else { *p++ = c1; state = st_ok; } } break; } } } /* check c is in chars */ ecb_inline int is_one_of (const char *s, int c) { if (c == EOF) return 1; return !!strchr (s, c); } /* skip white characters */ ecb_inline int skipspace (SCHEME_P) { int c, curr_line = 0; do { c = inchar (SCHEME_A); #if SHOW_ERROR_LINE if (c == '\n') curr_line++; #endif } while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); /* record it */ #if SHOW_ERROR_LINE if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; #endif if (c != EOF) { backchar (SCHEME_A_ c); return 1; } else return EOF; } /* get token */ static int token (SCHEME_P) { int c = skipspace (SCHEME_A); if (c == EOF) return TOK_EOF; switch ((c = inchar (SCHEME_A))) { case EOF: return TOK_EOF; case '(': return TOK_LPAREN; case ')': return TOK_RPAREN; case '.': c = inchar (SCHEME_A); if (is_one_of (" \n\t", c)) return TOK_DOT; else { backchar (SCHEME_A_ c); return TOK_DOTATOM; } case '|': return TOK_STRATOM; case '\'': return TOK_QUOTE; case ';': while ((c = inchar (SCHEME_A)) != '\n' && c != EOF) ; #if SHOW_ERROR_LINE if (c == '\n' && SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++; #endif if (c == EOF) return TOK_EOF; else return token (SCHEME_A); case '"': return TOK_DQUOTE; case BACKQUOTE: return TOK_BQUOTE; case ',': if ((c = inchar (SCHEME_A)) == '@') return TOK_ATMARK; else { backchar (SCHEME_A_ c); return TOK_COMMA; } case '#': c = inchar (SCHEME_A); if (c == '(') return TOK_VEC; else if (c == '!') { while ((c = inchar (SCHEME_A)) != '\n' && c != EOF) ; #if SHOW_ERROR_LINE if (c == '\n' && SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++; #endif if (c == EOF) return TOK_EOF; else return token (SCHEME_A); } else { backchar (SCHEME_A_ c); if (is_one_of (" tfodxb\\", c)) return TOK_SHARP_CONST; else return TOK_SHARP; } default: backchar (SCHEME_A_ c); return TOK_ATOM; } } /* ========== Routines for Printing ========== */ #define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) static void printslashstring (SCHEME_P_ char *p, int len) { int i; unsigned char *s = (unsigned char *) p; putcharacter (SCHEME_A_ '"'); for (i = 0; i < len; i++) { if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\') { putcharacter (SCHEME_A_ '\\'); switch (*s) { case '"': putcharacter (SCHEME_A_ '"'); break; case '\n': putcharacter (SCHEME_A_ 'n'); break; case '\t': putcharacter (SCHEME_A_ 't'); break; case '\r': putcharacter (SCHEME_A_ 'r'); break; case '\\': putcharacter (SCHEME_A_ '\\'); break; default: { int d = *s / 16; putcharacter (SCHEME_A_ 'x'); if (d < 10) putcharacter (SCHEME_A_ d + '0'); else putcharacter (SCHEME_A_ d - 10 + 'A'); d = *s % 16; if (d < 10) putcharacter (SCHEME_A_ d + '0'); else putcharacter (SCHEME_A_ d - 10 + 'A'); } } } else putcharacter (SCHEME_A_ * s); s++; } putcharacter (SCHEME_A_ '"'); } /* print atoms */ static void printatom (SCHEME_P_ pointer l, int f) { char *p; int len; atom2str (SCHEME_A_ l, f, &p, &len); putchars (SCHEME_A_ p, len); } /* Uses internal buffer unless string pointer is already available */ static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) { char *p; if (l == NIL) p = "()"; else if (l == S_T) p = "#t"; else if (l == S_F) p = "#f"; else if (l == S_EOF) p = "#"; else if (is_port (l)) p = "#"; else if (is_number (l)) { p = SCHEME_V->strbuff; if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { if (is_integer (l)) xnum (p, ivalue_unchecked (l)); #if USE_REAL else { snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); /* r5rs says there must be a '.' (unless 'e'?) */ f = strcspn (p, ".e"); if (p[f] == 0) { p[f] = '.'; /* not found, so add '.0' at the end */ p[f + 1] = '0'; p[f + 2] = 0; } } #endif } else { long v = ivalue (l); if (f == 16) xbase (p, v, 16); else if (f == 8) xbase (p, v, 8); else if (f == 2) { unsigned long b = (v < 0) ? -v : v; p = &p[STRBUFFSIZE - 1]; *p = 0; do { *--p = (b & 1) ? '1' : '0'; b >>= 1; } while (b != 0); if (v < 0) *--p = '-'; } } } else if (is_string (l)) { if (!f) p = strvalue (l); else /* Hack, uses the fact that printing is needed */ { *pp = SCHEME_V->strbuff; *plen = 0; printslashstring (SCHEME_A_ strvalue (l), strlength (l)); return; } } else if (is_character (l)) { int c = charvalue (l); p = SCHEME_V->strbuff; if (!f) { p[0] = c; p[1] = 0; } else { switch (c) { case ' ': p ="#\\space"; break; case '\n': p ="#\\newline"; break; case '\r': p ="#\\return"; break; case '\t': p ="#\\tab"; break; default: #if USE_ASCII_NAMES if (c == 127) { strcpy (p, "#\\del"); break; } else if (c < 32) { strcpy (p, "#\\"); strcpy (p + 2, charnames[c]); break; } #else if (c < 32) { strcpy (p, "#\\x"); xbase (p + 3, c, 16); break; } #endif strcpy (p, "#\\%"); p[2] = c; break; } } } else if (is_symbol (l)) p = symname (l); else if (is_proc (l)) { #if USE_PRINTF p = SCHEME_V->strbuff; snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l)); #else p = "#"; #endif } else if (is_macro (l)) p = "#"; else if (is_closure (l)) p = "#"; else if (is_promise (l)) p = "#"; else if (is_foreign (l)) { #if USE_PRINTF p = SCHEME_V->strbuff; snprintf (p, STRBUFFSIZE, "#", procnum (l)); #else p = "#"; #endif } else if (is_continuation (l)) p = "#"; else p = "#"; *pp = p; *plen = strlen (p); } /* ========== Routines for Evaluation Cycle ========== */ /* make closure. c is code. e is environment */ static pointer mk_closure (SCHEME_P_ pointer c, pointer e) { pointer x = get_cell (SCHEME_A_ c, e); set_typeflag (x, T_CLOSURE); set_car (x, c); set_cdr (x, e); return x; } /* make continuation. */ static pointer mk_continuation (SCHEME_P_ pointer d) { pointer x = get_cell (SCHEME_A_ NIL, d); set_typeflag (x, T_CONTINUATION); set_cont_dump (x, d); return x; } static pointer list_star (SCHEME_P_ pointer d) { pointer p, q; if (cdr (d) == NIL) return car (d); p = cons (car (d), cdr (d)); q = p; while (cdr (cdr (p)) != NIL) { d = cons (car (p), cdr (p)); if (cdr (cdr (p)) != NIL) p = cdr (d); } set_cdr (p, car (cdr (p))); return q; } /* reverse list -- produce new list */ static pointer reverse (SCHEME_P_ pointer a) { /* a must be checked by gc */ pointer p = NIL; for (; is_pair (a); a = cdr (a)) p = cons (car (a), p); return p; } /* reverse list --- in-place */ static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list) { pointer result = term; pointer p = list; while (p != NIL) { pointer q = cdr (p); set_cdr (p, result); result = p; p = q; } return result; } /* append list -- produce new list (in reverse order) */ static pointer revappend (SCHEME_P_ pointer a, pointer b) { pointer result = a; pointer p = b; while (is_pair (p)) { result = cons (car (p), result); p = cdr (p); } if (p == NIL) return result; return S_F; /* signal an error */ } /* equivalence of atoms */ int eqv (pointer a, pointer b) { if (is_string (a)) { if (is_string (b)) return strvalue (a) == strvalue (b); else return 0; } else if (is_number (a)) { if (is_number (b)) return num_cmp (nvalue (a), nvalue (b)) == 0; return 0; } else if (is_character (a)) { if (is_character (b)) return charvalue (a) == charvalue (b); else return 0; } else if (is_port (a)) { if (is_port (b)) return a == b; else return 0; } else if (is_proc (a)) { if (is_proc (b)) return procnum (a) == procnum (b); else return 0; } else return a == b; } /* true or false value macro */ /* () is #t in R5RS */ #define is_true(p) ((p) != S_F) #define is_false(p) ((p) == S_F) /* ========== Environment implementation ========== */ #ifndef USE_ALIST_ENV /* * In this implementation, each frame of the environment may be * a hash table: a vector of alists hashed by variable name. * In practice, we use a vector only for the initial frame; * subsequent frames are too small and transient for the lookup * speed to out-weigh the cost of making a new vector. */ static void new_frame_in_env (SCHEME_P_ pointer old_env) { pointer new_frame; /* The interaction-environment has about 300 variables in it. */ if (old_env == NIL) new_frame = mk_vector (SCHEME_A_ 461); else new_frame = NIL; SCHEME_V->envir = immutable_cons (new_frame, old_env); setenvironment (SCHEME_V->envir); } static uint32_t sym_hash (pointer sym, uint32_t size) { uintptr_t ptr = (uintptr_t)sym; #if 0 /* table size is prime, so why mix */ ptr += ptr >> 32; ptr += ptr >> 16; ptr += ptr >> 8; #endif return ptr % size; } ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { pointer slot = immutable_cons (variable, value); if (is_vector (car (env))) { int location = sym_hash (variable, veclength (car (env))); vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location))); } else set_car (env, immutable_cons (slot, car (env))); } static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) { pointer x, y; for (x = env; x != NIL; x = cdr (x)) { if (is_vector (car (x))) { int location = sym_hash (hdl, veclength (car (x))); y = vector_get (car (x), location); } else y = car (x); for (; y != NIL; y = cdr (y)) if (caar (y) == hdl) break; if (y != NIL) return car (y); if (!all) break; } return NIL; } #else /* USE_ALIST_ENV */ ecb_inline void new_frame_in_env (SCHEME_P_ pointer old_env) { SCHEME_V->envir = immutable_cons (NIL, old_env); setenvironment (SCHEME_V->envir); } ecb_inline void new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) { set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); } static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) { pointer x, y; for (x = env; x != NIL; x = cdr (x)) { for (y = car (x); y != NIL; y = cdr (y)) if (caar (y) == hdl) break; if (y != NIL) return car (y); break; if (!all) break; } return NIL; } #endif /* USE_ALIST_ENV else */ ecb_inline void new_slot_in_env (SCHEME_P_ pointer variable, pointer value) { new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); } ecb_inline void set_slot_in_env (SCHEME_P_ pointer slot, pointer value) { set_cdr (slot, value); } ecb_inline pointer slot_value_in_env (pointer slot) { return cdr (slot); } /* ========== Evaluation Cycle ========== */ static int xError_1 (SCHEME_P_ const char *s, pointer a) { #if USE_ERROR_HOOK pointer x; pointer hdl = SCHEME_V->ERROR_HOOK; #endif #if USE_PRINTF #if SHOW_ERROR_LINE char sbuf[STRBUFFSIZE]; /* make sure error is not in REPL */ if ((SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) && SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file != STDIN_FILENO) { int ln = SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line; const char *fname = SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename; /* should never happen */ if (!fname) fname = ""; /* we started from 0 */ ln++; snprintf (sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s); s = sbuf; } #endif #endif #if USE_ERROR_HOOK x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); if (x != NIL) { pointer code = a ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) : NIL; code = cons (mk_string (SCHEME_A_ s), code); setimmutable (car (code)); SCHEME_V->code = cons (slot_value_in_env (x), code); SCHEME_V->op = OP_EVAL; return 0; } #endif if (a) SCHEME_V->args = cons (a, NIL); else SCHEME_V->args = NIL; SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); setimmutable (car (SCHEME_V->args)); SCHEME_V->op = OP_ERR0; return 0; } #define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) #define Error_0(s) Error_1 (s, 0) /* Too small to turn into function */ #define BEGIN do { #define END } while (0) #define s_goto(a) BEGIN \ SCHEME_V->op = a; \ return 0; END #define s_return(a) return xs_return (SCHEME_A_ a) #ifndef USE_SCHEME_STACK /* this structure holds all the interpreter's registers */ struct dump_stack_frame { enum scheme_opcodes op; pointer args; pointer envir; pointer code; }; # define STACK_GROWTH 3 static void s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) { int nframes = (uintptr_t)SCHEME_V->dump; struct dump_stack_frame *next_frame; /* enough room for the next frame? */ if (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); } next_frame = SCHEME_V->dump_base + nframes; next_frame->op = op; next_frame->args = args; next_frame->envir = SCHEME_V->envir; next_frame->code = code; SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); } static int xs_return (SCHEME_P_ pointer a) { int nframes = (uintptr_t)SCHEME_V->dump; struct dump_stack_frame *frame; SCHEME_V->value = a; if (nframes <= 0) return -1; frame = &SCHEME_V->dump_base[--nframes]; SCHEME_V->op = frame->op; SCHEME_V->args = frame->args; SCHEME_V->envir = frame->envir; SCHEME_V->code = frame->code; SCHEME_V->dump = (pointer)(uintptr_t)nframes; return 0; } ecb_inline void dump_stack_reset (SCHEME_P) { /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ SCHEME_V->dump = (pointer)+0; } ecb_inline void dump_stack_initialize (SCHEME_P) { SCHEME_V->dump_size = 0; SCHEME_V->dump_base = 0; dump_stack_reset (SCHEME_A); } static void dump_stack_free (SCHEME_P) { free (SCHEME_V->dump_base); SCHEME_V->dump_base = 0; SCHEME_V->dump = (pointer)0; SCHEME_V->dump_size = 0; } static void dump_stack_mark (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; int i; for (i = 0; i < nframes; i++) { struct dump_stack_frame *frame = SCHEME_V->dump_base + i; mark (frame->args); mark (frame->envir); mark (frame->code); } } static pointer ss_get_cont (SCHEME_P) { int nframes = (uintptr_t)SCHEME_V->dump; int i; pointer cont = NIL; for (i = nframes; i--; ) { struct dump_stack_frame *frame = SCHEME_V->dump_base + i; cont = cons (mk_integer (SCHEME_A_ frame->op), cons (frame->args, cons (frame->envir, cons (frame->code, cont)))); } return cont; } static void ss_set_cont (SCHEME_P_ pointer cont) { int i = 0; struct dump_stack_frame *frame = SCHEME_V->dump_base; while (cont != NIL) { frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont); frame->args = car (cont) ; cont = cdr (cont); frame->envir = car (cont) ; cont = cdr (cont); frame->code = car (cont) ; cont = cdr (cont); ++frame; ++i; } SCHEME_V->dump = (pointer)(uintptr_t)i; } #else ecb_inline void dump_stack_reset (SCHEME_P) { SCHEME_V->dump = NIL; } ecb_inline void dump_stack_initialize (SCHEME_P) { dump_stack_reset (SCHEME_A); } static void dump_stack_free (SCHEME_P) { SCHEME_V->dump = NIL; } static int xs_return (SCHEME_P_ pointer a) { pointer dump = SCHEME_V->dump; SCHEME_V->value = a; if (dump == NIL) return -1; SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump); SCHEME_V->args = car (dump) ; dump = cdr (dump); SCHEME_V->envir = car (dump) ; dump = cdr (dump); SCHEME_V->code = car (dump) ; dump = cdr (dump); SCHEME_V->dump = dump; return 0; } static void s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) { SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), cons (args, cons (SCHEME_V->envir, cons (code, SCHEME_V->dump)))); } static void dump_stack_mark (SCHEME_P) { mark (SCHEME_V->dump); } static pointer ss_get_cont (SCHEME_P) { return SCHEME_V->dump; } static void ss_set_cont (SCHEME_P_ pointer cont) { SCHEME_V->dump = cont; } #endif #define s_retbool(tf) s_return ((tf) ? S_T : S_F) static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; pointer x, y; switch (op) { case OP_LOAD: /* load */ 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))); } if (!file_push (SCHEME_A_ strvalue (car (args)))) Error_1 ("unable to open", car (args)); else { SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); s_goto (OP_T0LVL); } 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 (SCHEME_V->file_i == 0) { SCHEME_V->args = NIL; s_goto (OP_QUIT); } else { file_pop (SCHEME_A); s_return (SCHEME_V->value); } /* NOTREACHED */ } /* If interactive, be nice to user. */ if (file_interactive (SCHEME_A)) { SCHEME_V->envir = SCHEME_V->global_env; dump_stack_reset (SCHEME_A); putstr (SCHEME_A_ "\n"); putstr (SCHEME_A_ prompt); } /* Set up another iteration of REPL */ SCHEME_V->nesting = 0; SCHEME_V->save_inport = SCHEME_V->inport; SCHEME_V->inport = SCHEME_V->loadport; s_save (SCHEME_A_ OP_T0LVL, NIL, NIL); s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); s_goto (OP_READ_INTERNAL); case OP_T1LVL: /* top level */ SCHEME_V->code = SCHEME_V->value; SCHEME_V->inport = SCHEME_V->save_inport; s_goto (OP_EVAL); case OP_READ_INTERNAL: /* internal read */ SCHEME_V->tok = token (SCHEME_A); if (SCHEME_V->tok == TOK_EOF) s_return (S_EOF); s_goto (OP_RDSEXPR); case OP_GENSYM: s_return (gensym (SCHEME_A)); case OP_VALUEPRINT: /* print evaluation result */ /* OP_VALUEPRINT is always pushed, because when changing from non-interactive to interactive mode, it needs to be already on the stack */ #if USE_TRACING if (SCHEME_V->tracing) putstr (SCHEME_A_ "\nGives: "); #endif if (file_interactive (SCHEME_A)) { SCHEME_V->print_flag = 1; SCHEME_V->args = SCHEME_V->value; s_goto (OP_P0LIST); } else s_return (SCHEME_V->value); case OP_EVAL: /* main part of evaluation */ #if USE_TRACING if (SCHEME_V->tracing) { /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */ s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code); SCHEME_V->args = SCHEME_V->code; putstr (SCHEME_A_ "\nEval: "); s_goto (OP_P0LIST); } /* fall through */ case OP_REAL_EVAL: #endif if (is_symbol (SCHEME_V->code)) /* symbol */ { 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 Error_1 ("eval: unbound variable:", SCHEME_V->code); } else if (is_pair (SCHEME_V->code)) { x = car (SCHEME_V->code); if (is_syntax (x)) /* SYNTAX */ { SCHEME_V->code = cdr (SCHEME_V->code); s_goto (syntaxnum (x)); } else /* first, eval top element and eval arguments */ { s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ SCHEME_V->code = x; s_goto (OP_EVAL); } } else s_return (SCHEME_V->code); case OP_E0ARGS: /* eval arguments */ if (is_macro (SCHEME_V->value)) /* macro expansion */ { s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); SCHEME_V->args = cons (SCHEME_V->code, NIL); SCHEME_V->code = SCHEME_V->value; s_goto (OP_APPLY); } else { SCHEME_V->code = cdr (SCHEME_V->code); s_goto (OP_E1ARGS); } case OP_E1ARGS: /* eval arguments */ args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { args = reverse_in_place (SCHEME_A_ NIL, args); SCHEME_V->code = car (args); SCHEME_V->args = cdr (args); s_goto (OP_APPLY); } #if USE_TRACING case OP_TRACING: { int tr = SCHEME_V->tracing; SCHEME_V->tracing = ivalue_unchecked (car (args)); s_return (mk_integer (SCHEME_A_ tr)); } #endif case OP_APPLY: /* apply 'code' to 'args' */ #if USE_TRACING if (SCHEME_V->tracing) { s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code); SCHEME_V->print_flag = 1; /* args=cons(SCHEME_V->code,args); */ putstr (SCHEME_A_ "\nApply to: "); s_goto (OP_P0LIST); } /* fall through */ case OP_REAL_APPLY: #endif if (is_proc (SCHEME_V->code)) s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ else if (is_foreign (SCHEME_V->code)) { /* Keep nested calls from GC'ing the arglist */ push_recent_alloc (SCHEME_A_ args, NIL); x = SCHEME_V->code->object.ff (SCHEME_A_ args); s_return (x); } else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ { /* Should not accept promise */ /* make environment */ new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y)) { if (y == NIL) Error_0 ("not enough arguments"); else new_slot_in_env (SCHEME_A_ car (x), car (y)); } if (x == NIL) { /*-- * if (y != NIL) { * Error_0("too many arguments"); * } */ } else if (is_symbol (x)) new_slot_in_env (SCHEME_A_ x, y); else Error_1 ("syntax error in closure: not a symbol:", x); SCHEME_V->code = cdr (closure_code (SCHEME_V->code)); SCHEME_V->args = NIL; s_goto (OP_BEGIN); } else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ { ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); s_return (args != NIL ? car (args) : NIL); } else Error_0 ("illegal function"); case OP_DOMACRO: /* do macro */ 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 */ { pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1); if (f != NIL) { s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code); SCHEME_V->args = cons (SCHEME_V->code, NIL); SCHEME_V->code = slot_value_in_env (f); s_goto (OP_APPLY); } SCHEME_V->value = SCHEME_V->code; /* 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); if (car (x) == SCHEME_V->LAMBDA) x = cdr (x); if (cdr (args) == NIL) y = SCHEME_V->envir; else y = cadr (args); s_return (mk_closure (SCHEME_A_ x, y)); case OP_QUOTE: /* quote */ s_return (car (SCHEME_V->code)); case OP_DEF0: /* define */ if (is_immutable (car (SCHEME_V->code))) Error_1 ("define: unable to alter immutable", car (SCHEME_V->code)); if (is_pair (car (SCHEME_V->code))) { x = caar (SCHEME_V->code); SCHEME_V->code = cons (SCHEME_V->LAMBDA, cons (cdar (SCHEME_V->code), cdr (SCHEME_V->code))); } else { x = car (SCHEME_V->code); SCHEME_V->code = cadr (SCHEME_V->code); } if (!is_symbol (x)) Error_0 ("variable is not a symbol"); s_save (SCHEME_A_ OP_DEF1, NIL, x); s_goto (OP_EVAL); case OP_DEF1: /* define */ x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0); if (x != NIL) set_slot_in_env (SCHEME_A_ x, SCHEME_V->value); else new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); s_return (SCHEME_V->code); case OP_DEFP: /* defined? */ x = SCHEME_V->envir; if (cdr (args) != NIL) x = cadr (args); s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL); case OP_SET0: /* set! */ if (is_immutable (car (SCHEME_V->code))) Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code)); s_save (SCHEME_A_ OP_SET1, NIL, car (SCHEME_V->code)); SCHEME_V->code = cadr (SCHEME_V->code); s_goto (OP_EVAL); case OP_SET1: /* set! */ y = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); if (y != NIL) { set_slot_in_env (SCHEME_A_ y, SCHEME_V->value); s_return (SCHEME_V->value); } else Error_1 ("set!: unbound variable:", SCHEME_V->code); case OP_BEGIN: /* begin */ if (!is_pair (SCHEME_V->code)) s_return (SCHEME_V->code); if (cdr (SCHEME_V->code) != NIL) s_save (SCHEME_A_ OP_BEGIN, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); case OP_IF0: /* if */ s_save (SCHEME_A_ OP_IF1, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); case OP_IF1: /* if */ if (is_true (SCHEME_V->value)) SCHEME_V->code = car (SCHEME_V->code); else SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ s_goto (OP_EVAL); case OP_LET0: /* let */ SCHEME_V->args = NIL; SCHEME_V->value = SCHEME_V->code; SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); s_goto (OP_LET1); case OP_LET1: /* let (calculate parameters) */ args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { args = reverse_in_place (SCHEME_A_ NIL, args); SCHEME_V->code = car (args); SCHEME_V->args = cdr (args); s_goto (OP_LET2); } case OP_LET2: /* let */ new_frame_in_env (SCHEME_A_ SCHEME_V->envir); for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) new_slot_in_env (SCHEME_A_ caar (x), car (y)); if (is_symbol (car (SCHEME_V->code))) /* named let */ { for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) { if (!is_pair (x)) Error_1 ("Bad syntax of binding in let :", x); if (!is_list (SCHEME_A_ car (x))) Error_1 ("Bad syntax of binding in let :", car (x)); args = cons (caar (x), args); } x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), SCHEME_V->envir); new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x); SCHEME_V->code = cddr (SCHEME_V->code); } else { SCHEME_V->code = cdr (SCHEME_V->code); } SCHEME_V->args = NIL; s_goto (OP_BEGIN); case OP_LET0AST: /* let* */ if (car (SCHEME_V->code) == NIL) { new_frame_in_env (SCHEME_A_ SCHEME_V->envir); SCHEME_V->code = cdr (SCHEME_V->code); s_goto (OP_BEGIN); } if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); SCHEME_V->code = car (cdaar (SCHEME_V->code)); s_goto (OP_EVAL); case OP_LET1AST: /* let* (make new frame) */ new_frame_in_env (SCHEME_A_ SCHEME_V->envir); s_goto (OP_LET2AST); case OP_LET2AST: /* let* (calculate parameters) */ new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value); SCHEME_V->code = cdr (SCHEME_V->code); if (is_pair (SCHEME_V->code)) /* continue */ { s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { SCHEME_V->code = args; SCHEME_V->args = NIL; s_goto (OP_BEGIN); } case OP_LET0REC: /* letrec */ new_frame_in_env (SCHEME_A_ SCHEME_V->envir); SCHEME_V->args = NIL; SCHEME_V->value = SCHEME_V->code; SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_LET1REC); case OP_LET1REC: /* letrec (calculate parameters) */ args = cons (SCHEME_V->value, args); if (is_pair (SCHEME_V->code)) /* continue */ { if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } else /* end */ { args = reverse_in_place (SCHEME_A_ NIL, args); SCHEME_V->code = car (args); SCHEME_V->args = cdr (args); s_goto (OP_LET2REC); } case OP_LET2REC: /* letrec */ for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) new_slot_in_env (SCHEME_A_ caar (x), car (y)); SCHEME_V->code = cdr (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_BEGIN); case OP_COND0: /* cond */ if (!is_pair (SCHEME_V->code)) Error_0 ("syntax error in cond"); s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); SCHEME_V->code = caar (SCHEME_V->code); s_goto (OP_EVAL); case OP_COND1: /* cond */ if (is_true (SCHEME_V->value)) { if ((SCHEME_V->code = cdar (SCHEME_V->code)) == NIL) s_return (SCHEME_V->value); if (car (SCHEME_V->code) == SCHEME_V->FEED_TO) { if (!is_pair (cdr (SCHEME_V->code))) Error_0 ("syntax error in cond"); x = cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)); SCHEME_V->code = cons (cadr (SCHEME_V->code), cons (x, NIL)); s_goto (OP_EVAL); } s_goto (OP_BEGIN); } else { if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) s_return (NIL); else { s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); SCHEME_V->code = caar (SCHEME_V->code); s_goto (OP_EVAL); } } case OP_DELAY: /* delay */ x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); set_typeflag (x, T_PROMISE); s_return (x); case OP_AND0: /* and */ if (SCHEME_V->code == NIL) s_return (S_T); s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); case OP_AND1: /* and */ if (is_false (SCHEME_V->value)) s_return (SCHEME_V->value); else if (SCHEME_V->code == NIL) s_return (SCHEME_V->value); else { s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); } case OP_OR0: /* or */ if (SCHEME_V->code == NIL) s_return (S_F); s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); case OP_OR1: /* or */ if (is_true (SCHEME_V->value)) s_return (SCHEME_V->value); else if (SCHEME_V->code == NIL) s_return (SCHEME_V->value); else { s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); } case OP_C0STREAM: /* cons-stream */ s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); case OP_C1STREAM: /* cons-stream */ SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */ x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); set_typeflag (x, T_PROMISE); s_return (cons (args, x)); case OP_MACRO0: /* macro */ if (is_pair (car (SCHEME_V->code))) { x = caar (SCHEME_V->code); SCHEME_V->code = cons (SCHEME_V->LAMBDA, cons (cdar (SCHEME_V->code), cdr (SCHEME_V->code))); } else { x = car (SCHEME_V->code); SCHEME_V->code = cadr (SCHEME_V->code); } if (!is_symbol (x)) Error_0 ("variable is not a symbol"); s_save (SCHEME_A_ OP_MACRO1, NIL, x); s_goto (OP_EVAL); case OP_MACRO1: /* macro */ set_typeflag (SCHEME_V->value, T_MACRO); x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0); if (x != NIL) set_slot_in_env (SCHEME_A_ x, SCHEME_V->value); else new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); s_return (SCHEME_V->code); case OP_CASE0: /* case */ s_save (SCHEME_A_ OP_CASE1, NIL, cdr (SCHEME_V->code)); SCHEME_V->code = car (SCHEME_V->code); s_goto (OP_EVAL); case OP_CASE1: /* case */ for (x = SCHEME_V->code; x != NIL; x = cdr (x)) { if (!is_pair (y = caar (x))) break; for (; y != NIL; y = cdr (y)) if (eqv (car (y), SCHEME_V->value)) break; if (y != NIL) break; } if (x != NIL) { if (is_pair (caar (x))) { SCHEME_V->code = cdar (x); s_goto (OP_BEGIN); } else /* else */ { s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); SCHEME_V->code = caar (x); s_goto (OP_EVAL); } } else s_return (NIL); case OP_CASE2: /* case */ if (is_true (SCHEME_V->value)) s_goto (OP_BEGIN); else s_return (NIL); case OP_PAPPLY: /* apply */ SCHEME_V->code = car (args); SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); /*SCHEME_V->args = cadr(args); */ s_goto (OP_APPLY); case OP_PEVAL: /* eval */ if (cdr (args) != NIL) SCHEME_V->envir = cadr (args); SCHEME_V->code = car (args); s_goto (OP_EVAL); case OP_CONTINUATION: /* call-with-current-continuation */ SCHEME_V->code = car (args); SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); s_goto (OP_APPLY); } if (USE_ERROR_CHECKING) abort (); } static int opexe_1 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; pointer x = car (args); num v; switch (op) { #if USE_MATH case OP_INEX2EX: /* inexact->exact */ { if (is_integer (x)) s_return (x); RVALUE r = rvalue_unchecked (x); if (r == (RVALUE)(IVALUE)r) s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); else Error_1 ("inexact->exact: not integral:", x); } case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); case OP_ATAN: if (cdr (args) == NIL) s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); else { pointer y = cadr (args); s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y)))); } case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); case OP_EXPT: { RVALUE result; int real_result = 1; pointer y = cadr (args); if (is_integer (x) && is_integer (y)) real_result = 0; /* This 'if' is an R5RS compatibility fix. */ /* NOTE: Remove this 'if' fix for R6RS. */ if (rvalue (x) == 0 && rvalue (y) < 0) result = 0; else result = pow (rvalue (x), rvalue (y)); /* Before returning integer result make sure we can. */ /* If the test fails, result is too big for integer. */ if (!real_result) { long result_as_long = result; if (result != result_as_long) real_result = 1; } if (real_result) s_return (mk_real (SCHEME_A_ result)); else s_return (mk_integer (SCHEME_A_ result)); } case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); case OP_TRUNCATE: { RVALUE n = rvalue (x); s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n))); } case OP_ROUND: if (is_integer (x)) s_return (x); s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); #endif case OP_ADD: /* + */ v = num_zero; for (x = args; x != NIL; x = cdr (x)) v = num_op (NUM_ADD, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_MUL: /* * */ v = num_one; for (x = args; x != NIL; x = cdr (x)) v = num_op (NUM_MUL, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_SUB: /* - */ if (cdr (args) == NIL) { x = args; v = num_zero; } else { x = cdr (args); v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) v = num_op (NUM_SUB, v, nvalue (car (x))); s_return (mk_number (SCHEME_A_ v)); case OP_DIV: /* / */ if (cdr (args) == NIL) { x = args; v = num_one; } else { x = cdr (args); v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) if (!is_zero_rvalue (rvalue (car (x)))) v = num_div (v, nvalue (car (x))); else Error_0 ("/: division by zero"); s_return (mk_number (SCHEME_A_ v)); case OP_INTDIV: /* quotient */ if (cdr (args) == NIL) { x = args; v = num_one; } else { x = cdr (args); v = nvalue (car (args)); } for (; x != NIL; x = cdr (x)) { if (ivalue (car (x)) != 0) v = num_op (NUM_INTDIV, v, nvalue (car (x))); else Error_0 ("quotient: division by zero"); } s_return (mk_number (SCHEME_A_ v)); case OP_REM: /* remainder */ v = nvalue (x); if (ivalue (cadr (args)) != 0) v = num_rem (v, nvalue (cadr (args))); else Error_0 ("remainder: division by zero"); s_return (mk_number (SCHEME_A_ v)); case OP_MOD: /* modulo */ v = nvalue (x); if (ivalue (cadr (args)) != 0) v = num_mod (v, nvalue (cadr (args))); else Error_0 ("modulo: division by zero"); s_return (mk_number (SCHEME_A_ v)); case OP_CAR: /* car */ s_return (caar (args)); case OP_CDR: /* cdr */ s_return (cdar (args)); case OP_CONS: /* cons */ set_cdr (args, cadr (args)); s_return (args); case OP_SETCAR: /* set-car! */ if (!is_immutable (x)) { set_car (x, cadr (args)); s_return (car (args)); } else Error_0 ("set-car!: unable to alter immutable pair"); case OP_SETCDR: /* set-cdr! */ if (!is_immutable (x)) { set_cdr (x, cadr (args)); s_return (car (args)); } else Error_0 ("set-cdr!: unable to alter immutable pair"); case OP_CHAR2INT: /* char->integer */ s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x))); case OP_INT2CHAR: /* integer->char */ s_return (mk_character (SCHEME_A_ ivalue_unchecked (x))); case OP_CHARUPCASE: { unsigned char c = ivalue_unchecked (x); c = toupper (c); s_return (mk_character (SCHEME_A_ c)); } case OP_CHARDNCASE: { unsigned char c = ivalue_unchecked (x); c = tolower (c); s_return (mk_character (SCHEME_A_ c)); } case OP_STR2SYM: /* string->symbol */ s_return (mk_symbol (SCHEME_A_ strvalue (x))); case OP_STR2ATOM: /* string->atom */ { char *s = strvalue (x); long pf = 0; if (cdr (args) != NIL) { /* we know cadr(args) is a natural number */ /* see if it is 2, 8, 10, or 16, or error */ pf = ivalue_unchecked (cadr (args)); if (pf == 16 || pf == 10 || pf == 8 || pf == 2) { /* base is OK */ } else pf = -1; } if (pf < 0) Error_1 ("string->atom: bad base:", cadr (args)); else if (*s == '#') /* no use of base! */ s_return (mk_sharp_const (SCHEME_A_ s + 1)); else { if (pf == 0 || pf == 10) s_return (mk_atom (SCHEME_A_ s)); else { char *ep; long iv = strtol (s, &ep, (int) pf); if (*ep == 0) s_return (mk_integer (SCHEME_A_ iv)); else s_return (S_F); } } } case OP_SYM2STR: /* symbol->string */ x = mk_string (SCHEME_A_ symname (x)); setimmutable (x); s_return (x); case OP_ATOM2STR: /* atom->string */ { long pf = 0; if (cdr (args) != NIL) { /* we know cadr(args) is a natural number */ /* see if it is 2, 8, 10, or 16, or error */ pf = ivalue_unchecked (cadr (args)); if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { /* base is OK */ } else pf = -1; } if (pf < 0) Error_1 ("atom->string: bad base:", cadr (args)); else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x)) { char *p; int len; atom2str (SCHEME_A_ x, pf, &p, &len); s_return (mk_counted_string (SCHEME_A_ p, len)); } else Error_1 ("atom->string: not an atom:", x); } case OP_MKSTRING: /* make-string */ { int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' '; int len = ivalue_unchecked (x); s_return (mk_empty_string (SCHEME_A_ len, fill)); } case OP_STRLEN: /* string-length */ s_return (mk_integer (SCHEME_A_ strlength (x))); case OP_STRREF: /* string-ref */ { char *str = strvalue (x); int index = ivalue_unchecked (cadr (args)); if (index >= strlength (x)) Error_1 ("string-ref: out of bounds:", cadr (args)); s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index])); } case OP_STRSET: /* string-set! */ { char *str = strvalue (x); int index = ivalue_unchecked (cadr (args)); int c; if (is_immutable (x)) Error_1 ("string-set!: unable to alter immutable string:", x); if (index >= strlength (x)) Error_1 ("string-set!: out of bounds:", cadr (args)); c = charvalue (caddr (args)); str[index] = c; s_return (car (args)); } case OP_STRAPPEND: /* string-append */ { /* in 1.29 string-append was in Scheme in init.scm but was too slow */ int len = 0; pointer newstr; char *pos; /* compute needed length for new string */ for (x = args; x != NIL; x = cdr (x)) len += strlength (car (x)); newstr = mk_empty_string (SCHEME_A_ len, ' '); /* store the contents of the argument strings into the new string */ for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x)) memcpy (pos, strvalue (car (x)), strlength (car (x))); s_return (newstr); } case OP_SUBSTR: /* substring */ { char *str = strvalue (x); int index0 = ivalue_unchecked (cadr (args)); int index1; int len; if (index0 > strlength (x)) Error_1 ("substring: start out of bounds:", cadr (args)); if (cddr (args) != NIL) { index1 = ivalue_unchecked (caddr (args)); if (index1 > strlength (x) || index1 < index0) Error_1 ("substring: end out of bounds:", caddr (args)); } else index1 = strlength (x); len = index1 - index0; x = mk_empty_string (SCHEME_A_ len, ' '); memcpy (strvalue (x), str + index0, len); strvalue (x)[len] = 0; s_return (x); } case OP_VECTOR: /* vector */ { int i; pointer vec; int len = list_length (SCHEME_A_ args); if (len < 0) Error_1 ("vector: not a proper list:", args); vec = mk_vector (SCHEME_A_ len); #if USE_ERROR_CHECKING if (SCHEME_V->no_memory) s_return (S_SINK); #endif for (x = args, i = 0; is_pair (x); x = cdr (x), i++) vector_set (vec, i, car (x)); s_return (vec); } case OP_MKVECTOR: /* make-vector */ { pointer fill = NIL; pointer vec; int len = ivalue_unchecked (x); if (cdr (args) != NIL) fill = cadr (args); vec = mk_vector (SCHEME_A_ len); #if USE_ERROR_CHECKING if (SCHEME_V->no_memory) s_return (S_SINK); #endif if (fill != NIL) fill_vector (vec, 0, fill); s_return (vec); } case OP_VECLEN: /* vector-length */ s_return (mk_integer (SCHEME_A_ veclength (x))); case OP_VECREF: /* vector-ref */ { int index = ivalue_unchecked (cadr (args)); if (index >= veclength (car (args)) && USE_ERROR_CHECKING) Error_1 ("vector-ref: out of bounds:", cadr (args)); s_return (vector_get (x, index)); } case OP_VECSET: /* vector-set! */ { int index = ivalue_unchecked (cadr (args)); if (is_immutable (x)) Error_1 ("vector-set!: unable to alter immutable vector:", x); if (index >= veclength (car (args)) && USE_ERROR_CHECKING) Error_1 ("vector-set!: out of bounds:", cadr (args)); vector_set (x, index, caddr (args)); s_return (x); } } if (USE_ERROR_CHECKING) abort (); } static int opexe_2 (SCHEME_P_ enum scheme_opcodes op) { pointer x = SCHEME_V->args; for (;;) { num v = nvalue (car (x)); x = cdr (x); if (x == NIL) break; int r = num_cmp (v, nvalue (car (x))); switch (op) { case OP_NUMEQ: r = r == 0; break; case OP_LESS: r = r < 0; break; case OP_GRE: r = r > 0; break; case OP_LEQ: r = r <= 0; break; case OP_GEQ: r = r >= 0; break; } if (!r) s_return (S_F); } s_return (S_T); } static int opexe_3 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; pointer a = car (args); pointer d = cdr (args); int r; 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; #if USE_CHAR_CLASSIFIERS case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break; case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break; #endif #if USE_PORTS case OP_PORTP: /* port? */ r = is_port (a) ; break; case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break; case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break; #endif case OP_PROCP: /* procedure? */ /*-- * continuation should be procedure by the example * (call-with-current-continuation procedure?) ==> #t * in R^3 report sec. 6.9 */ r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a); break; case OP_PAIRP: /* pair? */ r = is_pair (a) ; break; case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break; case OP_ENVP: /* environment? */ r = is_environment (a) ; break; case OP_VECTORP: /* vector? */ r = is_vector (a) ; break; case OP_EQ: /* eq? */ r = a == cadr (args) ; break; case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break; } s_retbool (r); } static int opexe_4 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; pointer a = car (args); pointer x, y; switch (op) { case OP_FORCE: /* force */ SCHEME_V->code = a; if (is_promise (SCHEME_V->code)) { /* Should change type to closure here */ s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_APPLY); } else s_return (SCHEME_V->code); case OP_SAVE_FORCED: /* Save forced value replacing promise */ memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); s_return (SCHEME_V->value); #if USE_PORTS case OP_WRITE: /* write */ case OP_DISPLAY: /* display */ case OP_WRITE_CHAR: /* write-char */ if (is_pair (cdr (SCHEME_V->args))) { if (cadr (SCHEME_V->args) != SCHEME_V->outport) { x = cons (SCHEME_V->outport, NIL); s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); SCHEME_V->outport = cadr (SCHEME_V->args); } } SCHEME_V->args = a; if (op == OP_WRITE) SCHEME_V->print_flag = 1; else SCHEME_V->print_flag = 0; s_goto (OP_P0LIST); case OP_NEWLINE: /* newline */ if (is_pair (args)) { if (a != SCHEME_V->outport) { x = cons (SCHEME_V->outport, NIL); s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); SCHEME_V->outport = a; } } putstr (SCHEME_A_ "\n"); s_return (S_T); #endif case OP_ERR0: /* error */ SCHEME_V->retcode = -1; if (!is_string (a)) { args = cons (mk_string (SCHEME_A_ " -- "), args); setimmutable (car (args)); } putstr (SCHEME_A_ "Error: "); putstr (SCHEME_A_ strvalue (car (args))); SCHEME_V->args = cdr (args); s_goto (OP_ERR1); case OP_ERR1: /* error */ putstr (SCHEME_A_ " "); if (args != NIL) { s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); SCHEME_V->args = a; SCHEME_V->print_flag = 1; s_goto (OP_P0LIST); } else { putstr (SCHEME_A_ "\n"); if (SCHEME_V->interactive_repl) s_goto (OP_T0LVL); else return -1; } case OP_REVERSE: /* reverse */ s_return (reverse (SCHEME_A_ a)); case OP_LIST_STAR: /* list* */ s_return (list_star (SCHEME_A_ SCHEME_V->args)); case OP_APPEND: /* append */ x = NIL; y = args; if (y == x) s_return (x); /* cdr() in the while condition is not a typo. If car() */ /* is used (append '() 'a) will return the wrong result. */ while (cdr (y) != NIL) { x = revappend (SCHEME_A_ x, car (y)); y = cdr (y); if (x == S_F) Error_0 ("non-list argument to append"); } s_return (reverse_in_place (SCHEME_A_ car (y), x)); #if USE_PLIST case OP_PUT: /* put */ if (!hasprop (a) || !hasprop (cadr (args))) Error_0 ("illegal use of put"); for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x)) { if (caar (x) == y) break; } if (x != NIL) cdar (x) = caddr (args); else symprop (a) = cons (cons (y, caddr (args)), symprop (a)); s_return (S_T); case OP_GET: /* get */ if (!hasprop (a) || !hasprop (cadr (args))) Error_0 ("illegal use of get"); for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x)) if (caar (x) == y) break; if (x != NIL) s_return (cdar (x)); else s_return (NIL); #endif /* USE_PLIST */ case OP_QUIT: /* quit */ if (is_pair (args)) SCHEME_V->retcode = ivalue (a); return -1; case OP_GC: /* gc */ gc (SCHEME_A_ NIL, NIL); s_return (S_T); case OP_GCVERB: /* gc-verbose */ { int was = SCHEME_V->gc_verbose; SCHEME_V->gc_verbose = (a != S_F); s_retbool (was); } case OP_NEWSEGMENT: /* new-segment */ 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); case OP_OBLIST: /* oblist */ s_return (oblist_all_symbols (SCHEME_A)); #if USE_PORTS case OP_CURR_INPORT: /* current-input-port */ s_return (SCHEME_V->inport); case OP_CURR_OUTPORT: /* current-output-port */ s_return (SCHEME_V->outport); case OP_OPEN_INFILE: /* open-input-file */ case OP_OPEN_OUTFILE: /* open-output-file */ case OP_OPEN_INOUTFILE: /* open-input-output-file */ { int prop = 0; pointer p; switch (op) { case OP_OPEN_INFILE: prop = port_input; break; case OP_OPEN_OUTFILE: prop = port_output; break; case OP_OPEN_INOUTFILE: prop = port_input | port_output; break; } p = port_from_filename (SCHEME_A_ strvalue (a), prop); s_return (p == NIL ? S_F : p); } # if USE_STRING_PORTS case OP_OPEN_INSTRING: /* open-input-string */ case OP_OPEN_INOUTSTRING: /* open-input-output-string */ { int prop = 0; pointer p; switch (op) { case OP_OPEN_INSTRING: prop = port_input; break; case OP_OPEN_INOUTSTRING: prop = port_input | port_output; break; } p = port_from_string (SCHEME_A_ strvalue (a), strvalue (a) + strlength (a), prop); s_return (p == NIL ? S_F : p); } case OP_OPEN_OUTSTRING: /* open-output-string */ { pointer p; if (a == NIL) p = port_from_scratch (SCHEME_A); else p = port_from_string (SCHEME_A_ strvalue (a), strvalue (a) + strlength (a), port_output); s_return (p == NIL ? S_F : p); } case OP_GET_OUTSTRING: /* get-output-string */ { port *p; if ((p = a->object.port)->kind & port_string) { off_t size; char *str; size = p->rep.string.curr - p->rep.string.start + 1; str = malloc (size); if (str != NULL) { pointer s; memcpy (str, p->rep.string.start, size - 1); str[size - 1] = '\0'; s = mk_string (SCHEME_A_ str); free (str); s_return (s); } } s_return (S_F); } # endif case OP_CLOSE_INPORT: /* close-input-port */ port_close (SCHEME_A_ a, port_input); s_return (S_T); case OP_CLOSE_OUTPORT: /* close-output-port */ port_close (SCHEME_A_ a, port_output); s_return (S_T); #endif case OP_INT_ENV: /* interaction-environment */ s_return (SCHEME_V->global_env); case OP_CURR_ENV: /* current-environment */ s_return (SCHEME_V->envir); } if (USE_ERROR_CHECKING) abort (); } static int opexe_5 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; pointer x; if (SCHEME_V->nesting != 0) { int n = SCHEME_V->nesting; SCHEME_V->nesting = 0; SCHEME_V->retcode = -1; Error_1 ("unmatched parentheses:", mk_integer (SCHEME_A_ n)); } switch (op) { /* ========== reading part ========== */ #if USE_PORTS case OP_READ: if (!is_pair (args)) s_goto (OP_READ_INTERNAL); if (!is_inport (car (args))) Error_1 ("read: not an input port:", car (args)); if (car (args) == SCHEME_V->inport) s_goto (OP_READ_INTERNAL); x = SCHEME_V->inport; SCHEME_V->inport = car (args); x = cons (x, NIL); s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); s_goto (OP_READ_INTERNAL); case OP_READ_CHAR: /* read-char */ case OP_PEEK_CHAR: /* peek-char */ { int c; if (is_pair (args)) { if (car (args) != SCHEME_V->inport) { x = SCHEME_V->inport; x = cons (x, NIL); s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); SCHEME_V->inport = car (args); } } c = inchar (SCHEME_A); if (c == EOF) s_return (S_EOF); if (SCHEME_V->op == OP_PEEK_CHAR) backchar (SCHEME_A_ c); s_return (mk_character (SCHEME_A_ c)); } case OP_CHAR_READY: /* char-ready? */ { pointer p = SCHEME_V->inport; int res; if (is_pair (args)) p = car (args); res = p->object.port->kind & port_string; s_retbool (res); } case OP_SET_INPORT: /* set-input-port */ SCHEME_V->inport = car (args); s_return (SCHEME_V->value); case OP_SET_OUTPORT: /* set-output-port */ SCHEME_V->outport = car (args); s_return (SCHEME_V->value); #endif case OP_RDSEXPR: switch (SCHEME_V->tok) { case TOK_EOF: s_return (S_EOF); /* NOTREACHED */ case TOK_VEC: s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); /* fall through */ case TOK_LPAREN: SCHEME_V->tok = token (SCHEME_A); if (SCHEME_V->tok == TOK_RPAREN) s_return (NIL); else if (SCHEME_V->tok == TOK_DOT) Error_0 ("syntax error: illegal dot expression"); else { SCHEME_V->nesting_stack[SCHEME_V->file_i]++; s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); s_goto (OP_RDSEXPR); } case TOK_QUOTE: s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); SCHEME_V->tok = token (SCHEME_A); s_goto (OP_RDSEXPR); case TOK_BQUOTE: SCHEME_V->tok = token (SCHEME_A); if (SCHEME_V->tok == TOK_VEC) { s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); SCHEME_V->tok = TOK_LPAREN; s_goto (OP_RDSEXPR); } else s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); s_goto (OP_RDSEXPR); case TOK_COMMA: s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); SCHEME_V->tok = token (SCHEME_A); s_goto (OP_RDSEXPR); case TOK_ATMARK: s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); SCHEME_V->tok = token (SCHEME_A); s_goto (OP_RDSEXPR); case TOK_ATOM: s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))); case TOK_DOTATOM: SCHEME_V->strbuff[0] = '.'; s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); case TOK_STRATOM: x = readstrexp (SCHEME_A_ '|'); //TODO: haven't checked whether the garbage collector could interfere s_return (mk_atom (SCHEME_A_ strvalue (x))); case TOK_DQUOTE: x = readstrexp (SCHEME_A_ '"'); if (x == S_F) Error_0 ("Error reading string"); setimmutable (x); s_return (x); case TOK_SHARP: { pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); if (f == NIL) Error_0 ("undefined sharp expression"); else { SCHEME_V->code = cons (slot_value_in_env (f), NIL); s_goto (OP_EVAL); } } case TOK_SHARP_CONST: if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) Error_0 ("undefined sharp expression"); else s_return (x); default: Error_0 ("syntax error: illegal token"); } break; case OP_RDLIST: SCHEME_V->args = cons (SCHEME_V->value, args); SCHEME_V->tok = token (SCHEME_A); switch (SCHEME_V->tok) { case TOK_EOF: s_return (S_EOF); case TOK_RPAREN: { int c = inchar (SCHEME_A); if (c != '\n') backchar (SCHEME_A_ c); #if SHOW_ERROR_LINE else if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++; #endif SCHEME_V->nesting_stack[SCHEME_V->file_i]--; s_return (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args)); } case TOK_DOT: s_save (SCHEME_A_ OP_RDDOT, SCHEME_V->args, NIL); SCHEME_V->tok = token (SCHEME_A); s_goto (OP_RDSEXPR); default: s_save (SCHEME_A_ OP_RDLIST, SCHEME_V->args, NIL); s_goto (OP_RDSEXPR); } case OP_RDDOT: if (token (SCHEME_A) != TOK_RPAREN) Error_0 ("syntax error: illegal dot expression"); SCHEME_V->nesting_stack[SCHEME_V->file_i]--; s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args)); case OP_RDQUOTE: s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); case OP_RDQQUOTE: s_return (cons (SCHEME_V->QQUOTE, cons (SCHEME_V->value, NIL))); case OP_RDQQUOTEVEC: s_return (cons (mk_symbol (SCHEME_A_ "apply"), cons (mk_symbol (SCHEME_A_ "vector"), cons (cons (SCHEME_V->QQUOTE, cons (SCHEME_V->value, NIL)), NIL)))); case OP_RDUNQUOTE: s_return (cons (SCHEME_V->UNQUOTE, cons (SCHEME_V->value, NIL))); case OP_RDUQTSP: s_return (cons (SCHEME_V->UNQUOTESP, cons (SCHEME_V->value, NIL))); case OP_RDVEC: /*SCHEME_V->code=cons(mk_proc(SCHEME_A_ OP_VECTOR),SCHEME_V->value); s_goto(OP_EVAL); Cannot be quoted */ /*x=cons(mk_proc(SCHEME_A_ OP_VECTOR),SCHEME_V->value); s_return(x); Cannot be part of pairs */ /*SCHEME_V->code=mk_proc(SCHEME_A_ OP_VECTOR); SCHEME_V->args=SCHEME_V->value; s_goto(OP_APPLY); */ SCHEME_V->args = SCHEME_V->value; s_goto (OP_VECTOR); /* ========== printing part ========== */ case OP_P0LIST: if (is_vector (args)) { putstr (SCHEME_A_ "#("); SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0)); s_goto (OP_PVECFROM); } else if (is_environment (args)) { putstr (SCHEME_A_ "#"); s_return (S_T); } else if (!is_pair (args)) { printatom (SCHEME_A_ args, SCHEME_V->print_flag); s_return (S_T); } else { pointer a = car (args); pointer b = cdr (args); int ok_abbr = ok_abbrev (b); SCHEME_V->args = car (b); if (a == SCHEME_V->QUOTE && ok_abbr) putstr (SCHEME_A_ "'"); else if (a == SCHEME_V->QQUOTE && ok_abbr) putstr (SCHEME_A_ "`"); else if (a == SCHEME_V->UNQUOTE && ok_abbr) putstr (SCHEME_A_ ","); else if (a == SCHEME_V->UNQUOTESP && ok_abbr) putstr (SCHEME_A_ ",@"); else { putstr (SCHEME_A_ "("); s_save (SCHEME_A_ OP_P1LIST, b, NIL); SCHEME_V->args = a; } s_goto (OP_P0LIST); } case OP_P1LIST: if (is_pair (args)) { s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); putstr (SCHEME_A_ " "); SCHEME_V->args = car (args); s_goto (OP_P0LIST); } else if (is_vector (args)) { s_save (SCHEME_A_ OP_P1LIST, NIL, NIL); putstr (SCHEME_A_ " . "); s_goto (OP_P0LIST); } else { if (args != NIL) { putstr (SCHEME_A_ " . "); printatom (SCHEME_A_ args, SCHEME_V->print_flag); } putstr (SCHEME_A_ ")"); s_return (S_T); } case OP_PVECFROM: { int i = ivalue_unchecked (cdr (args)); pointer vec = car (args); int len = veclength (vec); if (i == len) { putstr (SCHEME_A_ ")"); s_return (S_T); } else { pointer elem = vector_get (vec, i); ivalue_unchecked (cdr (args)) = i + 1; s_save (SCHEME_A_ OP_PVECFROM, args, NIL); SCHEME_V->args = elem; if (i > 0) putstr (SCHEME_A_ " "); s_goto (OP_P0LIST); } } } if (USE_ERROR_CHECKING) abort (); } static int opexe_6 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; pointer a = car (args); pointer x, y; switch (op) { case OP_LIST_LENGTH: /* length *//* a.k */ { long v = list_length (SCHEME_A_ a); if (v < 0) Error_1 ("length: not a list:", a); s_return (mk_integer (SCHEME_A_ v)); } case OP_ASSQ: /* assq *//* a.k */ x = a; for (y = cadr (args); is_pair (y); y = cdr (y)) { if (!is_pair (car (y))) Error_0 ("unable to handle non pair element"); if (x == caar (y)) break; } if (is_pair (y)) s_return (car (y)); else s_return (S_F); case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ SCHEME_V->args = a; if (SCHEME_V->args == NIL) s_return (S_F); else if (is_closure (SCHEME_V->args)) s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); else if (is_macro (SCHEME_V->args)) s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); else s_return (S_F); case OP_CLOSUREP: /* closure? */ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t */ s_retbool (is_closure (a)); case OP_MACROP: /* macro? */ s_retbool (is_macro (a)); } if (USE_ERROR_CHECKING) abort (); } /* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); typedef int (*test_predicate)(pointer); static int tst_any (pointer p) { return 1; } static int tst_inonneg (pointer p) { return is_integer (p) && ivalue_unchecked (p) >= 0; } static int tst_is_list (SCHEME_P_ pointer p) { return p == NIL || is_pair (p); } /* Correspond carefully with following defines! */ static struct { test_predicate fct; const char *kind; } tests[] = { { tst_any , 0 }, { is_string , "string" }, { is_symbol , "symbol" }, { is_port , "port" }, { is_inport , "input port" }, { is_outport , "output port" }, { is_environment, "environment" }, { is_pair , "pair" }, { 0 , "pair or '()" }, { is_character , "character" }, { is_vector , "vector" }, { is_number , "number" }, { is_integer , "integer" }, { tst_inonneg , "non-negative integer" } }; #define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */ #define TST_ANY "\001" #define TST_STRING "\002" #define TST_SYMBOL "\003" #define TST_PORT "\004" #define TST_INPORT "\005" #define TST_OUTPORT "\006" #define TST_ENVIRONMENT "\007" #define TST_PAIR "\010" #define TST_LIST "\011" #define TST_CHAR "\012" #define TST_VECTOR "\013" #define TST_NUMBER "\014" #define TST_INTEGER "\015" #define TST_NATURAL "\016" #define INF_ARG 0xff #define UNNAMED_OP "" static const char opnames[] = #define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" #include "opdefines.h" #undef OP_DEF ; static const char * opname (int idx) { const char *name = opnames; /* should do this at compile time, but would require external program, right? */ while (idx--) name += strlen (name) + 1; return *name ? name : "ILLEGAL"; } static const char * procname (pointer x) { return opname (procnum (x)); } typedef struct { uint8_t func; /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */ uint8_t builtin; #if USE_ERROR_CHECKING uint8_t min_arity; uint8_t max_arity; char arg_tests_encoding[3]; #endif } op_code_info; static const op_code_info dispatch_table[] = { #if USE_ERROR_CHECKING #define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest }, #else #define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 }, #endif #include "opdefines.h" #undef OP_DEF {0} }; /* kernel of this interpreter */ static void ecb_hot Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) { SCHEME_V->op = op; for (;;) { const op_code_info *pcd = dispatch_table + SCHEME_V->op; #if USE_ERROR_CHECKING if (pcd->builtin) /* if built-in function, check arguments */ { char msg[STRBUFFSIZE]; int n = list_length (SCHEME_A_ SCHEME_V->args); /* Check number of arguments */ if (ecb_expect_false (n < pcd->min_arity)) { snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); xError_1 (SCHEME_A_ msg, 0); continue; } else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG)) { snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); xError_1 (SCHEME_A_ msg, 0); continue; } else { if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */ { int i = 0; int j; const char *t = pcd->arg_tests_encoding; pointer arglist = SCHEME_V->args; do { pointer arg = car (arglist); j = t[0]; /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */ if (j == TST_LIST[0]) { if (!tst_is_list (SCHEME_A_ arg)) break; } else { if (!tests[j - 1].fct (arg)) break; } if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */ t++; arglist = cdr (arglist); i++; } while (i < n); if (i < n) { snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind); xError_1 (SCHEME_A_ msg, 0); continue; } } } } #endif ok_to_freely_gc (SCHEME_A); static const dispatch_func dispatch_funcs[] = { opexe_0, opexe_1, opexe_2, opexe_3, opexe_4, opexe_5, opexe_6, }; if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) return; if (SCHEME_V->no_memory && USE_ERROR_CHECKING) { xwrstr ("No memory!\n"); return; } } } /* ========== Initialization of internal keywords ========== */ static void assign_syntax (SCHEME_P_ const char *name) { pointer x = oblist_add_by_name (SCHEME_A_ name); set_typeflag (x, typeflag (x) | T_SYNTAX); } static void assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) { pointer x = mk_symbol (SCHEME_A_ name); pointer y = mk_proc (SCHEME_A_ op); new_slot_in_env (SCHEME_A_ x, y); } static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op) { pointer y = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (y, (T_PROC | T_ATOM)); ivalue_unchecked (y) = op; 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 */ } } #if USE_MULTIPLICITY ecb_cold scheme * scheme_init_new () { scheme *sc = malloc (sizeof (scheme)); if (!scheme_init (SCHEME_A)) { free (SCHEME_A); return 0; } else return sc; } #endif ecb_cold int scheme_init (SCHEME_P) { int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); pointer x; num_set_fixnum (num_zero, 1); num_set_ivalue (num_zero, 0); num_set_fixnum (num_one, 1); num_set_ivalue (num_one, 1); #if USE_INTERFACE SCHEME_V->vptr = &vtbl; #endif SCHEME_V->gensym_cnt = 0; SCHEME_V->last_cell_seg = -1; SCHEME_V->free_cell = NIL; SCHEME_V->fcells = 0; SCHEME_V->no_memory = 0; SCHEME_V->inport = NIL; SCHEME_V->outport = NIL; SCHEME_V->save_inport = NIL; SCHEME_V->loadport = NIL; SCHEME_V->nesting = 0; SCHEME_V->interactive_repl = 0; if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) { #if USE_ERROR_CHECKING SCHEME_V->no_memory = 1; return 0; #endif } SCHEME_V->gc_verbose = 0; dump_stack_initialize (SCHEME_A); SCHEME_V->code = NIL; SCHEME_V->args = NIL; SCHEME_V->envir = NIL; SCHEME_V->tracing = 0; /* init NIL */ set_typeflag (NIL, T_ATOM | T_MARK); set_car (NIL, NIL); set_cdr (NIL, NIL); /* init T */ set_typeflag (S_T, T_ATOM | T_MARK); set_car (S_T, S_T); set_cdr (S_T, S_T); /* init F */ set_typeflag (S_F, T_ATOM | T_MARK); set_car (S_F, S_F); set_cdr (S_F, S_F); /* init EOF_OBJ */ set_typeflag (S_EOF, T_ATOM | T_MARK); set_car (S_EOF, S_EOF); set_cdr (S_EOF, S_EOF); /* init sink */ set_typeflag (S_SINK, T_PAIR | T_MARK); set_car (S_SINK, NIL); /* init c_nest */ SCHEME_V->c_nest = NIL; SCHEME_V->oblist = oblist_initial_value (SCHEME_A); /* init global_env */ new_frame_in_env (SCHEME_A_ NIL); SCHEME_V->global_env = SCHEME_V->envir; /* init else */ x = mk_symbol (SCHEME_A_ "else"); new_slot_in_env (SCHEME_A_ x, S_T); { static const char *syntax_names[] = { "lambda", "quote", "define", "if", "begin", "set!", "let", "let*", "letrec", "cond", "delay", "and", "or", "cons-stream", "macro", "case" }; for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i) assign_syntax (SCHEME_A_ syntax_names[i]); } // TODO: should iterate via strlen, to avoid n² complexity for (i = 0; i < n; i++) if (dispatch_table[i].builtin) assign_proc (SCHEME_A_ i, opname (i)); /* initialization of global pointers to special symbols */ SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); SCHEME_V->UNQUOTE = mk_symbol (SCHEME_A_ "unquote"); SCHEME_V->UNQUOTESP = mk_symbol (SCHEME_A_ "unquote-splicing"); SCHEME_V->FEED_TO = mk_symbol (SCHEME_A_ "=>"); SCHEME_V->COLON_HOOK = mk_symbol (SCHEME_A_ "*colon-hook*"); SCHEME_V->ERROR_HOOK = mk_symbol (SCHEME_A_ "*error-hook*"); SCHEME_V->SHARP_HOOK = mk_symbol (SCHEME_A_ "*sharp-hook*"); SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*"); return !SCHEME_V->no_memory; } #if USE_PORTS void scheme_set_input_port_file (SCHEME_P_ int fin) { SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); } void scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) { SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); } void scheme_set_output_port_file (SCHEME_P_ int fout) { SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); } void scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) { SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); } #endif void scheme_set_external_data (SCHEME_P_ void *p) { SCHEME_V->ext_data = p; } ecb_cold void scheme_deinit (SCHEME_P) { int i; #if SHOW_ERROR_LINE char *fname; #endif SCHEME_V->oblist = NIL; SCHEME_V->global_env = NIL; dump_stack_free (SCHEME_A); SCHEME_V->envir = NIL; SCHEME_V->code = NIL; SCHEME_V->args = NIL; SCHEME_V->value = NIL; if (is_port (SCHEME_V->inport)) set_typeflag (SCHEME_V->inport, T_ATOM); SCHEME_V->inport = NIL; SCHEME_V->outport = NIL; if (is_port (SCHEME_V->save_inport)) set_typeflag (SCHEME_V->save_inport, T_ATOM); SCHEME_V->save_inport = NIL; if (is_port (SCHEME_V->loadport)) set_typeflag (SCHEME_V->loadport, T_ATOM); SCHEME_V->loadport = NIL; SCHEME_V->gc_verbose = 0; gc (SCHEME_A_ NIL, NIL); for (i = 0; i <= SCHEME_V->last_cell_seg; i++) free (SCHEME_V->alloc_seg[i]); #if SHOW_ERROR_LINE for (i = 0; i <= SCHEME_V->file_i; i++) { if (SCHEME_V->load_stack[i].kind & port_file) { fname = SCHEME_V->load_stack[i].rep.stdio.filename; if (fname) free (fname); } } #endif } void scheme_load_file (SCHEME_P_ int fin) { scheme_load_named_file (SCHEME_A_ fin, 0); } void scheme_load_named_file (SCHEME_P_ int fin, const char *filename) { dump_stack_reset (SCHEME_A); SCHEME_V->envir = SCHEME_V->global_env; SCHEME_V->file_i = 0; SCHEME_V->load_stack[0].unget = -1; SCHEME_V->load_stack[0].kind = port_input | port_file; SCHEME_V->load_stack[0].rep.stdio.file = fin; #if USE_PORTS SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); #endif SCHEME_V->retcode = 0; #if USE_PORTS if (fin == STDIN_FILENO) SCHEME_V->interactive_repl = 1; #endif #if USE_PORTS #if SHOW_ERROR_LINE SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; if (fin != STDIN_FILENO && filename) SCHEME_V->load_stack[0].rep.stdio.filename = store_string (SCHEME_A_ strlen (filename), filename, 0); #endif #endif SCHEME_V->inport = SCHEME_V->loadport; SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); Eval_Cycle (SCHEME_A_ OP_T0LVL); set_typeflag (SCHEME_V->loadport, T_ATOM); if (SCHEME_V->retcode == 0) SCHEME_V->retcode = SCHEME_V->nesting != 0; } void scheme_load_string (SCHEME_P_ const char *cmd) { dump_stack_reset (SCHEME_A); SCHEME_V->envir = SCHEME_V->global_env; SCHEME_V->file_i = 0; SCHEME_V->load_stack[0].kind = port_input | port_string; SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; #if USE_PORTS SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); #endif SCHEME_V->retcode = 0; SCHEME_V->interactive_repl = 0; SCHEME_V->inport = SCHEME_V->loadport; SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); Eval_Cycle (SCHEME_A_ OP_T0LVL); set_typeflag (SCHEME_V->loadport, T_ATOM); if (SCHEME_V->retcode == 0) SCHEME_V->retcode = SCHEME_V->nesting != 0; } void scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) { pointer x; x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); if (x != NIL) set_slot_in_env (SCHEME_A_ x, value); else new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); } #if !STANDALONE void scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) { scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); } void scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) { int i; for (i = 0; i < count; i++) scheme_register_foreign_func (SCHEME_A_ list + i); } pointer scheme_apply0 (SCHEME_P_ const char *procname) { return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); } void save_from_C_call (SCHEME_P) { pointer saved_data = cons (car (S_SINK), cons (SCHEME_V->envir, SCHEME_V->dump)); /* Push */ SCHEME_V->c_nest = cons (saved_data, SCHEME_V->c_nest); /* Truncate the dump stack so TS will return here when done, not directly resume pre-C-call operations. */ dump_stack_reset (SCHEME_A); } void restore_from_C_call (SCHEME_P) { set_car (S_SINK, caar (SCHEME_V->c_nest)); SCHEME_V->envir = cadar (SCHEME_V->c_nest); SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); /* Pop */ SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); } /* "func" and "args" are assumed to be already eval'ed. */ pointer scheme_call (SCHEME_P_ pointer func, pointer args) { int old_repl = SCHEME_V->interactive_repl; SCHEME_V->interactive_repl = 0; save_from_C_call (SCHEME_A); SCHEME_V->envir = SCHEME_V->global_env; SCHEME_V->args = args; SCHEME_V->code = func; SCHEME_V->retcode = 0; Eval_Cycle (SCHEME_A_ OP_APPLY); SCHEME_V->interactive_repl = old_repl; restore_from_C_call (SCHEME_A); return SCHEME_V->value; } pointer scheme_eval (SCHEME_P_ pointer obj) { int old_repl = SCHEME_V->interactive_repl; SCHEME_V->interactive_repl = 0; save_from_C_call (SCHEME_A); SCHEME_V->args = NIL; SCHEME_V->code = obj; SCHEME_V->retcode = 0; Eval_Cycle (SCHEME_A_ OP_EVAL); SCHEME_V->interactive_repl = old_repl; restore_from_C_call (SCHEME_A); return SCHEME_V->value; } #endif /* ========== Main ========== */ #if STANDALONE int main (int argc, char **argv) { # if USE_MULTIPLICITY scheme ssc; scheme *const SCHEME_V = &ssc; # else # endif int fin; char *file_name = InitFile; int retcode; int isfile = 1; if (argc == 2 && strcmp (argv[1], "-?") == 0) { xwrstr ("Usage: tinyscheme -?\n"); xwrstr ("or: tinyscheme [ ...]\n"); xwrstr ("followed by\n"); xwrstr (" -1 [ ...]\n"); xwrstr (" -c [ ...]\n"); xwrstr ("assuming that the executable is named tinyscheme.\n"); xwrstr ("Use - as filename for stdin.\n"); return 1; } if (!scheme_init (SCHEME_A)) { xwrstr ("Could not initialize!\n"); return 2; } # if USE_PORTS scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); scheme_set_output_port_file (SCHEME_A_ STDOUT_FILENO); # endif argv++; #if 0 if (access (file_name, 0) != 0) { char *p = getenv ("TINYSCHEMEINIT"); if (p != 0) file_name = p; } #endif do { #if USE_PORTS if (strcmp (file_name, "-") == 0) fin = STDIN_FILENO; else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) { pointer args = NIL; isfile = file_name[1] == '1'; file_name = *argv++; if (strcmp (file_name, "-") == 0) fin = STDIN_FILENO; else if (isfile) fin = open (file_name, O_RDONLY); for (; *argv; argv++) { pointer value = mk_string (SCHEME_A_ * argv); args = cons (value, args); } args = reverse_in_place (SCHEME_A_ NIL, args); scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); } else fin = open (file_name, O_RDONLY); #endif if (isfile && fin < 0) { xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); } else { if (isfile) scheme_load_named_file (SCHEME_A_ fin, file_name); else scheme_load_string (SCHEME_A_ file_name); #if USE_PORTS if (!isfile || fin != STDIN_FILENO) { if (SCHEME_V->retcode != 0) { xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); } if (isfile) close (fin); } #endif } file_name = *argv++; } while (file_name != 0); if (argc == 1) scheme_load_named_file (SCHEME_A_ STDIN_FILENO, 0); retcode = SCHEME_V->retcode; scheme_deinit (SCHEME_A); return retcode; } #endif /* Local variables: c-file-style: "k&r" End: */