/* * µ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 _POSIX_C_SOURCE 200201 #define _XOPEN_SOURCE 600 #define _GNU_SOURCE 1 /* for malloc mremap */ #define SCHEME_SOURCE #include "scheme-private.h" #ifndef WIN32 # include #endif #if USE_MATH # include #endif #define ECB_NO_THREADS 1 #include "ecb.h" #include #include #include #if !USE_ERROR_CHECKING # define NDEBUG #endif #include #include #include #include #include #include #if !USE_SYSTEM_MALLOC # define PAGE_SIZE 4096 /* does not work on sparc/alpha */ # include "malloc.c" # define malloc(n) tiny_malloc (n) # define realloc(p,n) tiny_realloc (p, n) # define free(p) tiny_free (p) #endif #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 WHITESPACE " \t\r\n\v\f" #define DELIMITERS "()\";" WHITESPACE #define NIL POINTER (&SCHEME_V->xNIL) #define S_T POINTER (&SCHEME_V->xT) #define S_F POINTER (&SCHEME_V->xF) #define S_SINK POINTER (&SCHEME_V->xsink) #define S_EOF POINTER (&SCHEME_V->xEOF_OBJ) #if !USE_MULTIPLICITY static scheme sc; #endif ecb_cold static void xbase (char *s, long n, int base) { if (n < 0) { *s++ = '-'; n = -n; } char *p = s; do { *p++ = "0123456789abcdef"[n % base]; n /= base; } while (n); *p-- = 0; while (p > s) { char x = *s; *s = *p; *p = x; --p; ++s; } } ecb_cold static void xnum (char *s, long n) { xbase (s, n, 10); } ecb_cold static void putnum (SCHEME_P_ long n) { char buf[64]; xnum (buf, n); putstr (SCHEME_A_ buf); } #if USE_CHAR_CLASSIFIERS #include #else 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) #endif #if USE_IGNORECASE ecb_cold 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 "ms> " #endif #ifndef InitFile # define InitFile "init.scm" #endif enum scheme_types { T_INTEGER, T_CHARACTER, T_REAL, T_STRING, T_SYMBOL, T_PROC, T_PAIR, /* also used for free cells */ T_CLOSURE, T_BYTECODE, // temp T_MACRO, T_CONTINUATION, T_FOREIGN, T_PORT, T_VECTOR, T_PROMISE, T_ENVIRONMENT, T_SPECIAL, // #t, #f, '(), eof-object T_NUM_SYSTEM_TYPES }; #define T_MASKTYPE 0x001f #define T_SYNTAX 0x0020 #define T_IMMUTABLE 0x0040 #define T_ATOM 0x0080 /* 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); static int is_zero_rvalue (RVALUE x); static num num_zero; static num num_one; /* convert "pointer" to cell* / cell* to pointer */ #define CELL(p) ((struct cell *)(p) + 0) #define POINTER(c) ((void *)((c) - 0)) /* macros for cell operations */ #define typeflag(p) (CELL(p)->flag + 0) #define set_typeflag(p,v) (CELL(p)->flag = (v)) #define type(p) (typeflag (p) & T_MASKTYPE) INTERFACE int is_string (pointer p) { return type (p) == T_STRING; } #define strvalue(p) (CELL(p)->object.string.svalue) #define strlength(p) (CELL(p)->object.string.length) INTERFACE int is_vector (pointer p) { return type (p) == T_VECTOR; } #define vecvalue(p) (CELL(p)->object.vector.vvalue) #define veclength(p) (CELL(p)->object.vector.length) INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); INTERFACE pointer vector_get (pointer vec, uint32_t ielem); INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 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) CELL(p)->object.ivalue #define set_ivalue(p,v) CELL(p)->object.ivalue = (v) #if USE_REAL #define rvalue_unchecked(p) CELL(p)->object.rvalue #define set_rvalue(p,v) CELL(p)->object.rvalue = (v) #else #define rvalue_unchecked(p) CELL(p)->object.ivalue #define set_rvalue(p,v) CELL(p)->object.ivalue = (v) #endif INTERFACE long charvalue (pointer p) { return ivalue_unchecked (p); } #define port(p) CELL(p)->object.port #define set_port(p,v) port(p) = (v) INTERFACE int is_port (pointer p) { return type (p) == T_PORT; } INTERFACE int is_inport (pointer p) { return is_port (p) && port (p)->kind & port_input; } INTERFACE int is_outport (pointer p) { return is_port (p) && port (p)->kind & port_output; } INTERFACE int is_pair (pointer p) { return type (p) == T_PAIR; } #define car(p) (POINTER (CELL(p)->object.cons.car)) #define cdr(p) (POINTER (CELL(p)->object.cons.cdr)) static pointer caar (pointer p) { return car (car (p)); } static pointer cadr (pointer p) { return car (cdr (p)); } 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))); } static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); } INTERFACE void set_car (pointer p, pointer q) { CELL(p)->object.cons.car = CELL (q); } INTERFACE void set_cdr (pointer p, pointer q) { CELL(p)->object.cons.cdr = CELL (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 (p); } #if USE_PLIST #error plists are broken because symbols are no longer pairs #define symprop(p) cdr(p) SCHEME_EXPORT int hasprop (pointer p) { return typeflag (p) & T_SYMBOL; } #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 (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) #if 1 #define is_mark(p) (CELL(p)->mark) #define setmark(p) (CELL(p)->mark = 1) #define clrmark(p) (CELL(p)->mark = 0) #else #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) #endif 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 */ ecb_hot 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" }; ecb_cold 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); ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); static void finalize_cell (SCHEME_P_ pointer a); 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); static pointer mk_port (SCHEME_P_ port *p); #if USE_PORTS 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); static 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; } 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 */ ecb_cold static int alloc_cellseg (SCHEME_P) { struct cell *newp; struct cell *last; struct cell *p; char *cp; long i; int k; static int segsize = CELL_SEGSIZE >> 1; segsize <<= 1; cp = malloc (segsize * sizeof (struct cell)); if (!cp && USE_ERROR_CHECKING) return k; i = ++SCHEME_V->last_cell_seg; newp = (struct cell *)cp; SCHEME_V->cell_seg[i] = newp; SCHEME_V->cell_segsize[i] = segsize; SCHEME_V->fcells += segsize; last = newp + segsize - 1; for (p = newp; p <= last; p++) { pointer cp = POINTER (p); clrmark (cp); set_typeflag (cp, T_PAIR); set_car (cp, NIL); set_cdr (cp, POINTER (p + 1)); } set_cdr (POINTER (last), SCHEME_V->free_cell); SCHEME_V->free_cell = POINTER (newp); return 1; } /* get new cell. parameter a, b is marked by gc. */ 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->cell_segsize [SCHEME_V->last_cell_seg] >> 2; 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) && 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 */ ecb_hot 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); } ecb_hot 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_ NIL, NIL); 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); CELL(v)->object.vector.vvalue = e; CELL(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) putstr (SCHEME_A_ "Cell is already allocated!\n"); if (!(typeflag (p)) & expect_alloced) putstr (SCHEME_A_ "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 */ ecb_hot static pointer xcons (SCHEME_P_ pointer a, pointer b) { pointer x = get_cell (SCHEME_A_ a, b); set_typeflag (x, T_PAIR); set_car (x, a); set_cdr (x, b); return x; } ecb_hot static pointer ximmutable_cons (SCHEME_P_ pointer a, pointer b) { pointer x = xcons (SCHEME_A_ a, b); setimmutable (x); return x; } #define cons(a,b) xcons (SCHEME_A_ a, b) #define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b) ecb_cold static pointer generate_symbol (SCHEME_P_ const char *name) { pointer x = mk_string (SCHEME_A_ name); setimmutable (x); set_typeflag (x, T_SYMBOL | T_ATOM); return x; } /* ========== oblist implementation ========== */ #ifndef USE_OBJECT_LIST static int hash_fn (const char *key, int table_size) { const unsigned char *p = (unsigned char *)key; uint32_t hash = 2166136261U; while (*p) hash = (hash ^ *p++) * 16777619; return hash % table_size; } ecb_cold static pointer oblist_initial_value (SCHEME_P) { return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ } /* returns the new symbol */ ecb_cold 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_cold static 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; } ecb_cold 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 ecb_cold static pointer oblist_initial_value (SCHEME_P) { return NIL; } ecb_cold static 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 */ ecb_cold static pointer oblist_add_by_name (SCHEME_P_ const char *name) { pointer x = generate_symbol (SCHEME_A_ name); SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); return x; } ecb_cold static pointer oblist_all_symbols (SCHEME_P) { return SCHEME_V->oblist; } #endif ecb_cold static pointer mk_port (SCHEME_P_ port *p) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_PORT | T_ATOM); set_port (x, p); return x; } ecb_cold pointer mk_foreign_func (SCHEME_P_ foreign_func f) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_FOREIGN | T_ATOM); CELL(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 p = 0; pointer *pp = &p; #if USE_INTCACHE if (n >= INTCACHE_MIN && n <= INTCACHE_MAX) pp = &SCHEME_V->intcache[n - INTCACHE_MIN]; #endif if (!*pp) { pointer x = get_cell (SCHEME_A_ NIL, NIL); set_typeflag (x, T_INTEGER | T_ATOM); setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */ set_ivalue (x, n); *pp = x; } return *pp; } INTERFACE pointer 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 void vector_resize (pointer vec, uint32_t newsize, pointer fill) { uint32_t oldsize = veclength (vec); vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer)); veclength (vec) = newsize; fill_vector (vec, oldsize, fill); } 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; } ecb_cold INTERFACE pointer gensym (SCHEME_P) { pointer x; char name[40] = "gensym-"; xnum (name + 7, ++SCHEME_V->gensym_cnt); return generate_symbol (SCHEME_A_ name); } static int is_gensym (SCHEME_P_ pointer x) { return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; } /* make symbol or number atom from string */ ecb_cold 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 */ ecb_cold 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; // TODO: optimise 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 (stricmp (name + 1, "alarm") == 0) c = 0x07; else if (stricmp (name + 1, "backspace") == 0) c = 0x08; else if (stricmp (name + 1, "escape") == 0) c = 0x1b; else if (stricmp (name + 1, "delete") == 0) c = 0x7f; else if (stricmp (name + 1, "null") == 0) c = 0; 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 ========== */ static void finalize_cell (SCHEME_P_ pointer a) { /* TODO, fast bitmap check? */ if (is_string (a) || is_symbol (a)) free (strvalue (a)); else if (is_vector (a)) free (vecvalue (a)); #if USE_PORTS else if (is_port (a)) { if (port(a)->kind & port_file && port (a)->rep.stdio.closeit) port_close (SCHEME_A_ a, port_input | port_output); free (port (a)); } #endif } /*-- * 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 */ ecb_hot 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; } } ecb_hot static void gc_free (SCHEME_P) { int i; uint32_t total = 0; /* Here we scan the cells to build the free-list. */ for (i = SCHEME_V->last_cell_seg; i >= 0; i--) { struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; struct cell *p; total += SCHEME_V->cell_segsize [i]; for (p = SCHEME_V->cell_seg[i]; p < end; ++p) { pointer c = POINTER (p); if (is_mark (c)) clrmark (c); else { /* reclaim cell */ if (typeflag (c) != T_PAIR) { finalize_cell (SCHEME_A_ c); set_typeflag (c, T_PAIR); set_car (c, NIL); } ++SCHEME_V->fcells; set_cdr (c, SCHEME_V->free_cell); SCHEME_V->free_cell = c; } } } if (SCHEME_V->gc_verbose) { putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n"); } } /* garbage collection. parameter a, b is marked. */ ecb_cold static void gc (SCHEME_P_ pointer a, pointer b) { 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); #if USE_INTCACHE /* mark intcache */ for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i) if (SCHEME_V->intcache[i - INTCACHE_MIN]) mark (SCHEME_V->intcache[i - INTCACHE_MIN]); #endif /* mark variables a, b */ mark (a); mark (b); /* garbage collect */ clrmark (NIL); SCHEME_V->fcells = 0; SCHEME_V->free_cell = NIL; if (SCHEME_V->gc_verbose) putstr (SCHEME_A_ "freeing..."); gc_free (SCHEME_A); } /* ========== Routines for Reading ========== */ ecb_cold static int file_push (SCHEME_P_ const char *fname) { 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; set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); #if SHOW_ERROR_LINE SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 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; } ecb_cold 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--; set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); } } ecb_cold 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 && (port (SCHEME_V->inport)->kind & port_file); #else return 0; #endif } #if USE_PORTS ecb_cold 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; } ecb_cold 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); } ecb_cold 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; } ecb_cold 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); } ecb_cold 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; } ecb_cold 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 ecb_cold 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; } ecb_cold 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); } ecb_cold static void port_close (SCHEME_P_ pointer p, int flag) { port *pt = port (p); 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 */ ecb_cold static int inchar (SCHEME_P) { int c; port *pt = port (SCHEME_V->inport); 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; } ecb_cold static int basic_inchar (port *pt) { if (pt->unget != -1) { int r = pt->unget; pt->unget = -1; return r; } #if USE_PORTS 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 char c; if (!read (pt->rep.stdio.file, &c, 1)) return EOF; return c; #endif } /* back character to input buffer */ ecb_cold static void backchar (SCHEME_P_ int c) { port *pt = port (SCHEME_V->inport); if (c == EOF) return; pt->unget = c; } #if USE_PORTS ecb_cold 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 ecb_cold static void putchars (SCHEME_P_ const char *s, int len) { port *pt = port (SCHEME_V->outport); #if USE_PORTS 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); // output not initialised #endif } INTERFACE void putstr (SCHEME_P_ const char *s) { putchars (SCHEME_A_ s, strlen (s)); } INTERFACE void putcharacter (SCHEME_P_ int c) { char cc = c; putchars (SCHEME_A_ &cc, 1); } /* read characters up to delimiter, but cater to character constants */ ecb_cold 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" */ ecb_cold 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 'a': *p++ = '\a'; state = st_ok; break; case 'n': *p++ = '\n'; state = st_ok; break; case 'r': *p++ = '\r'; state = st_ok; break; case 't': *p++ = '\t'; state = st_ok; break; // this overshoots the minimum requirements of r7rs case ' ': case '\t': case '\r': case '\n': skipspace (SCHEME_A); state = st_ok; break; //TODO: x should end in ;, not two-digit hex case 'x': case 'X': state = st_x1; c1 = 0; 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_cold int is_one_of (const char *s, int c) { return c == EOF || !!strchr (s, c); } /* skip white characters */ ecb_cold int skipspace (SCHEME_P) { int c, curr_line = 0; do { c = inchar (SCHEME_A); #if SHOW_ERROR_LINE if (ecb_expect_false (c == '\n')) curr_line++; #endif if (ecb_expect_false (c == EOF)) return c; } while (is_one_of (WHITESPACE, c)); /* 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 backchar (SCHEME_A_ c); return 1; } /* get token */ ecb_cold 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 (WHITESPACE, 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) ecb_cold 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 */ ecb_cold 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 */ ecb_cold 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 { #if USE_PRINTF p = SCHEME_V->strbuff; snprintf (p, STRBUFFSIZE, "#", (int)typeflag (l)); #else p = "#"; #endif } *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 (cddr (p) != NIL) { d = cons (car (p), cdr (p)); if (cddr (p) != NIL) p = cdr (d); } set_cdr (p, cadr (p)); return q; } /* reverse list -- produce new list */ ecb_hot 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 */ ecb_hot 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) */ ecb_hot 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 */ ecb_hot 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))); } ecb_hot 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 */ static void new_frame_in_env (SCHEME_P_ pointer old_env) { SCHEME_V->envir = immutable_cons (NIL, old_env); setenvironment (SCHEME_V->envir); } static 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))); } ecb_hot 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 */ static void new_slot_in_env (SCHEME_P_ pointer variable, pointer value) { assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); } static void set_slot_in_env (SCHEME_P_ pointer slot, pointer value) { set_cdr (slot, value); } static pointer slot_value_in_env (pointer slot) { return cdr (slot); } /* ========== Evaluation Cycle ========== */ ecb_cold static int xError_1 (SCHEME_P_ const char *s, pointer a) { #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 pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 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 ecb_hot 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 (ecb_expect_false (nframes >= SCHEME_V->dump_size)) { SCHEME_V->dump_size += STACK_GROWTH; SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); } 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 ecb_hot 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_cold 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_cold void dump_stack_initialize (SCHEME_P) { SCHEME_V->dump_size = 0; SCHEME_V->dump_base = 0; dump_stack_reset (SCHEME_A); } ecb_cold 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; } ecb_cold 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); } } ecb_cold 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; } ecb_cold 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_cold void dump_stack_reset (SCHEME_P) { SCHEME_V->dump = NIL; } ecb_cold void dump_stack_initialize (SCHEME_P) { dump_stack_reset (SCHEME_A); } ecb_cold static void dump_stack_free (SCHEME_P) { SCHEME_V->dump = NIL; } ecb_hot 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; } ecb_hot 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)))); } ecb_cold static void dump_stack_mark (SCHEME_P) { mark (SCHEME_V->dump); } ecb_cold static pointer ss_get_cont (SCHEME_P) { return SCHEME_V->dump; } ecb_cold 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) #if EXPERIMENT static int dtree (SCHEME_P_ int indent, pointer x) { int c; if (is_syntax (x)) { printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x)); return 8 + 8; } if (x == NIL) { printf ("%*sNIL\n", indent, ""); return 3; } switch (type (x)) { case T_INTEGER: printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x); return 32+8; case T_SYMBOL: printf ("%*sS<%s>\n", indent, "", symname (x)); return 24+8; case T_CLOSURE: printf ("%*sS<%s>\n", indent, "", "closure"); dtree (SCHEME_A_ indent + 3, cdr(x)); return 32 + dtree (SCHEME_A_ indent + 3, car (x)); case T_PAIR: printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); c = dtree (SCHEME_A_ indent + 3, car (x)); c += dtree (SCHEME_A_ indent + 3, cdr (x)); return c + 1; case T_PORT: printf ("%*sS<%s>\n", indent, "", "port"); return 24+8; case T_VECTOR: printf ("%*sS<%s>\n", indent, "", "vector"); return 24+8; case T_ENVIRONMENT: printf ("%*sS<%s>\n", indent, "", "environment"); return 0 + dtree (SCHEME_A_ indent + 3, car (x)); default: printf ("unhandled type %d\n", type (x)); break; } } #define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0) typedef void *stream[1]; #define stream_init() { 0 } #define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2) #define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2) #define stream_free(s) free (s[0]) ecb_cold static void stream_put (stream s, uint8_t byte) { uint32_t *sp = *s; uint32_t size = sizeof (uint32_t) * 2; uint32_t offs = size; if (ecb_expect_true (sp)) { offs = sp[0]; size = sp[1]; } if (ecb_expect_false (offs == size)) { size *= 2; sp = realloc (sp, size); *s = sp; sp[1] = size; } ((uint8_t *)sp)[offs++] = byte; sp[0] = offs; } ecb_cold static void stream_put_v (stream s, uint32_t v) { while (v > 0x7f) { stream_put (s, v | 0x80); v >>= 7; } stream_put (s, v); } ecb_cold static void stream_put_tv (stream s, int bop, uint32_t v) { printf ("put tv %d %d\n", bop, v);//D stream_put (s, bop); stream_put_v (s, v); } ecb_cold static void stream_put_stream (stream s, stream o) { uint32_t i; for (i = 0; i < stream_size (o); ++i) stream_put (s, stream_data (o)[i]); stream_free (o); } ecb_cold static uint32_t cell_id (SCHEME_P_ pointer x) { struct cell *p = CELL (x); int i; for (i = SCHEME_V->last_cell_seg; i >= 0; --i) if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i]) return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG); abort (); } // calculates a (preferably small) integer that makes it possible to find // the symbol again. if pointers were offsets into a memory area... until // then, we return segment number in the low bits, and offset in the high // bits. // also, this function must never return 0. ecb_cold static uint32_t symbol_id (SCHEME_P_ pointer sym) { return cell_id (SCHEME_A_ sym); } enum byteop { BOP_NIL, BOP_INTEGER, BOP_SYMBOL, BOP_DATUM, BOP_LIST_BEG, BOP_LIST_END, BOP_IF, BOP_AND, BOP_OR, BOP_CASE, BOP_COND, BOP_LET, BOP_LETAST, BOP_LETREC, BOP_DEFINE, BOP_MACRO, BOP_SET, BOP_BEGIN, BOP_LAMBDA, BOP_OP, }; ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x); ecb_cold static void compile_list (SCHEME_P_ stream s, pointer x) { // TODO: improper list for (; x != NIL; x = cdr (x)) { stream t = stream_init (); compile_expr (SCHEME_A_ t, car (x)); stream_put_v (s, stream_size (t)); stream_put_stream (s, t); } stream_put_v (s, 0); } static void compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff) { stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift); stream_put (s, BOP_IF); compile_expr (SCHEME_A_ s, cond); stream_put_v (s, stream_size (sift)); stream_put_stream (s, sift); compile_expr (SCHEME_A_ s, iff); } typedef uint32_t stream_fixup; static stream_fixup stream_put_fixup (stream s) { stream_put (s, 0); stream_put (s, 0); return stream_size (s); } static void stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target) { target -= fixup; assert (target < (1 << 14)); stream_data (s)[fixup - 2] = target | 0x80; stream_data (s)[fixup - 1] = target >> 7; } static void compile_and_or (SCHEME_P_ stream s, int and, pointer x) { for (; cdr (x) != NIL; x = cdr (x)) { stream t = stream_init (); compile_expr (SCHEME_A_ t, car (x)); stream_put_v (s, stream_size (t)); stream_put_stream (s, t); } stream_put_v (s, 0); } static void compile_case (SCHEME_P_ stream s, pointer x) { compile_expr (SCHEME_A_ s, caar (x)); for (;;) { x = cdr (x); if (x == NIL) break; compile_expr (SCHEME_A_ s, caar (x)); stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x)); stream_put_v (s, stream_size (t)); stream_put_stream (s, t); } stream_put_v (s, 0); } static void compile_cond (SCHEME_P_ stream s, pointer x) { for ( ; x != NIL; x = cdr (x)) { compile_expr (SCHEME_A_ s, caar (x)); stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x)); stream_put_v (s, stream_size (t)); stream_put_stream (s, t); } stream_put_v (s, 0); } static pointer lookup (SCHEME_P_ pointer x) { x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1); if (x != NIL) x = slot_value_in_env (x); return x; } ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x) { if (x == NIL) { stream_put (s, BOP_NIL); return; } if (is_pair (x)) { pointer head = car (x); if (is_syntax (head)) { x = cdr (x); switch (syntaxnum (head)) { case OP_IF0: /* if */ stream_put_v (s, BOP_IF); compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x)); break; case OP_OR0: /* or */ stream_put_v (s, BOP_OR); compile_and_or (SCHEME_A_ s, 0, x); break; case OP_AND0: /* and */ stream_put_v (s, BOP_AND); compile_and_or (SCHEME_A_ s, 1, x); break; case OP_CASE0: /* case */ stream_put_v (s, BOP_CASE); compile_case (SCHEME_A_ s, x); break; case OP_COND0: /* cond */ stream_put_v (s, BOP_COND); compile_cond (SCHEME_A_ s, x); break; case OP_LET0: /* let */ case OP_LET0AST: /* let* */ case OP_LET0REC: /* letrec */ switch (syntaxnum (head)) { case OP_LET0: stream_put (s, BOP_LET ); break; case OP_LET0AST: stream_put (s, BOP_LETAST); break; case OP_LET0REC: stream_put (s, BOP_LETREC); break; } { pointer bindings = car (x); pointer body = cadr (x); for (x = bindings; x != NIL; x = cdr (x)) { pointer init = NIL; pointer var = car (x); if (is_pair (var)) { init = cdr (var); var = car (var); } stream_put_v (s, symbol_id (SCHEME_A_ var)); compile_expr (SCHEME_A_ s, init); } stream_put_v (s, 0); compile_expr (SCHEME_A_ s, body); } break; case OP_DEF0: /* define */ case OP_MACRO0: /* macro */ stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO); stream_put_v (s, cell_id (SCHEME_A_ car (x))); compile_expr (SCHEME_A_ s, cadr (x)); break; case OP_SET0: /* set! */ stream_put (s, BOP_SET); stream_put_v (s, symbol_id (SCHEME_A_ car (x))); compile_expr (SCHEME_A_ s, cadr (x)); break; case OP_BEGIN: /* begin */ stream_put (s, BOP_BEGIN); compile_list (SCHEME_A_ s, x); return; case OP_DELAY: /* delay */ abort (); break; case OP_QUOTE: /* quote */ stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x)); break; case OP_LAMBDA: /* lambda */ { pointer formals = car (x); pointer body = cadr (x); stream_put (s, BOP_LAMBDA); for (; is_pair (formals); formals = cdr (formals)) stream_put_v (s, symbol_id (SCHEME_A_ car (formals))); stream_put_v (s, 0); stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals)); compile_expr (SCHEME_A_ s, body); } break; case OP_C0STREAM:/* cons-stream */ abort (); break; } return; } pointer m = lookup (SCHEME_A_ head); if (is_macro (m)) { s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code); SCHEME_V->code = m; SCHEME_V->args = cons (x, NIL); Eval_Cycle (SCHEME_A_ OP_APPLY); x = SCHEME_V->value; compile_expr (SCHEME_A_ s, SCHEME_V->value); return; } stream_put (s, BOP_LIST_BEG); for (; x != NIL; x = cdr (x)) compile_expr (SCHEME_A_ s, car (x)); stream_put (s, BOP_LIST_END); return; } switch (type (x)) { case T_INTEGER: { IVALUE iv = ivalue_unchecked (x); iv = iv < 0 ? ((~(uint32_t)iv) << 1) | 1 : (uint32_t)iv << 1; stream_put_tv (s, BOP_INTEGER, iv); } return; case T_SYMBOL: if (0) { // no can do without more analysis pointer m = lookup (SCHEME_A_ x); if (is_proc (m)) { printf ("compile proc %s %d\n", procname(m), procnum(m)); stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m)); } else stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x)); } stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x)); return; default: stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x)); break; } } ecb_cold static int compile_closure (SCHEME_P_ pointer p) { stream s = stream_init (); compile_list (SCHEME_A_ s, cdar (p)); FILE *xxd = popen ("xxd", "we"); fwrite (stream_data (s), 1, stream_size (s), xxd); fclose (xxd); return stream_size (s); } #endif /* syntax, eval, core, ... */ ecb_hot static int opexe_0 (SCHEME_P_ enum scheme_opcodes op) { pointer args = SCHEME_V->args; pointer x, y; switch (op) { #if EXPERIMENT //D case OP_DEBUG: { uint32_t len = compile_closure (SCHEME_A_ car (args)); printf ("len = %d\n", len); printf ("\n"); s_return (S_T); } case OP_DEBUG2: return -1; #endif case OP_LOAD: /* load */ if (file_interactive (SCHEME_A)) { putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putcharacter (SCHEME_A_ '\n'); } if (!file_push (SCHEME_A_ strvalue (car (args)))) Error_1 ("unable to open", car (args)); 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 (port (SCHEME_V->loadport)->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); putcharacter (SCHEME_A_ '\n'); #if EXPERIMENT system ("ps v $PPID"); #endif 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); } 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) Error_1 ("eval: unbound variable:", SCHEME_V->code); s_return (slot_value_in_env (x)); } 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); } } s_return (SCHEME_V->code); case OP_E0ARGS: /* eval arguments */ if (ecb_expect_false (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); } 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 = CELL(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); } Error_0 ("illegal function"); case OP_DOMACRO: /* do macro */ SCHEME_V->code = SCHEME_V->value; s_goto (OP_EVAL); 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)); 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) */ 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 let/letrec:", car (SCHEME_V->code)); s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code)); SCHEME_V->code = cadar (SCHEME_V->code); SCHEME_V->args = NIL; s_goto (OP_EVAL); } /* end */ args = reverse_in_place (SCHEME_A_ NIL, args); SCHEME_V->code = car (args); SCHEME_V->args = cdr (args); s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC); 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); } /* 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); /* OP_LET1REC handled by OP_LET1 */ 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); 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); 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); 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); } } s_return (NIL); case OP_CASE2: /* case */ if (is_true (SCHEME_V->value)) s_goto (OP_BEGIN); 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 (); } /* math, cxr */ ecb_hot 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)) { RVALUE r = rvalue_unchecked (x); if (r == (RVALUE)(IVALUE)r) x = mk_integer (SCHEME_A_ rvalue_unchecked (x)); else Error_1 ("inexact->exact: not integral:", x); } s_return (x); 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: s_return (mk_real (SCHEME_A_ trunc (rvalue (x)))); case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x)))); case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (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)) / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args)))))); 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: s_return (mk_real (SCHEME_A_ cdr (args) == NIL ? atan (rvalue (x)) : atan2 (rvalue (x), rvalue (cadr (args))))); 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)); } #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)); /* the compiler will optimize this mess... */ case OP_CAR: op_car: s_return (car (x)); case OP_CDR: op_cdr: s_return (cdr (x)); case OP_CAAR: op_caar: x = car (x); goto op_car; case OP_CADR: op_cadr: x = cdr (x); goto op_car; case OP_CDAR: op_cdar: x = car (x); goto op_cdr; case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr; case OP_CAAAR: op_caaar: x = car (x); goto op_caar; case OP_CAADR: op_caadr: x = cdr (x); goto op_caar; case OP_CADAR: op_cadar: x = car (x); goto op_cadr; case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr; case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar; case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar; case OP_CDDAR: op_cddar: x = car (x); goto op_cddr; case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr; case OP_CAAAAR: x = car (x); goto op_caaar; case OP_CAAADR: x = cdr (x); goto op_caaar; case OP_CAADAR: x = car (x); goto op_caadr; case OP_CAADDR: x = cdr (x); goto op_caadr; case OP_CADAAR: x = car (x); goto op_cadar; case OP_CADADR: x = cdr (x); goto op_cadar; case OP_CADDAR: x = car (x); goto op_caddr; case OP_CADDDR: x = cdr (x); goto op_caddr; case OP_CDAAAR: x = car (x); goto op_cdaar; case OP_CDAADR: x = cdr (x); goto op_cdaar; case OP_CDADAR: x = car (x); goto op_cdadr; case OP_CDADDR: x = cdr (x); goto op_cdadr; case OP_CDDAAR: x = car (x); goto op_cddar; case OP_CDDADR: x = cdr (x); goto op_cddar; case OP_CDDDAR: x = car (x); goto op_cdddr; case OP_CDDDDR: x = cdr (x); goto op_cdddr; case OP_CONS: /* cons */ set_cdr (args, cadr (args)); 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_STRING_COPY: /* substring/string-copy */ { char *str = strvalue (x); int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args)); int index1; int len; if (index0 > strlength (x)) Error_1 ("string->copy: start out of bounds:", cadr (args)); if (cddr (args) != NIL) { index1 = ivalue_unchecked (caddr (args)); if (index1 > strlength (x) || index1 < index0) Error_1 ("string->copy: end out of bounds:", caddr (args)); } else index1 = strlength (x); len = index1 - index0; x = mk_counted_string (SCHEME_A_ str + index0, len); 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_VECRESIZE: vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args)); s_return (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 (); } /* relational ops */ ecb_hot 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); } /* predicates */ ecb_hot 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_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break; case OP_NUMBERP: /* number? */ r = is_number (a) ; break; case OP_STRINGP: /* string? */ r = is_string (a) ; break; case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ case OP_CHARP: /* char? */ r = is_character (a) ; break; #if USE_CHAR_CLASSIFIERS case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 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); } /* promises, list ops, ports */ ecb_hot 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 */ *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); s_return (SCHEME_V->value); #if USE_PORTS case OP_EOF_OBJECT: /* eof-object */ s_return (S_EOF); 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); //TODO: move to scheme 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; } } putcharacter (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 */ putcharacter (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 { putcharacter (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 0 if (!is_pair (args) || !is_number (a)) Error_0 ("new-segment: argument must be a number"); #endif s_retbool (alloc_cellseg (SCHEME_A)); 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 = port (a); if (p->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 (); } /* reading */ ecb_cold 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 = port (p)->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); 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"); 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); } 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: //TODO: haven't checked whether the garbage collector could interfere and free x gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded x = readstrexp (SCHEME_A_ '|'); 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"); 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"); 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) putcharacter (SCHEME_A_ '\''); else if (a == SCHEME_V->QQUOTE && ok_abbr) putcharacter (SCHEME_A_ '`'); else if (a == SCHEME_V->UNQUOTE && ok_abbr) putcharacter (SCHEME_A_ ','); else if (a == SCHEME_V->UNQUOTESP && ok_abbr) putstr (SCHEME_A_ ",@"); else { putcharacter (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); putcharacter (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); } putcharacter (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) { putcharacter (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) putcharacter (SCHEME_A_ ' '); s_goto (OP_P0LIST); } } } if (USE_ERROR_CHECKING) abort (); } /* list ops */ ecb_hot 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)); 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) || is_macro (SCHEME_V->args)) s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); s_return (S_F); case OP_CLOSUREP: /* closure? */ /* * Note, macro object is also a closure. * Therefore, (closure? <#MACRO>) ==> #t * (schmorp) well, obviously not, fix? TODO */ 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); ecb_hot static int tst_any (pointer p) { return 1; } ecb_hot static int tst_inonneg (pointer p) { return is_integer (p) && ivalue_unchecked (p) >= 0; } ecb_hot 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 ; ecb_cold 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"; } ecb_cold 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 */ ecb_hot static void 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) { putstr (SCHEME_A_ "No memory!\n"); return; } } } /* ========== Initialization of internal keywords ========== */ ecb_cold 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); } ecb_cold 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! */ ecb_hot static int syntaxnum (pointer p) { const char *s = strvalue (p); switch (strlength (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]); /* this memset is not strictly correct, as we assume (intcache) * that memset 0 will also set pointers to 0, but memset does * of course not guarantee that. screw such systems. */ memset (SCHEME_V, 0, sizeof (*SCHEME_V)); num_set_fixnum (num_zero, 1); num_set_ivalue (num_zero, 0); num_set_fixnum (num_one, 1); 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)) { #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->value = NIL; SCHEME_V->tracing = 0; /* init NIL */ set_typeflag (NIL, T_SPECIAL | T_ATOM); set_car (NIL, NIL); set_cdr (NIL, NIL); /* init T */ set_typeflag (S_T, T_SPECIAL | T_ATOM); set_car (S_T, S_T); set_cdr (S_T, S_T); /* init F */ set_typeflag (S_F, T_SPECIAL | T_ATOM); set_car (S_F, S_F); set_cdr (S_F, S_F); /* init EOF_OBJ */ set_typeflag (S_EOF, T_SPECIAL | T_ATOM); set_car (S_EOF, S_EOF); set_cdr (S_EOF, S_EOF); /* init sink */ set_typeflag (S_SINK, T_PAIR); 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 */ new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), 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 ecb_cold void scheme_set_input_port_file (SCHEME_P_ int fin) { SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); } ecb_cold 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); } ecb_cold void scheme_set_output_port_file (SCHEME_P_ int fout) { SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); } ecb_cold 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 ecb_cold 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->cell_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 } ecb_cold void scheme_load_file (SCHEME_P_ int fin) { scheme_load_named_file (SCHEME_A_ fin, 0); } ecb_cold 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; SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); SCHEME_V->retcode = 0; if (fin == STDIN_FILENO) SCHEME_V->interactive_repl = 1; #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; } ecb_cold void scheme_load_string (SCHEME_P_ const char *cmd) { #if USE_PORTs 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; SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 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; #else abort (); #endif } ecb_cold 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 ecb_cold 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)); } ecb_cold 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); } ecb_cold pointer scheme_apply0 (SCHEME_P_ const char *procname) { return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); } ecb_cold 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); } ecb_cold 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. */ ecb_cold 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; } ecb_cold 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 ecb_cold 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 EXPERIMENT system ("ps v $PPID"); #endif if (argc == 2 && strcmp (argv[1], "-?") == 0) { putstr (SCHEME_A_ "Usage: tinyscheme -?\n"); putstr (SCHEME_A_ "or: tinyscheme [ ...]\n"); putstr (SCHEME_A_ "followed by\n"); putstr (SCHEME_A_ " -1 [ ...]\n"); putstr (SCHEME_A_ " -c [ ...]\n"); putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n"); putstr (SCHEME_A_ "Use - as filename for stdin.\n"); return 1; } if (!scheme_init (SCHEME_A)) { putstr (SCHEME_A_ "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 (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); if (isfile && fin < 0) { putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putcharacter (SCHEME_A_ '\n'); } else { if (isfile) scheme_load_named_file (SCHEME_A_ fin, file_name); else scheme_load_string (SCHEME_A_ file_name); if (!isfile || fin != STDIN_FILENO) { if (SCHEME_V->retcode != 0) { putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putcharacter (SCHEME_A_ '\n'); } if (isfile) close (fin); } } 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: */