$NetBSD: patch-ab,v 1.4 2005/03/24 16:30:45 agc Exp $ --- scheme.c.orig 2004-06-22 07:13:39.000000000 +0100 +++ scheme.c 2005-03-24 16:23:49.000000000 +0000 @@ -1,4450 +1,4457 @@ -/* T I N Y S C H E M E 1 . 3 5 - * 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 _SCHEME_SOURCE -#include "scheme-private.h" -#ifndef WIN32 -# include -#endif -#if USE_DL -# include "dynload.h" -#endif -#if USE_MATH -# include -#endif -#include -#include -#include - -#if USE_STRCASECMP -#include -#define stricmp strcasecmp -#endif - -/* Used for documentation purposes, to signal functions in 'interface' */ -#define INTERFACE - -#define TOK_EOF (-1) -#define TOK_LPAREN 0 -#define TOK_RPAREN 1 -#define TOK_DOT 2 -#define TOK_ATOM 3 -#define TOK_QUOTE 4 -#define TOK_COMMENT 5 -#define TOK_DQUOTE 6 -#define TOK_BQUOTE 7 -#define TOK_COMMA 8 -#define TOK_ATMARK 9 -#define TOK_SHARP 10 -#define TOK_SHARP_CONST 11 -#define TOK_VEC 12 - -# define BACKQUOTE '`' - -/* - * Basic memory allocation units - */ - -#define banner "TinyScheme 1.35" - -#include -#include -#ifndef macintosh -# include -#else -static int stricmp(const char *s1, const char *s2) -{ - unsigned char c1, c2; - do { - c1 = tolower(*s1); - c2 = tolower(*s2); - if (c1 < c2) - return -1; - else if (c1 > c2) - return 1; - s1++, s2++; - } while (c1 != 0); - return 0; -} -#endif /* macintosh */ - -#if USE_STRLWR -static const char *strlwr(char *s) { - const char *p=s; - while(*s) { - *s=tolower(*s); - s++; - } - return p; -} -#endif - -#ifndef prompt -# define prompt "> " -#endif - -#ifndef InitFile -# define InitFile "init.scm" -#endif - -#ifndef FIRST_CELLSEGS -# define FIRST_CELLSEGS 3 -#endif - -enum scheme_types { - T_STRING=1, - T_NUMBER=2, - T_SYMBOL=3, - T_PROC=4, - T_PAIR=5, - T_CLOSURE=6, - T_CONTINUATION=7, - T_FOREIGN=8, - T_CHARACTER=9, - T_PORT=10, - T_VECTOR=11, - T_MACRO=12, - T_PROMISE=13, - T_ENVIRONMENT=14, - T_LAST_SYSTEM_TYPE=14 -}; - -/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ -#define ADJ 32 -#define TYPE_BITS 5 -#define T_MASKTYPE 31 /* 0000000000011111 */ -#define T_SYNTAX 4096 /* 0001000000000000 */ -#define T_IMMUTABLE 8192 /* 0010000000000000 */ -#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ -#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ -#define MARK 32768 /* 1000000000000000 */ -#define UNMARK 32767 /* 0111111111111111 */ - - -static num num_add(num a, num b); -static num num_mul(num a, num b); -static num num_div(num a, num b); -static num num_intdiv(num a, num b); -static num num_sub(num a, num b); -static num num_rem(num a, num b); -static num num_mod(num a, num b); -static int num_eq(num a, num b); -static int num_gt(num a, num b); -static int num_ge(num a, num b); -static int num_lt(num a, num b); -static int num_le(num a, num b); - -#if USE_MATH -static double round_per_R5RS(double x); -#endif -static int is_zero_double(double x); - -static num num_zero; -static num num_one; - -/* macros for cell operations */ -#define typeflag(p) ((p)->_flag) -#define type(p) (typeflag(p)&T_MASKTYPE) - -INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } -#define strvalue(p) ((p)->_object._string._svalue) -#define strlength(p) ((p)->_object._string._length) - -INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } -INTERFACE static void fill_vector(pointer vec, pointer obj); -INTERFACE static pointer vector_elem(pointer vec, int ielem); -INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); -INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } -INTERFACE INLINE int is_integer(pointer p) { - return ((p)->_object._number.is_fixnum); -} -INTERFACE INLINE int is_real(pointer p) { - return (!(p)->_object._number.is_fixnum); -} - -INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } -INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } -INLINE num nvalue(pointer p) { return ((p)->_object._number); } -INTERFACE long ivalue(pointer p) { return (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } -INTERFACE double rvalue(pointer p) { return (!is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } -#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) -#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) -#define set_integer(p) (p)->_object._number.is_fixnum=1; -#define set_real(p) (p)->_object._number.is_fixnum=0; -INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } - -INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } -#define is_inport(p) (type(p)==T_PORT && p->_object._port->kind&port_input) -#define is_outport(p) (type(p)==T_PORT && p->_object._port->kind&port_output) - -INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } -#define car(p) ((p)->_object._cons._car) -#define cdr(p) ((p)->_object._cons._cdr) -INTERFACE pointer pair_car(pointer p) { return car(p); } -INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } -INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } -INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } - -INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } -INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } -#if USE_PLIST -SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } -#define symprop(p) cdr(p) -#endif - -INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } -INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } -INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } -INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } -#define procnum(p) ivalue(p) -static const char *procname(pointer x); - -INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } -INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } -INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } -INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } - -INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } -#define cont_dump(p) cdr(p) - -/* To do: promise should be forced ONCE only */ -INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } - -INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } -#define setenvironment(p) typeflag(p) = T_ENVIRONMENT - -#define is_atom(p) (typeflag(p)&T_ATOM) -#define setatom(p) typeflag(p) |= T_ATOM -#define clratom(p) typeflag(p) &= CLRATOM - -#define is_mark(p) (typeflag(p)&MARK) -#define setmark(p) typeflag(p) |= MARK -#define clrmark(p) typeflag(p) &= UNMARK - -INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } -/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ -INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } - -#define caar(p) car(car(p)) -#define cadr(p) car(cdr(p)) -#define cdar(p) cdr(car(p)) -#define cddr(p) cdr(cdr(p)) -#define cadar(p) car(cdr(car(p))) -#define caddr(p) car(cdr(cdr(p))) -#define cadaar(p) car(cdr(car(car(p)))) -#define cadddr(p) car(cdr(cdr(cdr(p)))) -#define cddddr(p) cdr(cdr(cdr(cdr(p)))) - -#if USE_CHAR_CLASSIFIERS -static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } -static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } -static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } -static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } -static INLINE int Cislower(int c) { return isascii(c) && islower(c); } -#endif - -#if USE_ASCII_NAMES -static const char *charnames[32]={ - "nul", - "soh", - "stx", - "etx", - "eot", - "enq", - "ack", - "bel", - "bs", - "ht", - "lf", - "vt", - "ff", - "cr", - "so", - "si", - "dle", - "dc1", - "dc2", - "dc3", - "dc4", - "nak", - "syn", - "etb", - "can", - "em", - "sub", - "esc", - "fs", - "gs", - "rs", - "us" -}; - -static int is_ascii_name(const char *name, int *pc) { - int i; - for(i=0; i<32; i++) { - if(stricmp(name,charnames[i])==0) { - *pc=i; - return 1; - } - } - if(stricmp(name,"del")==0) { - *pc=127; - return 1; - } - return 0; -} - -#endif - -static int file_push(scheme *sc, const char *fname); -static void file_pop(scheme *sc); -static int file_interactive(scheme *sc); -static INLINE int is_one_of(char *s, int c); -static int alloc_cellseg(scheme *sc, int n); -static long binary_decode(const char *s); -static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); -static pointer _get_cell(scheme *sc, pointer a, pointer b); -static pointer get_consecutive_cells(scheme *sc, int n); -static pointer find_consecutive_cells(scheme *sc, int n); -static void finalize_cell(scheme *sc, pointer a); -static int count_consecutive_cells(pointer x, int needed); -static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); -static pointer mk_number(scheme *sc, num n); -static pointer mk_empty_string(scheme *sc, int len, char fill); -static char *store_string(scheme *sc, int len, const char *str, char fill); -static pointer mk_vector(scheme *sc, int len); -static pointer mk_atom(scheme *sc, char *q); -static pointer mk_sharp_const(scheme *sc, char *name); -static pointer mk_port(scheme *sc, port *p); -static pointer port_from_filename(scheme *sc, const char *fn, int prop); -static pointer port_from_file(scheme *sc, FILE *, int prop); -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); -static port *port_rep_from_file(scheme *sc, FILE *, int prop); -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); -static void port_close(scheme *sc, pointer p, int flag); -static void mark(pointer a); -static void gc(scheme *sc, pointer a, pointer b); -static int basic_inchar(port *pt); -static int inchar(scheme *sc); -static void backchar(scheme *sc, int c); -static char *readstr_upto(scheme *sc, char *delim); -static pointer readstrexp(scheme *sc); -static INLINE void skipspace(scheme *sc); -static int token(scheme *sc); -static void printslashstring(scheme *sc, char *s, int len); -static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); -static void printatom(scheme *sc, pointer l, int f); -static pointer mk_proc(scheme *sc, enum scheme_opcodes op); -static pointer mk_closure(scheme *sc, pointer c, pointer e); -static pointer mk_continuation(scheme *sc, pointer d); -static pointer reverse(scheme *sc, pointer a); -static pointer reverse_in_place(scheme *sc, pointer term, pointer list); -static pointer append(scheme *sc, pointer a, pointer b); -static int list_length(scheme *sc, pointer a); -static int eqv(pointer a, pointer b); -static void dump_stack_mark(scheme *); -static pointer opexe_0(scheme *sc, enum scheme_opcodes op); -static pointer opexe_1(scheme *sc, enum scheme_opcodes op); -static pointer opexe_2(scheme *sc, enum scheme_opcodes op); -static pointer opexe_3(scheme *sc, enum scheme_opcodes op); -static pointer opexe_4(scheme *sc, enum scheme_opcodes op); -static pointer opexe_5(scheme *sc, enum scheme_opcodes op); -static pointer opexe_6(scheme *sc, enum scheme_opcodes op); -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); -static void assign_syntax(scheme *sc, char *name); -static int syntaxnum(pointer p); -static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); - -#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) -#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) - -static num num_add(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue+b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)+num_rvalue(b); - } - return ret; -} - -static num num_mul(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue*b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)*num_rvalue(b); - } - return ret; -} - -static num num_div(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_intdiv(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue/b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)/num_rvalue(b); - } - return ret; -} - -static num num_sub(num a, num b) { - num ret; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - if(ret.is_fixnum) { - ret.value.ivalue= a.value.ivalue-b.value.ivalue; - } else { - ret.value.rvalue=num_rvalue(a)-num_rvalue(b); - } - return ret; -} - -static num num_rem(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - /* modulo 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); - } - } - ret.value.ivalue=res; - return ret; -} - -static num num_mod(num a, num b) { - num ret; - long e1, e2, res; - ret.is_fixnum=a.is_fixnum && b.is_fixnum; - e1=num_ivalue(a); - e2=num_ivalue(b); - res=e1%e2; - if(res*e2<0) { /* modulo should have same sign as second operand */ - e2=labs(e2); - if(res>0) { - res-=e2; - } else { - res+=e2; - } - } - ret.value.ivalue=res; - return ret; -} - -static int num_eq(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue==b.value.ivalue; - } else { - ret=num_rvalue(a)==num_rvalue(b); - } - return ret; -} - - -static int num_gt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivalue>b.value.ivalue; - } else { - ret=num_rvalue(a)>num_rvalue(b); - } - return ret; -} - -static int num_ge(num a, num b) { - return !num_lt(a,b); -} - -static int num_lt(num a, num b) { - int ret; - int is_fixnum=a.is_fixnum && b.is_fixnum; - if(is_fixnum) { - ret= a.value.ivaluedce) { - return ce; - } else if(dfl-DBL_MIN; -} - -static long binary_decode(const char *s) { - long x=0; - - while(*s!=0 && (*s=='1' || *s=='0')) { - x<<=1; - x+=*s-'0'; - s++; - } - - return x; -} - -/* allocate new cell segment */ -static int alloc_cellseg(scheme *sc, int n) { - pointer newp; - pointer last; - pointer p; - char *cp; - long i; - int k; - int adj=ADJ; - - if(adjlast_cell_seg >= CELL_NSEGMENT - 1) - return k; - cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); - if (cp == 0) - return k; - i = ++sc->last_cell_seg ; - sc->alloc_seg[i] = cp; - /* adjust in TYPE_BITS-bit boundary */ - if(((unsigned)cp)%adj!=0) { - cp=(char*)(adj*((long)cp/adj+1)); - } - /* insert new segment in address order */ - newp=(pointer)cp; - sc->cell_seg[i] = newp; - while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { - p = sc->cell_seg[i]; - sc->cell_seg[i] = sc->cell_seg[i - 1]; - sc->cell_seg[--i] = p; - } - sc->fcells += CELL_SEGSIZE; - last = newp + CELL_SEGSIZE - 1; - for (p = newp; p <= last; p++) { - typeflag(p) = 0; - cdr(p) = p + 1; - car(p) = sc->NIL; - } - /* insert new cells in address order on free list */ - if (sc->free_cell == sc->NIL || p < sc->free_cell) { - cdr(last) = sc->free_cell; - sc->free_cell = newp; - } else { - p = sc->free_cell; - while (cdr(p) != sc->NIL && newp > cdr(p)) - p = cdr(p); - cdr(last) = cdr(p); - cdr(p) = newp; - } - } - return n; -} - -static INLINE pointer get_cell(scheme *sc, pointer a, pointer b) { - if (sc->free_cell != sc->NIL) { - pointer x = sc->free_cell; - sc->free_cell = cdr(x); - --sc->fcells; - return (x); - } - return _get_cell (sc, a, b); -} - - -/* get new cell. parameter a, b is marked by gc. */ -static pointer _get_cell(scheme *sc, pointer a, pointer b) { - pointer x; - - if(sc->no_memory) { - return sc->sink; - } - - if (sc->free_cell == sc->NIL) { - gc(sc,a, b); - if (sc->fcells < sc->last_cell_seg*8 - || sc->free_cell == sc->NIL) { - /* if only a few recovered, get more to avoid fruitless gc's */ - if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { - sc->no_memory=1; - return sc->sink; - } - } - } - x = sc->free_cell; - sc->free_cell = cdr(x); - --sc->fcells; - return (x); -} - -static pointer get_consecutive_cells(scheme *sc, int n) { - pointer x; - - if(sc->no_memory) { - return sc->sink; - } - - /* Are there any cells available? */ - x=find_consecutive_cells(sc,n); - if (x == sc->NIL) { - /* If not, try gc'ing some */ - gc(sc, sc->NIL, sc->NIL); - x=find_consecutive_cells(sc,n); - if (x == sc->NIL) { - /* If there still aren't, try getting more heap */ - if (!alloc_cellseg(sc,1)) { - sc->no_memory=1; - return sc->sink; - } - } - x=find_consecutive_cells(sc,n); - if (x == sc->NIL) { - /* If all fail, report failure */ - sc->no_memory=1; - return sc->sink; - } - } - return (x); -} - -static int count_consecutive_cells(pointer x, int needed) { - int n=1; - while(cdr(x)==x+1) { - x=cdr(x); - n++; - if(n>needed) return n; - } - return n; -} - -static pointer find_consecutive_cells(scheme *sc, int n) { - pointer *pp; - int cnt; - - pp=&sc->free_cell; - while(*pp!=sc->NIL) { - cnt=count_consecutive_cells(*pp,n); - if(cnt>=n) { - pointer x=*pp; - *pp=cdr(*pp+n-1); - sc->fcells -= n; - return x; - } - pp=&cdr(*pp+cnt-1); - } - return sc->NIL; -} - -/* get new cons cell */ -pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { - pointer x = get_cell(sc,a, b); - - typeflag(x) = T_PAIR; - if(immutable) { - setimmutable(x); - } - car(x) = a; - cdr(x) = b; - return (x); -} - -/* ========== oblist implementation ========== */ - -#ifndef USE_OBJECT_LIST - -static int hash_fn(const char *key, int table_size); - -static pointer oblist_initial_value(scheme *sc) -{ - return mk_vector(sc, 461); /* probably should be bigger */ -} - -/* returns the new symbol */ -static pointer oblist_add_by_name(scheme *sc, const char *name) -{ - pointer x; - int location; - - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - - location = hash_fn(name, ivalue_unchecked(sc->oblist)); - set_vector_elem(sc->oblist, location, - immutable_cons(sc, x, vector_elem(sc->oblist, location))); - return x; -} - -static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) -{ - int location; - pointer x; - char *s; - - location = hash_fn(name, ivalue_unchecked(sc->oblist)); - for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - if(stricmp(name, s) == 0) { - return car(x); - } - } - return sc->NIL; -} - -static pointer oblist_all_symbols(scheme *sc) -{ - int i; - pointer x; - pointer ob_list = sc->NIL; - - for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { - for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { - ob_list = cons(sc, x, ob_list); - } - } - return ob_list; -} - -#else - -static pointer oblist_initial_value(scheme *sc) -{ - return sc->NIL; -} - -static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) -{ - pointer x; - char *s; - - for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { - s = symname(car(x)); - /* case-insensitive, per R5RS section 2. */ - if(stricmp(name, s) == 0) { - return car(x); - } - } - return sc->NIL; -} - -/* returns the new symbol */ -static pointer oblist_add_by_name(scheme *sc, const char *name) -{ - pointer x; - - x = immutable_cons(sc, mk_string(sc, name), sc->NIL); - typeflag(x) = T_SYMBOL; - setimmutable(car(x)); - sc->oblist = immutable_cons(sc, x, sc->oblist); - return x; -} -static pointer oblist_all_symbols(scheme *sc) -{ - return sc->oblist; -} - -#endif - -static pointer mk_port(scheme *sc, port *p) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = T_PORT|T_ATOM; - x->_object._port=p; - return (x); -} - -pointer mk_foreign_func(scheme *sc, foreign_func f) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - typeflag(x) = (T_FOREIGN | T_ATOM); - x->_object._ff=f; - return (x); -} - -INTERFACE pointer mk_character(scheme *sc, int c) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_CHARACTER | T_ATOM); - ivalue_unchecked(x)= c; - set_integer(x); - return (x); -} - -/* get number atom (integer) */ -INTERFACE pointer mk_integer(scheme *sc, long num) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_NUMBER | T_ATOM); - ivalue_unchecked(x)= num; - set_integer(x); - return (x); -} - -INTERFACE pointer mk_real(scheme *sc, double n) { - pointer x = get_cell(sc,sc->NIL, sc->NIL); - - typeflag(x) = (T_NUMBER | T_ATOM); - rvalue_unchecked(x)= n; - set_real(x); - return (x); -} - -static pointer mk_number(scheme *sc, num n) { - if(n.is_fixnum) { - return mk_integer(sc,n.value.ivalue); - } else { - return mk_real(sc,n.value.rvalue); - } -} - -/* allocate name to string area */ -static char *store_string(scheme *sc, int len_str, const char *str, char fill) { - char *q; - - q=(char*)sc->malloc(len_str+1); - if(q==0) { - sc->no_memory=1; - return sc->strbuff; - } - if(str!=0) { - strcpy(q, str); - } else { - memset(q, fill, len_str); - q[len_str]=0; - } - return (q); -} - -/* get new string */ -INTERFACE pointer mk_string(scheme *sc, const char *str) { - return mk_counted_string(sc,str,strlen(str)); -} - -INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - strvalue(x) = store_string(sc,len,str,0); - typeflag(x) = (T_STRING | T_ATOM); - strlength(x) = len; - return (x); -} - -static pointer mk_empty_string(scheme *sc, int len, char fill) { - pointer x = get_cell(sc, sc->NIL, sc->NIL); - - strvalue(x) = store_string(sc,len,0,fill); - typeflag(x) = (T_STRING | T_ATOM); - strlength(x) = len; - return (x); -} - -INTERFACE static pointer mk_vector(scheme *sc, int len) { - pointer x=get_consecutive_cells(sc,len/2+len%2+1); - typeflag(x) = (T_VECTOR | T_ATOM); - ivalue_unchecked(x)=len; - set_integer(x); - fill_vector(x,sc->NIL); - return x; -} - -INTERFACE static void fill_vector(pointer vec, pointer obj) { - int i; - int num=ivalue(vec)/2+ivalue(vec)%2; - for(i=0; iNIL) { - return (x); - } else { - x = oblist_add_by_name(sc, name); - return (x); - } -} - -INTERFACE pointer gensym(scheme *sc) { - pointer x; - char name[40]; - - for(; sc->gensym_cntgensym_cnt++) { - sprintf(name,"gensym-%ld",sc->gensym_cnt); - - /* first check oblist */ - x = oblist_find_by_name(sc, name); - - if (x != sc->NIL) { - continue; - } else { - x = oblist_add_by_name(sc, name); - return (x); - } - } - - return sc->NIL; -} - -/* make symbol or number atom from string */ -static pointer mk_atom(scheme *sc, 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(sc, sc->COLON_HOOK, - cons(sc, - cons(sc, - sc->QUOTE, - cons(sc, mk_atom(sc,p+2), sc->NIL)), - cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); - } -#endif - - p = q; - c = *p++; - if ((c == '+') || (c == '-')) { - c = *p++; - if (c == '.') { - has_dec_point=1; - c = *p++; - } - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (c == '.') { - has_dec_point=1; - c = *p++; - if (!isdigit(c)) { - return (mk_symbol(sc, strlwr(q))); - } - } else if (!isdigit(c)) { - return (mk_symbol(sc, 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(sc, strlwr(q))); - } - } - if(has_dec_point) { - return mk_real(sc,atof(q)); - } - return (mk_integer(sc, atol(q))); -} - -/* make constant */ -static pointer mk_sharp_const(scheme *sc, char *name) { - long x; - char tmp[256]; - - if (!strcmp(name, "t")) - return (sc->T); - else if (!strcmp(name, "f")) - return (sc->F); - else if (*name == 'o') {/* #o (octal) */ - sprintf(tmp, "0%s", name+1); - sscanf(tmp, "%lo", &x); - return (mk_integer(sc, x)); - } else if (*name == 'd') { /* #d (decimal) */ - sscanf(name+1, "%ld", &x); - return (mk_integer(sc, x)); - } else if (*name == 'x') { /* #x (hex) */ - sprintf(tmp, "0x%s", name+1); - sscanf(tmp, "%lx", &x); - return (mk_integer(sc, x)); - } else if (*name == 'b') { /* #b (binary) */ - x = binary_decode(name+1); - return (mk_integer(sc, x)); - } else if (*name == '\\') { /* #\w (character) */ - int c=0; - if(stricmp(name+1,"space")==0) { - c=' '; - } else if(stricmp(name+1,"newline")==0) { - c='\n'; - } else if(stricmp(name+1,"return")==0) { - c='\r'; - } else if(stricmp(name+1,"tab")==0) { - c='\t'; - } else if(name[1]=='x' && name[2]!=0) { - int c1=0; - if(sscanf(name+2,"%x",&c1)==1 && c1<256) { - c=c1; - } else { - return sc->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 sc->NIL; - } - return mk_character(sc,c); - } else - return (sc->NIL); -} - -/* ========== garbage collector ========== */ - -/*-- - * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, - * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, - * for marking. - */ -static void mark(pointer a) { - pointer t, q, p; - - t = (pointer) 0; - p = a; -E2: setmark(p); - if(is_vector(p)) { - int i; - int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; - for(i=0; igc_verbose) { - putstr(sc, "gc..."); - } - - /* mark system globals */ - mark(sc->oblist); - mark(sc->global_env); - - /* mark current registers */ - mark(sc->args); - mark(sc->envir); - mark(sc->code); - dump_stack_mark(sc); - mark(sc->value); - mark(sc->inport); - mark(sc->save_inport); - mark(sc->outport); - mark(sc->loadport); - - /* mark variables a, b */ - mark(a); - mark(b); - - /* garbage collect */ - clrmark(sc->NIL); - sc->fcells = 0; - sc->free_cell = sc->NIL; - /* free-list is kept sorted by address so as to maintain consecutive - ranges, if possible, for use with vectors. Here we scan the cells - (which are also kept sorted by address) downwards to build the - free-list in sorted order. - */ - for (i = sc->last_cell_seg; i >= 0; i--) { - p = sc->cell_seg[i] + CELL_SEGSIZE; - while (--p >= sc->cell_seg[i]) { - if (is_mark(p)) { - clrmark(p); - } else { - /* reclaim cell */ - if (typeflag(p) != 0) { - finalize_cell(sc, p); - typeflag(p) = 0; - car(p) = sc->NIL; - } - ++sc->fcells; - cdr(p) = sc->free_cell; - sc->free_cell = p; - } - } - } - - if (sc->gc_verbose) { - char msg[80]; - sprintf(msg,"done: %ld cells were recovered.\n", sc->fcells); - putstr(sc,msg); - } -} - -static void finalize_cell(scheme *sc, pointer a) { - if(is_string(a)) { - sc->free(strvalue(a)); - } else if(is_port(a)) { - if(a->_object._port->kind&port_file - && a->_object._port->rep.stdio.closeit) { - port_close(sc,a,port_input|port_output); - } - sc->free(a->_object._port); - } -} - -/* ========== Routines for Reading ========== */ - -static int file_push(scheme *sc, const char *fname) { - FILE *fin=fopen(fname,"r"); - if(fin!=0) { - sc->file_i++; - sc->load_stack[sc->file_i].kind=port_file|port_input; - sc->load_stack[sc->file_i].rep.stdio.file=fin; - sc->load_stack[sc->file_i].rep.stdio.closeit=1; - sc->nesting_stack[sc->file_i]=0; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - } - return fin!=0; -} - -static void file_pop(scheme *sc) { - sc->nesting=sc->nesting_stack[sc->file_i]; - if(sc->file_i!=0) { - port_close(sc,sc->loadport,port_input); - sc->file_i--; - sc->loadport->_object._port=sc->load_stack+sc->file_i; - if(file_interactive(sc)) { - putstr(sc,prompt); - } - } -} - -static int file_interactive(scheme *sc) { - return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin - && sc->inport->_object._port->kind&port_file; -} - -static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { - FILE *f; - char *rw; - port *pt; - if(prop==(port_input|port_output)) { - rw="a+"; - } else if(prop==port_output) { - rw="w"; - } else { - rw="r"; - } - f=fopen(fn,rw); - if(f==0) { - return 0; - } - pt=port_rep_from_file(sc,f,prop); - pt->rep.stdio.closeit=1; - return pt; -} - -static pointer port_from_filename(scheme *sc, const char *fn, int prop) { - port *pt; - pt=port_rep_from_filename(sc,fn,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_file(scheme *sc, FILE *f, int prop) { - char *rw; - port *pt; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - if(prop==(port_input|port_output)) { - rw="a+"; - } else if(prop==port_output) { - rw="w"; - } else { - rw="r"; - } - pt->kind=port_file|prop; - pt->rep.stdio.file=f; - pt->rep.stdio.closeit=0; - return pt; -} - -static pointer port_from_file(scheme *sc, FILE *f, int prop) { - port *pt; - pt=port_rep_from_file(sc,f,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=(port*)sc->malloc(sizeof(port)); - if(pt==0) { - return 0; - } - pt->kind=port_string|prop; - pt->rep.string.start=start; - pt->rep.string.curr=start; - pt->rep.string.past_the_end=past_the_end; - return pt; -} - -static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { - port *pt; - pt=port_rep_from_string(sc,start,past_the_end,prop); - if(pt==0) { - return sc->NIL; - } - return mk_port(sc,pt); -} - -static void port_close(scheme *sc, pointer p, int flag) { - port *pt=p->_object._port; - pt->kind&=~flag; - if((pt->kind & (port_input|port_output))==0) { - if(pt->kind&port_file) { - fclose(pt->rep.stdio.file); - } - pt->kind=port_free; - } -} - -/* get new character from input file */ -static int inchar(scheme *sc) { - int c; - port *pt; - again: - pt=sc->inport->_object._port; - c=basic_inchar(pt); - if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) { - file_pop(sc); - if(sc->nesting!=0) { - return EOF; - } - goto again; - } - return c; -} - -static int basic_inchar(port *pt) { - if(pt->kind&port_file) { - return fgetc(pt->rep.stdio.file); - } 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++; - } - } -} - -/* back character to input buffer */ -static void backchar(scheme *sc, int c) { - port *pt; - if(c==EOF) return; - pt=sc->inport->_object._port; - if(pt->kind&port_file) { - ungetc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.start) { - --pt->rep.string.curr; - } - } -} - -INTERFACE void putstr(scheme *sc, const char *s) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputs(s,pt->rep.stdio.file); - } else { - for(;*s;s++) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s; - } - } - } -} - -static void putchars(scheme *sc, const char *s, int len) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fwrite(s,1,len,pt->rep.stdio.file); - } else { - for(;len;len--) { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=*s++; - } - } - } -} - -INTERFACE void putcharacter(scheme *sc, int c) { - port *pt=sc->outport->_object._port; - if(pt->kind&port_file) { - fputc(c,pt->rep.stdio.file); - } else { - if(pt->rep.string.curr!=pt->rep.string.past_the_end) { - *pt->rep.string.curr++=c; - } - } -} - -/* read characters up to delimiter, but cater to character constants */ -static char *readstr_upto(scheme *sc, char *delim) { - char *p = sc->strbuff; - - while (!is_one_of(delim, (*p++ = inchar(sc)))); - if(p==sc->strbuff+2 && p[-2]=='\\') { - *p=0; - } else { - backchar(sc,p[-1]); - *--p = '\0'; - } - return sc->strbuff; -} - -/* read string expression "xxx...xxx" */ -static pointer readstrexp(scheme *sc) { - char *p = sc->strbuff; - int c; - int c1=0; - enum { st_ok, st_bsl, st_x1, st_x2} state=st_ok; - - for (;;) { - c=inchar(sc); - if(c==EOF || p-sc->strbuff>sizeof(sc->strbuff)-1) { - return sc->F; - } - switch(state) { - case st_ok: - switch(c) { - case '\\': - state=st_bsl; - break; - case '"': - *p=0; - return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); - default: - *p++=c; - break; - } - break; - case st_bsl: - switch(c) { - case 'x': - case 'X': - state=st_x1; - c1=0; - break; - case 'n': - *p++='\n'; - state=st_ok; - break; - case 't': - *p++='\t'; - state=st_ok; - break; - case 'r': - *p++='\r'; - state=st_ok; - break; - case '"': - *p++='"'; - state=st_ok; - break; - default: - *p++=c; - state=st_ok; - break; - } - break; - case st_x1: - case st_x2: - c=toupper(c); - if(c>='0' && c<='F') { - if(c<='9') { - c1=(c1<<4)+c-'0'; - } else { - c1=(c1<<4)+c-'A'+10; - } - if(state==st_x1) { - state=st_x2; - } else { - *p++=c1; - state=st_ok; - } - } else { - return sc->F; - } - break; - } - } -} - -/* check c is in chars */ -static INLINE int is_one_of(char *s, int c) { - if(c==EOF) return 1; - while (*s) - if (*s++ == c) - return (1); - return (0); -} - -/* skip white characters */ -static INLINE void skipspace(scheme *sc) { - int c; - while (isspace(c=inchar(sc))) - ; - if(c!=EOF) { - backchar(sc,c); - } -} - -/* get token */ -static int token(scheme *sc) { - int c; - skipspace(sc); - switch (c=inchar(sc)) { - case EOF: - return (TOK_EOF); - case '(': - return (TOK_LPAREN); - case ')': - return (TOK_RPAREN); - case '.': - c=inchar(sc); - if(is_one_of(" \n\t",c)) { - return (TOK_DOT); - } else { - backchar(sc,c); - backchar(sc,'.'); - return TOK_ATOM; - } - case '\'': - return (TOK_QUOTE); - case ';': - return (TOK_COMMENT); - case '"': - return (TOK_DQUOTE); - case BACKQUOTE: - return (TOK_BQUOTE); - case ',': - if ((c=inchar(sc)) == '@') - return (TOK_ATMARK); - else { - backchar(sc,c); - return (TOK_COMMA); - } - case '#': - c=inchar(sc); - if (c == '(') { - return (TOK_VEC); - } else if(c == '!') { - return TOK_COMMENT; - } else { - backchar(sc,c); - if(is_one_of(" tfodxb\\",c)) { - return TOK_SHARP_CONST; - } else { - return (TOK_SHARP); - } - } - default: - backchar(sc,c); - return (TOK_ATOM); - } -} - -/* ========== Routines for Printing ========== */ -#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) - -static void printslashstring(scheme *sc, char *p, int len) { - int i; - unsigned char *s=(unsigned char*)p; - putcharacter(sc,'"'); - for ( i=0; iNIL) { - p = "()"; - } else if (l == sc->T) { - p = "#t"; - } else if (l == sc->F) { - p = "#f"; - } else if (l == sc->EOF_OBJ) { - p = "#"; - } else if (is_port(l)) { - p = sc->strbuff; - strcpy(p, "#"); - } else if (is_number(l)) { - p = sc->strbuff; - if(is_integer(l)) { - sprintf(p, "%ld", ivalue_unchecked(l)); - } else { - sprintf(p, "%.10g", rvalue_unchecked(l)); - } - } else if (is_string(l)) { - if (!f) { - p = strvalue(l); - } else { /* Hack, uses the fact that printing is needed */ - *pp=sc->strbuff; - *plen=0; - printslashstring(sc, strvalue(l), strlength(l)); - return; - } - } else if (is_character(l)) { - int c=charvalue(l); - p = sc->strbuff; - if (!f) { - p[0]=c; - p[1]=0; - } else { - switch(c) { - case ' ': - sprintf(p,"#\\space"); break; - case '\n': - sprintf(p,"#\\newline"); break; - case '\r': - sprintf(p,"#\\return"); break; - case '\t': - sprintf(p,"#\\tab"); break; - default: -#if USE_ASCII_NAMES - if(c==127) { - strcpy(p,"#\\del"); break; - } else if(c<32) { - strcpy(p,"#\\"); strcat(p,charnames[c]); break; - } -#else - if(c<32) { - sprintf(p,"#\\x%x",c); break; - } -#endif - sprintf(p,"#\\%c",c); break; - } - } - } else if (is_symbol(l)) { - p = symname(l); - } else if (is_proc(l)) { - p = sc->strbuff; - sprintf(p, "#<%s PROCEDURE %ld>", procname(l),procnum(l)); - } else if (is_macro(l)) { - p = "#"; - } else if (is_closure(l)) { - p = "#"; - } else if (is_promise(l)) { - p = "#"; - } else if (is_foreign(l)) { - p = sc->strbuff; - sprintf(p, "#", procnum(l)); - } else if (is_continuation(l)) { - p = "#"; - } else { - p = "#"; - } - *pp=p; - *plen=strlen(p); -} -/* ========== Routines for Evaluation Cycle ========== */ - -/* make closure. c is code. e is environment */ -static pointer mk_closure(scheme *sc, pointer c, pointer e) { - pointer x = get_cell(sc, c, e); - - typeflag(x) = T_CLOSURE; - car(x) = c; - cdr(x) = e; - return (x); -} - -/* make continuation. */ -static pointer mk_continuation(scheme *sc, pointer d) { - pointer x = get_cell(sc, sc->NIL, d); - - typeflag(x) = T_CONTINUATION; - cont_dump(x) = d; - return (x); -} - -static pointer list_star(scheme *sc, pointer d) { - pointer p, q; - if(cdr(d)==sc->NIL) { - return car(d); - } - p=cons(sc,car(d),cdr(d)); - q=p; - while(cdr(cdr(p))!=sc->NIL) { - d=cons(sc,car(p),cdr(p)); - if(cdr(cdr(p))!=sc->NIL) { - p=cdr(d); - } - } - cdr(p)=car(cdr(p)); - return q; -} - -/* reverse list -- produce new list */ -static pointer reverse(scheme *sc, pointer a) { -/* a must be checked by gc */ - pointer p = sc->NIL; - - for ( ; is_pair(a); a = cdr(a)) { - p = cons(sc, car(a), p); - } - return (p); -} - -/* reverse list --- in-place */ -static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { - pointer p = list, result = term, q; - - while (p != sc->NIL) { - q = cdr(p); - cdr(p) = result; - result = p; - p = q; - } - return (result); -} - -/* append list -- produce new list */ -static pointer append(scheme *sc, pointer a, pointer b) { - pointer p = b, q; - - if (a != sc->NIL) { - a = reverse(sc, a); - while (a != sc->NIL) { - q = cdr(a); - cdr(a) = p; - p = a; - a = q; - } - } - return (p); -} - -/* equivalence of atoms */ -static 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_eq(nvalue(a),nvalue(b)); - else - 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) != sc->F) -#define is_false(p) ((p) == sc->F) - -/* ========== Environment implementation ========== */ - -#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) - -static int hash_fn(const char *key, int table_size) -{ - unsigned int hashed = 0; - const char *c; - int bits_per_int = sizeof(unsigned int)*8; - - for (c = key; *c; c++) { - /* letters have about 5 bits in them */ - hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); - hashed ^= *c; - } - return hashed % table_size; -} -#endif - -#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 *sc, pointer old_env) -{ - pointer new_frame; - - /* The interaction-environment has about 300 variables in it. */ - if (old_env == sc->NIL) { - new_frame = mk_vector(sc, 461); - } else { - new_frame = sc->NIL; - } - - sc->envir = immutable_cons(sc, new_frame, old_env); - setenvironment(sc->envir); -} - -static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, - pointer variable, pointer value) -{ - pointer slot = immutable_cons(sc, variable, value); - - if (is_vector(car(env))) { - int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); - - set_vector_elem(car(env), location, - immutable_cons(sc, slot, vector_elem(car(env), location))); - } else { - car(env) = immutable_cons(sc, slot, car(env)); - } -} - -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) -{ - pointer x,y; - int location; - - for (x = env; x != sc->NIL; x = cdr(x)) { - if (is_vector(car(x))) { - location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); - y = vector_elem(car(x), location); - } else { - y = car(x); - } - for ( ; y != sc->NIL; y = cdr(y)) { - if (caar(y) == hdl) { - break; - } - } - if (y != sc->NIL) { - break; - } - if(!all) { - return sc->NIL; - } - } - if (x != sc->NIL) { - return car(y); - } - return sc->NIL; -} - -#else /* USE_ALIST_ENV */ - -static INLINE void new_frame_in_env(scheme *sc, pointer old_env) -{ - sc->envir = immutable_cons(sc, sc->NIL, old_env); - setenvironment(sc->envir); -} - -static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, - pointer variable, pointer value) -{ - car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); -} - -static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) -{ - pointer x,y; - for (x = env; x != sc->NIL; x = cdr(x)) { - for (y = car(x); y != sc->NIL; y = cdr(y)) { - if (caar(y) == hdl) { - break; - } - } - if (y != sc->NIL) { - break; - } - if(!all) { - return sc->NIL; - } - } - if (x != sc->NIL) { - return car(y); - } - return sc->NIL; -} - -#endif /* USE_ALIST_ENV else */ - -static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) -{ - new_slot_spec_in_env(sc, sc->envir, variable, value); -} - -static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) -{ - cdr(slot) = value; -} - -static INLINE pointer slot_value_in_env(pointer slot) -{ - return cdr(slot); -} - -/* ========== Evaluation Cycle ========== */ - - -static pointer _Error_1(scheme *sc, const char *s, pointer a) { -#if USE_ERROR_HOOK - pointer x; - pointer hdl=sc->ERROR_HOOK; - - x=find_slot_in_env(sc,sc->envir,hdl,1); - if (x != sc->NIL) { - if(a!=0) { - sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); - } else { - sc->code = sc->NIL; - } - sc->code = cons(sc, mk_string(sc, (s)), sc->code); - setimmutable(car(sc->code)); - sc->code = cons(sc, slot_value_in_env(x), sc->code); - sc->op = (int)OP_EVAL; - return sc->T; - } -#endif - - if(a!=0) { - sc->args = cons(sc, (a), sc->NIL); - } else { - sc->args = sc->NIL; - } - sc->args = cons(sc, mk_string(sc, (s)), sc->args); - setimmutable(car(sc->args)); - sc->op = (int)OP_ERR0; - return sc->T; -} -#define Error_1(sc,s, a) return _Error_1(sc,s,a) -#define Error_0(sc,s) return _Error_1(sc,s,0) - -/* Too small to turn into function */ -# define BEGIN do { -# define END } while (0) -#define s_goto(sc,a) BEGIN \ - sc->op = (int)(a); \ - return sc->T; END - -#define s_return(sc,a) return _s_return(sc,a) - -#ifndef USE_SCHEME_STACK - -/* this structure holds all the interpreter's registers */ -struct dump_stack_frame { - enum scheme_opcodes op; - pointer args; - pointer envir; - pointer code; -}; - -#define STACK_GROWTH 3 - -static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) -{ - int nframes = (int)sc->dump; - struct dump_stack_frame *next_frame; - - /* enough room for the next frame? */ - if (nframes >= sc->dump_size) { - sc->dump_size += STACK_GROWTH; - /* alas there is no sc->realloc */ - sc->dump_base = realloc(sc->dump_base, - sizeof(struct dump_stack_frame) * sc->dump_size); - } - next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; - next_frame->op = op; - next_frame->args = args; - next_frame->envir = sc->envir; - next_frame->code = code; - sc->dump = (pointer)(nframes+1); -} - -static pointer _s_return(scheme *sc, pointer a) -{ - int nframes = (int)sc->dump; - struct dump_stack_frame *frame; - - sc->value = (a); - if (nframes <= 0) { - return sc->NIL; - } - nframes--; - frame = (struct dump_stack_frame *)sc->dump_base + nframes; - sc->op = frame->op; - sc->args = frame->args; - sc->envir = frame->envir; - sc->code = frame->code; - sc->dump = (pointer)nframes; - return sc->T; -} - -static INLINE void dump_stack_reset(scheme *sc) -{ - /* in this implementation, sc->dump is the number of frames on the stack */ - sc->dump = (pointer)0; -} - -static INLINE void dump_stack_initialize(scheme *sc) -{ - sc->dump_size = 0; - sc->dump_base = NULL; - dump_stack_reset(sc); -} - -static void dump_stack_free(scheme *sc) -{ - free(sc->dump_base); - sc->dump_base = NULL; - sc->dump = (pointer)0; - sc->dump_size = 0; -} - -static INLINE void dump_stack_mark(scheme *sc) -{ - int nframes = (int)sc->dump; - int i; - for(i=0; idump_base + i; - mark(frame->args); - mark(frame->envir); - mark(frame->code); - } -} - -#else - -static INLINE void dump_stack_reset(scheme *sc) -{ - sc->dump = sc->NIL; -} - -static INLINE void dump_stack_initialize(scheme *sc) -{ - dump_stack_reset(sc); -} - -static void dump_stack_free(scheme *sc) -{ - sc->dump = sc->NIL; -} - -static pointer _s_return(scheme *sc, pointer a) { - sc->value = (a); - if(sc->dump==sc->NIL) return sc->NIL; - sc->op = ivalue(car(sc->dump)); - sc->args = cadr(sc->dump); - sc->envir = caddr(sc->dump); - sc->code = cadddr(sc->dump); - sc->dump = cddddr(sc->dump); - return sc->T; -} - -static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { - sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); - sc->dump = cons(sc, (args), sc->dump); - sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); -} - -static INLINE void dump_stack_mark(scheme *sc) -{ - mark(sc->dump); -} -#endif - -#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) - -static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { - case OP_LOAD: /* load */ - if(file_interactive(sc)) { - fprintf(sc->outport->_object._port->rep.stdio.file, - "Loading %s\n", strvalue(car(sc->args))); - } - if (!file_push(sc,strvalue(car(sc->args)))) { - Error_1(sc,"unable to open", car(sc->args)); - } - s_goto(sc,OP_T0LVL); - - case OP_T0LVL: /* top level */ - if(file_interactive(sc)) { - putstr(sc,"\n"); - } - sc->nesting=0; - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->save_inport=sc->inport; - sc->inport = sc->loadport; - s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); - s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); - s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); - if (file_interactive(sc)) { - putstr(sc,prompt); - } - s_goto(sc,OP_READ_INTERNAL); - - case OP_T1LVL: /* top level */ - sc->code = sc->value; - sc->inport=sc->save_inport; - s_goto(sc,OP_EVAL); - - case OP_READ_INTERNAL: /* internal read */ - sc->tok = token(sc); - if(sc->tok==TOK_EOF) { - if(sc->inport==sc->loadport) { - sc->args=sc->NIL; - s_goto(sc,OP_QUIT); - } else { - s_return(sc,sc->EOF_OBJ); - } - } - s_goto(sc,OP_RDSEXPR); - - case OP_GENSYM: - s_return(sc, gensym(sc)); - - 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(sc->tracing) { - putstr(sc,"\nGives: "); - } - if(file_interactive(sc)) { - sc->print_flag = 1; - sc->args = sc->value; - s_goto(sc,OP_P0LIST); - } else { - s_return(sc,sc->value); - } - - case OP_EVAL: /* main part of evaluation */ -#if USE_TRACING - if(sc->tracing) { - /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ - s_save(sc,OP_REAL_EVAL,sc->args,sc->code); - sc->args=sc->code; - putstr(sc,"\nEval: "); - s_goto(sc,OP_P0LIST); - } - /* fall through */ - case OP_REAL_EVAL: -#endif - if (is_symbol(sc->code)) { /* symbol */ - x=find_slot_in_env(sc,sc->envir,sc->code,1); - if (x != sc->NIL) { - s_return(sc,slot_value_in_env(x)); - } else { - Error_1(sc,"eval: unbound variable:", sc->code); - } - } else if (is_pair(sc->code)) { - if (is_syntax(x = car(sc->code))) { /* SYNTAX */ - sc->code = cdr(sc->code); - s_goto(sc,syntaxnum(x)); - } else {/* first, eval top element and eval arguments */ - s_save(sc,OP_E0ARGS, sc->NIL, sc->code); - /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - } - } else { - s_return(sc,sc->code); - } - - case OP_E0ARGS: /* eval arguments */ - if (is_macro(sc->value)) { /* macro expansion */ - s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); - sc->args = cons(sc,sc->code, sc->NIL); - sc->code = sc->value; - s_goto(sc,OP_APPLY); - } else { - sc->code = cdr(sc->code); - s_goto(sc,OP_E1ARGS); - } - - case OP_E1ARGS: /* eval arguments */ - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); - sc->code = car(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_goto(sc,OP_APPLY); - } - -#if USE_TRACING - case OP_TRACING: { - int tr=sc->tracing; - sc->tracing=ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,tr)); - } -#endif - - case OP_APPLY: /* apply 'code' to 'args' */ -#if USE_TRACING - if(sc->tracing) { - s_save(sc,OP_REAL_APPLY,sc->args,sc->code); - sc->print_flag = 1; - /* sc->args=cons(sc,sc->code,sc->args);*/ - putstr(sc,"\nApply to: "); - s_goto(sc,OP_P0LIST); - } - /* fall through */ - case OP_REAL_APPLY: -#endif - if (is_proc(sc->code)) { - s_goto(sc,procnum(sc->code)); /* PROCEDURE */ - } else if (is_foreign(sc->code)) { - x=sc->code->_object._ff(sc,sc->args); - s_return(sc,x); - } else if (is_closure(sc->code) || is_macro(sc->code) - || is_promise(sc->code)) { /* CLOSURE */ - /* Should not accept promise */ - /* make environment */ - new_frame_in_env(sc, closure_env(sc->code)); - for (x = car(closure_code(sc->code)), y = sc->args; - is_pair(x); x = cdr(x), y = cdr(y)) { - if (y == sc->NIL) { - Error_0(sc,"not enough arguments"); - } else { - new_slot_in_env(sc, car(x), car(y)); - } - } - if (x == sc->NIL) { - /*-- - * if (y != sc->NIL) { - * Error_0(sc,"too many arguments"); - * } - */ - } else if (is_symbol(x)) - new_slot_in_env(sc, x, y); - else { - Error_1(sc,"syntax error in closure: not a symbol:", x); - } - sc->code = cdr(closure_code(sc->code)); - sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); - } else if (is_continuation(sc->code)) { /* CONTINUATION */ - sc->dump = cont_dump(sc->code); - s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); - } else { - Error_0(sc,"illegal function"); - } - - case OP_DOMACRO: /* do macro */ - sc->code = sc->value; - s_goto(sc,OP_EVAL); - - case OP_LAMBDA: /* lambda */ - s_return(sc,mk_closure(sc, sc->code, sc->envir)); - - case OP_MKCLOSURE: /* make-closure */ - x=car(sc->args); - if(car(x)==sc->LAMBDA) { - x=cdr(x); - } - if(cdr(sc->args)==sc->NIL) { - y=sc->envir; - } else { - y=cadr(sc->args); - } - s_return(sc,mk_closure(sc, x, y)); - - case OP_QUOTE: /* quote */ - x=car(sc->code); - s_return(sc,car(sc->code)); - - case OP_DEF0: /* define */ - if (is_pair(car(sc->code))) { - x = caar(sc->code); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_DEF1, sc->NIL, x); - s_goto(sc,OP_EVAL); - - case OP_DEF1: /* define */ - x=find_slot_in_env(sc,sc->envir,sc->code,0); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_in_env(sc, sc->code, sc->value); - } - s_return(sc,sc->code); - - - case OP_DEFP: /* defined? */ - x=sc->envir; - if(cdr(sc->args)!=sc->NIL) { - x=cadr(sc->args); - } - s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); - - case OP_SET0: /* set! */ - s_save(sc,OP_SET1, sc->NIL, car(sc->code)); - sc->code = cadr(sc->code); - s_goto(sc,OP_EVAL); - - case OP_SET1: /* set! */ - y=find_slot_in_env(sc,sc->envir,sc->code,1); - if (y != sc->NIL) { - set_slot_in_env(sc, y, sc->value); - s_return(sc,sc->value); - } else { - Error_1(sc,"set!: unbound variable:", sc->code); - } - - - case OP_BEGIN: /* begin */ - if (!is_pair(sc->code)) { - s_return(sc,sc->code); - } - if (cdr(sc->code) != sc->NIL) { - s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); - } - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_IF0: /* if */ - s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_IF1: /* if */ - if (is_true(sc->value)) - sc->code = car(sc->code); - else - sc->code = cadr(sc->code); /* (if #f 1) ==> () because - * car(sc->NIL) = sc->NIL */ - s_goto(sc,OP_EVAL); - - case OP_LET0: /* let */ - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); - s_goto(sc,OP_LET1); - - case OP_LET1: /* let (calculate parameters) */ - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET1, sc->args, cdr(sc->code)); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_goto(sc,OP_LET2); - } - - case OP_LET2: /* let */ - new_frame_in_env(sc, sc->envir); - for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; - y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - if (is_symbol(car(sc->code))) { /* named let */ - for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { - - sc->args = cons(sc, caar(x), sc->args); - } - x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); - new_slot_in_env(sc, car(sc->code), x); - sc->code = cddr(sc->code); - sc->args = sc->NIL; - } else { - sc->code = cdr(sc->code); - sc->args = sc->NIL; - } - s_goto(sc,OP_BEGIN); - - case OP_LET0AST: /* let* */ - if (car(sc->code) == sc->NIL) { - new_frame_in_env(sc, sc->envir); - sc->code = cdr(sc->code); - s_goto(sc,OP_BEGIN); - } - s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); - sc->code = cadaar(sc->code); - s_goto(sc,OP_EVAL); - - case OP_LET1AST: /* let* (make new frame) */ - new_frame_in_env(sc, sc->envir); - s_goto(sc,OP_LET2AST); - - case OP_LET2AST: /* let* (calculate parameters) */ - new_slot_in_env(sc, caar(sc->code), sc->value); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET2AST, sc->args, sc->code); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->code = sc->args; - sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); - } - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { - case OP_LET0REC: /* letrec */ - new_frame_in_env(sc, sc->envir); - sc->args = sc->NIL; - sc->value = sc->code; - sc->code = car(sc->code); - s_goto(sc,OP_LET1REC); - - case OP_LET1REC: /* letrec (calculate parameters) */ - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) { /* continue */ - s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); - sc->code = cadar(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_EVAL); - } else { /* end */ - sc->args = reverse_in_place(sc, sc->NIL, sc->args); - sc->code = car(sc->args); - sc->args = cdr(sc->args); - s_goto(sc,OP_LET2REC); - } - - case OP_LET2REC: /* letrec */ - for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { - new_slot_in_env(sc, caar(x), car(y)); - } - sc->code = cdr(sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_BEGIN); - - case OP_COND0: /* cond */ - if (!is_pair(sc->code)) { - Error_0(sc,"syntax error in cond"); - } - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_goto(sc,OP_EVAL); - - case OP_COND1: /* cond */ - if (is_true(sc->value)) { - if ((sc->code = cdar(sc->code)) == sc->NIL) { - s_return(sc,sc->value); - } - if(car(sc->code)==sc->FEED_TO) { - if(!is_pair(cdr(sc->code))) { - Error_0(sc,"syntax error in cond"); - } - x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); - sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); - s_goto(sc,OP_EVAL); - } - s_goto(sc,OP_BEGIN); - } else { - if ((sc->code = cdr(sc->code)) == sc->NIL) { - s_return(sc,sc->NIL); - } else { - s_save(sc,OP_COND1, sc->NIL, sc->code); - sc->code = caar(sc->code); - s_goto(sc,OP_EVAL); - } - } - - case OP_DELAY: /* delay */ - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return(sc,x); - - case OP_AND0: /* and */ - if (sc->code == sc->NIL) { - s_return(sc,sc->T); - } - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_AND1: /* and */ - if (is_false(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - } - - case OP_OR0: /* or */ - if (sc->code == sc->NIL) { - s_return(sc,sc->F); - } - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_OR1: /* or */ - if (is_true(sc->value)) { - s_return(sc,sc->value); - } else if (sc->code == sc->NIL) { - s_return(sc,sc->value); - } else { - s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - } - - case OP_C0STREAM: /* cons-stream */ - s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_C1STREAM: /* cons-stream */ - sc->args = sc->value; /* save sc->value to register sc->args for gc */ - x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); - typeflag(x)=T_PROMISE; - s_return(sc,cons(sc, sc->args, x)); - - case OP_MACRO0: /* macro */ - if (is_pair(car(sc->code))) { - x = caar(sc->code); - sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); - } else { - x = car(sc->code); - sc->code = cadr(sc->code); - } - if (!is_symbol(x)) { - Error_0(sc,"variable is not a symbol"); - } - s_save(sc,OP_MACRO1, sc->NIL, x); - s_goto(sc,OP_EVAL); - - case OP_MACRO1: /* macro */ - typeflag(sc->value) = T_MACRO; - x = find_slot_in_env(sc, sc->envir, sc->code, 0); - if (x != sc->NIL) { - set_slot_in_env(sc, x, sc->value); - } else { - new_slot_in_env(sc, sc->code, sc->value); - } - s_return(sc,sc->code); - - case OP_CASE0: /* case */ - s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); - sc->code = car(sc->code); - s_goto(sc,OP_EVAL); - - case OP_CASE1: /* case */ - for (x = sc->code; x != sc->NIL; x = cdr(x)) { - if (!is_pair(y = caar(x))) { - break; - } - for ( ; y != sc->NIL; y = cdr(y)) { - if (eqv(car(y), sc->value)) { - break; - } - } - if (y != sc->NIL) { - break; - } - } - if (x != sc->NIL) { - if (is_pair(caar(x))) { - sc->code = cdar(x); - s_goto(sc,OP_BEGIN); - } else {/* else */ - s_save(sc,OP_CASE2, sc->NIL, cdar(x)); - sc->code = caar(x); - s_goto(sc,OP_EVAL); - } - } else { - s_return(sc,sc->NIL); - } - - case OP_CASE2: /* case */ - if (is_true(sc->value)) { - s_goto(sc,OP_BEGIN); - } else { - s_return(sc,sc->NIL); - } - - case OP_PAPPLY: /* apply */ - sc->code = car(sc->args); - sc->args = list_star(sc,cdr(sc->args)); - /*sc->args = cadr(sc->args);*/ - s_goto(sc,OP_APPLY); - - case OP_PEVAL: /* eval */ - if(cdr(sc->args)!=sc->NIL) { - sc->envir=cadr(sc->args); - } - sc->code = car(sc->args); - s_goto(sc,OP_EVAL); - - case OP_CONTINUATION: /* call-with-current-continuation */ - sc->code = car(sc->args); - sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); - s_goto(sc,OP_APPLY); - - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; -#if USE_MATH - double dd; -#endif - - switch (op) { -#if USE_MATH - case OP_INEX2EX: /* inexact->exact */ - x=car(sc->args); - if(is_integer(x)) { - s_return(sc,x); - } else if(modf(rvalue_unchecked(x),&dd)==0.0) { - s_return(sc,mk_integer(sc,ivalue(x))); - } else { - Error_1(sc,"inexact->exact: not integral:",x); - } - - case OP_EXP: - x=car(sc->args); - s_return(sc, mk_real(sc, exp(rvalue(x)))); - - case OP_LOG: - x=car(sc->args); - s_return(sc, mk_real(sc, log(rvalue(x)))); - - case OP_SIN: - x=car(sc->args); - s_return(sc, mk_real(sc, sin(rvalue(x)))); - - case OP_COS: - x=car(sc->args); - s_return(sc, mk_real(sc, cos(rvalue(x)))); - - case OP_TAN: - x=car(sc->args); - s_return(sc, mk_real(sc, tan(rvalue(x)))); - - case OP_ASIN: - x=car(sc->args); - s_return(sc, mk_real(sc, asin(rvalue(x)))); - - case OP_ACOS: - x=car(sc->args); - s_return(sc, mk_real(sc, acos(rvalue(x)))); - - case OP_ATAN: - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - s_return(sc, mk_real(sc, atan(rvalue(x)))); - } else { - pointer y=cadr(sc->args); - s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); - } - - case OP_SQRT: - x=car(sc->args); - s_return(sc, mk_real(sc, sqrt(rvalue(x)))); - - case OP_EXPT: - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - Error_0(sc,"expt: needs two arguments"); - } else { - pointer y=cadr(sc->args); - s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y)))); - } - - case OP_FLOOR: - x=car(sc->args); - s_return(sc, mk_real(sc, floor(rvalue(x)))); - - case OP_CEILING: - x=car(sc->args); - s_return(sc, mk_real(sc, ceil(rvalue(x)))); - - case OP_TRUNCATE : { - double rvalue_of_x ; - x=car(sc->args); - rvalue_of_x = rvalue(x) ; - if (rvalue_of_x > 0) { - s_return(sc, mk_real(sc, floor(rvalue_of_x))); - } else { - s_return(sc, mk_real(sc, ceil(rvalue_of_x))); - } - } - - case OP_ROUND: - x=car(sc->args); - s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); -#endif - - case OP_ADD: /* + */ - v=num_zero; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_add(v,nvalue(car(x))); - } - s_return(sc,mk_number(sc, v)); - - case OP_MUL: /* * */ - v=num_one; - for (x = sc->args; x != sc->NIL; x = cdr(x)) { - v=num_mul(v,nvalue(car(x))); - } - s_return(sc,mk_number(sc, v)); - - case OP_SUB: /* - */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_zero; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - v=num_sub(v,nvalue(car(x))); - } - s_return(sc,mk_number(sc, v)); - - case OP_DIV: /* / */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (!is_zero_double(rvalue(car(x)))) - v=num_div(v,nvalue(car(x))); - else { - Error_0(sc,"/: division by zero"); - } - } - s_return(sc,mk_number(sc, v)); - - case OP_INTDIV: /* quotient */ - if(cdr(sc->args)==sc->NIL) { - x=sc->args; - v=num_one; - } else { - x = cdr(sc->args); - v = nvalue(car(sc->args)); - } - for (; x != sc->NIL; x = cdr(x)) { - if (ivalue(car(x)) != 0) - v=num_intdiv(v,nvalue(car(x))); - else { - Error_0(sc,"quotient: division by zero"); - } - } - s_return(sc,mk_number(sc, v)); - - case OP_REM: /* remainder */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_rem(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"remainder: division by zero"); - } - s_return(sc,mk_number(sc, v)); - - case OP_MOD: /* modulo */ - v = nvalue(car(sc->args)); - if (ivalue(cadr(sc->args)) != 0) - v=num_mod(v,nvalue(cadr(sc->args))); - else { - Error_0(sc,"modulo: division by zero"); - } - s_return(sc,mk_number(sc, v)); - - case OP_CAR: /* car */ - s_return(sc,caar(sc->args)); - - case OP_CDR: /* cdr */ - s_return(sc,cdar(sc->args)); - - case OP_CONS: /* cons */ - cdr(sc->args) = cadr(sc->args); - s_return(sc,sc->args); - - case OP_SETCAR: /* set-car! */ - if(!is_immutable(car(sc->args))) { - caar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-car!: unable to alter immutable pair"); - } - - case OP_SETCDR: /* set-cdr! */ - if(!is_immutable(car(sc->args))) { - cdar(sc->args) = cadr(sc->args); - s_return(sc,car(sc->args)); - } else { - Error_0(sc,"set-cdr!: unable to alter immutable pair"); - } - - case OP_CHAR2INT: { /* char->integer */ - char c; - c=(char)ivalue(car(sc->args)); - s_return(sc,mk_integer(sc,(unsigned char)c)); - } - - case OP_INT2CHAR: { /* integer->char */ - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - s_return(sc,mk_character(sc,(char)c)); - } - - case OP_CHARUPCASE: { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=toupper(c); - s_return(sc,mk_character(sc,(char)c)); - } - - case OP_CHARDNCASE: { - unsigned char c; - c=(unsigned char)ivalue(car(sc->args)); - c=tolower(c); - s_return(sc,mk_character(sc,(char)c)); - } - - case OP_STR2SYM: /* string->symbol */ - s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); - - case OP_STR2ATOM: /* string->atom */ { - char *s=strvalue(car(sc->args)); - if(*s=='#') { - s_return(sc, mk_sharp_const(sc, s+1)); - } else { - s_return(sc, mk_atom(sc, s)); - } - } - - case OP_SYM2STR: /* symbol->string */ - x=mk_string(sc,symname(car(sc->args))); - setimmutable(x); - s_return(sc,x); - case OP_ATOM2STR: /* atom->string */ - x=car(sc->args); - if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { - char *p; - int len; - atom2str(sc,x,0,&p,&len); - s_return(sc,mk_counted_string(sc,p,len)); - } else { - Error_1(sc, "atom->string: not an atom:", x); - } - - case OP_MKSTRING: { /* make-string */ - int fill=' '; - int len; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=charvalue(cadr(sc->args)); - } - s_return(sc,mk_empty_string(sc,len,(char)fill)); - } - - case OP_STRLEN: /* string-length */ - s_return(sc,mk_integer(sc,strlength(car(sc->args)))); - - case OP_STRREF: { /* string-ref */ - char *str; - int index; - - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - - if(index>=strlength(car(sc->args))) { - Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); - } - - s_return(sc,mk_character(sc,((unsigned char*)str)[index])); - } - - case OP_STRSET: { /* string-set! */ - char *str; - int index; - int c; - - if(is_immutable(car(sc->args))) { - Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); - } - str=strvalue(car(sc->args)); - - index=ivalue(cadr(sc->args)); - if(index>=strlength(car(sc->args))) { - Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); - } - - c=charvalue(caddr(sc->args)); - - str[index]=(char)c; - s_return(sc,car(sc->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 = sc->args; x != sc->NIL; x = cdr(x)) { - len += strlength(car(x)); - } - newstr = mk_empty_string(sc, len, ' '); - /* store the contents of the argument strings into the new string */ - for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; - pos += strlength(car(x)), x = cdr(x)) { - memcpy(pos, strvalue(car(x)), strlength(car(x))); - } - s_return(sc, newstr); - } - - case OP_SUBSTR: { /* substring */ - char *str; - int index0; - int index1; - int len; - - str=strvalue(car(sc->args)); - - index0=ivalue(cadr(sc->args)); - - if(index0>strlength(car(sc->args))) { - Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); - } - - if(cddr(sc->args)!=sc->NIL) { - index1=ivalue(caddr(sc->args)); - if(index1>strlength(car(sc->args)) || index1args)); - } - } else { - index1=strlength(car(sc->args)); - } - - len=index1-index0; - x=mk_empty_string(sc,len,' '); - memcpy(strvalue(x),str+index0,len); - strvalue(x)[len]=0; - - s_return(sc,x); - } - - case OP_VECTOR: { /* vector */ - int i; - pointer vec; - int len=list_length(sc,sc->args); - if(len<0) { - Error_1(sc,"vector: not a proper list:",sc->args); - } - vec=mk_vector(sc,len); - for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { - set_vector_elem(vec,i,car(x)); - } - s_return(sc,vec); - } - - case OP_MKVECTOR: { /* make-vector */ - pointer fill=sc->NIL; - int len; - pointer vec; - - len=ivalue(car(sc->args)); - - if(cdr(sc->args)!=sc->NIL) { - fill=cadr(sc->args); - } - vec=mk_vector(sc,len); - if(fill!=sc->NIL) { - fill_vector(vec,fill); - } - s_return(sc,vec); - } - - case OP_VECLEN: /* vector-length */ - s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); - - case OP_VECREF: { /* vector-ref */ - int index; - - index=ivalue(cadr(sc->args)); - - if(index>=ivalue(car(sc->args))) { - Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); - } - - s_return(sc,vector_elem(car(sc->args),index)); - } - - case OP_VECSET: { /* vector-set! */ - int index; - - if(is_immutable(car(sc->args))) { - Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); - } - - index=ivalue(cadr(sc->args)); - if(index>=ivalue(car(sc->args))) { - Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); - } - - set_vector_elem(car(sc->args),index,caddr(sc->args)); - s_return(sc,car(sc->args)); - } - - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static int list_length(scheme *sc, pointer a) { - int v=0; - pointer x; - for (x = a, v = 0; is_pair(x); x = cdr(x)) { - ++v; - } - if(x==sc->NIL) { - return v; - } - return -1; -} - -static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { - pointer x; - num v; - int (*comp_func)(num,num)=0; - - switch (op) { - case OP_NOT: /* not */ - s_retbool(is_false(car(sc->args))); - case OP_BOOLP: /* boolean? */ - s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); - case OP_EOFOBJP: /* boolean? */ - s_retbool(car(sc->args) == sc->EOF_OBJ); - case OP_NULLP: /* null? */ - s_retbool(car(sc->args) == sc->NIL); - case OP_NUMEQ: /* = */ - case OP_LESS: /* < */ - case OP_GRE: /* > */ - case OP_LEQ: /* <= */ - case OP_GEQ: /* >= */ - switch(op) { - case OP_NUMEQ: comp_func=num_eq; break; - case OP_LESS: comp_func=num_lt; break; - case OP_GRE: comp_func=num_gt; break; - case OP_LEQ: comp_func=num_le; break; - case OP_GEQ: comp_func=num_ge; break; - } - x=sc->args; - v=nvalue(car(x)); - x=cdr(x); - - for (; x != sc->NIL; x = cdr(x)) { - if(!comp_func(v,nvalue(car(x)))) { - s_retbool(0); - } - v=nvalue(car(x)); - } - s_retbool(1); - case OP_SYMBOLP: /* symbol? */ - s_retbool(is_symbol(car(sc->args))); - case OP_NUMBERP: /* number? */ - s_retbool(is_number(car(sc->args))); - case OP_STRINGP: /* string? */ - s_retbool(is_string(car(sc->args))); - case OP_INTEGERP: /* integer? */ - s_retbool(is_integer(car(sc->args))); - case OP_REALP: /* real? */ - s_retbool(is_number(car(sc->args))); /* All numbers are real */ - case OP_CHARP: /* char? */ - s_retbool(is_character(car(sc->args))); -#if USE_CHAR_CLASSIFIERS - case OP_CHARAP: /* char-alphabetic? */ - s_retbool(Cisalpha(ivalue(car(sc->args)))); - case OP_CHARNP: /* char-numeric? */ - s_retbool(Cisdigit(ivalue(car(sc->args)))); - case OP_CHARWP: /* char-whitespace? */ - s_retbool(Cisspace(ivalue(car(sc->args)))); - case OP_CHARUP: /* char-upper-case? */ - s_retbool(Cisupper(ivalue(car(sc->args)))); - case OP_CHARLP: /* char-lower-case? */ - s_retbool(Cislower(ivalue(car(sc->args)))); -#endif - case OP_PORTP: /* port? */ - s_retbool(is_port(car(sc->args))); - case OP_INPORTP: /* input-port? */ - s_retbool(is_inport(car(sc->args))); - case OP_OUTPORTP: /* output-port? */ - s_retbool(is_outport(car(sc->args))); - case OP_PROCP: /* procedure? */ - /*-- - * continuation should be procedure by the example - * (call-with-current-continuation procedure?) ==> #t - * in R^3 report sec. 6.9 - */ - s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) - || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); - case OP_PAIRP: /* pair? */ - s_retbool(is_pair(car(sc->args))); - case OP_LISTP: { /* list? */ - pointer slow, fast; - slow = fast = car(sc->args); - while (1) { - if (!is_pair(fast)) s_retbool(fast == sc->NIL); - fast = cdr(fast); - if (!is_pair(fast)) s_retbool(fast == sc->NIL); - fast = cdr(fast); - 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 */ - s_retbool(0); - } - } - } - case OP_ENVP: /* environment? */ - s_retbool(is_environment(car(sc->args))); - case OP_VECTORP: /* vector? */ - s_retbool(is_vector(car(sc->args))); - case OP_EQ: /* eq? */ - s_retbool(car(sc->args) == cadr(sc->args)); - case OP_EQV: /* eqv? */ - s_retbool(eqv(car(sc->args), cadr(sc->args))); - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; -} - -static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - - switch (op) { - case OP_FORCE: /* force */ - sc->code = car(sc->args); - if (is_promise(sc->code)) { - /* Should change type to closure here */ - s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); - sc->args = sc->NIL; - s_goto(sc,OP_APPLY); - } else { - s_return(sc,sc->code); - } - - case OP_SAVE_FORCED: /* Save forced value replacing promise */ - memcpy(sc->code,sc->value,sizeof(struct cell)); - s_return(sc,sc->value); - - case OP_WRITE: /* write */ - case OP_DISPLAY: /* display */ - case OP_WRITE_CHAR: /* write-char */ - if(is_pair(cdr(sc->args))) { - if(cadr(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=cadr(sc->args); - } - } - sc->args = car(sc->args); - if(op==OP_WRITE) { - sc->print_flag = 1; - } else { - sc->print_flag = 0; - } - s_goto(sc,OP_P0LIST); - - case OP_NEWLINE: /* newline */ - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->outport) { - x=cons(sc,sc->outport,sc->NIL); - s_save(sc,OP_SET_OUTPORT, x, sc->NIL); - sc->outport=car(sc->args); - } - } - putstr(sc, "\n"); - s_return(sc,sc->T); - - case OP_ERR0: /* error */ - sc->retcode=-1; - if (!is_string(car(sc->args))) { - sc->args=cons(sc,mk_string(sc," -- "),sc->args); - setimmutable(car(sc->args)); - } - putstr(sc, "Error: "); - putstr(sc, strvalue(car(sc->args))); - sc->args = cdr(sc->args); - s_goto(sc,OP_ERR1); - - case OP_ERR1: /* error */ - putstr(sc, " "); - if (sc->args != sc->NIL) { - s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - sc->print_flag = 1; - s_goto(sc,OP_P0LIST); - } else { - putstr(sc, "\n"); - if(sc->interactive_repl) { - s_goto(sc,OP_T0LVL); - } else { - return sc->NIL; - } - } - - case OP_REVERSE: /* reverse */ - s_return(sc,reverse(sc, car(sc->args))); - - case OP_LIST_STAR: /* list* */ - s_return(sc,list_star(sc,sc->args)); - - case OP_APPEND: /* append */ - if(sc->args==sc->NIL) { - s_return(sc,sc->NIL); - } - x=car(sc->args); - if(cdr(sc->args)==sc->NIL) { - s_return(sc,sc->args); - } - for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) { - x=append(sc,x,car(y)); - } - s_return(sc,x); - -#if USE_PLIST - case OP_PUT: /* put */ - if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { - Error_0(sc,"illegal use of put"); - } - for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { - if (caar(x) == y) { - break; - } - } - if (x != sc->NIL) - cdar(x) = caddr(sc->args); - else - symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), - symprop(car(sc->args))); - s_return(sc,sc->T); - - case OP_GET: /* get */ - if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { - Error_0(sc,"illegal use of get"); - } - for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { - if (caar(x) == y) { - break; - } - } - if (x != sc->NIL) { - s_return(sc,cdar(x)); - } else { - s_return(sc,sc->NIL); - } -#endif /* USE_PLIST */ - case OP_QUIT: /* quit */ - if(is_pair(sc->args)) { - sc->retcode=ivalue(car(sc->args)); - } - return (sc->NIL); - - case OP_GC: /* gc */ - gc(sc, sc->NIL, sc->NIL); - s_return(sc,sc->T); - - case OP_GCVERB: /* gc-verbose */ - { int was = sc->gc_verbose; - - sc->gc_verbose = (car(sc->args) != sc->F); - s_retbool(was); - } - - case OP_NEWSEGMENT: /* new-segment */ - if (!is_pair(sc->args) || !is_number(car(sc->args))) { - Error_0(sc,"new-segment: argument must be a number"); - } - alloc_cellseg(sc, (int) ivalue(car(sc->args))); - s_return(sc,sc->T); - - case OP_OBLIST: /* oblist */ - s_return(sc, oblist_all_symbols(sc)); - - case OP_CURR_INPORT: /* current-input-port */ - s_return(sc,sc->inport); - - case OP_CURR_OUTPORT: /* current-output-port */ - s_return(sc,sc->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(sc,strvalue(car(sc->args)),prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - } - -#if USE_STRING_PORTS - case OP_OPEN_INSTRING: /* open-input-string */ - case OP_OPEN_OUTSTRING: /* open-output-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_OUTSTRING: prop=port_output; break; - case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; - } - p=port_from_string(sc, strvalue(car(sc->args)), - strvalue(car(sc->args))+strlength(car(sc->args)), prop); - if(p==sc->NIL) { - s_return(sc,sc->F); - } - s_return(sc,p); - } -#endif - - case OP_CLOSE_INPORT: /* close-input-port */ - port_close(sc,car(sc->args),port_input); - s_return(sc,sc->T); - - case OP_CLOSE_OUTPORT: /* close-output-port */ - port_close(sc,car(sc->args),port_output); - s_return(sc,sc->T); - - case OP_INT_ENV: /* interaction-environment */ - s_return(sc,sc->global_env); - - case OP_CURR_ENV: /* current-environment */ - s_return(sc,sc->envir); - - } - return sc->T; -} - -static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { - pointer x; - - if(sc->nesting!=0) { - int n=sc->nesting; - sc->nesting=0; - sc->retcode=-1; - Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); - } - - switch (op) { - /* ========== reading part ========== */ - case OP_READ: - if(!is_pair(sc->args)) { - s_goto(sc,OP_READ_INTERNAL); - } - if(!is_inport(car(sc->args))) { - Error_1(sc,"read: not an input port:",car(sc->args)); - } - if(car(sc->args)==sc->inport) { - s_goto(sc,OP_READ_INTERNAL); - } - x=sc->inport; - sc->inport=car(sc->args); - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - s_goto(sc,OP_READ_INTERNAL); - - case OP_READ_CHAR: /* read-char */ - case OP_PEEK_CHAR: /* peek-char */ { - int c; - if(is_pair(sc->args)) { - if(car(sc->args)!=sc->inport) { - x=sc->inport; - x=cons(sc,x,sc->NIL); - s_save(sc,OP_SET_INPORT, x, sc->NIL); - sc->inport=car(sc->args); - } - } - c=inchar(sc); - if(c==EOF) { - s_return(sc,sc->EOF_OBJ); - } - if(sc->op==OP_PEEK_CHAR) { - backchar(sc,c); - } - s_return(sc,mk_character(sc,c)); - } - - case OP_CHAR_READY: /* char-ready? */ { - pointer p=sc->inport; - int res; - if(is_pair(sc->args)) { - p=car(sc->args); - } - res=p->_object._port->kind&port_string; - s_retbool(res); - } - - case OP_SET_INPORT: /* set-input-port */ - sc->inport=car(sc->args); - s_return(sc,sc->value); - - case OP_SET_OUTPORT: /* set-output-port */ - sc->outport=car(sc->args); - s_return(sc,sc->value); - - case OP_RDSEXPR: - switch (sc->tok) { - case TOK_EOF: - if(sc->inport==sc->loadport) { - sc->args=sc->NIL; - s_goto(sc,OP_QUIT); - } else { - s_return(sc,sc->EOF_OBJ); - } - case TOK_COMMENT: { - int c; - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - } - case TOK_VEC: - s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); - /* fall through */ - case TOK_LPAREN: - sc->tok = token(sc); - if (sc->tok == TOK_RPAREN) { - s_return(sc,sc->NIL); - } else if (sc->tok == TOK_DOT) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { - sc->nesting_stack[sc->file_i]++; - s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); - s_goto(sc,OP_RDSEXPR); - } - case TOK_QUOTE: - s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - case TOK_BQUOTE: - sc->tok = token(sc); - if(sc->tok==TOK_VEC) { - s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); - sc->tok=TOK_LPAREN; - s_goto(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); - } - s_goto(sc,OP_RDSEXPR); - case TOK_COMMA: - s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - case TOK_ATMARK: - s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - case TOK_ATOM: - s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r "))); - case TOK_DQUOTE: - x=readstrexp(sc); - if(x==sc->F) { - Error_0(sc,"Error reading string"); - } - setimmutable(x); - s_return(sc,x); - case TOK_SHARP: { - pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); - if(f==sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - sc->code=cons(sc,slot_value_in_env(f),sc->NIL); - s_goto(sc,OP_EVAL); - } - } - case TOK_SHARP_CONST: - if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) { - Error_0(sc,"undefined sharp expression"); - } else { - s_return(sc,x); - } - default: - Error_0(sc,"syntax error: illegal token"); - } - break; - - case OP_RDLIST: { - sc->args = cons(sc, sc->value, sc->args); - sc->tok = token(sc); - if (sc->tok == TOK_COMMENT) { - int c; - while ((c=inchar(sc)) != '\n' && c!=EOF) - ; - sc->tok = token(sc); - } - if (sc->tok == TOK_RPAREN) { - int c = inchar(sc); - if (c != '\n') backchar(sc,c); - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); - } else if (sc->tok == TOK_DOT) { - s_save(sc,OP_RDDOT, sc->args, sc->NIL); - sc->tok = token(sc); - s_goto(sc,OP_RDSEXPR); - } else { - s_save(sc,OP_RDLIST, sc->args, sc->NIL);; - s_goto(sc,OP_RDSEXPR); - } - } - - case OP_RDDOT: - if (token(sc) != TOK_RPAREN) { - Error_0(sc,"syntax error: illegal dot expression"); - } else { - sc->nesting_stack[sc->file_i]--; - s_return(sc,reverse_in_place(sc, sc->value, sc->args)); - } - - case OP_RDQUOTE: - s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); - - case OP_RDQQUOTE: - s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); - - case OP_RDQQUOTEVEC: - s_return(sc,cons(sc, mk_symbol(sc,"apply"), - cons(sc, mk_symbol(sc,"vector"), - cons(sc,cons(sc, sc->QQUOTE, - cons(sc,sc->value,sc->NIL)), - sc->NIL)))); - - case OP_RDUNQUOTE: - s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); - - case OP_RDUQTSP: - s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); - - case OP_RDVEC: - /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_goto(sc,OP_EVAL); Cannot be quoted*/ - /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); - s_return(sc,x); Cannot be part of pairs*/ - /*sc->code=mk_proc(sc,OP_VECTOR); - sc->args=sc->value; - s_goto(sc,OP_APPLY);*/ - sc->args=sc->value; - s_goto(sc,OP_VECTOR); - - /* ========== printing part ========== */ - case OP_P0LIST: - if(is_vector(sc->args)) { - putstr(sc,"#("); - sc->args=cons(sc,sc->args,mk_integer(sc,0)); - s_goto(sc,OP_PVECFROM); - } else if(is_environment(sc->args)) { - putstr(sc,"#"); - s_return(sc,sc->T); - } else if (!is_pair(sc->args)) { - printatom(sc, sc->args, sc->print_flag); - s_return(sc,sc->T); - } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "'"); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, "`"); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { - putstr(sc, ","); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { - putstr(sc, ",@"); - sc->args = cadr(sc->args); - s_goto(sc,OP_P0LIST); - } else { - putstr(sc, "("); - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - sc->args = car(sc->args); - s_goto(sc,OP_P0LIST); - } - - case OP_P1LIST: - if (is_pair(sc->args)) { - s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); - putstr(sc, " "); - sc->args = car(sc->args); - s_goto(sc,OP_P0LIST); - } else if(is_vector(sc->args)) { - s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); - putstr(sc, " . "); - s_goto(sc,OP_P0LIST); - } else { - if (sc->args != sc->NIL) { - putstr(sc, " . "); - printatom(sc, sc->args, sc->print_flag); - } - putstr(sc, ")"); - s_return(sc,sc->T); - } - case OP_PVECFROM: { - int i=ivalue_unchecked(cdr(sc->args)); - pointer vec=car(sc->args); - int len=ivalue_unchecked(vec); - if(i==len) { - putstr(sc,")"); - s_return(sc,sc->T); - } else { - pointer elem=vector_elem(vec,i); - ivalue_unchecked(cdr(sc->args))=i+1; - s_save(sc,OP_PVECFROM, sc->args, sc->NIL); - sc->args=elem; - putstr(sc," "); - s_goto(sc,OP_P0LIST); - } - } - - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - - } - return sc->T; -} - -static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { - pointer x, y; - long v; - - switch (op) { - case OP_LIST_LENGTH: /* length */ /* a.k */ - v=list_length(sc,car(sc->args)); - if(v<0) { - Error_1(sc,"length: not a list:",car(sc->args)); - } - s_return(sc,mk_integer(sc, v)); - - case OP_ASSQ: /* assq */ /* a.k */ - x = car(sc->args); - for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { - if (!is_pair(car(y))) { - Error_0(sc,"unable to handle non pair element"); - } - if (x == caar(y)) - break; - } - if (is_pair(y)) { - s_return(sc,car(y)); - } else { - s_return(sc,sc->F); - } - - - case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ - sc->args = car(sc->args); - if (sc->args == sc->NIL) { - s_return(sc,sc->F); - } else if (is_closure(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); - } else if (is_macro(sc->args)) { - s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); - } else { - s_return(sc,sc->F); - } - case OP_CLOSUREP: /* closure? */ - /* - * Note, macro object is also a closure. - * Therefore, (closure? <#MACRO>) ==> #t - */ - s_retbool(is_closure(car(sc->args))); - case OP_MACROP: /* macro? */ - s_retbool(is_macro(car(sc->args))); - default: - sprintf(sc->strbuff, "%d: illegal operator", sc->op); - Error_0(sc,sc->strbuff); - } - return sc->T; /* NOTREACHED */ -} - -typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); - -typedef int (*test_predicate)(pointer); -static int is_any(pointer p) { return 1;} -static int is_num_integer(pointer p) { - return is_number(p) && ((p)->_object._number.is_fixnum); -} -static int is_nonneg(pointer p) { - return is_num_integer(p) && ivalue(p)>=0; -} - -/* Correspond carefully with following defines! */ -static struct { - test_predicate fct; - const char *kind; -} tests[]={ - {0,0}, /* unused */ - {is_any, 0}, - {is_string, "string"}, - {is_symbol, "symbol"}, - {is_port, "port"}, - {0,"input port"}, - {0,"output_port"}, - {is_environment, "environment"}, - {is_pair, "pair"}, - {0, "pair or '()"}, - {is_character, "character"}, - {is_vector, "vector"}, - {is_number, "number"}, - {is_num_integer, "integer"}, - {is_nonneg, "non-negative integer"} -}; - -#define TST_NONE 0 -#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" - -typedef struct { - dispatch_func func; - char *name; - int min_arity; - int max_arity; - char *arg_tests_encoding; -} op_code_info; - -#define INF_ARG 0xffff - -static op_code_info dispatch_table[]= { -#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, -#include "opdefines.h" - { 0 } -}; - -static const char *procname(pointer x) { - int n=procnum(x); - const char *name=dispatch_table[n].name; - if(name==0) { - name="ILLEGAL!"; - } - return name; -} - -/* kernel of this interpreter */ -static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { - int count=0; - int old_op; - - sc->op = op; - for (;;) { - op_code_info *pcd=dispatch_table+sc->op; - if (pcd->name!=0) { /* if built-in function, check arguments */ - char msg[512]; - int ok=1; - int n=list_length(sc,sc->args); - - /* Check number of arguments */ - if(nmin_arity) { - ok=0; - sprintf(msg,"%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at least", - pcd->min_arity); - } - if(ok && n>pcd->max_arity) { - ok=0; - sprintf(msg,"%s: needs%s %d argument(s)", - pcd->name, - pcd->min_arity==pcd->max_arity?"":" at most", - pcd->max_arity); - } - if(ok) { - if(pcd->arg_tests_encoding!=0) { - int i=0; - int j; - const char *t=pcd->arg_tests_encoding; - pointer arglist=sc->args; - do { - pointer arg=car(arglist); - j=(int)t[0]; - if(j==TST_INPORT[0]) { - if(!is_inport(arg)) break; - } else if(j==TST_OUTPORT[0]) { - if(!is_outport(arg)) break; - } else if(j==TST_LIST[0]) { - if(arg!=sc->NIL && !is_pair(arg)) break; - } else { - if(!tests[j].fct(arg)) break; - } - - if(t[1]!=0) {/* last test is replicated as necessary */ - t++; - } - arglist=cdr(arglist); - i++; - } while(iname, - i+1, - tests[j].kind); - } - } - } - if(!ok) { - if(_Error_1(sc,msg,0)==sc->NIL) { - return; - } - pcd=dispatch_table+sc->op; - } - } - old_op=sc->op; - if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { - return; - } - if(sc->no_memory) { - fprintf(stderr,"No memory!\n"); - return; - } - count++; - } -} - -/* ========== Initialization of internal keywords ========== */ - -static void assign_syntax(scheme *sc, char *name) { - pointer x; - - x = oblist_add_by_name(sc, name); - typeflag(x) |= T_SYNTAX; -} - -static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { - pointer x, y; - - x = mk_symbol(sc, name); - y = mk_proc(sc,op); - new_slot_in_env(sc, x, y); -} - -static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { - pointer y; - - y = get_cell(sc, sc->NIL, sc->NIL); - typeflag(y) = (T_PROC | T_ATOM); - ivalue_unchecked(y) = (long) op; - set_integer(y); - return y; -} - -/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ -static int syntaxnum(pointer p) { - const char *s=strvalue(car(p)); - switch(strlength(car(p))) { - case 2: - if(s[0]=='i') return OP_IF0; /* if */ - else return OP_OR0; /* or */ - case 3: - if(s[0]=='a') return OP_AND0; /* and */ - else return OP_LET0; /* let */ - case 4: - switch(s[3]) { - case 'e': return OP_CASE0; /* case */ - case 'd': return OP_COND0; /* cond */ - case '*': return OP_LET0AST; /* let* */ - default: return OP_SET0; /* set! */ - } - case 5: - switch(s[2]) { - case 'g': return OP_BEGIN; /* begin */ - case 'l': return OP_DELAY; /* delay */ - case 'c': return OP_MACRO0; /* macro */ - default: return OP_QUOTE; /* quote */ - } - case 6: - switch(s[2]) { - case 'm': return OP_LAMBDA; /* lambda */ - case 'f': return OP_DEF0; /* define */ - default: return OP_LET0REC; /* letrec */ - } - default: - return OP_C0STREAM; /* cons-stream */ - } -} - -/* initialization of TinyScheme */ -#if USE_INTERFACE -INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { - return cons(sc,a,b); -} -INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { - return immutable_cons(sc,a,b); -} - -static struct scheme_interface vtbl ={ - scheme_define, - s_cons, - s_immutable_cons, - mk_integer, - mk_real, - mk_symbol, - gensym, - mk_string, - mk_counted_string, - mk_character, - mk_vector, - mk_foreign_func, - putstr, - putcharacter, - - is_string, - string_value, - is_number, - nvalue, - ivalue, - rvalue, - is_integer, - is_real, - is_character, - charvalue, - is_vector, - ivalue, - fill_vector, - vector_elem, - set_vector_elem, - is_port, - is_pair, - pair_car, - pair_cdr, - set_car, - set_cdr, - - is_symbol, - symname, - - is_syntax, - is_proc, - is_foreign, - syntaxname, - is_closure, - is_macro, - closure_code, - closure_env, - - is_continuation, - is_promise, - is_environment, - is_immutable, - setimmutable, - - scheme_load_file, - scheme_load_string -}; -#endif - -scheme *scheme_init_new() { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init(sc)) { - free(sc); - return 0; - } else { - return sc; - } -} - -scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { - scheme *sc=(scheme*)malloc(sizeof(scheme)); - if(!scheme_init_custom_alloc(sc,malloc,free)) { - free(sc); - return 0; - } else { - return sc; - } -} - - -int scheme_init(scheme *sc) { - return scheme_init_custom_alloc(sc,malloc,free); -} - -int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { - int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); - pointer x; - - num_zero.is_fixnum=1; - num_zero.value.ivalue=0; - num_one.is_fixnum=1; - num_one.value.ivalue=1; - -#if USE_INTERFACE - sc->vptr=&vtbl; -#endif - sc->gensym_cnt=0; - sc->malloc=malloc; - sc->free=free; - sc->last_cell_seg = -1; - sc->sink = &sc->_sink; - sc->NIL = &sc->_NIL; - sc->T = &sc->_HASHT; - sc->F = &sc->_HASHF; - sc->EOF_OBJ=&sc->_EOF_OBJ; - sc->free_cell = &sc->_NIL; - sc->fcells = 0; - sc->no_memory=0; - sc->inport=sc->NIL; - sc->outport=sc->NIL; - sc->save_inport=sc->NIL; - sc->loadport=sc->NIL; - sc->nesting=0; - sc->interactive_repl=0; - - if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { - sc->no_memory=1; - return 0; - } - sc->gc_verbose = 0; - dump_stack_initialize(sc); - sc->code = sc->NIL; - sc->tracing=0; - - /* init sc->NIL */ - typeflag(sc->NIL) = (T_ATOM | MARK); - car(sc->NIL) = cdr(sc->NIL) = sc->NIL; - /* init T */ - typeflag(sc->T) = (T_ATOM | MARK); - car(sc->T) = cdr(sc->T) = sc->T; - /* init F */ - typeflag(sc->F) = (T_ATOM | MARK); - car(sc->F) = cdr(sc->F) = sc->F; - sc->oblist = oblist_initial_value(sc); - /* init global_env */ - new_frame_in_env(sc, sc->NIL); - sc->global_env = sc->envir; - /* init else */ - x = mk_symbol(sc,"else"); - new_slot_in_env(sc, x, sc->T); - - assign_syntax(sc, "lambda"); - assign_syntax(sc, "quote"); - assign_syntax(sc, "define"); - assign_syntax(sc, "if"); - assign_syntax(sc, "begin"); - assign_syntax(sc, "set!"); - assign_syntax(sc, "let"); - assign_syntax(sc, "let*"); - assign_syntax(sc, "letrec"); - assign_syntax(sc, "cond"); - assign_syntax(sc, "delay"); - assign_syntax(sc, "and"); - assign_syntax(sc, "or"); - assign_syntax(sc, "cons-stream"); - assign_syntax(sc, "macro"); - assign_syntax(sc, "case"); - - for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); - sc->QUOTE = mk_symbol(sc, "quote"); - sc->QQUOTE = mk_symbol(sc, "quasiquote"); - sc->UNQUOTE = mk_symbol(sc, "unquote"); - sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); - sc->FEED_TO = mk_symbol(sc, "=>"); - sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); - sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); - sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); - - return !sc->no_memory; -} - -void scheme_set_input_port_file(scheme *sc, FILE *fin) { - sc->inport=port_from_file(sc,fin,port_input); -} - -void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { - sc->inport=port_from_string(sc,start,past_the_end,port_input); -} - -void scheme_set_output_port_file(scheme *sc, FILE *fout) { - sc->outport=port_from_file(sc,fout,port_output); -} - -void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { - sc->outport=port_from_string(sc,start,past_the_end,port_output); -} - -void scheme_set_external_data(scheme *sc, void *p) { - sc->ext_data=p; -} - -void scheme_deinit(scheme *sc) { - int i; - - sc->oblist=sc->NIL; - sc->global_env=sc->NIL; - dump_stack_free(sc); - sc->envir=sc->NIL; - sc->code=sc->NIL; - sc->args=sc->NIL; - sc->value=sc->NIL; - if(is_port(sc->inport)) { - typeflag(sc->inport) = T_ATOM; - } - sc->inport=sc->NIL; - sc->outport=sc->NIL; - if(is_port(sc->save_inport)) { - typeflag(sc->save_inport) = T_ATOM; - } - sc->save_inport=sc->NIL; - if(is_port(sc->loadport)) { - typeflag(sc->loadport) = T_ATOM; - } - sc->loadport=sc->NIL; - sc->gc_verbose=0; - gc(sc,sc->NIL,sc->NIL); - - for(i=0; i<=sc->last_cell_seg; i++) { - sc->free(sc->alloc_seg[i]); - } -} - -void scheme_load_file(scheme *sc, FILE *fin) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_file; - sc->load_stack[0].rep.stdio.file=fin; - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - if(fin==stdin) { - sc->interactive_repl=1; - } - sc->inport=sc->loadport; - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } -} - -void scheme_load_string(scheme *sc, const char *cmd) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->file_i=0; - sc->load_stack[0].kind=port_input|port_string; - sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ - sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); - sc->load_stack[0].rep.string.curr=(char*)cmd; - sc->loadport=mk_port(sc,sc->load_stack); - sc->retcode=0; - sc->interactive_repl=0; - sc->inport=sc->loadport; - Eval_Cycle(sc, OP_T0LVL); - typeflag(sc->loadport)=T_ATOM; - if(sc->retcode==0) { - sc->retcode=sc->nesting!=0; - } -} - -void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { - pointer x; - - x=find_slot_in_env(sc,envir,symbol,0); - if (x != sc->NIL) { - set_slot_in_env(sc, x, value); - } else { - new_slot_spec_in_env(sc, envir, symbol, value); - } -} - -#if !STANDALONE -void scheme_apply0(scheme *sc, const char *procname) { - pointer carx=mk_symbol(sc,procname); - pointer cdrx=sc->NIL; - - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->code = cons(sc,carx,cdrx); - sc->interactive_repl=0; - sc->retcode=0; - Eval_Cycle(sc,OP_EVAL); - } - -void scheme_call(scheme *sc, pointer func, pointer args) { - dump_stack_reset(sc); - sc->envir = sc->global_env; - sc->args = args; - sc->code = func; - sc->interactive_repl =0; - sc->retcode = 0; - Eval_Cycle(sc, OP_APPLY); -} -#endif - -/* ========== Main ========== */ - -#if STANDALONE - -#ifdef macintosh -int main() -{ - extern MacTS_main(int argc, char **argv); - char** argv; - int argc = ccommand(&argv); - MacTS_main(argc,argv); - return 0; -} -int MacTS_main(int argc, char **argv) { -#else -int main(int argc, char **argv) { -#endif - scheme sc; - FILE *fin; - char *file_name=InitFile; - int retcode; - int isfile=1; - - if(argc==1) { - printf(banner); - } - if(argc==2 && strcmp(argv[1],"-?")==0) { - printf("Usage: %s [-? | ... | -1 ...]\n\tUse - as filename for stdin.\n",argv[0]); - return 1; - } - if(!scheme_init(&sc)) { - fprintf(stderr,"Could not initialize!\n"); - return 2; - } - scheme_set_input_port_file(&sc, stdin); - scheme_set_output_port_file(&sc, stdout); -#if USE_DL - scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); -#endif - argv++; - if(access(file_name,0)!=0) { - char *p=getenv("TINYSCHEMEINIT"); - if(p!=0) { - file_name=p; - } - } - do { - if(strcmp(file_name,"-")==0) { - fin=stdin; - } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { - pointer args=sc.NIL; - isfile=file_name[1]=='1'; - file_name=*argv++; - if(strcmp(file_name,"-")==0) { - fin=stdin; - } else if(isfile) { - fin=fopen(file_name,"r"); - } - for(;*argv;argv++) { - pointer value=mk_string(&sc,*argv); - args=cons(&sc,value,args); - } - args=reverse_in_place(&sc,sc.NIL,args); - scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); - - } else { - fin=fopen(file_name,"r"); - } - if(isfile && fin==0) { - fprintf(stderr,"Could not open file %s\n",file_name); - } else { - if(isfile) { - scheme_load_file(&sc,fin); - } else { - scheme_load_string(&sc,file_name); - } - if(!isfile || fin!=stdin) { - if(sc.retcode!=0) { - fprintf(stderr,"Errors encountered reading %s\n",file_name); - } - if(isfile) { - fclose(fin); - } - } - } - file_name=*argv++; - } while(file_name!=0); - if(argc==1) { - scheme_load_file(&sc,stdin); - } - retcode=sc.retcode; - scheme_deinit(&sc); - - return retcode; -} - -#endif +/* T I N Y S C H E M E 1 . 3 5 + * 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 _SCHEME_SOURCE +#include "scheme-private.h" +#ifndef WIN32 +# include +#endif +#if USE_DL +# include "dynload.h" +#endif +#if USE_MATH +# include +#endif +#include +#include +#include + +#if USE_STRCASECMP +#include +#define stricmp strcasecmp +#endif + +/* Used for documentation purposes, to signal functions in 'interface' */ +#define INTERFACE + +#define TOK_EOF (-1) +#define TOK_LPAREN 0 +#define TOK_RPAREN 1 +#define TOK_DOT 2 +#define TOK_ATOM 3 +#define TOK_QUOTE 4 +#define TOK_COMMENT 5 +#define TOK_DQUOTE 6 +#define TOK_BQUOTE 7 +#define TOK_COMMA 8 +#define TOK_ATMARK 9 +#define TOK_SHARP 10 +#define TOK_SHARP_CONST 11 +#define TOK_VEC 12 + +# define BACKQUOTE '`' + +/* + * Basic memory allocation units + */ + +#define banner "TinyScheme 1.35" + +#include +#include +#ifdef macintosh +static int stricmp(const char *s1, const char *s2) +{ + unsigned char c1, c2; + do { + c1 = tolower(*s1); + c2 = tolower(*s2); + if (c1 < c2) + return -1; + else if (c1 > c2) + return 1; + s1++, s2++; + } while (c1 != 0); + return 0; +} +#endif /* macintosh */ + +#if USE_STRLWR +static const char *strlwr(char *s) { + const char *p=s; + while(*s) { + *s=tolower(*s); + s++; + } + return p; +} +#endif + +#ifndef prompt +# define prompt "> " +#endif + +#ifndef TINYSCHEMEPREFIX +# define TINYSCHEMEPREFIX "" +#endif + +#ifndef TINYSCHEMEDIR +# define TINYSCHEMEDIR "" +#endif + +#ifndef InitFile +# define InitFile TINYSCHEMEPREFIX TINYSCHEMEDIR "init.scm" +#endif + + +#ifndef FIRST_CELLSEGS +# define FIRST_CELLSEGS 3 +#endif + +enum scheme_types { + T_STRING=1, + T_NUMBER=2, + T_SYMBOL=3, + T_PROC=4, + T_PAIR=5, + T_CLOSURE=6, + T_CONTINUATION=7, + T_FOREIGN=8, + T_CHARACTER=9, + T_PORT=10, + T_VECTOR=11, + T_MACRO=12, + T_PROMISE=13, + T_ENVIRONMENT=14, + T_LAST_SYSTEM_TYPE=14 +}; + +/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ +#define ADJ 32 +#define TYPE_BITS 5 +#define T_MASKTYPE 31 /* 0000000000011111 */ +#define T_SYNTAX 4096 /* 0001000000000000 */ +#define T_IMMUTABLE 8192 /* 0010000000000000 */ +#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ +#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ +#define MARK 32768 /* 1000000000000000 */ +#define UNMARK 32767 /* 0111111111111111 */ + + +static num num_add(num a, num b); +static num num_mul(num a, num b); +static num num_div(num a, num b); +static num num_intdiv(num a, num b); +static num num_sub(num a, num b); +static num num_rem(num a, num b); +static num num_mod(num a, num b); +static int num_eq(num a, num b); +static int num_gt(num a, num b); +static int num_ge(num a, num b); +static int num_lt(num a, num b); +static int num_le(num a, num b); + +#if USE_MATH +static double round_per_R5RS(double x); +#endif +static int is_zero_double(double x); + +static num num_zero; +static num num_one; + +/* macros for cell operations */ +#define typeflag(p) ((p)->_flag) +#define type(p) (typeflag(p)&T_MASKTYPE) + +INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } +#define strvalue(p) ((p)->_object._string._svalue) +#define strlength(p) ((p)->_object._string._length) + +INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } +INTERFACE static void fill_vector(pointer vec, pointer obj); +INTERFACE static pointer vector_elem(pointer vec, int ielem); +INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); +INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } +INTERFACE INLINE int is_integer(pointer p) { + return ((p)->_object._number.is_fixnum); +} +INTERFACE INLINE int is_real(pointer p) { + return (!(p)->_object._number.is_fixnum); +} + +INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } +INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } +INLINE num nvalue(pointer p) { return ((p)->_object._number); } +INTERFACE long ivalue(pointer p) { return (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } +INTERFACE double rvalue(pointer p) { return (!is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } +#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) +#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) +#define set_integer(p) (p)->_object._number.is_fixnum=1; +#define set_real(p) (p)->_object._number.is_fixnum=0; +INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } + +INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } +#define is_inport(p) (type(p)==T_PORT && p->_object._port->kind&port_input) +#define is_outport(p) (type(p)==T_PORT && p->_object._port->kind&port_output) + +INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } +#define car(p) ((p)->_object._cons._car) +#define cdr(p) ((p)->_object._cons._cdr) +INTERFACE pointer pair_car(pointer p) { return car(p); } +INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } +INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } +INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } + +INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } +INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } +#if USE_PLIST +SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } +#define symprop(p) cdr(p) +#endif + +INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } +INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } +INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } +INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } +#define procnum(p) ivalue(p) +static const char *procname(pointer x); + +INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } +INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } +INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } +INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } + +INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } +#define cont_dump(p) cdr(p) + +/* To do: promise should be forced ONCE only */ +INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } + +INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } +#define setenvironment(p) typeflag(p) = T_ENVIRONMENT + +#define is_atom(p) (typeflag(p)&T_ATOM) +#define setatom(p) typeflag(p) |= T_ATOM +#define clratom(p) typeflag(p) &= CLRATOM + +#define is_mark(p) (typeflag(p)&MARK) +#define setmark(p) typeflag(p) |= MARK +#define clrmark(p) typeflag(p) &= UNMARK + +INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } +/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ +INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } + +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define cdar(p) cdr(car(p)) +#define cddr(p) cdr(cdr(p)) +#define cadar(p) car(cdr(car(p))) +#define caddr(p) car(cdr(cdr(p))) +#define cadaar(p) car(cdr(car(car(p)))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define cddddr(p) cdr(cdr(cdr(cdr(p)))) + +#if USE_CHAR_CLASSIFIERS +static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } +static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } +static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } +static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } +static INLINE int Cislower(int c) { return isascii(c) && islower(c); } +#endif + +#if USE_ASCII_NAMES +static const char *charnames[32]={ + "nul", + "soh", + "stx", + "etx", + "eot", + "enq", + "ack", + "bel", + "bs", + "ht", + "lf", + "vt", + "ff", + "cr", + "so", + "si", + "dle", + "dc1", + "dc2", + "dc3", + "dc4", + "nak", + "syn", + "etb", + "can", + "em", + "sub", + "esc", + "fs", + "gs", + "rs", + "us" +}; + +static int is_ascii_name(const char *name, int *pc) { + int i; + for(i=0; i<32; i++) { + if(stricmp(name,charnames[i])==0) { + *pc=i; + return 1; + } + } + if(stricmp(name,"del")==0) { + *pc=127; + return 1; + } + return 0; +} + +#endif + +static int file_push(scheme *sc, const char *fname); +static void file_pop(scheme *sc); +static int file_interactive(scheme *sc); +static INLINE int is_one_of(char *s, int c); +static int alloc_cellseg(scheme *sc, int n); +static long binary_decode(const char *s); +static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); +static pointer _get_cell(scheme *sc, pointer a, pointer b); +static pointer get_consecutive_cells(scheme *sc, int n); +static pointer find_consecutive_cells(scheme *sc, int n); +static void finalize_cell(scheme *sc, pointer a); +static int count_consecutive_cells(pointer x, int needed); +static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); +static pointer mk_number(scheme *sc, num n); +static pointer mk_empty_string(scheme *sc, int len, char fill); +static char *store_string(scheme *sc, int len, const char *str, char fill); +static pointer mk_vector(scheme *sc, int len); +static pointer mk_atom(scheme *sc, char *q); +static pointer mk_sharp_const(scheme *sc, char *name); +static pointer mk_port(scheme *sc, port *p); +static pointer port_from_filename(scheme *sc, const char *fn, int prop); +static pointer port_from_file(scheme *sc, FILE *, int prop); +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); +static port *port_rep_from_file(scheme *sc, FILE *, int prop); +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); +static void port_close(scheme *sc, pointer p, int flag); +static void mark(pointer a); +static void gc(scheme *sc, pointer a, pointer b); +static int basic_inchar(port *pt); +static int inchar(scheme *sc); +static void backchar(scheme *sc, int c); +static char *readstr_upto(scheme *sc, char *delim); +static pointer readstrexp(scheme *sc); +static INLINE void skipspace(scheme *sc); +static int token(scheme *sc); +static void printslashstring(scheme *sc, char *s, int len); +static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); +static void printatom(scheme *sc, pointer l, int f); +static pointer mk_proc(scheme *sc, enum scheme_opcodes op); +static pointer mk_closure(scheme *sc, pointer c, pointer e); +static pointer mk_continuation(scheme *sc, pointer d); +static pointer reverse(scheme *sc, pointer a); +static pointer reverse_in_place(scheme *sc, pointer term, pointer list); +static pointer append(scheme *sc, pointer a, pointer b); +static int list_length(scheme *sc, pointer a); +static int eqv(pointer a, pointer b); +static void dump_stack_mark(scheme *); +static pointer opexe_0(scheme *sc, enum scheme_opcodes op); +static pointer opexe_1(scheme *sc, enum scheme_opcodes op); +static pointer opexe_2(scheme *sc, enum scheme_opcodes op); +static pointer opexe_3(scheme *sc, enum scheme_opcodes op); +static pointer opexe_4(scheme *sc, enum scheme_opcodes op); +static pointer opexe_5(scheme *sc, enum scheme_opcodes op); +static pointer opexe_6(scheme *sc, enum scheme_opcodes op); +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); +static void assign_syntax(scheme *sc, char *name); +static int syntaxnum(pointer p); +static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); + +#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) +#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) + +static num num_add(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue+b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)+num_rvalue(b); + } + return ret; +} + +static num num_mul(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue*b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)*num_rvalue(b); + } + return ret; +} + +static num num_div(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_intdiv(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue/b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)/num_rvalue(b); + } + return ret; +} + +static num num_sub(num a, num b) { + num ret; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + if(ret.is_fixnum) { + ret.value.ivalue= a.value.ivalue-b.value.ivalue; + } else { + ret.value.rvalue=num_rvalue(a)-num_rvalue(b); + } + return ret; +} + +static num num_rem(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + /* modulo 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); + } + } + ret.value.ivalue=res; + return ret; +} + +static num num_mod(num a, num b) { + num ret; + long e1, e2, res; + ret.is_fixnum=a.is_fixnum && b.is_fixnum; + e1=num_ivalue(a); + e2=num_ivalue(b); + res=e1%e2; + if(res*e2<0) { /* modulo should have same sign as second operand */ + e2=labs(e2); + if(res>0) { + res-=e2; + } else { + res+=e2; + } + } + ret.value.ivalue=res; + return ret; +} + +static int num_eq(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue==b.value.ivalue; + } else { + ret=num_rvalue(a)==num_rvalue(b); + } + return ret; +} + + +static int num_gt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivalue>b.value.ivalue; + } else { + ret=num_rvalue(a)>num_rvalue(b); + } + return ret; +} + +static int num_ge(num a, num b) { + return !num_lt(a,b); +} + +static int num_lt(num a, num b) { + int ret; + int is_fixnum=a.is_fixnum && b.is_fixnum; + if(is_fixnum) { + ret= a.value.ivaluedce) { + return ce; + } else if(dfl-DBL_MIN; +} + +static long binary_decode(const char *s) { + long x=0; + + while(*s!=0 && (*s=='1' || *s=='0')) { + x<<=1; + x+=*s-'0'; + s++; + } + + return x; +} + +/* allocate new cell segment */ +static int alloc_cellseg(scheme *sc, int n) { + pointer newp; + pointer last; + pointer p; + char *cp; + long i; + int k; + int adj=ADJ; + + if(adjlast_cell_seg >= CELL_NSEGMENT - 1) + return k; + cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); + if (cp == 0) + return k; + i = ++sc->last_cell_seg ; + sc->alloc_seg[i] = cp; + /* adjust in TYPE_BITS-bit boundary */ + if(((long)cp)%adj!=0) { + cp=(char*)(adj*((long)cp/adj+1)); + } + /* insert new segment in address order */ + newp=(pointer)cp; + sc->cell_seg[i] = newp; + while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { + p = sc->cell_seg[i]; + sc->cell_seg[i] = sc->cell_seg[i - 1]; + sc->cell_seg[--i] = p; + } + sc->fcells += CELL_SEGSIZE; + last = newp + CELL_SEGSIZE - 1; + for (p = newp; p <= last; p++) { + typeflag(p) = 0; + cdr(p) = p + 1; + car(p) = sc->NIL; + } + /* insert new cells in address order on free list */ + if (sc->free_cell == sc->NIL || p < sc->free_cell) { + cdr(last) = sc->free_cell; + sc->free_cell = newp; + } else { + p = sc->free_cell; + while (cdr(p) != sc->NIL && newp > cdr(p)) + p = cdr(p); + cdr(last) = cdr(p); + cdr(p) = newp; + } + } + return n; +} + +static INLINE pointer get_cell(scheme *sc, pointer a, pointer b) { + if (sc->free_cell != sc->NIL) { + pointer x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); + } + return _get_cell (sc, a, b); +} + + +/* get new cell. parameter a, b is marked by gc. */ +static pointer _get_cell(scheme *sc, pointer a, pointer b) { + pointer x; + + if(sc->no_memory) { + return sc->sink; + } + + if (sc->free_cell == sc->NIL) { + gc(sc,a, b); + if (sc->fcells < sc->last_cell_seg*8 + || sc->free_cell == sc->NIL) { + /* if only a few recovered, get more to avoid fruitless gc's */ + if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { + sc->no_memory=1; + return sc->sink; + } + } + } + x = sc->free_cell; + sc->free_cell = cdr(x); + --sc->fcells; + return (x); +} + +static pointer get_consecutive_cells(scheme *sc, int n) { + pointer x; + + if(sc->no_memory) { + return sc->sink; + } + + /* Are there any cells available? */ + x=find_consecutive_cells(sc,n); + if (x == sc->NIL) { + /* If not, try gc'ing some */ + gc(sc, sc->NIL, sc->NIL); + x=find_consecutive_cells(sc,n); + if (x == sc->NIL) { + /* If there still aren't, try getting more heap */ + if (!alloc_cellseg(sc,1)) { + sc->no_memory=1; + return sc->sink; + } + } + x=find_consecutive_cells(sc,n); + if (x == sc->NIL) { + /* If all fail, report failure */ + sc->no_memory=1; + return sc->sink; + } + } + return (x); +} + +static int count_consecutive_cells(pointer x, int needed) { + int n=1; + while(cdr(x)==x+1) { + x=cdr(x); + n++; + if(n>needed) return n; + } + return n; +} + +static pointer find_consecutive_cells(scheme *sc, int n) { + pointer *pp; + int cnt; + + pp=&sc->free_cell; + while(*pp!=sc->NIL) { + cnt=count_consecutive_cells(*pp,n); + if(cnt>=n) { + pointer x=*pp; + *pp=cdr(*pp+n-1); + sc->fcells -= n; + return x; + } + pp=&cdr(*pp+cnt-1); + } + return sc->NIL; +} + +/* get new cons cell */ +pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { + pointer x = get_cell(sc,a, b); + + typeflag(x) = T_PAIR; + if(immutable) { + setimmutable(x); + } + car(x) = a; + cdr(x) = b; + return (x); +} + +/* ========== oblist implementation ========== */ + +#ifndef USE_OBJECT_LIST + +static int hash_fn(const char *key, int table_size); + +static pointer oblist_initial_value(scheme *sc) +{ + return mk_vector(sc, 461); /* probably should be bigger */ +} + +/* returns the new symbol */ +static pointer oblist_add_by_name(scheme *sc, const char *name) +{ + pointer x; + int location; + + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + + location = hash_fn(name, ivalue_unchecked(sc->oblist)); + set_vector_elem(sc->oblist, location, + immutable_cons(sc, x, vector_elem(sc->oblist, location))); + return x; +} + +static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +{ + int location; + pointer x; + char *s; + + location = hash_fn(name, ivalue_unchecked(sc->oblist)); + for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + if(stricmp(name, s) == 0) { + return car(x); + } + } + return sc->NIL; +} + +static pointer oblist_all_symbols(scheme *sc) +{ + int i; + pointer x; + pointer ob_list = sc->NIL; + + for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { + for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { + ob_list = cons(sc, x, ob_list); + } + } + return ob_list; +} + +#else + +static pointer oblist_initial_value(scheme *sc) +{ + return sc->NIL; +} + +static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) +{ + pointer x; + char *s; + + for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { + s = symname(car(x)); + /* case-insensitive, per R5RS section 2. */ + if(stricmp(name, s) == 0) { + return car(x); + } + } + return sc->NIL; +} + +/* returns the new symbol */ +static pointer oblist_add_by_name(scheme *sc, const char *name) +{ + pointer x; + + x = immutable_cons(sc, mk_string(sc, name), sc->NIL); + typeflag(x) = T_SYMBOL; + setimmutable(car(x)); + sc->oblist = immutable_cons(sc, x, sc->oblist); + return x; +} +static pointer oblist_all_symbols(scheme *sc) +{ + return sc->oblist; +} + +#endif + +static pointer mk_port(scheme *sc, port *p) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = T_PORT|T_ATOM; + x->_object._port=p; + return (x); +} + +pointer mk_foreign_func(scheme *sc, foreign_func f) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + typeflag(x) = (T_FOREIGN | T_ATOM); + x->_object._ff=f; + return (x); +} + +INTERFACE pointer mk_character(scheme *sc, int c) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_CHARACTER | T_ATOM); + ivalue_unchecked(x)= c; + set_integer(x); + return (x); +} + +/* get number atom (integer) */ +INTERFACE pointer mk_integer(scheme *sc, long num) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + ivalue_unchecked(x)= num; + set_integer(x); + return (x); +} + +INTERFACE pointer mk_real(scheme *sc, double n) { + pointer x = get_cell(sc,sc->NIL, sc->NIL); + + typeflag(x) = (T_NUMBER | T_ATOM); + rvalue_unchecked(x)= n; + set_real(x); + return (x); +} + +static pointer mk_number(scheme *sc, num n) { + if(n.is_fixnum) { + return mk_integer(sc,n.value.ivalue); + } else { + return mk_real(sc,n.value.rvalue); + } +} + +/* allocate name to string area */ +static char *store_string(scheme *sc, int len_str, const char *str, char fill) { + char *q; + + q=(char*)sc->malloc(len_str+1); + if(q==0) { + sc->no_memory=1; + return sc->strbuff; + } + if(str!=0) { + strcpy(q, str); + } else { + memset(q, fill, len_str); + q[len_str]=0; + } + return (q); +} + +/* get new string */ +INTERFACE pointer mk_string(scheme *sc, const char *str) { + return mk_counted_string(sc,str,strlen(str)); +} + +INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + strvalue(x) = store_string(sc,len,str,0); + typeflag(x) = (T_STRING | T_ATOM); + strlength(x) = len; + return (x); +} + +static pointer mk_empty_string(scheme *sc, int len, char fill) { + pointer x = get_cell(sc, sc->NIL, sc->NIL); + + strvalue(x) = store_string(sc,len,0,fill); + typeflag(x) = (T_STRING | T_ATOM); + strlength(x) = len; + return (x); +} + +INTERFACE static pointer mk_vector(scheme *sc, int len) { + pointer x=get_consecutive_cells(sc,len/2+len%2+1); + typeflag(x) = (T_VECTOR | T_ATOM); + ivalue_unchecked(x)=len; + set_integer(x); + fill_vector(x,sc->NIL); + return x; +} + +INTERFACE static void fill_vector(pointer vec, pointer obj) { + int i; + int num=ivalue(vec)/2+ivalue(vec)%2; + for(i=0; iNIL) { + return (x); + } else { + x = oblist_add_by_name(sc, name); + return (x); + } +} + +INTERFACE pointer gensym(scheme *sc) { + pointer x; + char name[40]; + + for(; sc->gensym_cntgensym_cnt++) { + sprintf(name,"gensym-%ld",sc->gensym_cnt); + + /* first check oblist */ + x = oblist_find_by_name(sc, name); + + if (x != sc->NIL) { + continue; + } else { + x = oblist_add_by_name(sc, name); + return (x); + } + } + + return sc->NIL; +} + +/* make symbol or number atom from string */ +static pointer mk_atom(scheme *sc, 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(sc, sc->COLON_HOOK, + cons(sc, + cons(sc, + sc->QUOTE, + cons(sc, mk_atom(sc,p+2), sc->NIL)), + cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); + } +#endif + + p = q; + c = *p++; + if ((c == '+') || (c == '-')) { + c = *p++; + if (c == '.') { + has_dec_point=1; + c = *p++; + } + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (c == '.') { + has_dec_point=1; + c = *p++; + if (!isdigit(c)) { + return (mk_symbol(sc, strlwr(q))); + } + } else if (!isdigit(c)) { + return (mk_symbol(sc, 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(sc, strlwr(q))); + } + } + if(has_dec_point) { + return mk_real(sc,atof(q)); + } + return (mk_integer(sc, atol(q))); +} + +/* make constant */ +static pointer mk_sharp_const(scheme *sc, char *name) { + long x; + char tmp[256]; + + if (!strcmp(name, "t")) + return (sc->T); + else if (!strcmp(name, "f")) + return (sc->F); + else if (*name == 'o') {/* #o (octal) */ + sprintf(tmp, "0%s", name+1); + sscanf(tmp, "%lo", &x); + return (mk_integer(sc, x)); + } else if (*name == 'd') { /* #d (decimal) */ + sscanf(name+1, "%ld", &x); + return (mk_integer(sc, x)); + } else if (*name == 'x') { /* #x (hex) */ + sprintf(tmp, "0x%s", name+1); + sscanf(tmp, "%lx", &x); + return (mk_integer(sc, x)); + } else if (*name == 'b') { /* #b (binary) */ + x = binary_decode(name+1); + return (mk_integer(sc, x)); + } else if (*name == '\\') { /* #\w (character) */ + int c=0; + if(stricmp(name+1,"space")==0) { + c=' '; + } else if(stricmp(name+1,"newline")==0) { + c='\n'; + } else if(stricmp(name+1,"return")==0) { + c='\r'; + } else if(stricmp(name+1,"tab")==0) { + c='\t'; + } else if(name[1]=='x' && name[2]!=0) { + int c1=0; + if(sscanf(name+2,"%x",&c1)==1 && c1<256) { + c=c1; + } else { + return sc->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 sc->NIL; + } + return mk_character(sc,c); + } else + return (sc->NIL); +} + +/* ========== garbage collector ========== */ + +/*-- + * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, + * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, + * for marking. + */ +static void mark(pointer a) { + pointer t, q, p; + + t = (pointer) 0; + p = a; +E2: setmark(p); + if(is_vector(p)) { + int i; + int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; + for(i=0; igc_verbose) { + putstr(sc, "gc..."); + } + + /* mark system globals */ + mark(sc->oblist); + mark(sc->global_env); + + /* mark current registers */ + mark(sc->args); + mark(sc->envir); + mark(sc->code); + dump_stack_mark(sc); + mark(sc->value); + mark(sc->inport); + mark(sc->save_inport); + mark(sc->outport); + mark(sc->loadport); + + /* mark variables a, b */ + mark(a); + mark(b); + + /* garbage collect */ + clrmark(sc->NIL); + sc->fcells = 0; + sc->free_cell = sc->NIL; + /* free-list is kept sorted by address so as to maintain consecutive + ranges, if possible, for use with vectors. Here we scan the cells + (which are also kept sorted by address) downwards to build the + free-list in sorted order. + */ + for (i = sc->last_cell_seg; i >= 0; i--) { + p = sc->cell_seg[i] + CELL_SEGSIZE; + while (--p >= sc->cell_seg[i]) { + if (is_mark(p)) { + clrmark(p); + } else { + /* reclaim cell */ + if (typeflag(p) != 0) { + finalize_cell(sc, p); + typeflag(p) = 0; + car(p) = sc->NIL; + } + ++sc->fcells; + cdr(p) = sc->free_cell; + sc->free_cell = p; + } + } + } + + if (sc->gc_verbose) { + char msg[80]; + sprintf(msg,"done: %ld cells were recovered.\n", sc->fcells); + putstr(sc,msg); + } +} + +static void finalize_cell(scheme *sc, pointer a) { + if(is_string(a)) { + sc->free(strvalue(a)); + } else if(is_port(a)) { + if(a->_object._port->kind&port_file + && a->_object._port->rep.stdio.closeit) { + port_close(sc,a,port_input|port_output); + } + sc->free(a->_object._port); + } +} + +/* ========== Routines for Reading ========== */ + +static int file_push(scheme *sc, const char *fname) { + FILE *fin=fopen(fname,"r"); + if(fin!=0) { + sc->file_i++; + sc->load_stack[sc->file_i].kind=port_file|port_input; + sc->load_stack[sc->file_i].rep.stdio.file=fin; + sc->load_stack[sc->file_i].rep.stdio.closeit=1; + sc->nesting_stack[sc->file_i]=0; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + } + return fin!=0; +} + +static void file_pop(scheme *sc) { + sc->nesting=sc->nesting_stack[sc->file_i]; + if(sc->file_i!=0) { + port_close(sc,sc->loadport,port_input); + sc->file_i--; + sc->loadport->_object._port=sc->load_stack+sc->file_i; + if(file_interactive(sc)) { + putstr(sc,prompt); + } + } +} + +static int file_interactive(scheme *sc) { + return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin + && sc->inport->_object._port->kind&port_file; +} + +static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { + FILE *f; + char *rw; + port *pt; + if(prop==(port_input|port_output)) { + rw="a+"; + } else if(prop==port_output) { + rw="w"; + } else { + rw="r"; + } + f=fopen(fn,rw); + if(f==0) { + return 0; + } + pt=port_rep_from_file(sc,f,prop); + pt->rep.stdio.closeit=1; + return pt; +} + +static pointer port_from_filename(scheme *sc, const char *fn, int prop) { + port *pt; + pt=port_rep_from_filename(sc,fn,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_file(scheme *sc, FILE *f, int prop) { + char *rw; + port *pt; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + if(prop==(port_input|port_output)) { + rw="a+"; + } else if(prop==port_output) { + rw="w"; + } else { + rw="r"; + } + pt->kind=port_file|prop; + pt->rep.stdio.file=f; + pt->rep.stdio.closeit=0; + return pt; +} + +static pointer port_from_file(scheme *sc, FILE *f, int prop) { + port *pt; + pt=port_rep_from_file(sc,f,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=(port*)sc->malloc(sizeof(port)); + if(pt==0) { + return 0; + } + pt->kind=port_string|prop; + pt->rep.string.start=start; + pt->rep.string.curr=start; + pt->rep.string.past_the_end=past_the_end; + return pt; +} + +static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { + port *pt; + pt=port_rep_from_string(sc,start,past_the_end,prop); + if(pt==0) { + return sc->NIL; + } + return mk_port(sc,pt); +} + +static void port_close(scheme *sc, pointer p, int flag) { + port *pt=p->_object._port; + pt->kind&=~flag; + if((pt->kind & (port_input|port_output))==0) { + if(pt->kind&port_file) { + fclose(pt->rep.stdio.file); + } + pt->kind=port_free; + } +} + +/* get new character from input file */ +static int inchar(scheme *sc) { + int c; + port *pt; + again: + pt=sc->inport->_object._port; + c=basic_inchar(pt); + if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) { + file_pop(sc); + if(sc->nesting!=0) { + return EOF; + } + goto again; + } + return c; +} + +static int basic_inchar(port *pt) { + if(pt->kind&port_file) { + return fgetc(pt->rep.stdio.file); + } 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++; + } + } +} + +/* back character to input buffer */ +static void backchar(scheme *sc, int c) { + port *pt; + if(c==EOF) return; + pt=sc->inport->_object._port; + if(pt->kind&port_file) { + ungetc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.start) { + --pt->rep.string.curr; + } + } +} + +INTERFACE void putstr(scheme *sc, const char *s) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputs(s,pt->rep.stdio.file); + } else { + for(;*s;s++) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s; + } + } + } +} + +static void putchars(scheme *sc, const char *s, int len) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fwrite(s,1,len,pt->rep.stdio.file); + } else { + for(;len;len--) { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=*s++; + } + } + } +} + +INTERFACE void putcharacter(scheme *sc, int c) { + port *pt=sc->outport->_object._port; + if(pt->kind&port_file) { + fputc(c,pt->rep.stdio.file); + } else { + if(pt->rep.string.curr!=pt->rep.string.past_the_end) { + *pt->rep.string.curr++=c; + } + } +} + +/* read characters up to delimiter, but cater to character constants */ +static char *readstr_upto(scheme *sc, char *delim) { + char *p = sc->strbuff; + + while (!is_one_of(delim, (*p++ = inchar(sc)))); + if(p==sc->strbuff+2 && p[-2]=='\\') { + *p=0; + } else { + backchar(sc,p[-1]); + *--p = '\0'; + } + return sc->strbuff; +} + +/* read string expression "xxx...xxx" */ +static pointer readstrexp(scheme *sc) { + char *p = sc->strbuff; + int c; + int c1=0; + enum { st_ok, st_bsl, st_x1, st_x2} state=st_ok; + + for (;;) { + c=inchar(sc); + if(c==EOF || p-sc->strbuff>sizeof(sc->strbuff)-1) { + return sc->F; + } + switch(state) { + case st_ok: + switch(c) { + case '\\': + state=st_bsl; + break; + case '"': + *p=0; + return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); + default: + *p++=c; + break; + } + break; + case st_bsl: + switch(c) { + case 'x': + case 'X': + state=st_x1; + c1=0; + break; + case 'n': + *p++='\n'; + state=st_ok; + break; + case 't': + *p++='\t'; + state=st_ok; + break; + case 'r': + *p++='\r'; + state=st_ok; + break; + case '"': + *p++='"'; + state=st_ok; + break; + default: + *p++=c; + state=st_ok; + break; + } + break; + case st_x1: + case st_x2: + c=toupper(c); + if(c>='0' && c<='F') { + if(c<='9') { + c1=(c1<<4)+c-'0'; + } else { + c1=(c1<<4)+c-'A'+10; + } + if(state==st_x1) { + state=st_x2; + } else { + *p++=c1; + state=st_ok; + } + } else { + return sc->F; + } + break; + } + } +} + +/* check c is in chars */ +static INLINE int is_one_of(char *s, int c) { + if(c==EOF) return 1; + while (*s) + if (*s++ == c) + return (1); + return (0); +} + +/* skip white characters */ +static INLINE void skipspace(scheme *sc) { + int c; + while (isspace(c=inchar(sc))) + ; + if(c!=EOF) { + backchar(sc,c); + } +} + +/* get token */ +static int token(scheme *sc) { + int c; + skipspace(sc); + switch (c=inchar(sc)) { + case EOF: + return (TOK_EOF); + case '(': + return (TOK_LPAREN); + case ')': + return (TOK_RPAREN); + case '.': + c=inchar(sc); + if(is_one_of(" \n\t",c)) { + return (TOK_DOT); + } else { + backchar(sc,c); + backchar(sc,'.'); + return TOK_ATOM; + } + case '\'': + return (TOK_QUOTE); + case ';': + return (TOK_COMMENT); + case '"': + return (TOK_DQUOTE); + case BACKQUOTE: + return (TOK_BQUOTE); + case ',': + if ((c=inchar(sc)) == '@') + return (TOK_ATMARK); + else { + backchar(sc,c); + return (TOK_COMMA); + } + case '#': + c=inchar(sc); + if (c == '(') { + return (TOK_VEC); + } else if(c == '!') { + return TOK_COMMENT; + } else { + backchar(sc,c); + if(is_one_of(" tfodxb\\",c)) { + return TOK_SHARP_CONST; + } else { + return (TOK_SHARP); + } + } + default: + backchar(sc,c); + return (TOK_ATOM); + } +} + +/* ========== Routines for Printing ========== */ +#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) + +static void printslashstring(scheme *sc, char *p, int len) { + int i; + unsigned char *s=(unsigned char*)p; + putcharacter(sc,'"'); + for ( i=0; iNIL) { + p = "()"; + } else if (l == sc->T) { + p = "#t"; + } else if (l == sc->F) { + p = "#f"; + } else if (l == sc->EOF_OBJ) { + p = "#"; + } else if (is_port(l)) { + p = sc->strbuff; + strcpy(p, "#"); + } else if (is_number(l)) { + p = sc->strbuff; + if(is_integer(l)) { + sprintf(p, "%ld", ivalue_unchecked(l)); + } else { + sprintf(p, "%.10g", rvalue_unchecked(l)); + } + } else if (is_string(l)) { + if (!f) { + p = strvalue(l); + } else { /* Hack, uses the fact that printing is needed */ + *pp=sc->strbuff; + *plen=0; + printslashstring(sc, strvalue(l), strlength(l)); + return; + } + } else if (is_character(l)) { + int c=charvalue(l); + p = sc->strbuff; + if (!f) { + p[0]=c; + p[1]=0; + } else { + switch(c) { + case ' ': + sprintf(p,"#\\space"); break; + case '\n': + sprintf(p,"#\\newline"); break; + case '\r': + sprintf(p,"#\\return"); break; + case '\t': + sprintf(p,"#\\tab"); break; + default: +#if USE_ASCII_NAMES + if(c==127) { + strcpy(p,"#\\del"); break; + } else if(c<32) { + strcpy(p,"#\\"); strcat(p,charnames[c]); break; + } +#else + if(c<32) { + sprintf(p,"#\\x%x",c); break; + } +#endif + sprintf(p,"#\\%c",c); break; + } + } + } else if (is_symbol(l)) { + p = symname(l); + } else if (is_proc(l)) { + p = sc->strbuff; + sprintf(p, "#<%s PROCEDURE %ld>", procname(l),procnum(l)); + } else if (is_macro(l)) { + p = "#"; + } else if (is_closure(l)) { + p = "#"; + } else if (is_promise(l)) { + p = "#"; + } else if (is_foreign(l)) { + p = sc->strbuff; + sprintf(p, "#", procnum(l)); + } else if (is_continuation(l)) { + p = "#"; + } else { + p = "#"; + } + *pp=p; + *plen=strlen(p); +} +/* ========== Routines for Evaluation Cycle ========== */ + +/* make closure. c is code. e is environment */ +static pointer mk_closure(scheme *sc, pointer c, pointer e) { + pointer x = get_cell(sc, c, e); + + typeflag(x) = T_CLOSURE; + car(x) = c; + cdr(x) = e; + return (x); +} + +/* make continuation. */ +static pointer mk_continuation(scheme *sc, pointer d) { + pointer x = get_cell(sc, sc->NIL, d); + + typeflag(x) = T_CONTINUATION; + cont_dump(x) = d; + return (x); +} + +static pointer list_star(scheme *sc, pointer d) { + pointer p, q; + if(cdr(d)==sc->NIL) { + return car(d); + } + p=cons(sc,car(d),cdr(d)); + q=p; + while(cdr(cdr(p))!=sc->NIL) { + d=cons(sc,car(p),cdr(p)); + if(cdr(cdr(p))!=sc->NIL) { + p=cdr(d); + } + } + cdr(p)=car(cdr(p)); + return q; +} + +/* reverse list -- produce new list */ +static pointer reverse(scheme *sc, pointer a) { +/* a must be checked by gc */ + pointer p = sc->NIL; + + for ( ; is_pair(a); a = cdr(a)) { + p = cons(sc, car(a), p); + } + return (p); +} + +/* reverse list --- in-place */ +static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { + pointer p = list, result = term, q; + + while (p != sc->NIL) { + q = cdr(p); + cdr(p) = result; + result = p; + p = q; + } + return (result); +} + +/* append list -- produce new list */ +static pointer append(scheme *sc, pointer a, pointer b) { + pointer p = b, q; + + if (a != sc->NIL) { + a = reverse(sc, a); + while (a != sc->NIL) { + q = cdr(a); + cdr(a) = p; + p = a; + a = q; + } + } + return (p); +} + +/* equivalence of atoms */ +static 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_eq(nvalue(a),nvalue(b)); + else + 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) != sc->F) +#define is_false(p) ((p) == sc->F) + +/* ========== Environment implementation ========== */ + +#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) + +static int hash_fn(const char *key, int table_size) +{ + unsigned int hashed = 0; + const char *c; + int bits_per_int = sizeof(unsigned int)*8; + + for (c = key; *c; c++) { + /* letters have about 5 bits in them */ + hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); + hashed ^= *c; + } + return hashed % table_size; +} +#endif + +#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 *sc, pointer old_env) +{ + pointer new_frame; + + /* The interaction-environment has about 300 variables in it. */ + if (old_env == sc->NIL) { + new_frame = mk_vector(sc, 461); + } else { + new_frame = sc->NIL; + } + + sc->envir = immutable_cons(sc, new_frame, old_env); + setenvironment(sc->envir); +} + +static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, + pointer variable, pointer value) +{ + pointer slot = immutable_cons(sc, variable, value); + + if (is_vector(car(env))) { + int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); + + set_vector_elem(car(env), location, + immutable_cons(sc, slot, vector_elem(car(env), location))); + } else { + car(env) = immutable_cons(sc, slot, car(env)); + } +} + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + pointer x,y; + int location; + + for (x = env; x != sc->NIL; x = cdr(x)) { + if (is_vector(car(x))) { + location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); + y = vector_elem(car(x), location); + } else { + y = car(x); + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (caar(y) == hdl) { + break; + } + } + if (y != sc->NIL) { + break; + } + if(!all) { + return sc->NIL; + } + } + if (x != sc->NIL) { + return car(y); + } + return sc->NIL; +} + +#else /* USE_ALIST_ENV */ + +static INLINE void new_frame_in_env(scheme *sc, pointer old_env) +{ + sc->envir = immutable_cons(sc, sc->NIL, old_env); + setenvironment(sc->envir); +} + +static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, + pointer variable, pointer value) +{ + car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); +} + +static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) +{ + pointer x,y; + for (x = env; x != sc->NIL; x = cdr(x)) { + for (y = car(x); y != sc->NIL; y = cdr(y)) { + if (caar(y) == hdl) { + break; + } + } + if (y != sc->NIL) { + break; + } + if(!all) { + return sc->NIL; + } + } + if (x != sc->NIL) { + return car(y); + } + return sc->NIL; +} + +#endif /* USE_ALIST_ENV else */ + +static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) +{ + new_slot_spec_in_env(sc, sc->envir, variable, value); +} + +static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) +{ + cdr(slot) = value; +} + +static INLINE pointer slot_value_in_env(pointer slot) +{ + return cdr(slot); +} + +/* ========== Evaluation Cycle ========== */ + + +static pointer _Error_1(scheme *sc, const char *s, pointer a) { +#if USE_ERROR_HOOK + pointer x; + pointer hdl=sc->ERROR_HOOK; + + x=find_slot_in_env(sc,sc->envir,hdl,1); + if (x != sc->NIL) { + if(a!=0) { + sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); + } else { + sc->code = sc->NIL; + } + sc->code = cons(sc, mk_string(sc, (s)), sc->code); + setimmutable(car(sc->code)); + sc->code = cons(sc, slot_value_in_env(x), sc->code); + sc->op = (int)OP_EVAL; + return sc->T; + } +#endif + + if(a!=0) { + sc->args = cons(sc, (a), sc->NIL); + } else { + sc->args = sc->NIL; + } + sc->args = cons(sc, mk_string(sc, (s)), sc->args); + setimmutable(car(sc->args)); + sc->op = (int)OP_ERR0; + return sc->T; +} +#define Error_1(sc,s, a) return _Error_1(sc,s,a) +#define Error_0(sc,s) return _Error_1(sc,s,0) + +/* Too small to turn into function */ +# define BEGIN do { +# define END } while (0) +#define s_goto(sc,a) BEGIN \ + sc->op = (int)(a); \ + return sc->T; END + +#define s_return(sc,a) return _s_return(sc,a) + +#ifndef USE_SCHEME_STACK + +/* this structure holds all the interpreter's registers */ +struct dump_stack_frame { + enum scheme_opcodes op; + pointer args; + pointer envir; + pointer code; +}; + +#define STACK_GROWTH 3 + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) +{ + long nframes = (int)sc->dump; + struct dump_stack_frame *next_frame; + + /* enough room for the next frame? */ + if (nframes >= sc->dump_size) { + sc->dump_size += STACK_GROWTH; + /* alas there is no sc->realloc */ + sc->dump_base = realloc(sc->dump_base, + sizeof(struct dump_stack_frame) * sc->dump_size); + } + next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; + next_frame->op = op; + next_frame->args = args; + next_frame->envir = sc->envir; + next_frame->code = code; + sc->dump = (pointer)(nframes+1); +} + +static pointer _s_return(scheme *sc, pointer a) +{ + long nframes = (int)sc->dump; + struct dump_stack_frame *frame; + + sc->value = (a); + if (nframes <= 0) { + return sc->NIL; + } + nframes--; + frame = (struct dump_stack_frame *)sc->dump_base + nframes; + sc->op = frame->op; + sc->args = frame->args; + sc->envir = frame->envir; + sc->code = frame->code; + sc->dump = (pointer)nframes; + return sc->T; +} + +static INLINE void dump_stack_reset(scheme *sc) +{ + /* in this implementation, sc->dump is the number of frames on the stack */ + sc->dump = (pointer)0; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + sc->dump_size = 0; + sc->dump_base = NULL; + dump_stack_reset(sc); +} + +static void dump_stack_free(scheme *sc) +{ + free(sc->dump_base); + sc->dump_base = NULL; + sc->dump = (pointer)0; + sc->dump_size = 0; +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + long nframes = (int)sc->dump; + int i; + for(i=0; idump_base + i; + mark(frame->args); + mark(frame->envir); + mark(frame->code); + } +} + +#else + +static INLINE void dump_stack_reset(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static INLINE void dump_stack_initialize(scheme *sc) +{ + dump_stack_reset(sc); +} + +static void dump_stack_free(scheme *sc) +{ + sc->dump = sc->NIL; +} + +static pointer _s_return(scheme *sc, pointer a) { + sc->value = (a); + if(sc->dump==sc->NIL) return sc->NIL; + sc->op = ivalue(car(sc->dump)); + sc->args = cadr(sc->dump); + sc->envir = caddr(sc->dump); + sc->code = cadddr(sc->dump); + sc->dump = cddddr(sc->dump); + return sc->T; +} + +static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { + sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); + sc->dump = cons(sc, (args), sc->dump); + sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); +} + +static INLINE void dump_stack_mark(scheme *sc) +{ + mark(sc->dump); +} +#endif + +#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) + +static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_LOAD: /* load */ + if(file_interactive(sc)) { + fprintf(sc->outport->_object._port->rep.stdio.file, + "Loading %s\n", strvalue(car(sc->args))); + } + if (!file_push(sc,strvalue(car(sc->args)))) { + Error_1(sc,"unable to open", car(sc->args)); + } + s_goto(sc,OP_T0LVL); + + case OP_T0LVL: /* top level */ + if(file_interactive(sc)) { + putstr(sc,"\n"); + } + sc->nesting=0; + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->save_inport=sc->inport; + sc->inport = sc->loadport; + s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); + s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); + s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); + if (file_interactive(sc)) { + putstr(sc,prompt); + } + s_goto(sc,OP_READ_INTERNAL); + + case OP_T1LVL: /* top level */ + sc->code = sc->value; + sc->inport=sc->save_inport; + s_goto(sc,OP_EVAL); + + case OP_READ_INTERNAL: /* internal read */ + sc->tok = token(sc); + if(sc->tok==TOK_EOF) { + if(sc->inport==sc->loadport) { + sc->args=sc->NIL; + s_goto(sc,OP_QUIT); + } else { + s_return(sc,sc->EOF_OBJ); + } + } + s_goto(sc,OP_RDSEXPR); + + case OP_GENSYM: + s_return(sc, gensym(sc)); + + 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(sc->tracing) { + putstr(sc,"\nGives: "); + } + if(file_interactive(sc)) { + sc->print_flag = 1; + sc->args = sc->value; + s_goto(sc,OP_P0LIST); + } else { + s_return(sc,sc->value); + } + + case OP_EVAL: /* main part of evaluation */ +#if USE_TRACING + if(sc->tracing) { + /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ + s_save(sc,OP_REAL_EVAL,sc->args,sc->code); + sc->args=sc->code; + putstr(sc,"\nEval: "); + s_goto(sc,OP_P0LIST); + } + /* fall through */ + case OP_REAL_EVAL: +#endif + if (is_symbol(sc->code)) { /* symbol */ + x=find_slot_in_env(sc,sc->envir,sc->code,1); + if (x != sc->NIL) { + s_return(sc,slot_value_in_env(x)); + } else { + Error_1(sc,"eval: unbound variable:", sc->code); + } + } else if (is_pair(sc->code)) { + if (is_syntax(x = car(sc->code))) { /* SYNTAX */ + sc->code = cdr(sc->code); + s_goto(sc,syntaxnum(x)); + } else {/* first, eval top element and eval arguments */ + s_save(sc,OP_E0ARGS, sc->NIL, sc->code); + /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + } else { + s_return(sc,sc->code); + } + + case OP_E0ARGS: /* eval arguments */ + if (is_macro(sc->value)) { /* macro expansion */ + s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); + sc->args = cons(sc,sc->code, sc->NIL); + sc->code = sc->value; + s_goto(sc,OP_APPLY); + } else { + sc->code = cdr(sc->code); + s_goto(sc,OP_E1ARGS); + } + + case OP_E1ARGS: /* eval arguments */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); + sc->code = car(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_APPLY); + } + +#if USE_TRACING + case OP_TRACING: { + int tr=sc->tracing; + sc->tracing=ivalue(car(sc->args)); + s_return(sc,mk_integer(sc,tr)); + } +#endif + + case OP_APPLY: /* apply 'code' to 'args' */ +#if USE_TRACING + if(sc->tracing) { + s_save(sc,OP_REAL_APPLY,sc->args,sc->code); + sc->print_flag = 1; + /* sc->args=cons(sc,sc->code,sc->args);*/ + putstr(sc,"\nApply to: "); + s_goto(sc,OP_P0LIST); + } + /* fall through */ + case OP_REAL_APPLY: +#endif + if (is_proc(sc->code)) { + s_goto(sc,procnum(sc->code)); /* PROCEDURE */ + } else if (is_foreign(sc->code)) { + x=sc->code->_object._ff(sc,sc->args); + s_return(sc,x); + } else if (is_closure(sc->code) || is_macro(sc->code) + || is_promise(sc->code)) { /* CLOSURE */ + /* Should not accept promise */ + /* make environment */ + new_frame_in_env(sc, closure_env(sc->code)); + for (x = car(closure_code(sc->code)), y = sc->args; + is_pair(x); x = cdr(x), y = cdr(y)) { + if (y == sc->NIL) { + Error_0(sc,"not enough arguments"); + } else { + new_slot_in_env(sc, car(x), car(y)); + } + } + if (x == sc->NIL) { + /*-- + * if (y != sc->NIL) { + * Error_0(sc,"too many arguments"); + * } + */ + } else if (is_symbol(x)) + new_slot_in_env(sc, x, y); + else { + Error_1(sc,"syntax error in closure: not a symbol:", x); + } + sc->code = cdr(closure_code(sc->code)); + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + } else if (is_continuation(sc->code)) { /* CONTINUATION */ + sc->dump = cont_dump(sc->code); + s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); + } else { + Error_0(sc,"illegal function"); + } + + case OP_DOMACRO: /* do macro */ + sc->code = sc->value; + s_goto(sc,OP_EVAL); + + case OP_LAMBDA: /* lambda */ + s_return(sc,mk_closure(sc, sc->code, sc->envir)); + + case OP_MKCLOSURE: /* make-closure */ + x=car(sc->args); + if(car(x)==sc->LAMBDA) { + x=cdr(x); + } + if(cdr(sc->args)==sc->NIL) { + y=sc->envir; + } else { + y=cadr(sc->args); + } + s_return(sc,mk_closure(sc, x, y)); + + case OP_QUOTE: /* quote */ + x=car(sc->code); + s_return(sc,car(sc->code)); + + case OP_DEF0: /* define */ + if (is_pair(car(sc->code))) { + x = caar(sc->code); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_DEF1, sc->NIL, x); + s_goto(sc,OP_EVAL); + + case OP_DEF1: /* define */ + x=find_slot_in_env(sc,sc->envir,sc->code,0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_in_env(sc, sc->code, sc->value); + } + s_return(sc,sc->code); + + + case OP_DEFP: /* defined? */ + x=sc->envir; + if(cdr(sc->args)!=sc->NIL) { + x=cadr(sc->args); + } + s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); + + case OP_SET0: /* set! */ + s_save(sc,OP_SET1, sc->NIL, car(sc->code)); + sc->code = cadr(sc->code); + s_goto(sc,OP_EVAL); + + case OP_SET1: /* set! */ + y=find_slot_in_env(sc,sc->envir,sc->code,1); + if (y != sc->NIL) { + set_slot_in_env(sc, y, sc->value); + s_return(sc,sc->value); + } else { + Error_1(sc,"set!: unbound variable:", sc->code); + } + + + case OP_BEGIN: /* begin */ + if (!is_pair(sc->code)) { + s_return(sc,sc->code); + } + if (cdr(sc->code) != sc->NIL) { + s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); + } + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_IF0: /* if */ + s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_IF1: /* if */ + if (is_true(sc->value)) + sc->code = car(sc->code); + else + sc->code = cadr(sc->code); /* (if #f 1) ==> () because + * car(sc->NIL) = sc->NIL */ + s_goto(sc,OP_EVAL); + + case OP_LET0: /* let */ + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); + s_goto(sc,OP_LET1); + + case OP_LET1: /* let (calculate parameters) */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_LET1, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_LET2); + } + + case OP_LET2: /* let */ + new_frame_in_env(sc, sc->envir); + for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; + y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + if (is_symbol(car(sc->code))) { /* named let */ + for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { + + sc->args = cons(sc, caar(x), sc->args); + } + x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); + new_slot_in_env(sc, car(sc->code), x); + sc->code = cddr(sc->code); + sc->args = sc->NIL; + } else { + sc->code = cdr(sc->code); + sc->args = sc->NIL; + } + s_goto(sc,OP_BEGIN); + + case OP_LET0AST: /* let* */ + if (car(sc->code) == sc->NIL) { + new_frame_in_env(sc, sc->envir); + sc->code = cdr(sc->code); + s_goto(sc,OP_BEGIN); + } + s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); + sc->code = cadaar(sc->code); + s_goto(sc,OP_EVAL); + + case OP_LET1AST: /* let* (make new frame) */ + new_frame_in_env(sc, sc->envir); + s_goto(sc,OP_LET2AST); + + case OP_LET2AST: /* let* (calculate parameters) */ + new_slot_in_env(sc, caar(sc->code), sc->value); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_LET2AST, sc->args, sc->code); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->code = sc->args; + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + } + default: + sprintf(sc->strbuff, "%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_LET0REC: /* letrec */ + new_frame_in_env(sc, sc->envir); + sc->args = sc->NIL; + sc->value = sc->code; + sc->code = car(sc->code); + s_goto(sc,OP_LET1REC); + + case OP_LET1REC: /* letrec (calculate parameters) */ + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { /* continue */ + s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); + sc->code = cadar(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_EVAL); + } else { /* end */ + sc->args = reverse_in_place(sc, sc->NIL, sc->args); + sc->code = car(sc->args); + sc->args = cdr(sc->args); + s_goto(sc,OP_LET2REC); + } + + case OP_LET2REC: /* letrec */ + for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { + new_slot_in_env(sc, caar(x), car(y)); + } + sc->code = cdr(sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_BEGIN); + + case OP_COND0: /* cond */ + if (!is_pair(sc->code)) { + Error_0(sc,"syntax error in cond"); + } + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_goto(sc,OP_EVAL); + + case OP_COND1: /* cond */ + if (is_true(sc->value)) { + if ((sc->code = cdar(sc->code)) == sc->NIL) { + s_return(sc,sc->value); + } + if(car(sc->code)==sc->FEED_TO) { + if(!is_pair(cdr(sc->code))) { + Error_0(sc,"syntax error in cond"); + } + x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); + sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); + s_goto(sc,OP_EVAL); + } + s_goto(sc,OP_BEGIN); + } else { + if ((sc->code = cdr(sc->code)) == sc->NIL) { + s_return(sc,sc->NIL); + } else { + s_save(sc,OP_COND1, sc->NIL, sc->code); + sc->code = caar(sc->code); + s_goto(sc,OP_EVAL); + } + } + + case OP_DELAY: /* delay */ + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return(sc,x); + + case OP_AND0: /* and */ + if (sc->code == sc->NIL) { + s_return(sc,sc->T); + } + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_AND1: /* and */ + if (is_false(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + + case OP_OR0: /* or */ + if (sc->code == sc->NIL) { + s_return(sc,sc->F); + } + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_OR1: /* or */ + if (is_true(sc->value)) { + s_return(sc,sc->value); + } else if (sc->code == sc->NIL) { + s_return(sc,sc->value); + } else { + s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + } + + case OP_C0STREAM: /* cons-stream */ + s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_C1STREAM: /* cons-stream */ + sc->args = sc->value; /* save sc->value to register sc->args for gc */ + x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); + typeflag(x)=T_PROMISE; + s_return(sc,cons(sc, sc->args, x)); + + case OP_MACRO0: /* macro */ + if (is_pair(car(sc->code))) { + x = caar(sc->code); + sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); + } else { + x = car(sc->code); + sc->code = cadr(sc->code); + } + if (!is_symbol(x)) { + Error_0(sc,"variable is not a symbol"); + } + s_save(sc,OP_MACRO1, sc->NIL, x); + s_goto(sc,OP_EVAL); + + case OP_MACRO1: /* macro */ + typeflag(sc->value) = T_MACRO; + x = find_slot_in_env(sc, sc->envir, sc->code, 0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, sc->value); + } else { + new_slot_in_env(sc, sc->code, sc->value); + } + s_return(sc,sc->code); + + case OP_CASE0: /* case */ + s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); + sc->code = car(sc->code); + s_goto(sc,OP_EVAL); + + case OP_CASE1: /* case */ + for (x = sc->code; x != sc->NIL; x = cdr(x)) { + if (!is_pair(y = caar(x))) { + break; + } + for ( ; y != sc->NIL; y = cdr(y)) { + if (eqv(car(y), sc->value)) { + break; + } + } + if (y != sc->NIL) { + break; + } + } + if (x != sc->NIL) { + if (is_pair(caar(x))) { + sc->code = cdar(x); + s_goto(sc,OP_BEGIN); + } else {/* else */ + s_save(sc,OP_CASE2, sc->NIL, cdar(x)); + sc->code = caar(x); + s_goto(sc,OP_EVAL); + } + } else { + s_return(sc,sc->NIL); + } + + case OP_CASE2: /* case */ + if (is_true(sc->value)) { + s_goto(sc,OP_BEGIN); + } else { + s_return(sc,sc->NIL); + } + + case OP_PAPPLY: /* apply */ + sc->code = car(sc->args); + sc->args = list_star(sc,cdr(sc->args)); + /*sc->args = cadr(sc->args);*/ + s_goto(sc,OP_APPLY); + + case OP_PEVAL: /* eval */ + if(cdr(sc->args)!=sc->NIL) { + sc->envir=cadr(sc->args); + } + sc->code = car(sc->args); + s_goto(sc,OP_EVAL); + + case OP_CONTINUATION: /* call-with-current-continuation */ + sc->code = car(sc->args); + sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); + s_goto(sc,OP_APPLY); + + default: + sprintf(sc->strbuff, "%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { + pointer x; + num v; +#if USE_MATH + double dd; +#endif + + switch (op) { +#if USE_MATH + case OP_INEX2EX: /* inexact->exact */ + x=car(sc->args); + if(is_integer(x)) { + s_return(sc,x); + } else if(modf(rvalue_unchecked(x),&dd)==0.0) { + s_return(sc,mk_integer(sc,ivalue(x))); + } else { + Error_1(sc,"inexact->exact: not integral:",x); + } + + case OP_EXP: + x=car(sc->args); + s_return(sc, mk_real(sc, exp(rvalue(x)))); + + case OP_LOG: + x=car(sc->args); + s_return(sc, mk_real(sc, log(rvalue(x)))); + + case OP_SIN: + x=car(sc->args); + s_return(sc, mk_real(sc, sin(rvalue(x)))); + + case OP_COS: + x=car(sc->args); + s_return(sc, mk_real(sc, cos(rvalue(x)))); + + case OP_TAN: + x=car(sc->args); + s_return(sc, mk_real(sc, tan(rvalue(x)))); + + case OP_ASIN: + x=car(sc->args); + s_return(sc, mk_real(sc, asin(rvalue(x)))); + + case OP_ACOS: + x=car(sc->args); + s_return(sc, mk_real(sc, acos(rvalue(x)))); + + case OP_ATAN: + x=car(sc->args); + if(cdr(sc->args)==sc->NIL) { + s_return(sc, mk_real(sc, atan(rvalue(x)))); + } else { + pointer y=cadr(sc->args); + s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); + } + + case OP_SQRT: + x=car(sc->args); + s_return(sc, mk_real(sc, sqrt(rvalue(x)))); + + case OP_EXPT: + x=car(sc->args); + if(cdr(sc->args)==sc->NIL) { + Error_0(sc,"expt: needs two arguments"); + } else { + pointer y=cadr(sc->args); + s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y)))); + } + + case OP_FLOOR: + x=car(sc->args); + s_return(sc, mk_real(sc, floor(rvalue(x)))); + + case OP_CEILING: + x=car(sc->args); + s_return(sc, mk_real(sc, ceil(rvalue(x)))); + + case OP_TRUNCATE : { + double rvalue_of_x ; + x=car(sc->args); + rvalue_of_x = rvalue(x) ; + if (rvalue_of_x > 0) { + s_return(sc, mk_real(sc, floor(rvalue_of_x))); + } else { + s_return(sc, mk_real(sc, ceil(rvalue_of_x))); + } + } + + case OP_ROUND: + x=car(sc->args); + s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); +#endif + + case OP_ADD: /* + */ + v=num_zero; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_add(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_MUL: /* * */ + v=num_one; + for (x = sc->args; x != sc->NIL; x = cdr(x)) { + v=num_mul(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_SUB: /* - */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_zero; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + v=num_sub(v,nvalue(car(x))); + } + s_return(sc,mk_number(sc, v)); + + case OP_DIV: /* / */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (!is_zero_double(rvalue(car(x)))) + v=num_div(v,nvalue(car(x))); + else { + Error_0(sc,"/: division by zero"); + } + } + s_return(sc,mk_number(sc, v)); + + case OP_INTDIV: /* quotient */ + if(cdr(sc->args)==sc->NIL) { + x=sc->args; + v=num_one; + } else { + x = cdr(sc->args); + v = nvalue(car(sc->args)); + } + for (; x != sc->NIL; x = cdr(x)) { + if (ivalue(car(x)) != 0) + v=num_intdiv(v,nvalue(car(x))); + else { + Error_0(sc,"quotient: division by zero"); + } + } + s_return(sc,mk_number(sc, v)); + + case OP_REM: /* remainder */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_rem(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"remainder: division by zero"); + } + s_return(sc,mk_number(sc, v)); + + case OP_MOD: /* modulo */ + v = nvalue(car(sc->args)); + if (ivalue(cadr(sc->args)) != 0) + v=num_mod(v,nvalue(cadr(sc->args))); + else { + Error_0(sc,"modulo: division by zero"); + } + s_return(sc,mk_number(sc, v)); + + case OP_CAR: /* car */ + s_return(sc,caar(sc->args)); + + case OP_CDR: /* cdr */ + s_return(sc,cdar(sc->args)); + + case OP_CONS: /* cons */ + cdr(sc->args) = cadr(sc->args); + s_return(sc,sc->args); + + case OP_SETCAR: /* set-car! */ + if(!is_immutable(car(sc->args))) { + caar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-car!: unable to alter immutable pair"); + } + + case OP_SETCDR: /* set-cdr! */ + if(!is_immutable(car(sc->args))) { + cdar(sc->args) = cadr(sc->args); + s_return(sc,car(sc->args)); + } else { + Error_0(sc,"set-cdr!: unable to alter immutable pair"); + } + + case OP_CHAR2INT: { /* char->integer */ + char c; + c=(char)ivalue(car(sc->args)); + s_return(sc,mk_integer(sc,(unsigned char)c)); + } + + case OP_INT2CHAR: { /* integer->char */ + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_CHARUPCASE: { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=toupper(c); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_CHARDNCASE: { + unsigned char c; + c=(unsigned char)ivalue(car(sc->args)); + c=tolower(c); + s_return(sc,mk_character(sc,(char)c)); + } + + case OP_STR2SYM: /* string->symbol */ + s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); + + case OP_STR2ATOM: /* string->atom */ { + char *s=strvalue(car(sc->args)); + if(*s=='#') { + s_return(sc, mk_sharp_const(sc, s+1)); + } else { + s_return(sc, mk_atom(sc, s)); + } + } + + case OP_SYM2STR: /* symbol->string */ + x=mk_string(sc,symname(car(sc->args))); + setimmutable(x); + s_return(sc,x); + case OP_ATOM2STR: /* atom->string */ + x=car(sc->args); + if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { + char *p; + int len; + atom2str(sc,x,0,&p,&len); + s_return(sc,mk_counted_string(sc,p,len)); + } else { + Error_1(sc, "atom->string: not an atom:", x); + } + + case OP_MKSTRING: { /* make-string */ + int fill=' '; + int len; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=charvalue(cadr(sc->args)); + } + s_return(sc,mk_empty_string(sc,len,(char)fill)); + } + + case OP_STRLEN: /* string-length */ + s_return(sc,mk_integer(sc,strlength(car(sc->args)))); + + case OP_STRREF: { /* string-ref */ + char *str; + int index; + + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + + if(index>=strlength(car(sc->args))) { + Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); + } + + s_return(sc,mk_character(sc,((unsigned char*)str)[index])); + } + + case OP_STRSET: { /* string-set! */ + char *str; + int index; + int c; + + if(is_immutable(car(sc->args))) { + Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); + } + str=strvalue(car(sc->args)); + + index=ivalue(cadr(sc->args)); + if(index>=strlength(car(sc->args))) { + Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); + } + + c=charvalue(caddr(sc->args)); + + str[index]=(char)c; + s_return(sc,car(sc->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 = sc->args; x != sc->NIL; x = cdr(x)) { + len += strlength(car(x)); + } + newstr = mk_empty_string(sc, len, ' '); + /* store the contents of the argument strings into the new string */ + for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; + pos += strlength(car(x)), x = cdr(x)) { + memcpy(pos, strvalue(car(x)), strlength(car(x))); + } + s_return(sc, newstr); + } + + case OP_SUBSTR: { /* substring */ + char *str; + int index0; + int index1; + int len; + + str=strvalue(car(sc->args)); + + index0=ivalue(cadr(sc->args)); + + if(index0>strlength(car(sc->args))) { + Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); + } + + if(cddr(sc->args)!=sc->NIL) { + index1=ivalue(caddr(sc->args)); + if(index1>strlength(car(sc->args)) || index1args)); + } + } else { + index1=strlength(car(sc->args)); + } + + len=index1-index0; + x=mk_empty_string(sc,len,' '); + memcpy(strvalue(x),str+index0,len); + strvalue(x)[len]=0; + + s_return(sc,x); + } + + case OP_VECTOR: { /* vector */ + int i; + pointer vec; + int len=list_length(sc,sc->args); + if(len<0) { + Error_1(sc,"vector: not a proper list:",sc->args); + } + vec=mk_vector(sc,len); + for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { + set_vector_elem(vec,i,car(x)); + } + s_return(sc,vec); + } + + case OP_MKVECTOR: { /* make-vector */ + pointer fill=sc->NIL; + int len; + pointer vec; + + len=ivalue(car(sc->args)); + + if(cdr(sc->args)!=sc->NIL) { + fill=cadr(sc->args); + } + vec=mk_vector(sc,len); + if(fill!=sc->NIL) { + fill_vector(vec,fill); + } + s_return(sc,vec); + } + + case OP_VECLEN: /* vector-length */ + s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); + + case OP_VECREF: { /* vector-ref */ + int index; + + index=ivalue(cadr(sc->args)); + + if(index>=ivalue(car(sc->args))) { + Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); + } + + s_return(sc,vector_elem(car(sc->args),index)); + } + + case OP_VECSET: { /* vector-set! */ + int index; + + if(is_immutable(car(sc->args))) { + Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); + } + + index=ivalue(cadr(sc->args)); + if(index>=ivalue(car(sc->args))) { + Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); + } + + set_vector_elem(car(sc->args),index,caddr(sc->args)); + s_return(sc,car(sc->args)); + } + + default: + sprintf(sc->strbuff, "%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static int list_length(scheme *sc, pointer a) { + int v=0; + pointer x; + for (x = a, v = 0; is_pair(x); x = cdr(x)) { + ++v; + } + if(x==sc->NIL) { + return v; + } + return -1; +} + +static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { + pointer x; + num v; + int (*comp_func)(num,num)=0; + + switch (op) { + case OP_NOT: /* not */ + s_retbool(is_false(car(sc->args))); + case OP_BOOLP: /* boolean? */ + s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); + case OP_EOFOBJP: /* boolean? */ + s_retbool(car(sc->args) == sc->EOF_OBJ); + case OP_NULLP: /* null? */ + s_retbool(car(sc->args) == sc->NIL); + case OP_NUMEQ: /* = */ + case OP_LESS: /* < */ + case OP_GRE: /* > */ + case OP_LEQ: /* <= */ + case OP_GEQ: /* >= */ + switch(op) { + case OP_NUMEQ: comp_func=num_eq; break; + case OP_LESS: comp_func=num_lt; break; + case OP_GRE: comp_func=num_gt; break; + case OP_LEQ: comp_func=num_le; break; + case OP_GEQ: comp_func=num_ge; break; + } + x=sc->args; + v=nvalue(car(x)); + x=cdr(x); + + for (; x != sc->NIL; x = cdr(x)) { + if(!comp_func(v,nvalue(car(x)))) { + s_retbool(0); + } + v=nvalue(car(x)); + } + s_retbool(1); + case OP_SYMBOLP: /* symbol? */ + s_retbool(is_symbol(car(sc->args))); + case OP_NUMBERP: /* number? */ + s_retbool(is_number(car(sc->args))); + case OP_STRINGP: /* string? */ + s_retbool(is_string(car(sc->args))); + case OP_INTEGERP: /* integer? */ + s_retbool(is_integer(car(sc->args))); + case OP_REALP: /* real? */ + s_retbool(is_number(car(sc->args))); /* All numbers are real */ + case OP_CHARP: /* char? */ + s_retbool(is_character(car(sc->args))); +#if USE_CHAR_CLASSIFIERS + case OP_CHARAP: /* char-alphabetic? */ + s_retbool(Cisalpha(ivalue(car(sc->args)))); + case OP_CHARNP: /* char-numeric? */ + s_retbool(Cisdigit(ivalue(car(sc->args)))); + case OP_CHARWP: /* char-whitespace? */ + s_retbool(Cisspace(ivalue(car(sc->args)))); + case OP_CHARUP: /* char-upper-case? */ + s_retbool(Cisupper(ivalue(car(sc->args)))); + case OP_CHARLP: /* char-lower-case? */ + s_retbool(Cislower(ivalue(car(sc->args)))); +#endif + case OP_PORTP: /* port? */ + s_retbool(is_port(car(sc->args))); + case OP_INPORTP: /* input-port? */ + s_retbool(is_inport(car(sc->args))); + case OP_OUTPORTP: /* output-port? */ + s_retbool(is_outport(car(sc->args))); + case OP_PROCP: /* procedure? */ + /*-- + * continuation should be procedure by the example + * (call-with-current-continuation procedure?) ==> #t + * in R^3 report sec. 6.9 + */ + s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) + || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); + case OP_PAIRP: /* pair? */ + s_retbool(is_pair(car(sc->args))); + case OP_LISTP: { /* list? */ + pointer slow, fast; + slow = fast = car(sc->args); + while (1) { + if (!is_pair(fast)) s_retbool(fast == sc->NIL); + fast = cdr(fast); + if (!is_pair(fast)) s_retbool(fast == sc->NIL); + fast = cdr(fast); + 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 */ + s_retbool(0); + } + } + } + case OP_ENVP: /* environment? */ + s_retbool(is_environment(car(sc->args))); + case OP_VECTORP: /* vector? */ + s_retbool(is_vector(car(sc->args))); + case OP_EQ: /* eq? */ + s_retbool(car(sc->args) == cadr(sc->args)); + case OP_EQV: /* eqv? */ + s_retbool(eqv(car(sc->args), cadr(sc->args))); + default: + sprintf(sc->strbuff, "%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; +} + +static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + + switch (op) { + case OP_FORCE: /* force */ + sc->code = car(sc->args); + if (is_promise(sc->code)) { + /* Should change type to closure here */ + s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); + sc->args = sc->NIL; + s_goto(sc,OP_APPLY); + } else { + s_return(sc,sc->code); + } + + case OP_SAVE_FORCED: /* Save forced value replacing promise */ + memcpy(sc->code,sc->value,sizeof(struct cell)); + s_return(sc,sc->value); + + case OP_WRITE: /* write */ + case OP_DISPLAY: /* display */ + case OP_WRITE_CHAR: /* write-char */ + if(is_pair(cdr(sc->args))) { + if(cadr(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=cadr(sc->args); + } + } + sc->args = car(sc->args); + if(op==OP_WRITE) { + sc->print_flag = 1; + } else { + sc->print_flag = 0; + } + s_goto(sc,OP_P0LIST); + + case OP_NEWLINE: /* newline */ + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->outport) { + x=cons(sc,sc->outport,sc->NIL); + s_save(sc,OP_SET_OUTPORT, x, sc->NIL); + sc->outport=car(sc->args); + } + } + putstr(sc, "\n"); + s_return(sc,sc->T); + + case OP_ERR0: /* error */ + sc->retcode=-1; + if (!is_string(car(sc->args))) { + sc->args=cons(sc,mk_string(sc," -- "),sc->args); + setimmutable(car(sc->args)); + } + putstr(sc, "Error: "); + putstr(sc, strvalue(car(sc->args))); + sc->args = cdr(sc->args); + s_goto(sc,OP_ERR1); + + case OP_ERR1: /* error */ + putstr(sc, " "); + if (sc->args != sc->NIL) { + s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + sc->print_flag = 1; + s_goto(sc,OP_P0LIST); + } else { + putstr(sc, "\n"); + if(sc->interactive_repl) { + s_goto(sc,OP_T0LVL); + } else { + return sc->NIL; + } + } + + case OP_REVERSE: /* reverse */ + s_return(sc,reverse(sc, car(sc->args))); + + case OP_LIST_STAR: /* list* */ + s_return(sc,list_star(sc,sc->args)); + + case OP_APPEND: /* append */ + if(sc->args==sc->NIL) { + s_return(sc,sc->NIL); + } + x=car(sc->args); + if(cdr(sc->args)==sc->NIL) { + s_return(sc,sc->args); + } + for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) { + x=append(sc,x,car(y)); + } + s_return(sc,x); + +#if USE_PLIST + case OP_PUT: /* put */ + if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { + Error_0(sc,"illegal use of put"); + } + for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { + if (caar(x) == y) { + break; + } + } + if (x != sc->NIL) + cdar(x) = caddr(sc->args); + else + symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), + symprop(car(sc->args))); + s_return(sc,sc->T); + + case OP_GET: /* get */ + if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { + Error_0(sc,"illegal use of get"); + } + for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { + if (caar(x) == y) { + break; + } + } + if (x != sc->NIL) { + s_return(sc,cdar(x)); + } else { + s_return(sc,sc->NIL); + } +#endif /* USE_PLIST */ + case OP_QUIT: /* quit */ + if(is_pair(sc->args)) { + sc->retcode=ivalue(car(sc->args)); + } + return (sc->NIL); + + case OP_GC: /* gc */ + gc(sc, sc->NIL, sc->NIL); + s_return(sc,sc->T); + + case OP_GCVERB: /* gc-verbose */ + { int was = sc->gc_verbose; + + sc->gc_verbose = (car(sc->args) != sc->F); + s_retbool(was); + } + + case OP_NEWSEGMENT: /* new-segment */ + if (!is_pair(sc->args) || !is_number(car(sc->args))) { + Error_0(sc,"new-segment: argument must be a number"); + } + alloc_cellseg(sc, (int) ivalue(car(sc->args))); + s_return(sc,sc->T); + + case OP_OBLIST: /* oblist */ + s_return(sc, oblist_all_symbols(sc)); + + case OP_CURR_INPORT: /* current-input-port */ + s_return(sc,sc->inport); + + case OP_CURR_OUTPORT: /* current-output-port */ + s_return(sc,sc->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(sc,strvalue(car(sc->args)),prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + } + +#if USE_STRING_PORTS + case OP_OPEN_INSTRING: /* open-input-string */ + case OP_OPEN_OUTSTRING: /* open-output-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_OUTSTRING: prop=port_output; break; + case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; + } + p=port_from_string(sc, strvalue(car(sc->args)), + strvalue(car(sc->args))+strlength(car(sc->args)), prop); + if(p==sc->NIL) { + s_return(sc,sc->F); + } + s_return(sc,p); + } +#endif + + case OP_CLOSE_INPORT: /* close-input-port */ + port_close(sc,car(sc->args),port_input); + s_return(sc,sc->T); + + case OP_CLOSE_OUTPORT: /* close-output-port */ + port_close(sc,car(sc->args),port_output); + s_return(sc,sc->T); + + case OP_INT_ENV: /* interaction-environment */ + s_return(sc,sc->global_env); + + case OP_CURR_ENV: /* current-environment */ + s_return(sc,sc->envir); + + } + return sc->T; +} + +static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { + pointer x; + + if(sc->nesting!=0) { + int n=sc->nesting; + sc->nesting=0; + sc->retcode=-1; + Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); + } + + switch (op) { + /* ========== reading part ========== */ + case OP_READ: + if(!is_pair(sc->args)) { + s_goto(sc,OP_READ_INTERNAL); + } + if(!is_inport(car(sc->args))) { + Error_1(sc,"read: not an input port:",car(sc->args)); + } + if(car(sc->args)==sc->inport) { + s_goto(sc,OP_READ_INTERNAL); + } + x=sc->inport; + sc->inport=car(sc->args); + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + s_goto(sc,OP_READ_INTERNAL); + + case OP_READ_CHAR: /* read-char */ + case OP_PEEK_CHAR: /* peek-char */ { + int c; + if(is_pair(sc->args)) { + if(car(sc->args)!=sc->inport) { + x=sc->inport; + x=cons(sc,x,sc->NIL); + s_save(sc,OP_SET_INPORT, x, sc->NIL); + sc->inport=car(sc->args); + } + } + c=inchar(sc); + if(c==EOF) { + s_return(sc,sc->EOF_OBJ); + } + if(sc->op==OP_PEEK_CHAR) { + backchar(sc,c); + } + s_return(sc,mk_character(sc,c)); + } + + case OP_CHAR_READY: /* char-ready? */ { + pointer p=sc->inport; + int res; + if(is_pair(sc->args)) { + p=car(sc->args); + } + res=p->_object._port->kind&port_string; + s_retbool(res); + } + + case OP_SET_INPORT: /* set-input-port */ + sc->inport=car(sc->args); + s_return(sc,sc->value); + + case OP_SET_OUTPORT: /* set-output-port */ + sc->outport=car(sc->args); + s_return(sc,sc->value); + + case OP_RDSEXPR: + switch (sc->tok) { + case TOK_EOF: + if(sc->inport==sc->loadport) { + sc->args=sc->NIL; + s_goto(sc,OP_QUIT); + } else { + s_return(sc,sc->EOF_OBJ); + } + case TOK_COMMENT: { + int c; + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + } + case TOK_VEC: + s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); + /* fall through */ + case TOK_LPAREN: + sc->tok = token(sc); + if (sc->tok == TOK_RPAREN) { + s_return(sc,sc->NIL); + } else if (sc->tok == TOK_DOT) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]++; + s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); + s_goto(sc,OP_RDSEXPR); + } + case TOK_QUOTE: + s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_BQUOTE: + sc->tok = token(sc); + if(sc->tok==TOK_VEC) { + s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); + sc->tok=TOK_LPAREN; + s_goto(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); + } + s_goto(sc,OP_RDSEXPR); + case TOK_COMMA: + s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_ATMARK: + s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + case TOK_ATOM: + s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r "))); + case TOK_DQUOTE: + x=readstrexp(sc); + if(x==sc->F) { + Error_0(sc,"Error reading string"); + } + setimmutable(x); + s_return(sc,x); + case TOK_SHARP: { + pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); + if(f==sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + sc->code=cons(sc,slot_value_in_env(f),sc->NIL); + s_goto(sc,OP_EVAL); + } + } + case TOK_SHARP_CONST: + if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) { + Error_0(sc,"undefined sharp expression"); + } else { + s_return(sc,x); + } + default: + Error_0(sc,"syntax error: illegal token"); + } + break; + + case OP_RDLIST: { + sc->args = cons(sc, sc->value, sc->args); + sc->tok = token(sc); + if (sc->tok == TOK_COMMENT) { + int c; + while ((c=inchar(sc)) != '\n' && c!=EOF) + ; + sc->tok = token(sc); + } + if (sc->tok == TOK_RPAREN) { + int c = inchar(sc); + if (c != '\n') backchar(sc,c); + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); + } else if (sc->tok == TOK_DOT) { + s_save(sc,OP_RDDOT, sc->args, sc->NIL); + sc->tok = token(sc); + s_goto(sc,OP_RDSEXPR); + } else { + s_save(sc,OP_RDLIST, sc->args, sc->NIL);; + s_goto(sc,OP_RDSEXPR); + } + } + + case OP_RDDOT: + if (token(sc) != TOK_RPAREN) { + Error_0(sc,"syntax error: illegal dot expression"); + } else { + sc->nesting_stack[sc->file_i]--; + s_return(sc,reverse_in_place(sc, sc->value, sc->args)); + } + + case OP_RDQUOTE: + s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDQQUOTE: + s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDQQUOTEVEC: + s_return(sc,cons(sc, mk_symbol(sc,"apply"), + cons(sc, mk_symbol(sc,"vector"), + cons(sc,cons(sc, sc->QQUOTE, + cons(sc,sc->value,sc->NIL)), + sc->NIL)))); + + case OP_RDUNQUOTE: + s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); + + case OP_RDUQTSP: + s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); + + case OP_RDVEC: + /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_goto(sc,OP_EVAL); Cannot be quoted*/ + /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); + s_return(sc,x); Cannot be part of pairs*/ + /*sc->code=mk_proc(sc,OP_VECTOR); + sc->args=sc->value; + s_goto(sc,OP_APPLY);*/ + sc->args=sc->value; + s_goto(sc,OP_VECTOR); + + /* ========== printing part ========== */ + case OP_P0LIST: + if(is_vector(sc->args)) { + putstr(sc,"#("); + sc->args=cons(sc,sc->args,mk_integer(sc,0)); + s_goto(sc,OP_PVECFROM); + } else if(is_environment(sc->args)) { + putstr(sc,"#"); + s_return(sc,sc->T); + } else if (!is_pair(sc->args)) { + printatom(sc, sc->args, sc->print_flag); + s_return(sc,sc->T); + } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "'"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, "`"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { + putstr(sc, ","); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { + putstr(sc, ",@"); + sc->args = cadr(sc->args); + s_goto(sc,OP_P0LIST); + } else { + putstr(sc, "("); + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + sc->args = car(sc->args); + s_goto(sc,OP_P0LIST); + } + + case OP_P1LIST: + if (is_pair(sc->args)) { + s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); + putstr(sc, " "); + sc->args = car(sc->args); + s_goto(sc,OP_P0LIST); + } else if(is_vector(sc->args)) { + s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); + putstr(sc, " . "); + s_goto(sc,OP_P0LIST); + } else { + if (sc->args != sc->NIL) { + putstr(sc, " . "); + printatom(sc, sc->args, sc->print_flag); + } + putstr(sc, ")"); + s_return(sc,sc->T); + } + case OP_PVECFROM: { + int i=ivalue_unchecked(cdr(sc->args)); + pointer vec=car(sc->args); + int len=ivalue_unchecked(vec); + if(i==len) { + putstr(sc,")"); + s_return(sc,sc->T); + } else { + pointer elem=vector_elem(vec,i); + ivalue_unchecked(cdr(sc->args))=i+1; + s_save(sc,OP_PVECFROM, sc->args, sc->NIL); + sc->args=elem; + putstr(sc," "); + s_goto(sc,OP_P0LIST); + } + } + + default: + sprintf(sc->strbuff, "%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + + } + return sc->T; +} + +static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { + pointer x, y; + long v; + + switch (op) { + case OP_LIST_LENGTH: /* length */ /* a.k */ + v=list_length(sc,car(sc->args)); + if(v<0) { + Error_1(sc,"length: not a list:",car(sc->args)); + } + s_return(sc,mk_integer(sc, v)); + + case OP_ASSQ: /* assq */ /* a.k */ + x = car(sc->args); + for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { + if (!is_pair(car(y))) { + Error_0(sc,"unable to handle non pair element"); + } + if (x == caar(y)) + break; + } + if (is_pair(y)) { + s_return(sc,car(y)); + } else { + s_return(sc,sc->F); + } + + + case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ + sc->args = car(sc->args); + if (sc->args == sc->NIL) { + s_return(sc,sc->F); + } else if (is_closure(sc->args)) { + s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + } else if (is_macro(sc->args)) { + s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); + } else { + s_return(sc,sc->F); + } + case OP_CLOSUREP: /* closure? */ + /* + * Note, macro object is also a closure. + * Therefore, (closure? <#MACRO>) ==> #t + */ + s_retbool(is_closure(car(sc->args))); + case OP_MACROP: /* macro? */ + s_retbool(is_macro(car(sc->args))); + default: + sprintf(sc->strbuff, "%d: illegal operator", sc->op); + Error_0(sc,sc->strbuff); + } + return sc->T; /* NOTREACHED */ +} + +typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); + +typedef int (*test_predicate)(pointer); +static int is_any(pointer p) { return 1;} +static int is_num_integer(pointer p) { + return is_number(p) && ((p)->_object._number.is_fixnum); +} +static int is_nonneg(pointer p) { + return is_num_integer(p) && ivalue(p)>=0; +} + +/* Correspond carefully with following defines! */ +static struct { + test_predicate fct; + const char *kind; +} tests[]={ + {0,0}, /* unused */ + {is_any, 0}, + {is_string, "string"}, + {is_symbol, "symbol"}, + {is_port, "port"}, + {0,"input port"}, + {0,"output_port"}, + {is_environment, "environment"}, + {is_pair, "pair"}, + {0, "pair or '()"}, + {is_character, "character"}, + {is_vector, "vector"}, + {is_number, "number"}, + {is_num_integer, "integer"}, + {is_nonneg, "non-negative integer"} +}; + +#define TST_NONE 0 +#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" + +typedef struct { + dispatch_func func; + char *name; + int min_arity; + int max_arity; + char *arg_tests_encoding; +} op_code_info; + +#define INF_ARG 0xffff + +static op_code_info dispatch_table[]= { +#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, +#include "opdefines.h" + { 0 } +}; + +static const char *procname(pointer x) { + int n=procnum(x); + const char *name=dispatch_table[n].name; + if(name==0) { + name="ILLEGAL!"; + } + return name; +} + +/* kernel of this interpreter */ +static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { + int count=0; + int old_op; + + sc->op = op; + for (;;) { + op_code_info *pcd=dispatch_table+sc->op; + if (pcd->name!=0) { /* if built-in function, check arguments */ + char msg[512]; + int ok=1; + int n=list_length(sc,sc->args); + + /* Check number of arguments */ + if(nmin_arity) { + ok=0; + sprintf(msg,"%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity==pcd->max_arity?"":" at least", + pcd->min_arity); + } + if(ok && n>pcd->max_arity) { + ok=0; + sprintf(msg,"%s: needs%s %d argument(s)", + pcd->name, + pcd->min_arity==pcd->max_arity?"":" at most", + pcd->max_arity); + } + if(ok) { + if(pcd->arg_tests_encoding!=0) { + int i=0; + int j; + const char *t=pcd->arg_tests_encoding; + pointer arglist=sc->args; + do { + pointer arg=car(arglist); + j=(int)t[0]; + if(j==TST_INPORT[0]) { + if(!is_inport(arg)) break; + } else if(j==TST_OUTPORT[0]) { + if(!is_outport(arg)) break; + } else if(j==TST_LIST[0]) { + if(arg!=sc->NIL && !is_pair(arg)) break; + } else { + if(!tests[j].fct(arg)) break; + } + + if(t[1]!=0) {/* last test is replicated as necessary */ + t++; + } + arglist=cdr(arglist); + i++; + } while(iname, + i+1, + tests[j].kind); + } + } + } + if(!ok) { + if(_Error_1(sc,msg,0)==sc->NIL) { + return; + } + pcd=dispatch_table+sc->op; + } + } + old_op=sc->op; + if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { + return; + } + if(sc->no_memory) { + fprintf(stderr,"No memory!\n"); + return; + } + count++; + } +} + +/* ========== Initialization of internal keywords ========== */ + +static void assign_syntax(scheme *sc, char *name) { + pointer x; + + x = oblist_add_by_name(sc, name); + typeflag(x) |= T_SYNTAX; +} + +static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { + pointer x, y; + + x = mk_symbol(sc, name); + y = mk_proc(sc,op); + new_slot_in_env(sc, x, y); +} + +static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { + pointer y; + + y = get_cell(sc, sc->NIL, sc->NIL); + typeflag(y) = (T_PROC | T_ATOM); + ivalue_unchecked(y) = (long) op; + set_integer(y); + return y; +} + +/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ +static int syntaxnum(pointer p) { + const char *s=strvalue(car(p)); + switch(strlength(car(p))) { + case 2: + if(s[0]=='i') return OP_IF0; /* if */ + else return OP_OR0; /* or */ + case 3: + if(s[0]=='a') return OP_AND0; /* and */ + else return OP_LET0; /* let */ + case 4: + switch(s[3]) { + case 'e': return OP_CASE0; /* case */ + case 'd': return OP_COND0; /* cond */ + case '*': return OP_LET0AST; /* let* */ + default: return OP_SET0; /* set! */ + } + case 5: + switch(s[2]) { + case 'g': return OP_BEGIN; /* begin */ + case 'l': return OP_DELAY; /* delay */ + case 'c': return OP_MACRO0; /* macro */ + default: return OP_QUOTE; /* quote */ + } + case 6: + switch(s[2]) { + case 'm': return OP_LAMBDA; /* lambda */ + case 'f': return OP_DEF0; /* define */ + default: return OP_LET0REC; /* letrec */ + } + default: + return OP_C0STREAM; /* cons-stream */ + } +} + +/* initialization of TinyScheme */ +#if USE_INTERFACE +INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { + return cons(sc,a,b); +} +INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { + return immutable_cons(sc,a,b); +} + +static struct scheme_interface vtbl ={ + scheme_define, + s_cons, + s_immutable_cons, + mk_integer, + mk_real, + mk_symbol, + gensym, + mk_string, + mk_counted_string, + mk_character, + mk_vector, + mk_foreign_func, + putstr, + putcharacter, + + is_string, + string_value, + is_number, + nvalue, + ivalue, + rvalue, + is_integer, + is_real, + is_character, + charvalue, + is_vector, + ivalue, + fill_vector, + vector_elem, + set_vector_elem, + is_port, + is_pair, + pair_car, + pair_cdr, + set_car, + set_cdr, + + is_symbol, + symname, + + is_syntax, + is_proc, + is_foreign, + syntaxname, + is_closure, + is_macro, + closure_code, + closure_env, + + is_continuation, + is_promise, + is_environment, + is_immutable, + setimmutable, + + scheme_load_file, + scheme_load_string +}; +#endif + +scheme *scheme_init_new() { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init(sc)) { + free(sc); + return 0; + } else { + return sc; + } +} + +scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { + scheme *sc=(scheme*)malloc(sizeof(scheme)); + if(!scheme_init_custom_alloc(sc,malloc,free)) { + free(sc); + return 0; + } else { + return sc; + } +} + + +int scheme_init(scheme *sc) { + return scheme_init_custom_alloc(sc,malloc,free); +} + +int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { + int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); + pointer x; + + num_zero.is_fixnum=1; + num_zero.value.ivalue=0; + num_one.is_fixnum=1; + num_one.value.ivalue=1; + +#if USE_INTERFACE + sc->vptr=&vtbl; +#endif + sc->gensym_cnt=0; + sc->malloc=malloc; + sc->free=free; + sc->last_cell_seg = -1; + sc->sink = &sc->_sink; + sc->NIL = &sc->_NIL; + sc->T = &sc->_HASHT; + sc->F = &sc->_HASHF; + sc->EOF_OBJ=&sc->_EOF_OBJ; + sc->free_cell = &sc->_NIL; + sc->fcells = 0; + sc->no_memory=0; + sc->inport=sc->NIL; + sc->outport=sc->NIL; + sc->save_inport=sc->NIL; + sc->loadport=sc->NIL; + sc->nesting=0; + sc->interactive_repl=0; + + if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { + sc->no_memory=1; + return 0; + } + sc->gc_verbose = 0; + dump_stack_initialize(sc); + sc->code = sc->NIL; + sc->tracing=0; + + /* init sc->NIL */ + typeflag(sc->NIL) = (T_ATOM | MARK); + car(sc->NIL) = cdr(sc->NIL) = sc->NIL; + /* init T */ + typeflag(sc->T) = (T_ATOM | MARK); + car(sc->T) = cdr(sc->T) = sc->T; + /* init F */ + typeflag(sc->F) = (T_ATOM | MARK); + car(sc->F) = cdr(sc->F) = sc->F; + sc->oblist = oblist_initial_value(sc); + /* init global_env */ + new_frame_in_env(sc, sc->NIL); + sc->global_env = sc->envir; + /* init else */ + x = mk_symbol(sc,"else"); + new_slot_in_env(sc, x, sc->T); + + assign_syntax(sc, "lambda"); + assign_syntax(sc, "quote"); + assign_syntax(sc, "define"); + assign_syntax(sc, "if"); + assign_syntax(sc, "begin"); + assign_syntax(sc, "set!"); + assign_syntax(sc, "let"); + assign_syntax(sc, "let*"); + assign_syntax(sc, "letrec"); + assign_syntax(sc, "cond"); + assign_syntax(sc, "delay"); + assign_syntax(sc, "and"); + assign_syntax(sc, "or"); + assign_syntax(sc, "cons-stream"); + assign_syntax(sc, "macro"); + assign_syntax(sc, "case"); + + for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); + sc->QUOTE = mk_symbol(sc, "quote"); + sc->QQUOTE = mk_symbol(sc, "quasiquote"); + sc->UNQUOTE = mk_symbol(sc, "unquote"); + sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); + sc->FEED_TO = mk_symbol(sc, "=>"); + sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); + sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); + sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); + + return !sc->no_memory; +} + +void scheme_set_input_port_file(scheme *sc, FILE *fin) { + sc->inport=port_from_file(sc,fin,port_input); +} + +void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { + sc->inport=port_from_string(sc,start,past_the_end,port_input); +} + +void scheme_set_output_port_file(scheme *sc, FILE *fout) { + sc->outport=port_from_file(sc,fout,port_output); +} + +void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { + sc->outport=port_from_string(sc,start,past_the_end,port_output); +} + +void scheme_set_external_data(scheme *sc, void *p) { + sc->ext_data=p; +} + +void scheme_deinit(scheme *sc) { + int i; + + sc->oblist=sc->NIL; + sc->global_env=sc->NIL; + dump_stack_free(sc); + sc->envir=sc->NIL; + sc->code=sc->NIL; + sc->args=sc->NIL; + sc->value=sc->NIL; + if(is_port(sc->inport)) { + typeflag(sc->inport) = T_ATOM; + } + sc->inport=sc->NIL; + sc->outport=sc->NIL; + if(is_port(sc->save_inport)) { + typeflag(sc->save_inport) = T_ATOM; + } + sc->save_inport=sc->NIL; + if(is_port(sc->loadport)) { + typeflag(sc->loadport) = T_ATOM; + } + sc->loadport=sc->NIL; + sc->gc_verbose=0; + gc(sc,sc->NIL,sc->NIL); + + for(i=0; i<=sc->last_cell_seg; i++) { + sc->free(sc->alloc_seg[i]); + } +} + +void scheme_load_file(scheme *sc, FILE *fin) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_file; + sc->load_stack[0].rep.stdio.file=fin; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + if(fin==stdin) { + sc->interactive_repl=1; + } + sc->inport=sc->loadport; + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } +} + +void scheme_load_string(scheme *sc, const char *cmd) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->file_i=0; + sc->load_stack[0].kind=port_input|port_string; + sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ + sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); + sc->load_stack[0].rep.string.curr=(char*)cmd; + sc->loadport=mk_port(sc,sc->load_stack); + sc->retcode=0; + sc->interactive_repl=0; + sc->inport=sc->loadport; + Eval_Cycle(sc, OP_T0LVL); + typeflag(sc->loadport)=T_ATOM; + if(sc->retcode==0) { + sc->retcode=sc->nesting!=0; + } +} + +void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { + pointer x; + + x=find_slot_in_env(sc,envir,symbol,0); + if (x != sc->NIL) { + set_slot_in_env(sc, x, value); + } else { + new_slot_spec_in_env(sc, envir, symbol, value); + } +} + +#if !STANDALONE +void scheme_apply0(scheme *sc, const char *procname) { + pointer carx=mk_symbol(sc,procname); + pointer cdrx=sc->NIL; + + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->code = cons(sc,carx,cdrx); + sc->interactive_repl=0; + sc->retcode=0; + Eval_Cycle(sc,OP_EVAL); + } + +void scheme_call(scheme *sc, pointer func, pointer args) { + dump_stack_reset(sc); + sc->envir = sc->global_env; + sc->args = args; + sc->code = func; + sc->interactive_repl =0; + sc->retcode = 0; + Eval_Cycle(sc, OP_APPLY); +} +#endif + +/* ========== Main ========== */ + +#if STANDALONE + +#ifdef macintosh +int main() +{ + extern MacTS_main(int argc, char **argv); + char** argv; + int argc = ccommand(&argv); + MacTS_main(argc,argv); + return 0; +} +int MacTS_main(int argc, char **argv) { +#else +int main(int argc, char **argv) { +#endif + scheme sc; + FILE *fin; + char *file_name=InitFile; + int retcode; + int isfile=1; + + if(argc==1) { + printf(banner); + } + if(argc==2 && strcmp(argv[1],"-?")==0) { + printf("Usage: %s [-? | ... | -1 ...]\n\tUse - as filename for stdin.\n",argv[0]); + return 1; + } + if(!scheme_init(&sc)) { + fprintf(stderr,"Could not initialize!\n"); + return 2; + } + scheme_set_input_port_file(&sc, stdin); + scheme_set_output_port_file(&sc, stdout); +#if USE_DL + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); +#endif + argv++; + if(access(file_name,0)!=0) { + char *p=getenv("TINYSCHEMEINIT"); + if(p!=0) { + file_name=p; + } + } + do { + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { + pointer args=sc.NIL; + isfile=file_name[1]=='1'; + file_name=*argv++; + if(strcmp(file_name,"-")==0) { + fin=stdin; + } else if(isfile) { + fin=fopen(file_name,"r"); + } + for(;*argv;argv++) { + pointer value=mk_string(&sc,*argv); + args=cons(&sc,value,args); + } + args=reverse_in_place(&sc,sc.NIL,args); + scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); + + } else { + fin=fopen(file_name,"r"); + } + if(isfile && fin==0) { + fprintf(stderr,"Could not open file %s\n",file_name); + } else { + if(isfile) { + scheme_load_file(&sc,fin); + } else { + scheme_load_string(&sc,file_name); + } + if(!isfile || fin!=stdin) { + if(sc.retcode!=0) { + fprintf(stderr,"Errors encountered reading %s\n",file_name); + } + if(isfile) { + fclose(fin); + } + } + } + file_name=*argv++; + } while(file_name!=0); + if(argc==1) { + scheme_load_file(&sc,stdin); + } + retcode=sc.retcode; + scheme_deinit(&sc); + + return retcode; +} + +#endif