Back to index

texmacs  1.0.7.15
scheme.c
Go to the documentation of this file.
00001 /* T I N Y S C H E M E    1 . 3 9
00002  *   Dimitrios Souflis (dsouflis@acm.org)
00003  *   Based on MiniScheme (original credits follow)
00004  * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)
00005  * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
00006  * (MINISCM) This version has been modified by R.C. Secrist.
00007  * (MINISCM)
00008  * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
00009  * (MINISCM)
00010  * (MINISCM) This is a revised and modified version by Akira KIDA.
00011  * (MINISCM)    current version is 0.85k4 (15 May 1994)
00012  *
00013  */
00014 
00015 #define STANDALONE 0
00016 
00017 #define _SCHEME_SOURCE
00018 #include "scheme-private.h"
00019 #ifndef WIN32
00020 # include <unistd.h>
00021 #endif
00022 #ifdef WIN32
00023 #define snprintf _snprintf
00024 #endif
00025 #if USE_DL
00026 # include "dynload.h"
00027 #endif
00028 #if USE_MATH
00029 # include <math.h>
00030 #endif
00031 
00032 #include <limits.h>
00033 #include <float.h>
00034 #include <ctype.h>
00035 
00036 #if USE_STRCASECMP
00037 #include <strings.h>
00038 # ifndef __APPLE__
00039 #  define stricmp strcasecmp
00040 # endif
00041 #endif
00042 
00043 /* Used for documentation purposes, to signal functions in 'interface' */
00044 #define INTERFACE
00045 
00046 #define TOK_EOF     (-1)
00047 #define TOK_LPAREN  0
00048 #define TOK_RPAREN  1
00049 #define TOK_DOT     2
00050 #define TOK_ATOM    3
00051 #define TOK_QUOTE   4
00052 #define TOK_COMMENT 5
00053 #define TOK_DQUOTE  6
00054 #define TOK_BQUOTE  7
00055 #define TOK_COMMA   8
00056 #define TOK_ATMARK  9
00057 #define TOK_SHARP   10
00058 #define TOK_SHARP_CONST 11
00059 #define TOK_VEC     12
00060 
00061 # define BACKQUOTE '`'
00062 
00063 /*
00064  *  Basic memory allocation units
00065  */
00066 
00067 #define banner "TinyScheme 1.39"
00068 
00069 #include <string.h>
00070 #include <stdlib.h>
00071 
00072 #ifdef __APPLE__
00073 static int stricmp(const char *s1, const char *s2)
00074 {
00075   unsigned char c1, c2;
00076   do {
00077     c1 = tolower(*s1);
00078     c2 = tolower(*s2);
00079     if (c1 < c2)
00080       return -1;
00081     else if (c1 > c2)
00082       return 1;
00083     s1++, s2++;
00084   } while (c1 != 0);
00085   return 0;
00086 }
00087 #endif /* __APPLE__ */
00088 
00089 #if USE_STRLWR
00090 static const char *strlwr(char *s) {
00091   const char *p=s;
00092   while(*s) {
00093     *s=tolower(*s);
00094     s++;
00095   }
00096   return p;
00097 }
00098 #endif
00099 
00100 #ifndef prompt
00101 # define prompt "ts> "
00102 #endif
00103 
00104 #ifndef InitFile
00105 # define InitFile "init.scm"
00106 #endif
00107 
00108 #ifndef FIRST_CELLSEGS
00109 # define FIRST_CELLSEGS 3
00110 #endif
00111 
00112 enum scheme_types {
00113   T_STRING=1,
00114   T_NUMBER=2,
00115   T_SYMBOL=3,
00116   T_PROC=4,
00117   T_PAIR=5,
00118   T_CLOSURE=6,
00119   T_CONTINUATION=7,
00120   T_FOREIGN=8,
00121   T_CHARACTER=9,
00122   T_PORT=10,
00123   T_VECTOR=11,
00124   T_MACRO=12,
00125   T_PROMISE=13,
00126   T_ENVIRONMENT=14,
00127   T_BLACKBOX=15,
00128   T_LAST_SYSTEM_TYPE=15
00129 };
00130 
00131 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
00132 #define ADJ 32
00133 #define TYPE_BITS 5
00134 #define T_MASKTYPE      31    /* 0000000000011111 */
00135 #define T_SYNTAX      4096    /* 0001000000000000 */
00136 #define T_IMMUTABLE   8192    /* 0010000000000000 */
00137 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
00138 #define CLRATOM      49151    /* 1011111111111111 */   /* only for gc */
00139 #define MARK         32768    /* 1000000000000000 */
00140 #define UNMARK       32767    /* 0111111111111111 */
00141 
00142 
00143 static num num_add(num a, num b);
00144 static num num_mul(num a, num b);
00145 static num num_div(num a, num b);
00146 static num num_intdiv(num a, num b);
00147 static num num_sub(num a, num b);
00148 static num num_rem(num a, num b);
00149 static num num_mod(num a, num b);
00150 static int num_eq(num a, num b);
00151 static int num_gt(num a, num b);
00152 static int num_ge(num a, num b);
00153 static int num_lt(num a, num b);
00154 static int num_le(num a, num b);
00155 
00156 #if USE_MATH
00157 static double round_per_R5RS(double x);
00158 #endif
00159 static int is_zero_double(double x);
00160 static INLINE int num_is_integer(cell_ptr p) {
00161   return ((p)->_object._number.is_fixnum);
00162 }
00163 
00164 static num num_zero;
00165 static num num_one;
00166 
00167 /* macros for cell operations */
00168 #define typeflag(p)      ((p)->_flag)
00169 #define type(p)          (typeflag(p)&T_MASKTYPE)
00170 
00171 INTERFACE INLINE int is_string(cell_ptr p)     { return (type(p)==T_STRING); }
00172 #define strvalue(p)      ((p)->_object._string._svalue)
00173 #define strlength(p)        ((p)->_object._string._length)
00174 
00175 INTERFACE static int is_list(scheme *sc, cell_ptr p);
00176 INTERFACE INLINE int is_vector(cell_ptr p)    { return (type(p)==T_VECTOR); }
00177 INTERFACE static void fill_vector(cell_ptr vec, cell_ptr obj);
00178 INTERFACE static cell_ptr vector_elem(cell_ptr vec, int ielem);
00179 INTERFACE static cell_ptr set_vector_elem(cell_ptr vec, int ielem, cell_ptr a);
00180 INTERFACE INLINE int is_number(cell_ptr p)    { return (type(p)==T_NUMBER); }
00181 INTERFACE INLINE int is_integer(cell_ptr p) {
00182   return is_number(p) && ((p)->_object._number.is_fixnum);
00183 }
00184 
00185 INTERFACE INLINE int is_real(cell_ptr p) {
00186   return is_number(p) && (!(p)->_object._number.is_fixnum);
00187 }
00188 
00189 INTERFACE INLINE int is_character(cell_ptr p) { return (type(p)==T_CHARACTER); }
00190 INTERFACE INLINE char *string_value(cell_ptr p) { return strvalue(p); }
00191 INTERFACE INLINE int string_length(cell_ptr p) { return strlength(p); }
00192 INLINE num nvalue(cell_ptr p)       { return ((p)->_object._number); }
00193 INTERFACE long ivalue(cell_ptr p)      { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
00194 INTERFACE double rvalue(cell_ptr p)    { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
00195 #define ivalue_unchecked(p)       ((p)->_object._number.value.ivalue)
00196 #define rvalue_unchecked(p)       ((p)->_object._number.value.rvalue)
00197 #define set_num_integer(p)   (p)->_object._number.is_fixnum=1;
00198 #define set_num_real(p)      (p)->_object._number.is_fixnum=0;
00199 INTERFACE  long charvalue(cell_ptr p)  { return ivalue_unchecked(p); }
00200 
00201 INTERFACE INLINE int is_port(cell_ptr p)     { return (type(p)==T_PORT); }
00202 INTERFACE INLINE int is_inport(cell_ptr p)  { return is_port(p) && p->_object._port->kind & port_input; }
00203 INTERFACE INLINE int is_outport(cell_ptr p) { return is_port(p) && p->_object._port->kind & port_output; }
00204 
00205 INTERFACE INLINE int is_pair(cell_ptr p)     { return (type(p)==T_PAIR); }
00206 INTERFACE INLINE int is_blackbox(cell_ptr p)     { return (type(p)==T_BLACKBOX); }
00207 
00208 #define car(p)           ((p)->_object._cons._car)
00209 #define cdr(p)           ((p)->_object._cons._cdr)
00210 INTERFACE cell_ptr pair_car(cell_ptr p)   { return car(p); }
00211 INTERFACE cell_ptr pair_cdr(cell_ptr p)   { return cdr(p); }
00212 INTERFACE cell_ptr set_car(cell_ptr p, cell_ptr q) { return car(p)=q; }
00213 INTERFACE cell_ptr set_cdr(cell_ptr p, cell_ptr q) { return cdr(p)=q; }
00214 
00215 INTERFACE INLINE void *blackboxvalue(cell_ptr p)  { return car(p); }
00216 
00217 INTERFACE INLINE int is_symbol(cell_ptr p)   { return (type(p)==T_SYMBOL); }
00218 INTERFACE INLINE char *symname(cell_ptr p)   { return strvalue(car(p)); }
00219 INTERFACE INLINE int symlen(cell_ptr p)   { return strlength(car(p)); }
00220 #if USE_PLIST
00221 SCHEME_EXPORT INLINE int hasprop(cell_ptr p)     { return (typeflag(p)&T_SYMBOL); }
00222 #define symprop(p)       cdr(p)
00223 #endif
00224 
00225 INTERFACE INLINE int is_syntax(cell_ptr p)   { return (typeflag(p)&T_SYNTAX); }
00226 INTERFACE INLINE int is_proc(cell_ptr p)     { return (type(p)==T_PROC); }
00227 INTERFACE INLINE int is_foreign(cell_ptr p)  { return (type(p)==T_FOREIGN); }
00228 INTERFACE INLINE char *syntaxname(cell_ptr p) { return strvalue(car(p)); }
00229 #define procnum(p)       ivalue(p)
00230 static const char *procname(cell_ptr x);
00231 
00232 INTERFACE INLINE int is_closure(cell_ptr p)  { return (type(p)==T_CLOSURE); }
00233 INTERFACE INLINE int is_macro(cell_ptr p)    { return (type(p)==T_MACRO); }
00234 INTERFACE INLINE cell_ptr closure_code(cell_ptr p)   { return car(p); }
00235 INTERFACE INLINE cell_ptr closure_env(cell_ptr p)    { return cdr(p); }
00236 
00237 INTERFACE INLINE int is_continuation(cell_ptr p)    { return (type(p)==T_CONTINUATION); }
00238 #define cont_dump(p)     cdr(p)
00239 
00240 /* To do: promise should be forced ONCE only */
00241 INTERFACE INLINE int is_promise(cell_ptr p)  { return (type(p)==T_PROMISE); }
00242 
00243 INTERFACE INLINE int is_environment(cell_ptr p) { return (type(p)==T_ENVIRONMENT); }
00244 #define setenvironment(p)    typeflag(p) = T_ENVIRONMENT
00245 
00246 #define is_atom(p)       (typeflag(p)&T_ATOM)
00247 #define setatom(p)       typeflag(p) |= T_ATOM
00248 #define clratom(p)       typeflag(p) &= CLRATOM
00249 
00250 #define is_mark(p)       (typeflag(p)&MARK)
00251 #define setmark(p)       typeflag(p) |= MARK
00252 #define clrmark(p)       typeflag(p) &= UNMARK
00253 
00254 INTERFACE INLINE int is_immutable(cell_ptr p) { return (typeflag(p)&T_IMMUTABLE); }
00255 /*#define setimmutable(p)  typeflag(p) |= T_IMMUTABLE*/
00256 INTERFACE INLINE void setimmutable(cell_ptr p) { typeflag(p) |= T_IMMUTABLE; }
00257 
00258 #define caar(p)          car(car(p))
00259 #define cadr(p)          car(cdr(p))
00260 #define cdar(p)          cdr(car(p))
00261 #define cddr(p)          cdr(cdr(p))
00262 #define cadar(p)         car(cdr(car(p)))
00263 #define caddr(p)         car(cdr(cdr(p)))
00264 #define cdaar(p)         cdr(car(car(p)))
00265 #define cadaar(p)        car(cdr(car(car(p))))
00266 #define cadddr(p)        car(cdr(cdr(cdr(p))))
00267 #define cddddr(p)        cdr(cdr(cdr(cdr(p))))
00268 
00269 #if USE_CHAR_CLASSIFIERS
00270 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
00271 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
00272 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
00273 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
00274 static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
00275 #endif
00276 
00277 #if USE_ASCII_NAMES
00278 static const char *charnames[32]={
00279  "nul",
00280  "soh",
00281  "stx",
00282  "etx",
00283  "eot",
00284  "enq",
00285  "ack",
00286  "bel",
00287  "bs",
00288  "ht",
00289  "lf",
00290  "vt",
00291  "ff",
00292  "cr",
00293  "so",
00294  "si",
00295  "dle",
00296  "dc1",
00297  "dc2",
00298  "dc3",
00299  "dc4",
00300  "nak",
00301  "syn",
00302  "etb",
00303  "can",
00304  "em",
00305  "sub",
00306  "esc",
00307  "fs",
00308  "gs",
00309  "rs",
00310  "us"
00311 };
00312 
00313 static int is_ascii_name(const char *name, int *pc) {
00314   int i;
00315   for(i=0; i<32; i++) {
00316      if(stricmp(name,charnames[i])==0) {
00317           *pc=i;
00318           return 1;
00319      }
00320   }
00321   if(stricmp(name,"del")==0) {
00322      *pc=127;
00323      return 1;
00324   }
00325   return 0;
00326 }
00327 
00328 #endif
00329 
00330 static int file_push(scheme *sc, const char *fname);
00331 static void file_pop(scheme *sc);
00332 static int file_interactive(scheme *sc);
00333 static INLINE int is_one_of(char *s, int c);
00334 static int alloc_cellseg(scheme *sc, int n);
00335 static long binary_decode(const char *s);
00336 static INLINE cell_ptr get_cell(scheme *sc, cell_ptr a, cell_ptr b);
00337 static cell_ptr _get_cell(scheme *sc, cell_ptr a, cell_ptr b);
00338 static cell_ptr reserve_cells(scheme *sc, int n);
00339 static cell_ptr get_consecutive_cells(scheme *sc, int n);
00340 static cell_ptr find_consecutive_cells(scheme *sc, int n);
00341 static void finalize_cell(scheme *sc, cell_ptr a);
00342 static int count_consecutive_cells(cell_ptr x, int needed);
00343 static cell_ptr find_slot_in_env(scheme *sc, cell_ptr env, cell_ptr sym, int all);
00344 static cell_ptr mk_number(scheme *sc, num n);
00345 static char *store_string(scheme *sc, int len, const char *str, char fill);
00346 static cell_ptr mk_vector(scheme *sc, int len);
00347 static cell_ptr mk_atom(scheme *sc, char *q);
00348 static cell_ptr mk_sharp_const(scheme *sc, char *name);
00349 static cell_ptr mk_port(scheme *sc, port *p);
00350 static cell_ptr port_from_filename(scheme *sc, const char *fn, int prop);
00351 static cell_ptr port_from_file(scheme *sc, FILE *, int prop);
00352 static cell_ptr port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
00353 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
00354 static port *port_rep_from_file(scheme *sc, FILE *, int prop);
00355 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
00356 static void port_close(scheme *sc, cell_ptr p, int flag);
00357 static void mark(cell_ptr a);
00358 static void gc(scheme *sc, cell_ptr a, cell_ptr b);
00359 static int basic_inchar(port *pt);
00360 static int inchar(scheme *sc);
00361 static void backchar(scheme *sc, int c);
00362 static char   *readstr_upto(scheme *sc, char *delim);
00363 static cell_ptr readstrexp(scheme *sc);
00364 static INLINE int skipspace(scheme *sc);
00365 static int token(scheme *sc);
00366 static void printslashstring(scheme *sc, char *s, int len);
00367 static void atom2str(scheme *sc, cell_ptr l, int f, char **pp, int *plen);
00368 static void printatom(scheme *sc, cell_ptr l, int f);
00369 static cell_ptr mk_proc(scheme *sc, enum scheme_opcodes op);
00370 static cell_ptr mk_closure(scheme *sc, cell_ptr c, cell_ptr e);
00371 static cell_ptr mk_continuation(scheme *sc, cell_ptr d);
00372 static cell_ptr reverse(scheme *sc, cell_ptr a);
00373 static cell_ptr reverse_in_place(scheme *sc, cell_ptr term, cell_ptr list);
00374 static cell_ptr append(scheme *sc, cell_ptr a, cell_ptr b);
00375 static void dump_stack_mark(scheme *);
00376 static cell_ptr opexe_0(scheme *sc, enum scheme_opcodes op);
00377 static cell_ptr opexe_1(scheme *sc, enum scheme_opcodes op);
00378 static cell_ptr opexe_2(scheme *sc, enum scheme_opcodes op);
00379 static cell_ptr opexe_3(scheme *sc, enum scheme_opcodes op);
00380 static cell_ptr opexe_4(scheme *sc, enum scheme_opcodes op);
00381 static cell_ptr opexe_5(scheme *sc, enum scheme_opcodes op);
00382 static cell_ptr opexe_6(scheme *sc, enum scheme_opcodes op);
00383 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
00384 static void assign_syntax(scheme *sc, char *name);
00385 static int syntaxnum(cell_ptr p);
00386 static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
00387 
00388 #define num_ivalue(n)       (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
00389 #define num_rvalue(n)       (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
00390 
00391 static num num_add(num a, num b) {
00392  num ret;
00393  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00394  if(ret.is_fixnum) {
00395      ret.value.ivalue= a.value.ivalue+b.value.ivalue;
00396  } else {
00397      ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
00398  }
00399  return ret;
00400 }
00401 
00402 static num num_mul(num a, num b) {
00403  num ret;
00404  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00405  if(ret.is_fixnum) {
00406      ret.value.ivalue= a.value.ivalue*b.value.ivalue;
00407  } else {
00408      ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
00409  }
00410  return ret;
00411 }
00412 
00413 static num num_div(num a, num b) {
00414  num ret;
00415  ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
00416  if(ret.is_fixnum) {
00417      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
00418  } else {
00419      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
00420  }
00421  return ret;
00422 }
00423 
00424 static num num_intdiv(num a, num b) {
00425  num ret;
00426  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00427  if(ret.is_fixnum) {
00428      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
00429  } else {
00430      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
00431  }
00432  return ret;
00433 }
00434 
00435 static num num_sub(num a, num b) {
00436  num ret;
00437  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00438  if(ret.is_fixnum) {
00439      ret.value.ivalue= a.value.ivalue-b.value.ivalue;
00440  } else {
00441      ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
00442  }
00443  return ret;
00444 }
00445 
00446 static num num_rem(num a, num b) {
00447  num ret;
00448  long e1, e2, res;
00449  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00450  e1=num_ivalue(a);
00451  e2=num_ivalue(b);
00452  res=e1%e2;
00453  /* modulo should have same sign as second operand */
00454  if (res > 0) {
00455      if (e1 < 0) {
00456         res -= labs(e2);
00457      }
00458  } else if (res < 0) {
00459      if (e1 > 0) {
00460          res += labs(e2);
00461      }
00462  }
00463  ret.value.ivalue=res;
00464  return ret;
00465 }
00466 
00467 static num num_mod(num a, num b) {
00468  num ret;
00469  long e1, e2, res;
00470  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
00471  e1=num_ivalue(a);
00472  e2=num_ivalue(b);
00473  res=e1%e2;
00474  if(res*e2<0) {    /* modulo should have same sign as second operand */
00475      e2=labs(e2);
00476      if(res>0) {
00477           res-=e2;
00478      } else {
00479           res+=e2;
00480      }
00481  }
00482  ret.value.ivalue=res;
00483  return ret;
00484 }
00485 
00486 static int num_eq(num a, num b) {
00487  int ret;
00488  int is_fixnum=a.is_fixnum && b.is_fixnum;
00489  if(is_fixnum) {
00490      ret= a.value.ivalue==b.value.ivalue;
00491  } else {
00492      ret=num_rvalue(a)==num_rvalue(b);
00493  }
00494  return ret;
00495 }
00496 
00497 
00498 static int num_gt(num a, num b) {
00499  int ret;
00500  int is_fixnum=a.is_fixnum && b.is_fixnum;
00501  if(is_fixnum) {
00502      ret= a.value.ivalue>b.value.ivalue;
00503  } else {
00504      ret=num_rvalue(a)>num_rvalue(b);
00505  }
00506  return ret;
00507 }
00508 
00509 static int num_ge(num a, num b) {
00510  return !num_lt(a,b);
00511 }
00512 
00513 static int num_lt(num a, num b) {
00514  int ret;
00515  int is_fixnum=a.is_fixnum && b.is_fixnum;
00516  if(is_fixnum) {
00517      ret= a.value.ivalue<b.value.ivalue;
00518  } else {
00519      ret=num_rvalue(a)<num_rvalue(b);
00520  }
00521  return ret;
00522 }
00523 
00524 static int num_le(num a, num b) {
00525  return !num_gt(a,b);
00526 }
00527 
00528 #if USE_MATH
00529 /* Round to nearest. Round to even if midway */
00530 static double round_per_R5RS(double x) {
00531  double fl=floor(x);
00532  double ce=ceil(x);
00533  double dfl=x-fl;
00534  double dce=ce-x;
00535  if(dfl>dce) {
00536      return ce;
00537  } else if(dfl<dce) {
00538      return fl;
00539  } else {
00540      if(fmod(fl,2.0)==0.0) {       /* I imagine this holds */
00541           return fl;
00542      } else {
00543           return ce;
00544      }
00545  }
00546 }
00547 #endif
00548 
00549 static int is_zero_double(double x) {
00550  return x<DBL_MIN && x>-DBL_MIN;
00551 }
00552 
00553 static long binary_decode(const char *s) {
00554  long x=0;
00555 
00556  while(*s!=0 && (*s=='1' || *s=='0')) {
00557      x<<=1;
00558      x+=*s-'0';
00559      s++;
00560  }
00561 
00562  return x;
00563 }
00564 
00565 /* allocate new cell segment */
00566 static int alloc_cellseg(scheme *sc, int n) {
00567      cell_ptr newp;
00568      cell_ptr last;
00569      cell_ptr p;
00570      char *cp;
00571      long i;
00572      int k;
00573      int adj=ADJ;
00574 
00575      if(adj<sizeof(struct cell)) {
00576        adj=sizeof(struct cell);
00577      }
00578 
00579      for (k = 0; k < n; k++) {
00580           if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
00581                return k;
00582           cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
00583           if (cp == 0)
00584                return k;
00585       i = ++sc->last_cell_seg ;
00586       sc->alloc_seg[i] = cp;
00587       /* adjust in TYPE_BITS-bit boundary */
00588       if(((unsigned long)cp)%adj!=0) {
00589         cp=(char*)(adj*((unsigned long)cp/adj+1));
00590       }
00591         /* insert new segment in address order */
00592       newp=(cell_ptr)cp;
00593         sc->cell_seg[i] = newp;
00594         while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
00595               p = sc->cell_seg[i];
00596             sc->cell_seg[i] = sc->cell_seg[i - 1];
00597             sc->cell_seg[--i] = p;
00598         }
00599           sc->fcells += CELL_SEGSIZE;
00600         last = newp + CELL_SEGSIZE - 1;
00601           for (p = newp; p <= last; p++) {
00602                typeflag(p) = 0;
00603                cdr(p) = p + 1;
00604                car(p) = sc->NIL;
00605           }
00606         /* insert new cells in address order on free list */
00607         if (sc->free_cell == sc->NIL || p < sc->free_cell) {
00608              cdr(last) = sc->free_cell;
00609              sc->free_cell = newp;
00610         } else {
00611               p = sc->free_cell;
00612               while (cdr(p) != sc->NIL && newp > cdr(p))
00613                    p = cdr(p);
00614               cdr(last) = cdr(p);
00615               cdr(p) = newp;
00616         }
00617      }
00618      return n;
00619 }
00620 
00621 static INLINE cell_ptr get_cell_x(scheme *sc, cell_ptr a, cell_ptr b) {
00622   if (sc->free_cell != sc->NIL) {
00623     cell_ptr x = sc->free_cell;
00624     sc->free_cell = cdr(x);
00625     --sc->fcells;
00626     return (x);
00627   }
00628   return _get_cell (sc, a, b);
00629 }
00630 
00631 
00632 /* get new cell.  parameter a, b is marked by gc. */
00633 static cell_ptr _get_cell(scheme *sc, cell_ptr a, cell_ptr b) {
00634   cell_ptr x;
00635 
00636   if(sc->no_memory) {
00637     return sc->sink;
00638   }
00639 
00640   if (sc->free_cell == sc->NIL) {
00641     const int min_to_be_recovered = sc->last_cell_seg*8;
00642     gc(sc,a, b);
00643     if (sc->fcells < min_to_be_recovered
00644     || sc->free_cell == sc->NIL) {
00645       /* if only a few recovered, get more to avoid fruitless gc's */
00646       if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
00647     sc->no_memory=1;
00648     return sc->sink;
00649       }
00650     }
00651   }
00652   x = sc->free_cell;
00653   sc->free_cell = cdr(x);
00654   --sc->fcells;
00655   return (x);
00656 }
00657 
00658 /* make sure that there is a given number of cells free */
00659 static cell_ptr reserve_cells(scheme *sc, int n) {
00660     if(sc->no_memory) {
00661         return sc->NIL;
00662     }
00663 
00664     /* Are there enough cells available? */
00665     if (sc->fcells < n) {
00666         /* If not, try gc'ing some */
00667         gc(sc, sc->NIL, sc->NIL);
00668         if (sc->fcells < n) {
00669             /* If there still aren't, try getting more heap */
00670             if (!alloc_cellseg(sc,1)) {
00671                 sc->no_memory=1;
00672                 return sc->NIL;
00673             }
00674         }
00675         if (sc->fcells < n) {
00676             /* If all fail, report failure */
00677             sc->no_memory=1;
00678             return sc->NIL;
00679         }
00680     }
00681     return (sc->T);
00682 }
00683 
00684 static cell_ptr get_consecutive_cells(scheme *sc, int n) {
00685   cell_ptr x;
00686 
00687   if(sc->no_memory) { return sc->sink; }
00688 
00689   /* Are there any cells available? */
00690   x=find_consecutive_cells(sc,n);
00691   if (x != sc->NIL) { return x; }
00692 
00693   /* If not, try gc'ing some */
00694   gc(sc, sc->NIL, sc->NIL);
00695   x=find_consecutive_cells(sc,n);
00696   if (x != sc->NIL) { return x; }
00697 
00698   /* If there still aren't, try getting more heap */
00699   if (!alloc_cellseg(sc,1))
00700     {
00701       sc->no_memory=1;
00702       return sc->sink;
00703     }
00704 
00705   x=find_consecutive_cells(sc,n);
00706   if (x != sc->NIL) { return x; }
00707 
00708   /* If all fail, report failure */
00709   sc->no_memory=1;
00710   return sc->sink;
00711 }
00712 
00713 static int count_consecutive_cells(cell_ptr x, int needed) {
00714  int n=1;
00715  while(cdr(x)==x+1) {
00716      x=cdr(x);
00717      n++;
00718      if(n>needed) return n;
00719  }
00720  return n;
00721 }
00722 
00723 static cell_ptr find_consecutive_cells(scheme *sc, int n) {
00724   cell_ptr *pp;
00725   int cnt;
00726 
00727   pp=&sc->free_cell;
00728   while(*pp!=sc->NIL) {
00729     cnt=count_consecutive_cells(*pp,n);
00730     if(cnt>=n) {
00731       cell_ptr x=*pp;
00732       *pp=cdr(*pp+n-1);
00733       sc->fcells -= n;
00734       return x;
00735     }
00736     pp=&cdr(*pp+cnt-1);
00737   }
00738   return sc->NIL;
00739 }
00740 
00741 /* To retain recent allocs before interpreter knows about them -
00742    Tehom */
00743 
00744 static void push_recent_alloc(scheme *sc, cell_ptr recent, cell_ptr extra)
00745 {
00746   cell_ptr holder = get_cell_x(sc, recent, extra);
00747   typeflag(holder) = T_PAIR | T_IMMUTABLE;
00748   car(holder) = recent;
00749   cdr(holder) = car(sc->sink);
00750   car(sc->sink) = holder;
00751 }
00752 
00753 
00754 static cell_ptr get_cell(scheme *sc, cell_ptr a, cell_ptr b)
00755 {
00756   cell_ptr cell   = get_cell_x(sc, a, b);
00757   /* For right now, include "a" and "b" in "cell" so that gc doesn't
00758      think they are garbage. */
00759   /* Tentatively record it as a pair so gc understands it. */
00760   typeflag(cell) = T_PAIR;
00761   car(cell) = a;
00762   cdr(cell) = b;
00763   push_recent_alloc(sc, cell, sc->NIL);
00764   return cell;
00765 }
00766 
00767 static cell_ptr get_vector_object(scheme *sc, int len, cell_ptr init)
00768 {
00769   cell_ptr cells = get_consecutive_cells(sc,len/2+len%2+1);
00770   if(sc->no_memory) { return sc->sink; }
00771   /* Record it as a vector so that gc understands it. */
00772   typeflag(cells) = (T_VECTOR | T_ATOM);
00773   ivalue_unchecked(cells)=len;
00774   set_num_integer(cells);
00775   fill_vector(cells,init);
00776   push_recent_alloc(sc, cells, sc->NIL);
00777   return cells;
00778 }
00779 
00780 static INLINE void ok_to_freely_gc(scheme *sc)
00781 {
00782   car(sc->sink) = sc->NIL;
00783 }
00784 
00785 
00786 #if defined TSGRIND
00787 static void check_cell_alloced(cell_ptr p, int expect_alloced)
00788 {
00789   /* Can't use putstr(sc,str) because callers have no access to
00790      sc.  */
00791   if(typeflag(p) & !expect_alloced)
00792     {
00793       fprintf(stderr,"Cell is already allocated!\n");
00794     }
00795   if(!(typeflag(p)) & expect_alloced)
00796     {
00797       fprintf(stderr,"Cell is not allocated!\n");
00798     }
00799 
00800 }
00801 static void check_range_alloced(cell_ptr p, int n, int expect_alloced)
00802 {
00803   int i;
00804   for(i = 0;i<n;i++)
00805     { (void)check_cell_alloced(p+i,expect_alloced); }
00806 }
00807 
00808 #endif
00809 
00810 /* Medium level cell allocation */
00811 
00812 /* get new cons cell */
00813 cell_ptr _cons(scheme *sc, cell_ptr a, cell_ptr b, int immutable) {
00814   cell_ptr x = get_cell(sc,a, b);
00815 
00816   typeflag(x) = T_PAIR;
00817   if(immutable) {
00818     setimmutable(x);
00819   }
00820   car(x) = a;
00821   cdr(x) = b;
00822   return (x);
00823 }
00824 
00825 /* ========== oblist implementation  ========== */
00826 
00827 #ifndef USE_OBJECT_LIST
00828 
00829 static int hash_fn(const char *key, int table_size);
00830 
00831 static cell_ptr oblist_initial_value(scheme *sc)
00832 {
00833   return mk_vector(sc, 461); /* probably should be bigger */
00834 }
00835 
00836 /* returns the new symbol */
00837 static cell_ptr oblist_add_by_name(scheme *sc, const char *name)
00838 {
00839   cell_ptr x;
00840   int location;
00841 
00842   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
00843   typeflag(x) = T_SYMBOL;
00844   setimmutable(car(x));
00845 
00846   location = hash_fn(name, ivalue_unchecked(sc->oblist));
00847   set_vector_elem(sc->oblist, location,
00848                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
00849   return x;
00850 }
00851 
00852 static INLINE cell_ptr oblist_find_by_name(scheme *sc, const char *name)
00853 {
00854   int location;
00855   cell_ptr x;
00856   char *s;
00857 
00858   location = hash_fn(name, ivalue_unchecked(sc->oblist));
00859   for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
00860     s = symname(car(x));
00861     /* case-insensitive, per R5RS section 2. */
00862     if(stricmp(name, s) == 0) {
00863       return car(x);
00864     }
00865   }
00866   return sc->NIL;
00867 }
00868 
00869 static cell_ptr oblist_all_symbols(scheme *sc)
00870 {
00871   int i;
00872   cell_ptr x;
00873   cell_ptr ob_list = sc->NIL;
00874 
00875   for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
00876     for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
00877       ob_list = cons(sc, x, ob_list);
00878     }
00879   }
00880   return ob_list;
00881 }
00882 
00883 #else
00884 
00885 static cell_ptr oblist_initial_value(scheme *sc)
00886 {
00887   return sc->NIL;
00888 }
00889 
00890 static INLINE cell_ptr oblist_find_by_name(scheme *sc, const char *name)
00891 {
00892      cell_ptr x;
00893      char    *s;
00894 
00895      for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
00896         s = symname(car(x));
00897         /* case-insensitive, per R5RS section 2. */
00898         if(stricmp(name, s) == 0) {
00899           return car(x);
00900         }
00901      }
00902      return sc->NIL;
00903 }
00904 
00905 /* returns the new symbol */
00906 static cell_ptr oblist_add_by_name(scheme *sc, const char *name)
00907 {
00908   cell_ptr x;
00909 
00910   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
00911   typeflag(x) = T_SYMBOL;
00912   setimmutable(car(x));
00913   sc->oblist = immutable_cons(sc, x, sc->oblist);
00914   return x;
00915 }
00916 static cell_ptr oblist_all_symbols(scheme *sc)
00917 {
00918   return sc->oblist;
00919 }
00920 
00921 #endif
00922 
00923 static cell_ptr mk_port(scheme *sc, port *p) {
00924   cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
00925 
00926   typeflag(x) = T_PORT|T_ATOM;
00927   x->_object._port=p;
00928   return (x);
00929 }
00930 
00931 cell_ptr mk_foreign_func(scheme *sc, foreign_func f) {
00932   cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
00933 
00934   typeflag(x) = (T_FOREIGN | T_ATOM);
00935   x->_object._ff=f;
00936   return (x);
00937 }
00938 
00939 INTERFACE cell_ptr mk_character(scheme *sc, int c) {
00940   cell_ptr x = get_cell(sc,sc->NIL, sc->NIL);
00941 
00942   typeflag(x) = (T_CHARACTER | T_ATOM);
00943   ivalue_unchecked(x)= c;
00944   set_num_integer(x);
00945   return (x);
00946 }
00947 
00948 /* get number atom (integer) */
00949 INTERFACE cell_ptr mk_integer(scheme *sc, long num) {
00950   cell_ptr x = get_cell(sc,sc->NIL, sc->NIL);
00951 
00952   typeflag(x) = (T_NUMBER | T_ATOM);
00953   ivalue_unchecked(x)= num;
00954   set_num_integer(x);
00955   return (x);
00956 }
00957 
00958 INTERFACE cell_ptr mk_real(scheme *sc, double n) {
00959   cell_ptr x = get_cell(sc,sc->NIL, sc->NIL);
00960 
00961   typeflag(x) = (T_NUMBER | T_ATOM);
00962   rvalue_unchecked(x)= n;
00963   set_num_real(x);
00964   return (x);
00965 }
00966 
00967 static cell_ptr mk_number(scheme *sc, num n) {
00968  if(n.is_fixnum) {
00969      return mk_integer(sc,n.value.ivalue);
00970  } else {
00971      return mk_real(sc,n.value.rvalue);
00972  }
00973 }
00974 
00975 /* allocate name to string area */
00976 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
00977      char *q;
00978 
00979      q=(char*)sc->malloc(len_str+1);
00980      if(q==0) {
00981           sc->no_memory=1;
00982           return sc->strbuff;
00983      }
00984      if(str!=0) {
00985           snprintf(q, len_str+1, "%s", str);
00986      } else {
00987           memset(q, fill, len_str);
00988           q[len_str]=0;
00989      }
00990      return (q);
00991 }
00992 
00993 /* get new string */
00994 INTERFACE cell_ptr mk_string(scheme *sc, const char *str) {
00995      return mk_counted_string(sc,str,strlen(str));
00996 }
00997 
00998 INTERFACE cell_ptr mk_counted_string(scheme *sc, const char *str, int len) {
00999      cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
01000      typeflag(x) = (T_STRING | T_ATOM);
01001      strvalue(x) = store_string(sc,len,str,0);
01002      strlength(x) = len;
01003      return (x);
01004 }
01005 
01006 INTERFACE cell_ptr mk_empty_string(scheme *sc, int len, char fill) {
01007      cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
01008      typeflag(x) = (T_STRING | T_ATOM);
01009      strvalue(x) = store_string(sc,len,0,fill);
01010      strlength(x) = len;
01011      return (x);
01012 }
01013 
01014 INTERFACE cell_ptr mk_blackbox(scheme *sc, void *blackbox) {
01015        cell_ptr x = get_cell(sc, sc->NIL, sc->NIL);
01016        typeflag(x) = (T_BLACKBOX | T_ATOM);
01017        car(x) = blackbox;
01018        return (x);
01019 }
01020 
01021 INTERFACE static cell_ptr mk_vector(scheme *sc, int len)
01022 { return get_vector_object(sc,len,sc->NIL); }
01023 
01024 INTERFACE static void fill_vector(cell_ptr vec, cell_ptr obj) {
01025      int i;
01026      int num=ivalue(vec)/2+ivalue(vec)%2;
01027      for(i=0; i<num; i++) {
01028           typeflag(vec+1+i) = T_PAIR;
01029           setimmutable(vec+1+i);
01030           car(vec+1+i)=obj;
01031           cdr(vec+1+i)=obj;
01032      }
01033 }
01034 
01035 INTERFACE static cell_ptr vector_elem(cell_ptr vec, int ielem) {
01036      int n=ielem/2;
01037      if(ielem%2==0) {
01038           return car(vec+1+n);
01039      } else {
01040           return cdr(vec+1+n);
01041      }
01042 }
01043 
01044 INTERFACE static cell_ptr set_vector_elem(cell_ptr vec, int ielem, cell_ptr a) {
01045      int n=ielem/2;
01046      if(ielem%2==0) {
01047           return car(vec+1+n)=a;
01048      } else {
01049           return cdr(vec+1+n)=a;
01050      }
01051 }
01052 
01053 /* get new symbol */
01054 INTERFACE cell_ptr mk_symbol(scheme *sc, const char *name) {
01055      cell_ptr x;
01056 
01057      /* first check oblist */
01058      x = oblist_find_by_name(sc, name);
01059      if (x != sc->NIL) {
01060           return (x);
01061      } else {
01062           x = oblist_add_by_name(sc, name);
01063           return (x);
01064      }
01065 }
01066 
01067 INTERFACE cell_ptr gensym(scheme *sc) {
01068      cell_ptr x;
01069      char name[40];
01070 
01071      for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
01072           snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
01073 
01074           /* first check oblist */
01075           x = oblist_find_by_name(sc, name);
01076 
01077           if (x != sc->NIL) {
01078                continue;
01079           } else {
01080                x = oblist_add_by_name(sc, name);
01081                return (x);
01082           }
01083      }
01084 
01085      return sc->NIL;
01086 }
01087 
01088 /* make symbol or number atom from string */
01089 static cell_ptr mk_atom(scheme *sc, char *q) {
01090      char    c, *p;
01091      int has_dec_point=0;
01092      int has_fp_exp = 0;
01093 
01094 #if USE_COLON_HOOK
01095      if((p=strstr(q,"::"))!=0) {
01096           *p=0;
01097           return cons(sc, sc->COLON_HOOK,
01098                           cons(sc,
01099                               cons(sc,
01100                                    sc->QUOTE,
01101                                    cons(sc, mk_atom(sc,p+2), sc->NIL)),
01102                               cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
01103      }
01104 #endif
01105 
01106      p = q;
01107      c = *p++;
01108      if ((c == '+') || (c == '-')) {
01109        c = *p++;
01110        if (c == '.') {
01111          has_dec_point=1;
01112      c = *p++;
01113        }
01114        if (!isdigit(c)) {
01115      return (mk_symbol(sc, strlwr(q)));
01116        }
01117      } else if (c == '.') {
01118        has_dec_point=1;
01119        c = *p++;
01120        if (!isdigit(c)) {
01121      return (mk_symbol(sc, strlwr(q)));
01122        }
01123      } else if (!isdigit(c)) {
01124        return (mk_symbol(sc, strlwr(q)));
01125      }
01126 
01127      for ( ; (c = *p) != 0; ++p) {
01128           if (!isdigit(c)) {
01129                if(c=='.') {
01130                     if(!has_dec_point) {
01131                          has_dec_point=1;
01132                          continue;
01133                     }
01134                }
01135                else if ((c == 'e') || (c == 'E')) {
01136                        if(!has_fp_exp) {
01137                           has_dec_point = 1; /* decimal point illegal
01138                                                 from now on */
01139                           p++;
01140                           if ((*p == '-') || (*p == '+') || isdigit(*p)) {
01141                              continue;
01142                           }
01143                        }
01144                }
01145                return (mk_symbol(sc, strlwr(q)));
01146           }
01147      }
01148      if(has_dec_point) {
01149           return mk_real(sc,atof(q));
01150      }
01151      return (mk_integer(sc, atol(q)));
01152 }
01153 
01154 /* make constant */
01155 static cell_ptr mk_sharp_const(scheme *sc, char *name) {
01156      long    x;
01157      char    tmp[STRBUFFSIZE];
01158 
01159      if (!strcmp(name, "t"))
01160           return (sc->T);
01161      else if (!strcmp(name, "f"))
01162           return (sc->F);
01163      else if (*name == 'o') {/* #o (octal) */
01164           snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
01165           sscanf(tmp, "%lo", &x);
01166           return (mk_integer(sc, x));
01167      } else if (*name == 'd') {    /* #d (decimal) */
01168           sscanf(name+1, "%ld", &x);
01169           return (mk_integer(sc, x));
01170      } else if (*name == 'x') {    /* #x (hex) */
01171           snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
01172           sscanf(tmp, "%lx", &x);
01173           return (mk_integer(sc, x));
01174      } else if (*name == 'b') {    /* #b (binary) */
01175           x = binary_decode(name+1);
01176           return (mk_integer(sc, x));
01177      } else if (*name == '\\') { /* #\w (character) */
01178           int c=0;
01179           if(stricmp(name+1,"space")==0) {
01180                c=' ';
01181           } else if(stricmp(name+1,"newline")==0) {
01182                c='\n';
01183           } else if(stricmp(name+1,"return")==0) {
01184                c='\r';
01185           } else if(stricmp(name+1,"tab")==0) {
01186                c='\t';
01187      } else if(name[1]=='x' && name[2]!=0) {
01188           int c1=0;
01189           if(sscanf(name+2,"%x",&c1)==1 && c1 < UCHAR_MAX) {
01190                c=c1;
01191           } else {
01192                return sc->NIL;
01193      }
01194 #if USE_ASCII_NAMES
01195           } else if(is_ascii_name(name+1,&c)) {
01196                /* nothing */
01197 #endif
01198           } else if(name[2]==0) {
01199                c=name[1];
01200           } else {
01201                return sc->NIL;
01202           }
01203           return mk_character(sc,c);
01204      } else
01205           return (sc->NIL);
01206 }
01207 
01208 /* ========== garbage collector ========== */
01209 
01210 /*--
01211  *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
01212  *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
01213  *  for marking.
01214  */
01215 static void mark(cell_ptr a) {
01216      cell_ptr t, q, p;
01217 
01218      t = (cell_ptr) 0;
01219      p = a;
01220 E2:  setmark(p);
01221      if(is_vector(p)) {
01222           int i;
01223           int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
01224           for(i=0; i<num; i++) {
01225                /* Vector cells will be treated like ordinary cells */
01226                mark(p+1+i);
01227           }
01228      }
01229      if (is_atom(p))
01230           goto E6;
01231      /* E4: down car */
01232      q = car(p);
01233      if (q && !is_mark(q)) {
01234           setatom(p);  /* a note that we have moved car */
01235           car(p) = t;
01236           t = p;
01237           p = q;
01238           goto E2;
01239      }
01240  E5:  q = cdr(p); /* down cdr */
01241      if (q && !is_mark(q)) {
01242           cdr(p) = t;
01243           t = p;
01244           p = q;
01245           goto E2;
01246      }
01247 E6:   /* up.  Undo the link switching from steps E4 and E5. */
01248      if (!t)
01249           return;
01250      q = t;
01251      if (is_atom(q)) {
01252           clratom(q);
01253           t = car(q);
01254           car(q) = p;
01255           p = q;
01256           goto E5;
01257      } else {
01258           t = cdr(q);
01259           cdr(q) = p;
01260           p = q;
01261           goto E6;
01262      }
01263 }
01264 
01265 /* garbage collection. parameter a, b is marked. */
01266 static void gc(scheme *sc, cell_ptr a, cell_ptr b) {
01267   cell_ptr p;
01268   int i;
01269 
01270   if(sc->gc_verbose) {
01271     putstr(sc, "gc...");
01272   }
01273 
01274   /* mark system globals */
01275   mark(sc->oblist);
01276   mark(sc->global_env);
01277 
01278   /* mark current registers */
01279   mark(sc->args);
01280   mark(sc->envir);
01281   mark(sc->code);
01282   dump_stack_mark(sc);
01283   mark(sc->value);
01284   mark(sc->inport);
01285   mark(sc->save_inport);
01286   mark(sc->outport);
01287   mark(sc->loadport);
01288 
01289   /* Mark recent objects the interpreter doesn't know about yet. */
01290   mark(car(sc->sink));
01291   /* Mark any older stuff above nested C calls */
01292   mark(sc->c_nest);
01293 
01294   /* mark variables a, b */
01295   mark(a);
01296   mark(b);
01297 
01298   /* garbage collect */
01299   clrmark(sc->NIL);
01300   sc->fcells = 0;
01301   sc->free_cell = sc->NIL;
01302   /* free-list is kept sorted by address so as to maintain consecutive
01303      ranges, if possible, for use with vectors. Here we scan the cells
01304      (which are also kept sorted by address) downwards to build the
01305      free-list in sorted order.
01306   */
01307   for (i = sc->last_cell_seg; i >= 0; i--) {
01308     p = sc->cell_seg[i] + CELL_SEGSIZE;
01309     while (--p >= sc->cell_seg[i]) {
01310       if (is_mark(p)) {
01311     clrmark(p);
01312       } else {
01313     /* reclaim cell */
01314         if (typeflag(p) != 0) {
01315           finalize_cell(sc, p);
01316           typeflag(p) = 0;
01317           car(p) = sc->NIL;
01318         }
01319         ++sc->fcells;
01320         cdr(p) = sc->free_cell;
01321         sc->free_cell = p;
01322       }
01323     }
01324   }
01325 
01326   if (sc->gc_verbose) {
01327     char msg[80];
01328     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
01329     putstr(sc,msg);
01330   }
01331 }
01332 
01333 static void finalize_cell(scheme *sc, cell_ptr a) {
01334   if(is_string(a)) {
01335     sc->free(strvalue(a));
01336   } else if(is_port(a)) {
01337     if(a->_object._port->kind&port_file
01338        && a->_object._port->rep.stdio.closeit) {
01339       port_close(sc,a,port_input|port_output);
01340     }
01341     sc->free(a->_object._port);
01342   } else if(is_blackbox(a)) {
01343          finalize_blackbox(car(a));
01344   }
01345 }
01346 
01347 /* ========== Routines for Reading ========== */
01348 
01349 static int file_push(scheme *sc, const char *fname) {
01350   FILE *fin = NULL;
01351 
01352   if (sc->file_i == MAXFIL-1)
01353      return 0;
01354   fin=fopen(fname,"r");
01355   if(fin!=0) {
01356     sc->file_i++;
01357     sc->load_stack[sc->file_i].kind=port_file|port_input;
01358     sc->load_stack[sc->file_i].rep.stdio.file=fin;
01359     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
01360     sc->nesting_stack[sc->file_i]=0;
01361     sc->loadport->_object._port=sc->load_stack+sc->file_i;
01362 
01363 #if SHOW_ERROR_LINE
01364     sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
01365     if(fname)
01366       sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
01367 #endif
01368 
01369   }
01370   return fin!=0;
01371 }
01372 
01373 static void file_pop(scheme *sc) {
01374  if(sc->file_i != 0) {
01375    sc->nesting=sc->nesting_stack[sc->file_i];
01376    port_close(sc,sc->loadport,port_input);
01377    sc->file_i--;
01378    sc->loadport->_object._port=sc->load_stack+sc->file_i;
01379  }
01380 }
01381 
01382 static int file_interactive(scheme *sc) {
01383  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
01384      && sc->inport->_object._port->kind&port_file;
01385 }
01386 
01387 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
01388   FILE *f;
01389   char *rw;
01390   port *pt;
01391   if(prop==(port_input|port_output)) {
01392     rw="a+";
01393   } else if(prop==port_output) {
01394     rw="w";
01395   } else {
01396     rw="r";
01397   }
01398   f=fopen(fn,rw);
01399   if(f==0) {
01400     return 0;
01401   }
01402   pt=port_rep_from_file(sc,f,prop);
01403   pt->rep.stdio.closeit=1;
01404 
01405 #if SHOW_ERROR_LINE
01406   if(fn)
01407     pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
01408 
01409   pt->rep.stdio.curr_line = 0;
01410 #endif
01411   return pt;
01412 }
01413 
01414 static cell_ptr port_from_filename(scheme *sc, const char *fn, int prop) {
01415   port *pt;
01416   pt=port_rep_from_filename(sc,fn,prop);
01417   if(pt==0) {
01418     return sc->NIL;
01419   }
01420   return mk_port(sc,pt);
01421 }
01422 
01423 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
01424 {
01425     port *pt;
01426 
01427     pt = (port *)sc->malloc(sizeof *pt);
01428     if (pt == NULL) {
01429         return NULL;
01430     }
01431     pt->kind = port_file | prop;
01432     pt->rep.stdio.file = f;
01433     pt->rep.stdio.closeit = 0;
01434     return pt;
01435 }
01436 
01437 static cell_ptr port_from_file(scheme *sc, FILE *f, int prop) {
01438   port *pt;
01439   pt=port_rep_from_file(sc,f,prop);
01440   if(pt==0) {
01441     return sc->NIL;
01442   }
01443   return mk_port(sc,pt);
01444 }
01445 
01446 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
01447   port *pt;
01448   pt=(port*)sc->malloc(sizeof(port));
01449   if(pt==0) {
01450     return 0;
01451   }
01452   pt->kind=port_string|prop;
01453   pt->rep.string.start=start;
01454   pt->rep.string.curr=start;
01455   pt->rep.string.past_the_end=past_the_end;
01456   return pt;
01457 }
01458 
01459 static cell_ptr port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
01460   port *pt;
01461   pt=port_rep_from_string(sc,start,past_the_end,prop);
01462   if(pt==0) {
01463     return sc->NIL;
01464   }
01465   return mk_port(sc,pt);
01466 }
01467 
01468 #define BLOCK_SIZE 256
01469 
01470 static port *port_rep_from_scratch(scheme *sc) {
01471   port *pt;
01472   char *start;
01473   pt=(port*)sc->malloc(sizeof(port));
01474   if(pt==0) {
01475     return 0;
01476   }
01477   start=sc->malloc(BLOCK_SIZE);
01478   if(start==0) {
01479     return 0;
01480   }
01481   memset(start,' ',BLOCK_SIZE-1);
01482   start[BLOCK_SIZE-1]='\0';
01483   pt->kind=port_string|port_output|port_srfi6;
01484   pt->rep.string.start=start;
01485   pt->rep.string.curr=start;
01486   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
01487   return pt;
01488 }
01489 
01490 static cell_ptr port_from_scratch(scheme *sc) {
01491   port *pt;
01492   pt=port_rep_from_scratch(sc);
01493   if(pt==0) {
01494     return sc->NIL;
01495   }
01496   return mk_port(sc,pt);
01497 }
01498 
01499 static void port_close(scheme *sc, cell_ptr p, int flag) {
01500   port *pt=p->_object._port;
01501   pt->kind&=~flag;
01502   if((pt->kind & (port_input|port_output))==0) {
01503     if(pt->kind&port_file) {
01504 
01505 #if SHOW_ERROR_LINE
01506       /* Cleanup is here so (close-*-port) functions could work too */
01507       pt->rep.stdio.curr_line = 0;
01508 
01509       if(pt->rep.stdio.filename)
01510         sc->free(pt->rep.stdio.filename);
01511 #endif
01512 
01513       fclose(pt->rep.stdio.file);
01514     }
01515     pt->kind=port_free;
01516   }
01517 }
01518 
01519 /* get new character from input file */
01520 static int inchar(scheme *sc) {
01521   int c;
01522   port *pt;
01523 
01524   pt = sc->inport->_object._port;
01525   if(pt->kind & port_saw_EOF)
01526     { return EOF; }
01527   c = basic_inchar(pt);
01528   if(c == EOF && sc->inport == sc->loadport) {
01529     /* Instead, set port_saw_EOF */
01530     pt->kind |= port_saw_EOF;
01531 
01532     /* file_pop(sc); */
01533     return EOF;
01534     /* NOTREACHED */
01535   }
01536   return c;
01537 }
01538 
01539 static int basic_inchar(port *pt) {
01540   if(pt->kind & port_file) {
01541     return fgetc(pt->rep.stdio.file);
01542   } else {
01543     if(*pt->rep.string.curr == 0 ||
01544        pt->rep.string.curr == pt->rep.string.past_the_end) {
01545       return EOF;
01546     } else {
01547       return *pt->rep.string.curr++;
01548     }
01549   }
01550 }
01551 
01552 /* back character to input buffer */
01553 static void backchar(scheme *sc, int c) {
01554   port *pt;
01555   if(c==EOF) return;
01556   pt=sc->inport->_object._port;
01557   if(pt->kind&port_file) {
01558     ungetc(c,pt->rep.stdio.file);
01559   } else {
01560     if(pt->rep.string.curr!=pt->rep.string.start) {
01561       --pt->rep.string.curr;
01562     }
01563   }
01564 }
01565 
01566 static int realloc_port_string(scheme *sc, port *p)
01567 {
01568   char *start=p->rep.string.start;
01569   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
01570   char *str=sc->malloc(new_size);
01571   if(str) {
01572     memset(str,' ',new_size-1);
01573     str[new_size-1]='\0';
01574     strcpy(str,start);
01575     p->rep.string.start=str;
01576     p->rep.string.past_the_end=str+new_size-1;
01577     p->rep.string.curr-=start-str;
01578     sc->free(start);
01579     return 1;
01580   } else {
01581     return 0;
01582   }
01583 }
01584 
01585 INTERFACE void putstr(scheme *sc, const char *s) {
01586   port *pt=sc->outport->_object._port;
01587   if(pt->kind&port_file) {
01588     fputs(s,pt->rep.stdio.file);
01589   } else {
01590     for(;*s;s++) {
01591       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
01592       *pt->rep.string.curr++=*s;
01593       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
01594       *pt->rep.string.curr++=*s;
01595       }
01596     }
01597   }
01598 }
01599 
01600 static void putchars(scheme *sc, const char *s, int len) {
01601   port *pt=sc->outport->_object._port;
01602   if(pt->kind&port_file) {
01603     fwrite(s,1,len,pt->rep.stdio.file);
01604   } else {
01605     for(;len;len--) {
01606       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
01607     *pt->rep.string.curr++=*s++;
01608       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
01609       *pt->rep.string.curr++=*s++;
01610       }
01611     }
01612   }
01613 }
01614 
01615 INTERFACE void putcharacter(scheme *sc, int c) {
01616   port *pt=sc->outport->_object._port;
01617   if(pt->kind&port_file) {
01618     fputc(c,pt->rep.stdio.file);
01619   } else {
01620     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
01621       *pt->rep.string.curr++=c;
01622     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
01623         *pt->rep.string.curr++=c;
01624     }
01625   }
01626 }
01627 
01628 /* read characters up to delimiter, but cater to character constants */
01629 static char *readstr_upto(scheme *sc, char *delim) {
01630   char *p = sc->strbuff;
01631 
01632   while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
01633          !is_one_of(delim, (*p++ = inchar(sc))));
01634 
01635   if(p == sc->strbuff+2 && p[-2] == '\\') {
01636     *p=0;
01637   } else {
01638     backchar(sc,p[-1]);
01639     *--p = '\0';
01640   }
01641   return sc->strbuff;
01642 }
01643 
01644 /* read string expression "xxx...xxx" */
01645 static cell_ptr readstrexp(scheme *sc) {
01646   char *p = sc->strbuff;
01647   int c;
01648   int c1=0;
01649   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
01650 
01651   for (;;) {
01652     c=inchar(sc);
01653     if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
01654       return sc->F;
01655     }
01656     switch(state) {
01657         case st_ok:
01658             switch(c) {
01659                 case '\\':
01660                     state=st_bsl;
01661                     break;
01662                 case '"':
01663                     *p=0;
01664                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
01665                 default:
01666                     *p++=c;
01667                     break;
01668             }
01669             break;
01670         case st_bsl:
01671             switch(c) {
01672                 case '0':
01673                 case '1':
01674                 case '2':
01675                 case '3':
01676                 case '4':
01677                 case '5':
01678                 case '6':
01679                 case '7':
01680                         state=st_oct1;
01681                         c1=c-'0';
01682                         break;
01683                 case 'x':
01684                 case 'X':
01685                     state=st_x1;
01686                     c1=0;
01687                     break;
01688                 case 'n':
01689                     *p++='\n';
01690                     state=st_ok;
01691                     break;
01692                 case 't':
01693                     *p++='\t';
01694                     state=st_ok;
01695                     break;
01696                 case 'r':
01697                     *p++='\r';
01698                     state=st_ok;
01699                     break;
01700                 case '"':
01701                     *p++='"';
01702                     state=st_ok;
01703                     break;
01704                 default:
01705                     *p++=c;
01706                     state=st_ok;
01707                     break;
01708             }
01709             break;
01710         case st_x1:
01711         case st_x2:
01712             c=toupper(c);
01713             if(c>='0' && c<='F') {
01714                 if(c<='9') {
01715                     c1=(c1<<4)+c-'0';
01716                 } else {
01717                     c1=(c1<<4)+c-'A'+10;
01718                 }
01719                 if(state==st_x1) {
01720                     state=st_x2;
01721                 } else {
01722                     *p++=c1;
01723                     state=st_ok;
01724                 }
01725             } else {
01726                 return sc->F;
01727             }
01728             break;
01729         case st_oct1:
01730         case st_oct2:
01731             if (c < '0' || c > '7')
01732             {
01733                    *p++=c1;
01734                    backchar(sc, c);
01735                    state=st_ok;
01736             }
01737             else
01738             {
01739                 if (state==st_oct2 && c1 >= 32)
01740                     return sc->F;
01741 
01742                    c1=(c1<<3)+(c-'0');
01743 
01744                 if (state == st_oct1)
01745                         state=st_oct2;
01746                 else
01747                 {
01748                         *p++=c1;
01749                         state=st_ok;
01750                    }
01751             }
01752             break;
01753 
01754     }
01755   }
01756 }
01757 
01758 /* check c is in chars */
01759 static INLINE int is_one_of(char *s, int c) {
01760      if(c==EOF) return 1;
01761      while (*s)
01762           if (*s++ == c)
01763                return (1);
01764      return (0);
01765 }
01766 
01767 /* skip white characters */
01768 static INLINE int skipspace(scheme *sc) {
01769      int c = 0, curr_line = 0;
01770 
01771      do {
01772          c=inchar(sc);
01773 #if SHOW_ERROR_LINE
01774          if(c=='\n')
01775            curr_line++;
01776 #endif
01777      } while (isspace(c));
01778 
01779 /* record it */
01780 #if SHOW_ERROR_LINE
01781      sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
01782 #endif
01783 
01784      if(c!=EOF) {
01785           backchar(sc,c);
01786       return 1;
01787      }
01788      else
01789        { return EOF; }
01790 }
01791 
01792 /* get token */
01793 static int token(scheme *sc) {
01794      int c;
01795      c = skipspace(sc);
01796      if(c == EOF) { return (TOK_EOF); }
01797      switch (c=inchar(sc)) {
01798      case EOF:
01799           return (TOK_EOF);
01800      case '(':
01801           return (TOK_LPAREN);
01802      case ')':
01803           return (TOK_RPAREN);
01804      case '.':
01805           c=inchar(sc);
01806           if(is_one_of(" \n\t",c)) {
01807                return (TOK_DOT);
01808           } else {
01809                backchar(sc,c);
01810            backchar(sc,'.');
01811                return TOK_ATOM;
01812           }
01813      case '\'':
01814           return (TOK_QUOTE);
01815      case ';':
01816            while ((c=inchar(sc)) != '\n' && c!=EOF)
01817              ;
01818 
01819 #if SHOW_ERROR_LINE
01820            if(c == '\n')
01821              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
01822 #endif
01823 
01824        if(c == EOF)
01825          { return (TOK_EOF); }
01826        else
01827          { return (token(sc));}
01828      case '"':
01829           return (TOK_DQUOTE);
01830      case BACKQUOTE:
01831           return (TOK_BQUOTE);
01832      case ',':
01833          if ((c=inchar(sc)) == '@') {
01834                return (TOK_ATMARK);
01835          } else {
01836                backchar(sc,c);
01837                return (TOK_COMMA);
01838          }
01839      case '#':
01840           c=inchar(sc);
01841           if (c == '(') {
01842                return (TOK_VEC);
01843           } else if(c == '!') {
01844                while ((c=inchar(sc)) != '\n' && c!=EOF)
01845                    ;
01846 
01847 #if SHOW_ERROR_LINE
01848            if(c == '\n')
01849              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
01850 #endif
01851 
01852            if(c == EOF)
01853          { return (TOK_EOF); }
01854            else
01855          { return (token(sc));}
01856           } else {
01857                backchar(sc,c);
01858                if(is_one_of(" tfodxb\\",c)) {
01859                     return TOK_SHARP_CONST;
01860                } else {
01861                     return (TOK_SHARP);
01862                }
01863           }
01864      default:
01865           backchar(sc,c);
01866           return (TOK_ATOM);
01867      }
01868 }
01869 
01870 /* ========== Routines for Printing ========== */
01871 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
01872 
01873 static void printslashstring(scheme *sc, char *p, int len) {
01874   int i;
01875   unsigned char *s=(unsigned char*)p;
01876   putcharacter(sc,'"');
01877   for ( i=0; i<len; i++) {
01878     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
01879       putcharacter(sc,'\\');
01880       switch(*s) {
01881       case '"':
01882     putcharacter(sc,'"');
01883     break;
01884       case '\n':
01885     putcharacter(sc,'n');
01886     break;
01887       case '\t':
01888     putcharacter(sc,'t');
01889     break;
01890       case '\r':
01891     putcharacter(sc,'r');
01892     break;
01893       case '\\':
01894     putcharacter(sc,'\\');
01895     break;
01896       default: {
01897       int d=*s/16;
01898       putcharacter(sc,'x');
01899       if(d<10) {
01900         putcharacter(sc,d+'0');
01901       } else {
01902         putcharacter(sc,d-10+'A');
01903       }
01904       d=*s%16;
01905       if(d<10) {
01906         putcharacter(sc,d+'0');
01907       } else {
01908         putcharacter(sc,d-10+'A');
01909       }
01910     }
01911       }
01912     } else {
01913       putcharacter(sc,*s);
01914     }
01915     s++;
01916   }
01917   putcharacter(sc,'"');
01918 }
01919 
01920 
01921 /* print atoms */
01922 static void printatom(scheme *sc, cell_ptr l, int f) {
01923   char *p;
01924   int len;
01925   atom2str(sc,l,f,&p,&len);
01926   putchars(sc,p,len);
01927 }
01928 
01929 
01930 /* Uses internal buffer unless string pointer is already available */
01931 static void atom2str(scheme *sc, cell_ptr l, int f, char **pp, int *plen) {
01932      char *p;
01933 
01934      if (l == sc->NIL) {
01935           p = "()";
01936      } else if (l == sc->T) {
01937           p = "#t";
01938      } else if (l == sc->F) {
01939           p = "#f";
01940      } else if (l == sc->EOF_OBJ) {
01941           p = "#<EOF>";
01942      } else if (is_port(l)) {
01943           p = sc->strbuff;
01944           snprintf(p, STRBUFFSIZE, "#<PORT>");
01945      } else if (is_number(l)) {
01946           p = sc->strbuff;
01947           if(num_is_integer(l)) {
01948         snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
01949           } else {
01950                snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
01951           }
01952      } else if (is_string(l)) {
01953           if (!f) {
01954                p = strvalue(l);
01955           } else { /* Hack, uses the fact that printing is needed */
01956                *pp=sc->strbuff;
01957            *plen=0;
01958                printslashstring(sc, strvalue(l), strlength(l));
01959            return;
01960           }
01961      } else if (is_character(l)) {
01962           int c=charvalue(l);
01963           p = sc->strbuff;
01964           if (!f) {
01965                p[0]=c;
01966                p[1]=0;
01967           } else {
01968                switch(c) {
01969                case ' ':
01970                     snprintf(p,STRBUFFSIZE,"#\\space"); break;
01971                case '\n':
01972                     snprintf(p,STRBUFFSIZE,"#\\newline"); break;
01973                case '\r':
01974                     snprintf(p,STRBUFFSIZE,"#\\return"); break;
01975                case '\t':
01976                     snprintf(p,STRBUFFSIZE,"#\\tab"); break;
01977                default:
01978 #if USE_ASCII_NAMES
01979                     if(c==127) {
01980                          snprintf(p,STRBUFFSIZE, "#\\del");
01981              break;
01982                     } else if(c<32) {
01983                          snprintf(p, STRBUFFSIZE, "#\\%s", charnames[c]);
01984              break;
01985                     }
01986 #else
01987             if(c<32) {
01988               snprintf(p,STRBUFFSIZE,"#\\x%x",c); break;
01989           break;
01990             }
01991 #endif
01992                     snprintf(p,STRBUFFSIZE,"#\\%c",c); break;
01993             break;
01994                }
01995           }
01996      } else if (is_symbol(l)) {
01997           p = symname(l);
01998      } else if (is_proc(l)) {
01999           p = sc->strbuff;
02000           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
02001      } else if (is_macro(l)) {
02002           p = "#<MACRO>";
02003      } else if (is_closure(l)) {
02004           p = "#<CLOSURE>";
02005      } else if (is_promise(l)) {
02006           p = "#<PROMISE>";
02007      } else if (is_foreign(l)) {
02008           p = sc->strbuff;
02009           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
02010      } else if (is_continuation(l)) {
02011           p = "#<CONTINUATION>";
02012      } else if (is_blackbox(l)) {
02013                p = "#<BLACKBOX>";
02014      } else {
02015           p = "#<ERROR>";
02016      }
02017      *pp=p;
02018      *plen=strlen(p);
02019 }
02020 /* ========== Routines for Evaluation Cycle ========== */
02021 
02022 /* make closure. c is code. e is environment */
02023 static cell_ptr mk_closure(scheme *sc, cell_ptr c, cell_ptr e) {
02024      cell_ptr x = get_cell(sc, c, e);
02025 
02026      typeflag(x) = T_CLOSURE;
02027      car(x) = c;
02028      cdr(x) = e;
02029      return (x);
02030 }
02031 
02032 /* make continuation. */
02033 static cell_ptr mk_continuation(scheme *sc, cell_ptr d) {
02034      cell_ptr x = get_cell(sc, sc->NIL, d);
02035 
02036      typeflag(x) = T_CONTINUATION;
02037      cont_dump(x) = d;
02038      return (x);
02039 }
02040 
02041 static cell_ptr list_star(scheme *sc, cell_ptr d) {
02042   cell_ptr p, q;
02043   if(cdr(d)==sc->NIL) {
02044     return car(d);
02045   }
02046   p=cons(sc,car(d),cdr(d));
02047   q=p;
02048   while(cdr(cdr(p))!=sc->NIL) {
02049     d=cons(sc,car(p),cdr(p));
02050     if(cdr(cdr(p))!=sc->NIL) {
02051       p=cdr(d);
02052     }
02053   }
02054   cdr(p)=car(cdr(p));
02055   return q;
02056 }
02057 
02058 /* reverse list -- produce new list */
02059 static cell_ptr reverse(scheme *sc, cell_ptr a) {
02060 /* a must be checked by gc */
02061      cell_ptr p = sc->NIL;
02062 
02063      for ( ; is_pair(a); a = cdr(a)) {
02064           p = cons(sc, car(a), p);
02065      }
02066      return (p);
02067 }
02068 
02069 /* reverse list --- in-place */
02070 static cell_ptr reverse_in_place(scheme *sc, cell_ptr term, cell_ptr list) {
02071      cell_ptr p = list, result = term, q;
02072 
02073      while (p != sc->NIL) {
02074           q = cdr(p);
02075           cdr(p) = result;
02076           result = p;
02077           p = q;
02078      }
02079      return (result);
02080 }
02081 
02082 /* append list -- produce new list */
02083 static cell_ptr append(scheme *sc, cell_ptr a, cell_ptr b) {
02084      cell_ptr p = b, q;
02085 
02086      if (a != sc->NIL) {
02087           a = reverse(sc, a);
02088           while (a != sc->NIL) {
02089                q = cdr(a);
02090                cdr(a) = p;
02091                p = a;
02092                a = q;
02093           }
02094      }
02095      return (p);
02096 }
02097 
02098 /* equivalence of atoms */
02099 int eqv(cell_ptr a, cell_ptr b) {
02100      if (is_string(a)) {
02101           if (is_string(b))
02102                return (strvalue(a) == strvalue(b));
02103           else
02104                return (0);
02105      } else if (is_number(a)) {
02106           if (is_number(b)) {
02107                if (num_is_integer(a) == num_is_integer(b))
02108                     return num_eq(nvalue(a),nvalue(b));
02109           }
02110           return (0);
02111      } else if (is_character(a)) {
02112           if (is_character(b))
02113                return charvalue(a)==charvalue(b);
02114           else
02115                return (0);
02116      } else if (is_port(a)) {
02117           if (is_port(b))
02118                return a==b;
02119           else
02120                return (0);
02121      } else if (is_proc(a)) {
02122           if (is_proc(b))
02123                return procnum(a)==procnum(b);
02124           else
02125                return (0);
02126      } else {
02127           return (a == b);
02128      }
02129 }
02130 
02131 /* true or false value macro */
02132 /* () is #t in R5RS */
02133 #define is_true(p)       ((p) != sc->F)
02134 #define is_false(p)      ((p) == sc->F)
02135 
02136 /* ========== Environment implementation  ========== */
02137 
02138 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
02139 
02140 static int hash_fn(const char *key, int table_size)
02141 {
02142   unsigned int hashed = 0;
02143   const char *c;
02144   int bits_per_int = sizeof(unsigned int)*8;
02145 
02146   for (c = key; *c; c++) {
02147     /* letters have about 5 bits in them */
02148     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
02149     hashed ^= *c;
02150   }
02151   return hashed % table_size;
02152 }
02153 #endif
02154 
02155 #ifndef USE_ALIST_ENV
02156 
02157 /*
02158  * In this implementation, each frame of the environment may be
02159  * a hash table: a vector of alists hashed by variable name.
02160  * In practice, we use a vector only for the initial frame;
02161  * subsequent frames are too small and transient for the lookup
02162  * speed to out-weigh the cost of making a new vector.
02163  */
02164 
02165 static void new_frame_in_env(scheme *sc, cell_ptr old_env)
02166 {
02167   cell_ptr new_frame;
02168 
02169   /* The interaction-environment has about 300 variables in it. */
02170   if (old_env == sc->NIL) {
02171     new_frame = mk_vector(sc, 461);
02172   } else {
02173     new_frame = sc->NIL;
02174   }
02175 
02176   sc->envir = immutable_cons(sc, new_frame, old_env);
02177   setenvironment(sc->envir);
02178 }
02179 
02180 static INLINE void new_slot_spec_in_env(scheme *sc, cell_ptr env,
02181                                         cell_ptr variable, cell_ptr value)
02182 {
02183   cell_ptr slot = immutable_cons(sc, variable, value);
02184 
02185   if (is_vector(car(env))) {
02186     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
02187 
02188     set_vector_elem(car(env), location,
02189                     immutable_cons(sc, slot, vector_elem(car(env), location)));
02190   } else {
02191     car(env) = immutable_cons(sc, slot, car(env));
02192   }
02193 }
02194 
02195 static cell_ptr find_slot_in_env(scheme *sc, cell_ptr env, cell_ptr hdl, int all)
02196 {
02197   cell_ptr x,y;
02198   int location;
02199 
02200   for (x = env; x != sc->NIL; x = cdr(x)) {
02201     if (is_vector(car(x))) {
02202       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
02203       y = vector_elem(car(x), location);
02204     } else {
02205       y = car(x);
02206     }
02207     for ( ; y != sc->NIL; y = cdr(y)) {
02208               if (caar(y) == hdl) {
02209                    break;
02210               }
02211          }
02212          if (y != sc->NIL) {
02213               break;
02214          }
02215          if(!all) {
02216            return sc->NIL;
02217          }
02218     }
02219     if (x != sc->NIL) {
02220           return car(y);
02221     }
02222     return sc->NIL;
02223 }
02224 
02225 #else /* USE_ALIST_ENV */
02226 
02227 static INLINE void new_frame_in_env(scheme *sc, cell_ptr old_env)
02228 {
02229   sc->envir = immutable_cons(sc, sc->NIL, old_env);
02230   setenvironment(sc->envir);
02231 }
02232 
02233 static INLINE void new_slot_spec_in_env(scheme *sc, cell_ptr env,
02234                                         cell_ptr variable, cell_ptr value)
02235 {
02236   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
02237 }
02238 
02239 static cell_ptr find_slot_in_env(scheme *sc, cell_ptr env, cell_ptr hdl, int all)
02240 {
02241     cell_ptr x,y;
02242     for (x = env; x != sc->NIL; x = cdr(x)) {
02243          for (y = car(x); y != sc->NIL; y = cdr(y)) {
02244               if (caar(y) == hdl) {
02245                    break;
02246               }
02247          }
02248          if (y != sc->NIL) {
02249               break;
02250          }
02251          if(!all) {
02252            return sc->NIL;
02253          }
02254     }
02255     if (x != sc->NIL) {
02256           return car(y);
02257     }
02258     return sc->NIL;
02259 }
02260 
02261 #endif /* USE_ALIST_ENV else */
02262 
02263 static INLINE void new_slot_in_env(scheme *sc, cell_ptr variable, cell_ptr value)
02264 {
02265   new_slot_spec_in_env(sc, sc->envir, variable, value);
02266 }
02267 
02268 static INLINE void set_slot_in_env(scheme *sc, cell_ptr slot, cell_ptr value)
02269 {
02270   cdr(slot) = value;
02271 }
02272 
02273 static INLINE cell_ptr slot_value_in_env(cell_ptr slot)
02274 {
02275   return cdr(slot);
02276 }
02277 
02278 /* ========== Evaluation Cycle ========== */
02279 
02280 
02281 static cell_ptr _Error_1(scheme *sc, const char *s, cell_ptr a) {
02282 #if SHOW_ERROR_LINE
02283      const char *str = s;
02284      char sbuf[STRBUFFSIZE];
02285 
02286      /* make sure error is not in REPL */
02287      if(sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
02288        int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
02289        const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
02290 
02291        /* should never happen */
02292        if(!fname) fname = "<unknown>";
02293 
02294        /* we started from 0 */
02295        ln++;
02296        snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
02297 
02298        str = (const char*)sbuf;
02299      }
02300 #else
02301      const char *str = s;
02302 #endif
02303 
02304 #if USE_ERROR_HOOK
02305      cell_ptr x;
02306      cell_ptr hdl=sc->ERROR_HOOK;
02307 
02308      x=find_slot_in_env(sc,sc->envir,hdl,1);
02309     if (x != sc->NIL) {
02310          if(a!=0) {
02311                sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
02312          } else {
02313                sc->code = sc->NIL;
02314          }
02315          sc->code = cons(sc, mk_string(sc, str), sc->code);
02316          setimmutable(car(sc->code));
02317          sc->code = cons(sc, slot_value_in_env(x), sc->code);
02318          sc->op = (int)OP_EVAL;
02319          return sc->T;
02320     }
02321 #endif
02322 
02323     if(a!=0) {
02324           sc->args = cons(sc, (a), sc->NIL);
02325     } else {
02326           sc->args = sc->NIL;
02327     }
02328     sc->args = cons(sc, mk_string(sc, str), sc->args);
02329     setimmutable(car(sc->args));
02330     sc->op = (int)OP_ERR0;
02331     return sc->T;
02332 }
02333 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
02334 #define Error_0(sc,s)    return _Error_1(sc,s,0)
02335 
02336 /* Too small to turn into function */
02337 # define  BEGIN     do {
02338 # define  END  } while (0)
02339 #define s_goto(sc,a) BEGIN                                  \
02340     sc->op = (int)(a);                                      \
02341     return sc->T; END
02342 
02343 #define s_return(sc,a) return _s_return(sc,a)
02344 
02345 #ifndef USE_SCHEME_STACK
02346 
02347 /* this structure holds all the interpreter's registers */
02348 struct dump_stack_frame {
02349   enum scheme_opcodes op;
02350   cell_ptr args;
02351   cell_ptr envir;
02352   cell_ptr code;
02353 };
02354 
02355 #define STACK_GROWTH 3
02356 
02357 static void s_save(scheme *sc, enum scheme_opcodes op, cell_ptr args, cell_ptr code)
02358 {
02359   int nframes = (int)sc->dump;
02360   struct dump_stack_frame *next_frame;
02361 
02362   /* enough room for the next frame? */
02363   if (nframes >= sc->dump_size) {
02364     sc->dump_size += STACK_GROWTH;
02365     /* alas there is no sc->realloc */
02366     sc->dump_base = realloc(sc->dump_base,
02367                             sizeof(struct dump_stack_frame) * sc->dump_size);
02368   }
02369   next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
02370   next_frame->op = op;
02371   next_frame->args = args;
02372   next_frame->envir = sc->envir;
02373   next_frame->code = code;
02374   sc->dump = (cell_ptr)(nframes+1);
02375 }
02376 
02377 static cell_ptr _s_return(scheme *sc, cell_ptr a)
02378 {
02379   int nframes = (int)sc->dump;
02380   struct dump_stack_frame *frame;
02381 
02382   sc->value = (a);
02383   if (nframes <= 0) {
02384     return sc->NIL;
02385   }
02386   nframes--;
02387   frame = (struct dump_stack_frame *)sc->dump_base + nframes;
02388   sc->op = frame->op;
02389   sc->args = frame->args;
02390   sc->envir = frame->envir;
02391   sc->code = frame->code;
02392   sc->dump = (cell_ptr)nframes;
02393   return sc->T;
02394 }
02395 
02396 static INLINE void dump_stack_reset(scheme *sc)
02397 {
02398   /* in this implementation, sc->dump is the number of frames on the stack */
02399   sc->dump = (cell_ptr)0;
02400 }
02401 
02402 static INLINE void dump_stack_initialize(scheme *sc)
02403 {
02404   sc->dump_size = 0;
02405   sc->dump_base = NULL;
02406   dump_stack_reset(sc);
02407 }
02408 
02409 static void dump_stack_free(scheme *sc)
02410 {
02411   free(sc->dump_base);
02412   sc->dump_base = NULL;
02413   sc->dump = (cell_ptr)0;
02414   sc->dump_size = 0;
02415 }
02416 
02417 static INLINE void dump_stack_mark(scheme *sc)
02418 {
02419   int nframes = (int)sc->dump;
02420   int i;
02421   for(i=0; i<nframes; i++) {
02422     struct dump_stack_frame *frame;
02423     frame = (struct dump_stack_frame *)sc->dump_base + i;
02424     mark(frame->args);
02425     mark(frame->envir);
02426     mark(frame->code);
02427   }
02428 }
02429 
02430 #else
02431 
02432 static INLINE void dump_stack_reset(scheme *sc)
02433 {
02434   sc->dump = sc->NIL;
02435 }
02436 
02437 static INLINE void dump_stack_initialize(scheme *sc)
02438 {
02439   dump_stack_reset(sc);
02440 }
02441 
02442 static void dump_stack_free(scheme *sc)
02443 {
02444   sc->dump = sc->NIL;
02445 }
02446 
02447 static cell_ptr _s_return(scheme *sc, cell_ptr a) {
02448     sc->value = (a);
02449     if(sc->dump==sc->NIL) return sc->NIL;
02450     sc->op = ivalue(car(sc->dump));
02451     sc->args = cadr(sc->dump);
02452     sc->envir = caddr(sc->dump);
02453     sc->code = cadddr(sc->dump);
02454     sc->dump = cddddr(sc->dump);
02455     return sc->T;
02456 }
02457 
02458 static void s_save(scheme *sc, enum scheme_opcodes op, cell_ptr args, cell_ptr code) {
02459     sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
02460     sc->dump = cons(sc, (args), sc->dump);
02461     sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
02462 }
02463 
02464 static INLINE void dump_stack_mark(scheme *sc)
02465 {
02466   mark(sc->dump);
02467 }
02468 #endif
02469 
02470 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
02471 
02472 static cell_ptr opexe_0(scheme *sc, enum scheme_opcodes op) {
02473      cell_ptr x, y;
02474 
02475      switch (op) {
02476      case OP_LOAD:       /* load */
02477           if(file_interactive(sc)) {
02478                fprintf(sc->outport->_object._port->rep.stdio.file,
02479                "Loading %s\n", strvalue(car(sc->args)));
02480           }
02481           if (!file_push(sc,strvalue(car(sc->args)))) {
02482                Error_1(sc,"unable to open", car(sc->args));
02483           }
02484       else
02485         {
02486           sc->args = mk_integer(sc,sc->file_i);
02487           s_goto(sc,OP_T0LVL);
02488         }
02489 
02490      case OP_T0LVL: /* top level */
02491        /* If we reached the end of file, this loop is done. */
02492        if(sc->loadport->_object._port->kind & port_saw_EOF)
02493      {
02494        if(sc->file_i == 0)
02495          {
02496            sc->args=sc->NIL;
02497            s_goto(sc,OP_QUIT);
02498          }
02499        else
02500          {
02501            file_pop(sc);
02502            s_return(sc,sc->value);
02503          }
02504        /* NOTREACHED */
02505      }
02506 
02507        /* If interactive, be nice to user. */
02508        if(file_interactive(sc))
02509      {
02510        sc->envir = sc->global_env;
02511        dump_stack_reset(sc);
02512        putstr(sc,"\n");
02513        putstr(sc,prompt);
02514      }
02515 
02516        /* Set up another iteration of REPL */
02517        sc->nesting=0;
02518        sc->save_inport=sc->inport;
02519        sc->inport = sc->loadport;
02520        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
02521        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
02522        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
02523        s_goto(sc,OP_READ_INTERNAL);
02524 
02525      case OP_T1LVL: /* top level */
02526           sc->code = sc->value;
02527           sc->inport=sc->save_inport;
02528           s_goto(sc,OP_EVAL);
02529 
02530      case OP_READ_INTERNAL:       /* internal read */
02531           sc->tok = token(sc);
02532           if(sc->tok==TOK_EOF)
02533         { s_return(sc,sc->EOF_OBJ); }
02534           s_goto(sc,OP_RDSEXPR);
02535 
02536      case OP_GENSYM:
02537           s_return(sc, gensym(sc));
02538 
02539      case OP_VALUEPRINT: /* print evaluation result */
02540           /* OP_VALUEPRINT is always pushed, because when changing from
02541              non-interactive to interactive mode, it needs to be
02542              already on the stack */
02543        if(sc->tracing) {
02544      putstr(sc,"\nGives: ");
02545        }
02546        if(file_interactive(sc)) {
02547      sc->print_flag = 1;
02548      sc->args = sc->value;
02549      s_goto(sc,OP_P0LIST);
02550        } else {
02551      s_return(sc,sc->value);
02552        }
02553 
02554      case OP_EVAL:       /* main part of evaluation */
02555 #if USE_TRACING
02556        if(sc->tracing) {
02557      /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
02558      s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
02559      sc->args=sc->code;
02560      putstr(sc,"\nEval: ");
02561      s_goto(sc,OP_P0LIST);
02562        }
02563        /* fall through */
02564      case OP_REAL_EVAL:
02565 #endif
02566           if (is_symbol(sc->code)) {    /* symbol */
02567                x=find_slot_in_env(sc,sc->envir,sc->code,1);
02568                if (x != sc->NIL) {
02569                     s_return(sc,slot_value_in_env(x));
02570                } else {
02571                     Error_1(sc,"eval: unbound variable:", sc->code);
02572                }
02573           } else if (is_pair(sc->code)) {
02574                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
02575                     sc->code = cdr(sc->code);
02576                     s_goto(sc,syntaxnum(x));
02577                } else {/* first, eval top element and eval arguments */
02578                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
02579                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
02580                     sc->code = car(sc->code);
02581                     s_goto(sc,OP_EVAL);
02582                }
02583           } else {
02584                s_return(sc,sc->code);
02585           }
02586 
02587      case OP_E0ARGS:     /* eval arguments */
02588           if (is_macro(sc->value)) {    /* macro expansion */
02589                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
02590                sc->args = cons(sc,sc->code, sc->NIL);
02591                sc->code = sc->value;
02592                s_goto(sc,OP_APPLY);
02593           } else {
02594                sc->code = cdr(sc->code);
02595                s_goto(sc,OP_E1ARGS);
02596           }
02597 
02598      case OP_E1ARGS:     /* eval arguments */
02599           sc->args = cons(sc, sc->value, sc->args);
02600           if (is_pair(sc->code)) { /* continue */
02601                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
02602                sc->code = car(sc->code);
02603                sc->args = sc->NIL;
02604                s_goto(sc,OP_EVAL);
02605           } else {  /* end */
02606                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
02607                sc->code = car(sc->args);
02608                sc->args = cdr(sc->args);
02609                s_goto(sc,OP_APPLY);
02610           }
02611 
02612 #if USE_TRACING
02613      case OP_TRACING: {
02614        int tr=sc->tracing;
02615        sc->tracing=ivalue(car(sc->args));
02616        s_return(sc,mk_integer(sc,tr));
02617      }
02618 #endif
02619 
02620      case OP_APPLY:      /* apply 'code' to 'args' */
02621 #if USE_TRACING
02622        if(sc->tracing) {
02623      s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
02624      sc->print_flag = 1;
02625      /*  sc->args=cons(sc,sc->code,sc->args);*/
02626          putstr(sc,"\nApply to: ");
02627      s_goto(sc,OP_P0LIST);
02628        }
02629        /* fall through */
02630      case OP_REAL_APPLY:
02631 #endif
02632           if (is_proc(sc->code)) {
02633                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
02634           } else if (is_foreign(sc->code))
02635             {
02636               /* Keep nested calls from GC'ing the arglist */
02637               push_recent_alloc(sc,sc->args,sc->NIL);
02638                x=sc->code->_object._ff(sc,sc->args);
02639                s_return(sc,x);
02640           } else if (is_closure(sc->code) || is_macro(sc->code)
02641              || is_promise(sc->code)) { /* CLOSURE */
02642         /* Should not accept promise */
02643                /* make environment */
02644                new_frame_in_env(sc, closure_env(sc->code));
02645                for (x = car(closure_code(sc->code)), y = sc->args;
02646                     is_pair(x); x = cdr(x), y = cdr(y)) {
02647                     if (y == sc->NIL) {
02648                          Error_0(sc,"not enough arguments");
02649                     } else {
02650                          new_slot_in_env(sc, car(x), car(y));
02651                     }
02652                }
02653                if (x == sc->NIL) {
02654                     /*--
02655                      * if (y != sc->NIL) {
02656                      *   Error_0(sc,"too many arguments");
02657                      * }
02658                      */
02659                } else if (is_symbol(x))
02660                     new_slot_in_env(sc, x, y);
02661                else {
02662                     Error_1(sc,"syntax error in closure: not a symbol:", x);
02663                }
02664                sc->code = cdr(closure_code(sc->code));
02665                sc->args = sc->NIL;
02666                s_goto(sc,OP_BEGIN);
02667           } else if (is_continuation(sc->code)) { /* CONTINUATION */
02668                sc->dump = cont_dump(sc->code);
02669                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
02670           } else {
02671                Error_0(sc,"illegal function");
02672           }
02673 
02674      case OP_DOMACRO:    /* do macro */
02675           sc->code = sc->value;
02676           s_goto(sc,OP_EVAL);
02677 
02678 #if 1
02679      case OP_LAMBDA:     /* lambda */
02680           /* If the hook is defined, apply it to sc->code, otherwise
02681              set sc->value fall thru */
02682           {
02683                cell_ptr f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
02684                if(f==sc->NIL) {
02685                     sc->value = sc->code;
02686                     /* Fallthru */
02687                } else {
02688                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
02689                     sc->args=cons(sc,sc->code,sc->NIL);
02690                     sc->code=slot_value_in_env(f);
02691                     s_goto(sc,OP_APPLY);
02692                }
02693           }
02694 
02695      case OP_LAMBDA1:
02696           s_return(sc,mk_closure(sc, sc->value, sc->envir));
02697 
02698 #else
02699      case OP_LAMBDA:     /* lambda */
02700           s_return(sc,mk_closure(sc, sc->code, sc->envir));
02701 
02702 #endif
02703 
02704      case OP_MKCLOSURE: /* make-closure */
02705        x=car(sc->args);
02706        if(car(x)==sc->LAMBDA) {
02707      x=cdr(x);
02708        }
02709        if(cdr(sc->args)==sc->NIL) {
02710      y=sc->envir;
02711        } else {
02712      y=cadr(sc->args);
02713        }
02714        s_return(sc,mk_closure(sc, x, y));
02715 
02716      case OP_QUOTE:      /* quote */
02717           x=car(sc->code);
02718           s_return(sc,car(sc->code));
02719 
02720      case OP_DEF0:  /* define */
02721           if(is_immutable(car(sc->code)))
02722             Error_1(sc,"define: unable to alter immutable", car(sc->code));
02723 
02724           if (is_pair(car(sc->code))) {
02725                x = caar(sc->code);
02726                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
02727           } else {
02728                x = car(sc->code);
02729                sc->code = cadr(sc->code);
02730           }
02731           if (!is_symbol(x)) {
02732                Error_0(sc,"variable is not a symbol");
02733           }
02734           s_save(sc,OP_DEF1, sc->NIL, x);
02735           s_goto(sc,OP_EVAL);
02736 
02737      case OP_DEF1:  /* define */
02738        x=find_slot_in_env(sc,sc->envir,sc->code,0);
02739           if (x != sc->NIL) {
02740                set_slot_in_env(sc, x, sc->value);
02741           } else {
02742                new_slot_in_env(sc, sc->code, sc->value);
02743           }
02744           s_return(sc,sc->code);
02745 
02746 
02747      case OP_DEFP:  /* defined? */
02748           x=sc->envir;
02749           if(cdr(sc->args)!=sc->NIL) {
02750                x=cadr(sc->args);
02751           }
02752           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
02753 
02754      case OP_SET0:       /* set! */
02755           if(is_immutable(car(sc->code)))
02756                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
02757           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
02758           sc->code = cadr(sc->code);
02759           s_goto(sc,OP_EVAL);
02760 
02761      case OP_SET1:       /* set! */
02762        y=find_slot_in_env(sc,sc->envir,sc->code,1);
02763           if (y != sc->NIL) {
02764                set_slot_in_env(sc, y, sc->value);
02765                s_return(sc,sc->value);
02766           } else {
02767                Error_1(sc,"set!: unbound variable:", sc->code);
02768           }
02769 
02770 
02771      case OP_BEGIN:      /* begin */
02772           if (!is_pair(sc->code)) {
02773                s_return(sc,sc->code);
02774           }
02775           if (cdr(sc->code) != sc->NIL) {
02776                s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
02777           }
02778           sc->code = car(sc->code);
02779           s_goto(sc,OP_EVAL);
02780 
02781      case OP_IF0:        /* if */
02782           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
02783           sc->code = car(sc->code);
02784           s_goto(sc,OP_EVAL);
02785 
02786      case OP_IF1:        /* if */
02787           if (is_true(sc->value))
02788                sc->code = car(sc->code);
02789           else
02790                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
02791                                * car(sc->NIL) = sc->NIL */
02792           s_goto(sc,OP_EVAL);
02793 
02794      case OP_LET0:       /* let */
02795           sc->args = sc->NIL;
02796           sc->value = sc->code;
02797           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
02798           s_goto(sc,OP_LET1);
02799 
02800      case OP_LET1:       /* let (calculate parameters) */
02801           sc->args = cons(sc, sc->value, sc->args);
02802           if (is_pair(sc->code)) { /* continue */
02803                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
02804                     Error_1(sc, "Bad syntax of binding spec in let :",
02805                             car(sc->code));
02806                }
02807                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
02808                sc->code = cadar(sc->code);
02809                sc->args = sc->NIL;
02810                s_goto(sc,OP_EVAL);
02811           } else {  /* end */
02812                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
02813                sc->code = car(sc->args);
02814                sc->args = cdr(sc->args);
02815                s_goto(sc,OP_LET2);
02816           }
02817 
02818      case OP_LET2:       /* let */
02819           new_frame_in_env(sc, sc->envir);
02820           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
02821                y != sc->NIL; x = cdr(x), y = cdr(y)) {
02822                new_slot_in_env(sc, caar(x), car(y));
02823           }
02824           if (is_symbol(car(sc->code))) {    /* named let */
02825                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
02826                     if (!is_pair(x))
02827                         Error_1(sc, "Bad syntax of binding in let :", x);
02828                     if (!is_list(sc, car(x)))
02829                         Error_1(sc, "Bad syntax of binding in let :", car(x));
02830                     sc->args = cons(sc, caar(x), sc->args);
02831                }
02832                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
02833                new_slot_in_env(sc, car(sc->code), x);
02834                sc->code = cddr(sc->code);
02835                sc->args = sc->NIL;
02836           } else {
02837                sc->code = cdr(sc->code);
02838                sc->args = sc->NIL;
02839           }
02840           s_goto(sc,OP_BEGIN);
02841 
02842      case OP_LET0AST:    /* let* */
02843           if (car(sc->code) == sc->NIL) {
02844                new_frame_in_env(sc, sc->envir);
02845                sc->code = cdr(sc->code);
02846                s_goto(sc,OP_BEGIN);
02847           }
02848           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
02849                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
02850           }
02851           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
02852           sc->code = cadaar(sc->code);
02853           s_goto(sc,OP_EVAL);
02854 
02855      case OP_LET1AST:    /* let* (make new frame) */
02856           new_frame_in_env(sc, sc->envir);
02857           s_goto(sc,OP_LET2AST);
02858 
02859      case OP_LET2AST:    /* let* (calculate parameters) */
02860           new_slot_in_env(sc, caar(sc->code), sc->value);
02861           sc->code = cdr(sc->code);
02862           if (is_pair(sc->code)) { /* continue */
02863                s_save(sc,OP_LET2AST, sc->args, sc->code);
02864                sc->code = cadar(sc->code);
02865                sc->args = sc->NIL;
02866                s_goto(sc,OP_EVAL);
02867           } else {  /* end */
02868                sc->code = sc->args;
02869                sc->args = sc->NIL;
02870                s_goto(sc,OP_BEGIN);
02871           }
02872      default:
02873           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
02874           Error_0(sc,sc->strbuff);
02875      }
02876      return sc->T;
02877 }
02878 
02879 static cell_ptr opexe_1(scheme *sc, enum scheme_opcodes op) {
02880      cell_ptr x, y;
02881 
02882      switch (op) {
02883      case OP_LET0REC:    /* letrec */
02884           new_frame_in_env(sc, sc->envir);
02885           sc->args = sc->NIL;
02886           sc->value = sc->code;
02887           sc->code = car(sc->code);
02888           s_goto(sc,OP_LET1REC);
02889 
02890      case OP_LET1REC:    /* letrec (calculate parameters) */
02891           sc->args = cons(sc, sc->value, sc->args);
02892           if (is_pair(sc->code)) { /* continue */
02893                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
02894                     Error_1(sc, "Bad syntax of binding spec in letrec :",
02895                             car(sc->code));
02896                }
02897                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
02898                sc->code = cadar(sc->code);
02899                sc->args = sc->NIL;
02900                s_goto(sc,OP_EVAL);
02901           } else {  /* end */
02902                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
02903                sc->code = car(sc->args);
02904                sc->args = cdr(sc->args);
02905                s_goto(sc,OP_LET2REC);
02906           }
02907 
02908      case OP_LET2REC:    /* letrec */
02909           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
02910                new_slot_in_env(sc, caar(x), car(y));
02911           }
02912           sc->code = cdr(sc->code);
02913           sc->args = sc->NIL;
02914           s_goto(sc,OP_BEGIN);
02915 
02916      case OP_COND0:      /* cond */
02917           if (!is_pair(sc->code)) {
02918                Error_0(sc,"syntax error in cond");
02919           }
02920           s_save(sc,OP_COND1, sc->NIL, sc->code);
02921           sc->code = caar(sc->code);
02922           s_goto(sc,OP_EVAL);
02923 
02924      case OP_COND1:      /* cond */
02925           if (is_true(sc->value)) {
02926                if ((sc->code = cdar(sc->code)) == sc->NIL) {
02927                     s_return(sc,sc->value);
02928                }
02929                if(car(sc->code)==sc->FEED_TO) {
02930                     if(!is_pair(cdr(sc->code))) {
02931                          Error_0(sc,"syntax error in cond");
02932                     }
02933                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
02934                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
02935                     s_goto(sc,OP_EVAL);
02936                }
02937                s_goto(sc,OP_BEGIN);
02938           } else {
02939                if ((sc->code = cdr(sc->code)) == sc->NIL) {
02940                     s_return(sc,sc->NIL);
02941                } else {
02942                     s_save(sc,OP_COND1, sc->NIL, sc->code);
02943                     sc->code = caar(sc->code);
02944                     s_goto(sc,OP_EVAL);
02945                }
02946           }
02947 
02948      case OP_DELAY:      /* delay */
02949           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
02950           typeflag(x)=T_PROMISE;
02951           s_return(sc,x);
02952 
02953      case OP_AND0:       /* and */
02954           if (sc->code == sc->NIL) {
02955                s_return(sc,sc->T);
02956           }
02957           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
02958           sc->code = car(sc->code);
02959           s_goto(sc,OP_EVAL);
02960 
02961      case OP_AND1:       /* and */
02962           if (is_false(sc->value)) {
02963                s_return(sc,sc->value);
02964           } else if (sc->code == sc->NIL) {
02965                s_return(sc,sc->value);
02966           } else {
02967                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
02968                sc->code = car(sc->code);
02969                s_goto(sc,OP_EVAL);
02970           }
02971 
02972      case OP_OR0:        /* or */
02973           if (sc->code == sc->NIL) {
02974                s_return(sc,sc->F);
02975           }
02976           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
02977           sc->code = car(sc->code);
02978           s_goto(sc,OP_EVAL);
02979 
02980      case OP_OR1:        /* or */
02981           if (is_true(sc->value)) {
02982                s_return(sc,sc->value);
02983           } else if (sc->code == sc->NIL) {
02984                s_return(sc,sc->value);
02985           } else {
02986                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
02987                sc->code = car(sc->code);
02988                s_goto(sc,OP_EVAL);
02989           }
02990 
02991      case OP_C0STREAM:   /* cons-stream */
02992           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
02993           sc->code = car(sc->code);
02994           s_goto(sc,OP_EVAL);
02995 
02996      case OP_C1STREAM:   /* cons-stream */
02997           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
02998           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
02999           typeflag(x)=T_PROMISE;
03000           s_return(sc,cons(sc, sc->args, x));
03001 
03002      case OP_MACRO0:     /* macro */
03003           if (is_pair(car(sc->code))) {
03004                x = caar(sc->code);
03005                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
03006           } else {
03007                x = car(sc->code);
03008                sc->code = cadr(sc->code);
03009           }
03010           if (!is_symbol(x)) {
03011                Error_0(sc,"variable is not a symbol");
03012           }
03013           s_save(sc,OP_MACRO1, sc->NIL, x);
03014           s_goto(sc,OP_EVAL);
03015 
03016      case OP_MACRO1:     /* macro */
03017           typeflag(sc->value) = T_MACRO;
03018           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
03019           if (x != sc->NIL) {
03020                set_slot_in_env(sc, x, sc->value);
03021           } else {
03022                new_slot_in_env(sc, sc->code, sc->value);
03023           }
03024           s_return(sc,sc->code);
03025 
03026      case OP_CASE0:      /* case */
03027           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
03028           sc->code = car(sc->code);
03029           s_goto(sc,OP_EVAL);
03030 
03031      case OP_CASE1:      /* case */
03032           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
03033                if (!is_pair(y = caar(x))) {
03034                     break;
03035                }
03036                for ( ; y != sc->NIL; y = cdr(y)) {
03037                     if (eqv(car(y), sc->value)) {
03038                          break;
03039                     }
03040                }
03041                if (y != sc->NIL) {
03042                     break;
03043                }
03044           }
03045           if (x != sc->NIL) {
03046                if (is_pair(caar(x))) {
03047                     sc->code = cdar(x);
03048                     s_goto(sc,OP_BEGIN);
03049                } else {/* else */
03050                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
03051                     sc->code = caar(x);
03052                     s_goto(sc,OP_EVAL);
03053                }
03054           } else {
03055                s_return(sc,sc->NIL);
03056           }
03057 
03058      case OP_CASE2:      /* case */
03059           if (is_true(sc->value)) {
03060                s_goto(sc,OP_BEGIN);
03061           } else {
03062                s_return(sc,sc->NIL);
03063           }
03064 
03065      case OP_PAPPLY:     /* apply */
03066           sc->code = car(sc->args);
03067       sc->args = list_star(sc,cdr(sc->args));
03068           /*sc->args = cadr(sc->args);*/
03069           s_goto(sc,OP_APPLY);
03070 
03071      case OP_PEVAL: /* eval */
03072           if(cdr(sc->args)!=sc->NIL) {
03073                sc->envir=cadr(sc->args);
03074           }
03075           sc->code = car(sc->args);
03076           s_goto(sc,OP_EVAL);
03077 
03078      case OP_CONTINUATION:    /* call-with-current-continuation */
03079           sc->code = car(sc->args);
03080           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
03081           s_goto(sc,OP_APPLY);
03082 
03083      default:
03084           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
03085           Error_0(sc,sc->strbuff);
03086      }
03087      return sc->T;
03088 }
03089 
03090 static cell_ptr opexe_2(scheme *sc, enum scheme_opcodes op) {
03091      cell_ptr x;
03092      num v;
03093 #if USE_MATH
03094      double dd;
03095 #endif
03096 
03097      switch (op) {
03098 #if USE_MATH
03099      case OP_INEX2EX:    /* inexact->exact */
03100           x=car(sc->args);
03101           if(num_is_integer(x)) {
03102                s_return(sc,x);
03103           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
03104                s_return(sc,mk_integer(sc,ivalue(x)));
03105           } else {
03106                Error_1(sc,"inexact->exact: not integral:",x);
03107           }
03108 
03109      case OP_EXP:
03110           x=car(sc->args);
03111           s_return(sc, mk_real(sc, exp(rvalue(x))));
03112 
03113      case OP_LOG:
03114           x=car(sc->args);
03115           s_return(sc, mk_real(sc, log(rvalue(x))));
03116 
03117      case OP_SIN:
03118           x=car(sc->args);
03119           s_return(sc, mk_real(sc, sin(rvalue(x))));
03120 
03121      case OP_COS:
03122           x=car(sc->args);
03123           s_return(sc, mk_real(sc, cos(rvalue(x))));
03124 
03125      case OP_TAN:
03126           x=car(sc->args);
03127           s_return(sc, mk_real(sc, tan(rvalue(x))));
03128 
03129      case OP_ASIN:
03130           x=car(sc->args);
03131           s_return(sc, mk_real(sc, asin(rvalue(x))));
03132 
03133      case OP_ACOS:
03134           x=car(sc->args);
03135           s_return(sc, mk_real(sc, acos(rvalue(x))));
03136 
03137      case OP_ATAN:
03138           x=car(sc->args);
03139           if(cdr(sc->args)==sc->NIL) {
03140                s_return(sc, mk_real(sc, atan(rvalue(x))));
03141           } else {
03142                cell_ptr y=cadr(sc->args);
03143                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
03144           }
03145 
03146      case OP_SQRT:
03147           x=car(sc->args);
03148           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
03149 
03150      case OP_EXPT:
03151           x=car(sc->args);
03152           if(cdr(sc->args)==sc->NIL) {
03153                Error_0(sc,"expt: needs two arguments");
03154           } else {
03155                cell_ptr y=cadr(sc->args);
03156                s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y))));
03157           }
03158 
03159      case OP_FLOOR:
03160           x=car(sc->args);
03161       s_return(sc, mk_real(sc, floor(rvalue(x))));
03162 
03163      case OP_CEILING:
03164           x=car(sc->args);
03165       s_return(sc, mk_real(sc, ceil(rvalue(x))));
03166 
03167      case OP_TRUNCATE : {
03168       double rvalue_of_x ;
03169           x=car(sc->args);
03170       rvalue_of_x = rvalue(x) ;
03171       if (rvalue_of_x > 0) {
03172         s_return(sc, mk_real(sc, floor(rvalue_of_x)));
03173       } else {
03174         s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
03175       }
03176      }
03177 
03178      case OP_ROUND:
03179        x=car(sc->args);
03180        s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
03181 #endif
03182 
03183      case OP_ADD:        /* + */
03184        v=num_zero;
03185        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
03186      v=num_add(v,nvalue(car(x)));
03187        }
03188        s_return(sc,mk_number(sc, v));
03189 
03190      case OP_MUL:        /* * */
03191        v=num_one;
03192        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
03193      v=num_mul(v,nvalue(car(x)));
03194        }
03195        s_return(sc,mk_number(sc, v));
03196 
03197      case OP_SUB:        /* - */
03198        if(cdr(sc->args)==sc->NIL) {
03199      x=sc->args;
03200      v=num_zero;
03201        } else {
03202      x = cdr(sc->args);
03203      v = nvalue(car(sc->args));
03204        }
03205        for (; x != sc->NIL; x = cdr(x)) {
03206      v=num_sub(v,nvalue(car(x)));
03207        }
03208        s_return(sc,mk_number(sc, v));
03209 
03210      case OP_DIV:        /* / */
03211        if(cdr(sc->args)==sc->NIL) {
03212      x=sc->args;
03213      v=num_one;
03214        } else {
03215      x = cdr(sc->args);
03216      v = nvalue(car(sc->args));
03217        }
03218        for (; x != sc->NIL; x = cdr(x)) {
03219      if (!is_zero_double(rvalue(car(x))))
03220        v=num_div(v,nvalue(car(x)));
03221      else {
03222        Error_0(sc,"/: division by zero");
03223      }
03224        }
03225        s_return(sc,mk_number(sc, v));
03226 
03227      case OP_INTDIV:        /* quotient */
03228           if(cdr(sc->args)==sc->NIL) {
03229                x=sc->args;
03230                v=num_one;
03231           } else {
03232                x = cdr(sc->args);
03233                v = nvalue(car(sc->args));
03234           }
03235           for (; x != sc->NIL; x = cdr(x)) {
03236                if (ivalue(car(x)) != 0)
03237                     v=num_intdiv(v,nvalue(car(x)));
03238                else {
03239                     Error_0(sc,"quotient: division by zero");
03240                }
03241           }
03242           s_return(sc,mk_number(sc, v));
03243 
03244      case OP_REM:        /* remainder */
03245           v = nvalue(car(sc->args));
03246           if (ivalue(cadr(sc->args)) != 0)
03247                v=num_rem(v,nvalue(cadr(sc->args)));
03248           else {
03249                Error_0(sc,"remainder: division by zero");
03250           }
03251           s_return(sc,mk_number(sc, v));
03252 
03253      case OP_MOD:        /* modulo */
03254           v = nvalue(car(sc->args));
03255           if (ivalue(cadr(sc->args)) != 0)
03256                v=num_mod(v,nvalue(cadr(sc->args)));
03257           else {
03258                Error_0(sc,"modulo: division by zero");
03259           }
03260           s_return(sc,mk_number(sc, v));
03261 
03262      case OP_CAR:        /* car */
03263        s_return(sc,caar(sc->args));
03264 
03265      case OP_CDR:        /* cdr */
03266        s_return(sc,cdar(sc->args));
03267 
03268      case OP_CONS:       /* cons */
03269           cdr(sc->args) = cadr(sc->args);
03270           s_return(sc,sc->args);
03271 
03272      case OP_SETCAR:     /* set-car! */
03273        if(!is_immutable(car(sc->args))) {
03274      caar(sc->args) = cadr(sc->args);
03275      s_return(sc,car(sc->args));
03276        } else {
03277      Error_0(sc,"set-car!: unable to alter immutable pair");
03278        }
03279 
03280      case OP_SETCDR:     /* set-cdr! */
03281        if(!is_immutable(car(sc->args))) {
03282      cdar(sc->args) = cadr(sc->args);
03283      s_return(sc,car(sc->args));
03284        } else {
03285      Error_0(sc,"set-cdr!: unable to alter immutable pair");
03286        }
03287 
03288      case OP_CHAR2INT: { /* char->integer */
03289           char c;
03290           c=(char)ivalue(car(sc->args));
03291           s_return(sc,mk_integer(sc,(unsigned char)c));
03292      }
03293 
03294      case OP_INT2CHAR: { /* integer->char */
03295           unsigned char c;
03296           c=(unsigned char)ivalue(car(sc->args));
03297           s_return(sc,mk_character(sc,(char)c));
03298      }
03299 
03300      case OP_CHARUPCASE: {
03301           unsigned char c;
03302           c=(unsigned char)ivalue(car(sc->args));
03303           c=toupper(c);
03304           s_return(sc,mk_character(sc,(char)c));
03305      }
03306 
03307      case OP_CHARDNCASE: {
03308           unsigned char c;
03309           c=(unsigned char)ivalue(car(sc->args));
03310           c=tolower(c);
03311           s_return(sc,mk_character(sc,(char)c));
03312      }
03313 
03314      case OP_STR2SYM:  /* string->symbol */
03315           s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
03316 
03317      case OP_STR2ATOM: /* string->atom */ {
03318        char *s=strvalue(car(sc->args));
03319        if(*s=='#') {
03320      s_return(sc, mk_sharp_const(sc, s+1));
03321        } else {
03322      s_return(sc, mk_atom(sc, s));
03323        }
03324      }
03325 
03326      case OP_SYM2STR: /* symbol->string */
03327           x=mk_string(sc,symname(car(sc->args)));
03328           setimmutable(x);
03329           s_return(sc,x);
03330      case OP_ATOM2STR: /* atom->string */
03331        x=car(sc->args);
03332        if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
03333      char *p;
03334      int len;
03335      atom2str(sc,x,0,&p,&len);
03336      s_return(sc,mk_counted_string(sc,p,len));
03337        } else {
03338      Error_1(sc, "atom->string: not an atom:", x);
03339        }
03340 
03341      case OP_MKSTRING: { /* make-string */
03342           int fill=' ';
03343           int len;
03344 
03345           len=ivalue(car(sc->args));
03346 
03347           if(cdr(sc->args)!=sc->NIL) {
03348                fill=charvalue(cadr(sc->args));
03349           }
03350           s_return(sc,mk_empty_string(sc,len,(char)fill));
03351      }
03352 
03353      case OP_STRLEN:  /* string-length */
03354           s_return(sc,mk_integer(sc,strlength(car(sc->args))));
03355 
03356      case OP_STRREF: { /* string-ref */
03357           char *str;
03358           int index;
03359 
03360           str=strvalue(car(sc->args));
03361 
03362           index=ivalue(cadr(sc->args));
03363 
03364           if(index>=strlength(car(sc->args))) {
03365                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
03366           }
03367 
03368           s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
03369      }
03370 
03371      case OP_STRSET: { /* string-set! */
03372           char *str;
03373           int index;
03374           int c;
03375 
03376           if(is_immutable(car(sc->args))) {
03377                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
03378           }
03379           str=strvalue(car(sc->args));
03380 
03381           index=ivalue(cadr(sc->args));
03382           if(index>=strlength(car(sc->args))) {
03383                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
03384           }
03385 
03386           c=charvalue(caddr(sc->args));
03387 
03388           str[index]=(char)c;
03389           s_return(sc,car(sc->args));
03390      }
03391 
03392      case OP_STRAPPEND: { /* string-append */
03393        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
03394        int len = 0;
03395        cell_ptr newstr;
03396        char *pos;
03397 
03398        /* compute needed length for new string */
03399        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
03400           len += strlength(car(x));
03401        }
03402        newstr = mk_empty_string(sc, len, ' ');
03403        /* store the contents of the argument strings into the new string */
03404        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
03405            pos += strlength(car(x)), x = cdr(x)) {
03406            memcpy(pos, strvalue(car(x)), strlength(car(x)));
03407        }
03408        s_return(sc, newstr);
03409      }
03410 
03411      case OP_SUBSTR: { /* substring */
03412           char *str;
03413           int index0;
03414           int index1;
03415           int len;
03416 
03417           str=strvalue(car(sc->args));
03418 
03419           index0=ivalue(cadr(sc->args));
03420 
03421           if(index0>strlength(car(sc->args))) {
03422                Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
03423           }
03424 
03425           if(cddr(sc->args)!=sc->NIL) {
03426                index1=ivalue(caddr(sc->args));
03427                if(index1>strlength(car(sc->args)) || index1<index0) {
03428                     Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
03429                }
03430           } else {
03431                index1=strlength(car(sc->args));
03432           }
03433 
03434           len=index1-index0;
03435           x=mk_empty_string(sc,len,' ');
03436           memcpy(strvalue(x),str+index0,len);
03437           strvalue(x)[len]=0;
03438 
03439           s_return(sc,x);
03440      }
03441 
03442      case OP_VECTOR: {   /* vector */
03443           int i;
03444           cell_ptr vec;
03445           int len=list_length(sc,sc->args);
03446           if(len<0) {
03447                Error_1(sc,"vector: not a proper list:",sc->args);
03448           }
03449           vec=mk_vector(sc,len);
03450           if(sc->no_memory) { s_return(sc, sc->sink); }
03451           for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
03452                set_vector_elem(vec,i,car(x));
03453           }
03454           s_return(sc,vec);
03455      }
03456 
03457      case OP_MKVECTOR: { /* make-vector */
03458           cell_ptr fill=sc->NIL;
03459           int len;
03460           cell_ptr vec;
03461 
03462           len=ivalue(car(sc->args));
03463 
03464           if(cdr(sc->args)!=sc->NIL) {
03465                fill=cadr(sc->args);
03466           }
03467           vec=mk_vector(sc,len);
03468       if(sc->no_memory) { s_return(sc, sc->sink); }
03469           if(fill!=sc->NIL) {
03470                fill_vector(vec,fill);
03471           }
03472           s_return(sc,vec);
03473      }
03474 
03475      case OP_VECLEN:  /* vector-length */
03476           s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
03477 
03478      case OP_VECREF: { /* vector-ref */
03479           int index;
03480 
03481           index=ivalue(cadr(sc->args));
03482 
03483           if(index>=ivalue(car(sc->args))) {
03484                Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
03485           }
03486 
03487           s_return(sc,vector_elem(car(sc->args),index));
03488      }
03489 
03490      case OP_VECSET: {   /* vector-set! */
03491           int index;
03492 
03493           if(is_immutable(car(sc->args))) {
03494                Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
03495           }
03496 
03497           index=ivalue(cadr(sc->args));
03498           if(index>=ivalue(car(sc->args))) {
03499                Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
03500           }
03501 
03502           set_vector_elem(car(sc->args),index,caddr(sc->args));
03503           s_return(sc,car(sc->args));
03504      }
03505 
03506      default:
03507           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
03508           Error_0(sc,sc->strbuff);
03509      }
03510      return sc->T;
03511 }
03512 
03513 static int is_list(scheme *sc, cell_ptr a)
03514 { return list_length(sc,a) >= 0; }
03515 
03516 /* Result is:
03517    proper list: length
03518    circular list: -1
03519    not even a pair: -2
03520    dotted list: -2 minus length before dot
03521 */
03522 int list_length(scheme *sc, cell_ptr a) {
03523     int i=0;
03524     cell_ptr slow, fast;
03525 
03526     slow = fast = a;
03527     while (1)
03528     {
03529         if (fast == sc->NIL)
03530                 return i;
03531         if (!is_pair(fast))
03532                 return -2 - i;
03533         fast = cdr(fast);
03534         ++i;
03535         if (fast == sc->NIL)
03536                 return i;
03537         if (!is_pair(fast))
03538                 return -2 - i;
03539         ++i;
03540         fast = cdr(fast);
03541 
03542         /* Safe because we would have already returned if `fast'
03543            encountered a non-pair. */
03544         slow = cdr(slow);
03545         if (fast == slow)
03546         {
03547             /* the fast pointer has looped back around and caught up
03548                with the slow pointer, hence the structure is circular,
03549                not of finite length, and therefore not a list */
03550             return -1;
03551         }
03552     }
03553 }
03554 
03555 static cell_ptr opexe_3(scheme *sc, enum scheme_opcodes op) {
03556      cell_ptr x;
03557      num v;
03558      int (*comp_func)(num,num)=0;
03559 
03560      switch (op) {
03561      case OP_NOT:        /* not */
03562           s_retbool(is_false(car(sc->args)));
03563      case OP_BOOLP:       /* boolean? */
03564           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
03565      case OP_EOFOBJP:       /* boolean? */
03566           s_retbool(car(sc->args) == sc->EOF_OBJ);
03567      case OP_NULLP:       /* null? */
03568           s_retbool(car(sc->args) == sc->NIL);
03569      case OP_NUMEQ:      /* = */
03570      case OP_LESS:       /* < */
03571      case OP_GRE:        /* > */
03572      case OP_LEQ:        /* <= */
03573      case OP_GEQ:        /* >= */
03574           switch(op) {
03575                case OP_NUMEQ: comp_func=num_eq; break;
03576                case OP_LESS:  comp_func=num_lt; break;
03577                case OP_GRE:   comp_func=num_gt; break;
03578                case OP_LEQ:   comp_func=num_le; break;
03579                case OP_GEQ:   comp_func=num_ge; break;
03580           }
03581           x=sc->args;
03582           v=nvalue(car(x));
03583           x=cdr(x);
03584 
03585           for (; x != sc->NIL; x = cdr(x)) {
03586                if(!comp_func(v,nvalue(car(x)))) {
03587                     s_retbool(0);
03588                }
03589            v=nvalue(car(x));
03590           }
03591           s_retbool(1);
03592      case OP_SYMBOLP:     /* symbol? */
03593           s_retbool(is_symbol(car(sc->args)));
03594      case OP_NUMBERP:     /* number? */
03595           s_retbool(is_number(car(sc->args)));
03596      case OP_STRINGP:     /* string? */
03597           s_retbool(is_string(car(sc->args)));
03598      case OP_INTEGERP:     /* integer? */
03599           s_retbool(is_integer(car(sc->args)));
03600      case OP_REALP:     /* real? */
03601           s_retbool(is_number(car(sc->args))); /* All numbers are real */
03602      case OP_CHARP:     /* char? */
03603           s_retbool(is_character(car(sc->args)));
03604 #if USE_CHAR_CLASSIFIERS
03605      case OP_CHARAP:     /* char-alphabetic? */
03606           s_retbool(Cisalpha(ivalue(car(sc->args))));
03607      case OP_CHARNP:     /* char-numeric? */
03608           s_retbool(Cisdigit(ivalue(car(sc->args))));
03609      case OP_CHARWP:     /* char-whitespace? */
03610           s_retbool(Cisspace(ivalue(car(sc->args))));
03611      case OP_CHARUP:     /* char-upper-case? */
03612           s_retbool(Cisupper(ivalue(car(sc->args))));
03613      case OP_CHARLP:     /* char-lower-case? */
03614           s_retbool(Cislower(ivalue(car(sc->args))));
03615 #endif
03616      case OP_PORTP:     /* port? */
03617           s_retbool(is_port(car(sc->args)));
03618      case OP_INPORTP:     /* input-port? */
03619           s_retbool(is_inport(car(sc->args)));
03620      case OP_OUTPORTP:     /* output-port? */
03621           s_retbool(is_outport(car(sc->args)));
03622      case OP_PROCP:       /* procedure? */
03623           /*--
03624               * continuation should be procedure by the example
03625               * (call-with-current-continuation procedure?) ==> #t
03626                  * in R^3 report sec. 6.9
03627               */
03628           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
03629                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
03630      case OP_PAIRP:       /* pair? */
03631           s_retbool(is_pair(car(sc->args)));
03632      case OP_LISTP:       /* list? */
03633        s_retbool(list_length(sc,car(sc->args)) >= 0);
03634 
03635      case OP_ENVP:        /* environment? */
03636           s_retbool(is_environment(car(sc->args)));
03637      case OP_VECTORP:     /* vector? */
03638           s_retbool(is_vector(car(sc->args)));
03639      case OP_EQ:         /* eq? */
03640           s_retbool(car(sc->args) == cadr(sc->args));
03641      case OP_EQV:        /* eqv? */
03642           s_retbool(eqv(car(sc->args), cadr(sc->args)));
03643      default:
03644           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
03645           Error_0(sc,sc->strbuff);
03646      }
03647      return sc->T;
03648 }
03649 
03650 static cell_ptr opexe_4(scheme *sc, enum scheme_opcodes op) {
03651      cell_ptr x, y;
03652 
03653      switch (op) {
03654      case OP_FORCE:      /* force */
03655           sc->code = car(sc->args);
03656           if (is_promise(sc->code)) {
03657                /* Should change type to closure here */
03658                s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
03659                sc->args = sc->NIL;
03660                s_goto(sc,OP_APPLY);
03661           } else {
03662                s_return(sc,sc->code);
03663           }
03664 
03665      case OP_SAVE_FORCED:     /* Save forced value replacing promise */
03666           memcpy(sc->code,sc->value,sizeof(struct cell));
03667           s_return(sc,sc->value);
03668 
03669      case OP_WRITE:      /* write */
03670      case OP_DISPLAY:    /* display */
03671      case OP_WRITE_CHAR: /* write-char */
03672           if(is_pair(cdr(sc->args))) {
03673                if(cadr(sc->args)!=sc->outport) {
03674                     x=cons(sc,sc->outport,sc->NIL);
03675                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
03676                     sc->outport=cadr(sc->args);
03677                }
03678           }
03679           sc->args = car(sc->args);
03680           if(op==OP_WRITE) {
03681                sc->print_flag = 1;
03682           } else {
03683                sc->print_flag = 0;
03684           }
03685           s_goto(sc,OP_P0LIST);
03686 
03687      case OP_NEWLINE:    /* newline */
03688           if(is_pair(sc->args)) {
03689                if(car(sc->args)!=sc->outport) {
03690                     x=cons(sc,sc->outport,sc->NIL);
03691                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
03692                     sc->outport=car(sc->args);
03693                }
03694           }
03695           putstr(sc, "\n");
03696           s_return(sc,sc->T);
03697 
03698      case OP_ERR0:  /* error */
03699           sc->retcode=-1;
03700           if (!is_string(car(sc->args))) {
03701                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
03702                setimmutable(car(sc->args));
03703           }
03704           putstr(sc, "Error: ");
03705           putstr(sc, strvalue(car(sc->args)));
03706           sc->args = cdr(sc->args);
03707           s_goto(sc,OP_ERR1);
03708 
03709      case OP_ERR1:  /* error */
03710           putstr(sc, " ");
03711           if (sc->args != sc->NIL) {
03712                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
03713                sc->args = car(sc->args);
03714                sc->print_flag = 1;
03715                s_goto(sc,OP_P0LIST);
03716           } else {
03717                putstr(sc, "\n");
03718                if(sc->interactive_repl) {
03719                     s_goto(sc,OP_T0LVL);
03720                } else {
03721                     return sc->NIL;
03722                }
03723           }
03724 
03725      case OP_REVERSE:    /* reverse */
03726           s_return(sc,reverse(sc, car(sc->args)));
03727 
03728      case OP_LIST_STAR: /* list* */
03729        s_return(sc,list_star(sc,sc->args));
03730 
03731      case OP_APPEND:     /* append */
03732           if(sc->args==sc->NIL) {
03733                s_return(sc,sc->NIL);
03734           }
03735           x=car(sc->args);
03736           if(cdr(sc->args)==sc->NIL) {
03737         s_return(sc,sc->args);
03738       }
03739           for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
03740                x=append(sc,x,car(y));
03741           }
03742           s_return(sc,x);
03743 
03744 #if USE_PLIST
03745      case OP_PUT:        /* put */
03746           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
03747                Error_0(sc,"illegal use of put");
03748           }
03749           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
03750                if (caar(x) == y) {
03751                     break;
03752                }
03753           }
03754           if (x != sc->NIL)
03755                cdar(x) = caddr(sc->args);
03756           else
03757                symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
03758                                 symprop(car(sc->args)));
03759           s_return(sc,sc->T);
03760 
03761      case OP_GET:        /* get */
03762           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
03763                Error_0(sc,"illegal use of get");
03764           }
03765           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
03766                if (caar(x) == y) {
03767                     break;
03768                }
03769           }
03770           if (x != sc->NIL) {
03771                s_return(sc,cdar(x));
03772           } else {
03773                s_return(sc,sc->NIL);
03774           }
03775 #endif /* USE_PLIST */
03776      case OP_QUIT:       /* quit */
03777           if(is_pair(sc->args)) {
03778                sc->retcode=ivalue(car(sc->args));
03779           }
03780           return (sc->NIL);
03781 
03782      case OP_GC:         /* gc */
03783           gc(sc, sc->NIL, sc->NIL);
03784           s_return(sc,sc->T);
03785 
03786      case OP_GCVERB:          /* gc-verbose */
03787      {    int  was = sc->gc_verbose;
03788 
03789           sc->gc_verbose = (car(sc->args) != sc->F);
03790           s_retbool(was);
03791      }
03792 
03793      case OP_NEWSEGMENT: /* new-segment */
03794           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
03795                Error_0(sc,"new-segment: argument must be a number");
03796           }
03797           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
03798           s_return(sc,sc->T);
03799 
03800      case OP_OBLIST: /* oblist */
03801           s_return(sc, oblist_all_symbols(sc));
03802 
03803      case OP_CURR_INPORT: /* current-input-port */
03804           s_return(sc,sc->inport);
03805 
03806      case OP_CURR_OUTPORT: /* current-output-port */
03807           s_return(sc,sc->outport);
03808 
03809      case OP_OPEN_INFILE: /* open-input-file */
03810      case OP_OPEN_OUTFILE: /* open-output-file */
03811      case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
03812           int prop=0;
03813           cell_ptr p;
03814           switch(op) {
03815                case OP_OPEN_INFILE:     prop=port_input; break;
03816                case OP_OPEN_OUTFILE:    prop=port_output; break;
03817                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
03818           }
03819           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
03820           if(p==sc->NIL) {
03821                s_return(sc,sc->F);
03822           }
03823           s_return(sc,p);
03824      }
03825 
03826 #if USE_STRING_PORTS
03827      case OP_OPEN_INSTRING: /* open-input-string */
03828      case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
03829           int prop=0;
03830           cell_ptr p;
03831           switch(op) {
03832                case OP_OPEN_INSTRING:     prop=port_input; break;
03833                case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
03834           }
03835           p=port_from_string(sc, strvalue(car(sc->args)),
03836                  strvalue(car(sc->args))+strlength(car(sc->args)), prop);
03837           if(p==sc->NIL) {
03838                s_return(sc,sc->F);
03839           }
03840           s_return(sc,p);
03841      }
03842      case OP_OPEN_OUTSTRING: /* open-output-string */ {
03843           cell_ptr p;
03844       if(car(sc->args)==sc->NIL) {
03845                p=port_from_scratch(sc);
03846                if(p==sc->NIL) {
03847                     s_return(sc,sc->F);
03848                }
03849       } else {
03850                p=port_from_string(sc, strvalue(car(sc->args)),
03851                       strvalue(car(sc->args))+strlength(car(sc->args)),
03852                           port_output);
03853                if(p==sc->NIL) {
03854                     s_return(sc,sc->F);
03855                }
03856       }
03857           s_return(sc,p);
03858      }
03859      case OP_GET_OUTSTRING: /* get-output-string */ {
03860           port *p;
03861 
03862       if ((p=car(sc->args)->_object._port)->kind&port_string) {
03863            off_t size;
03864            char *str;
03865 
03866            size=p->rep.string.curr-p->rep.string.start+1;
03867            str=sc->malloc(size);
03868            if(str != NULL) {
03869                 cell_ptr s;
03870 
03871                 memcpy(str,p->rep.string.start,size-1);
03872                 str[size-1]='\0';
03873                 s=mk_string(sc,str);
03874                 sc->free(str);
03875                 s_return(sc,s);
03876            }
03877       }
03878           s_return(sc,sc->F);
03879      }
03880 #endif
03881 
03882      case OP_CLOSE_INPORT: /* close-input-port */
03883           port_close(sc,car(sc->args),port_input);
03884           s_return(sc,sc->T);
03885 
03886      case OP_CLOSE_OUTPORT: /* close-output-port */
03887           port_close(sc,car(sc->args),port_output);
03888           s_return(sc,sc->T);
03889 
03890      case OP_INT_ENV: /* interaction-environment */
03891           s_return(sc,sc->global_env);
03892 
03893      case OP_CURR_ENV: /* current-environment */
03894           s_return(sc,sc->envir);
03895 
03896      }
03897      return sc->T;
03898 }
03899 
03900 static cell_ptr opexe_5(scheme *sc, enum scheme_opcodes op) {
03901      cell_ptr x;
03902 
03903      if(sc->nesting!=0) {
03904           int n=sc->nesting;
03905           sc->nesting=0;
03906           sc->retcode=-1;
03907           Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
03908      }
03909 
03910      switch (op) {
03911      /* ========== reading part ========== */
03912      case OP_READ:
03913           if(!is_pair(sc->args)) {
03914                s_goto(sc,OP_READ_INTERNAL);
03915           }
03916           if(!is_inport(car(sc->args))) {
03917                Error_1(sc,"read: not an input port:",car(sc->args));
03918           }
03919           if(car(sc->args)==sc->inport) {
03920                s_goto(sc,OP_READ_INTERNAL);
03921           }
03922           x=sc->inport;
03923           sc->inport=car(sc->args);
03924           x=cons(sc,x,sc->NIL);
03925           s_save(sc,OP_SET_INPORT, x, sc->NIL);
03926           s_goto(sc,OP_READ_INTERNAL);
03927 
03928      case OP_READ_CHAR: /* read-char */
03929      case OP_PEEK_CHAR: /* peek-char */ {
03930           int c;
03931           if(is_pair(sc->args)) {
03932                if(car(sc->args)!=sc->inport) {
03933                     x=sc->inport;
03934                     x=cons(sc,x,sc->NIL);
03935                     s_save(sc,OP_SET_INPORT, x, sc->NIL);
03936                     sc->inport=car(sc->args);
03937                }
03938           }
03939           c=inchar(sc);
03940           if(c==EOF) {
03941                s_return(sc,sc->EOF_OBJ);
03942           }
03943           if(sc->op==OP_PEEK_CHAR) {
03944                backchar(sc,c);
03945           }
03946           s_return(sc,mk_character(sc,c));
03947      }
03948 
03949      case OP_CHAR_READY: /* char-ready? */ {
03950           cell_ptr p=sc->inport;
03951           int res;
03952           if(is_pair(sc->args)) {
03953                p=car(sc->args);
03954           }
03955           res=p->_object._port->kind&port_string;
03956           s_retbool(res);
03957      }
03958 
03959      case OP_SET_INPORT: /* set-input-port */
03960           sc->inport=car(sc->args);
03961           s_return(sc,sc->value);
03962 
03963      case OP_SET_OUTPORT: /* set-output-port */
03964           sc->outport=car(sc->args);
03965           s_return(sc,sc->value);
03966 
03967      case OP_RDSEXPR:
03968           switch (sc->tok) {
03969           case TOK_EOF:
03970         s_return(sc,sc->EOF_OBJ);
03971         /* NOTREACHED */
03972 /*
03973  * Commented out because we now skip comments in the scanner
03974  *
03975           case TOK_COMMENT: {
03976                int c;
03977                while ((c=inchar(sc)) != '\n' && c!=EOF)
03978                     ;
03979                sc->tok = token(sc);
03980                s_goto(sc,OP_RDSEXPR);
03981           }
03982 */
03983           case TOK_VEC:
03984                s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
03985                /* fall through */
03986           case TOK_LPAREN:
03987                sc->tok = token(sc);
03988                if (sc->tok == TOK_RPAREN) {
03989                     s_return(sc,sc->NIL);
03990                } else if (sc->tok == TOK_DOT) {
03991                     Error_0(sc,"syntax error: illegal dot expression");
03992                } else {
03993                     sc->nesting_stack[sc->file_i]++;
03994                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
03995                     s_goto(sc,OP_RDSEXPR);
03996                }
03997           case TOK_QUOTE:
03998                s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
03999                sc->tok = token(sc);
04000                s_goto(sc,OP_RDSEXPR);
04001           case TOK_BQUOTE:
04002                sc->tok = token(sc);
04003            if(sc->tok==TOK_VEC) {
04004          s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
04005          sc->tok=TOK_LPAREN;
04006          s_goto(sc,OP_RDSEXPR);
04007            } else {
04008          s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
04009            }
04010                s_goto(sc,OP_RDSEXPR);
04011           case TOK_COMMA:
04012                s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
04013                sc->tok = token(sc);
04014                s_goto(sc,OP_RDSEXPR);
04015           case TOK_ATMARK:
04016                s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
04017                sc->tok = token(sc);
04018                s_goto(sc,OP_RDSEXPR);
04019           case TOK_ATOM:
04020                s_return(sc,mk_atom(sc, readstr_upto(sc, "();\t\n\r ")));
04021           case TOK_DQUOTE:
04022                x=readstrexp(sc);
04023            if(x==sc->F) {
04024          Error_0(sc,"Error reading string");
04025            }
04026                setimmutable(x);
04027                s_return(sc,x);
04028           case TOK_SHARP: {
04029                cell_ptr f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
04030                if(f==sc->NIL) {
04031                     Error_0(sc,"undefined sharp expression");
04032                } else {
04033                     sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
04034                     s_goto(sc,OP_EVAL);
04035                }
04036           }
04037           case TOK_SHARP_CONST:
04038                if ((x = mk_sharp_const(sc, readstr_upto(sc, "();\t\n\r "))) == sc->NIL) {
04039                     Error_0(sc,"undefined sharp expression");
04040                } else {
04041                     s_return(sc,x);
04042                }
04043           default:
04044                Error_0(sc,"syntax error: illegal token");
04045           }
04046           break;
04047 
04048      case OP_RDLIST: {
04049           sc->args = cons(sc, sc->value, sc->args);
04050           sc->tok = token(sc);
04051 /* We now skip comments in the scanner
04052 
04053           while (sc->tok == TOK_COMMENT) {
04054                int c;
04055                while ((c=inchar(sc)) != '\n' && c!=EOF)
04056                     ;
04057                sc->tok = token(sc);
04058           }
04059 */
04060       if(sc->tok == TOK_EOF)
04061            { s_return(sc,sc->EOF_OBJ); }
04062       else if (sc->tok == TOK_RPAREN) {
04063                int c = inchar(sc);
04064                if (c != '\n')
04065                  backchar(sc,c);
04066 #if SHOW_ERROR_LINE
04067                else
04068                   sc->load_stack[sc->file_i].rep.stdio.curr_line++;
04069 #endif
04070                sc->nesting_stack[sc->file_i]--;
04071                s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
04072           } else if (sc->tok == TOK_DOT) {
04073                s_save(sc,OP_RDDOT, sc->args, sc->NIL);
04074                sc->tok = token(sc);
04075                s_goto(sc,OP_RDSEXPR);
04076           } else {
04077                s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
04078                s_goto(sc,OP_RDSEXPR);
04079           }
04080      }
04081 
04082      case OP_RDDOT:
04083           if (token(sc) != TOK_RPAREN) {
04084                Error_0(sc,"syntax error: illegal dot expression");
04085           } else {
04086                sc->nesting_stack[sc->file_i]--;
04087                s_return(sc,reverse_in_place(sc, sc->value, sc->args));
04088           }
04089 
04090      case OP_RDQUOTE:
04091           s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
04092 
04093      case OP_RDQQUOTE:
04094           s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
04095 
04096      case OP_RDQQUOTEVEC:
04097        s_return(sc,cons(sc, mk_symbol(sc,"apply"),
04098             cons(sc, mk_symbol(sc,"vector"),
04099                  cons(sc,cons(sc, sc->QQUOTE,
04100                   cons(sc,sc->value,sc->NIL)),
04101                   sc->NIL))));
04102 
04103      case OP_RDUNQUOTE:
04104           s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
04105 
04106      case OP_RDUQTSP:
04107           s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
04108 
04109      case OP_RDVEC:
04110           /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
04111           s_goto(sc,OP_EVAL); Cannot be quoted*/
04112        /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
04113      s_return(sc,x); Cannot be part of pairs*/
04114        /*sc->code=mk_proc(sc,OP_VECTOR);
04115        sc->args=sc->value;
04116        s_goto(sc,OP_APPLY);*/
04117        sc->args=sc->value;
04118        s_goto(sc,OP_VECTOR);
04119 
04120      /* ========== printing part ========== */
04121      case OP_P0LIST:
04122           if(is_vector(sc->args)) {
04123                putstr(sc,"#(");
04124                sc->args=cons(sc,sc->args,mk_integer(sc,0));
04125                s_goto(sc,OP_PVECFROM);
04126           } else if(is_environment(sc->args)) {
04127                putstr(sc,"#<ENVIRONMENT>");
04128                s_return(sc,sc->T);
04129           } else if (!is_pair(sc->args)) {
04130                printatom(sc, sc->args, sc->print_flag);
04131                s_return(sc,sc->T);
04132           } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
04133                putstr(sc, "'");
04134                sc->args = cadr(sc->args);
04135                s_goto(sc,OP_P0LIST);
04136           } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
04137                putstr(sc, "`");
04138                sc->args = cadr(sc->args);
04139                s_goto(sc,OP_P0LIST);
04140           } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
04141                putstr(sc, ",");
04142                sc->args = cadr(sc->args);
04143                s_goto(sc,OP_P0LIST);
04144           } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
04145                putstr(sc, ",@");
04146                sc->args = cadr(sc->args);
04147                s_goto(sc,OP_P0LIST);
04148           } else {
04149                putstr(sc, "(");
04150                s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
04151                sc->args = car(sc->args);
04152                s_goto(sc,OP_P0LIST);
04153           }
04154 
04155      case OP_P1LIST:
04156           if (is_pair(sc->args)) {
04157         s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
04158         putstr(sc, " ");
04159         sc->args = car(sc->args);
04160         s_goto(sc,OP_P0LIST);
04161       } else if(is_vector(sc->args)) {
04162         s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
04163         putstr(sc, " . ");
04164         s_goto(sc,OP_P0LIST);
04165           } else {
04166         if (sc->args != sc->NIL) {
04167           putstr(sc, " . ");
04168           printatom(sc, sc->args, sc->print_flag);
04169         }
04170         putstr(sc, ")");
04171         s_return(sc,sc->T);
04172           }
04173      case OP_PVECFROM: {
04174           int i=ivalue_unchecked(cdr(sc->args));
04175           cell_ptr vec=car(sc->args);
04176           int len=ivalue_unchecked(vec);
04177           if(i==len) {
04178                putstr(sc,")");
04179                s_return(sc,sc->T);
04180           } else {
04181                cell_ptr elem=vector_elem(vec,i);
04182                ivalue_unchecked(cdr(sc->args))=i+1;
04183                s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
04184                sc->args=elem;
04185                putstr(sc," ");
04186                s_goto(sc,OP_P0LIST);
04187           }
04188      }
04189 
04190      default:
04191           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
04192           Error_0(sc,sc->strbuff);
04193 
04194      }
04195      return sc->T;
04196 }
04197 
04198 static cell_ptr opexe_6(scheme *sc, enum scheme_opcodes op) {
04199      cell_ptr x, y;
04200      long v;
04201 
04202      switch (op) {
04203      case OP_LIST_LENGTH:     /* length */   /* a.k */
04204           v=list_length(sc,car(sc->args));
04205           if(v<0) {
04206                Error_1(sc,"length: not a list:",car(sc->args));
04207           }
04208           s_return(sc,mk_integer(sc, v));
04209 
04210      case OP_ASSQ:       /* assq */     /* a.k */
04211           x = car(sc->args);
04212           for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
04213                if (!is_pair(car(y))) {
04214                     Error_0(sc,"unable to handle non pair element");
04215                }
04216                if (x == caar(y))
04217                     break;
04218           }
04219           if (is_pair(y)) {
04220                s_return(sc,car(y));
04221           } else {
04222                s_return(sc,sc->F);
04223           }
04224 
04225 
04226      case OP_GET_CLOSURE:     /* get-closure-code */   /* a.k */
04227           sc->args = car(sc->args);
04228           if (sc->args == sc->NIL) {
04229                s_return(sc,sc->F);
04230           } else if (is_closure(sc->args)) {
04231                s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
04232           } else if (is_macro(sc->args)) {
04233                s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
04234           } else {
04235                s_return(sc,sc->F);
04236           }
04237      case OP_CLOSUREP:        /* closure? */
04238           /*
04239            * Note, macro object is also a closure.
04240            * Therefore, (closure? <#MACRO>) ==> #t
04241            */
04242           s_retbool(is_closure(car(sc->args)));
04243      case OP_MACROP:          /* macro? */
04244           s_retbool(is_macro(car(sc->args)));
04245      default:
04246           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
04247           Error_0(sc,sc->strbuff);
04248      }
04249      return sc->T; /* NOTREACHED */
04250 }
04251 
04252 typedef cell_ptr (*dispatch_func)(scheme *, enum scheme_opcodes);
04253 
04254 typedef int (*test_predicate)(cell_ptr);
04255 static int is_any(cell_ptr p) { return 1;}
04256 
04257 static int is_nonneg(cell_ptr p) {
04258   return is_integer(p) && ivalue(p)>=0;
04259 }
04260 
04261 /* Correspond carefully with following defines! */
04262 static struct {
04263   test_predicate fct;
04264   const char *kind;
04265 } tests[]={
04266   {0,0}, /* unused */
04267   {is_any, 0},
04268   {is_string, "string"},
04269   {is_symbol, "symbol"},
04270   {is_port, "port"},
04271   {is_inport,"input port"},
04272   {is_outport,"output port"},
04273   {is_environment, "environment"},
04274   {is_pair, "pair"},
04275   {0, "pair or '()"},
04276   {is_character, "character"},
04277   {is_vector, "vector"},
04278   {is_number, "number"},
04279   {is_integer, "integer"},
04280   {is_nonneg, "non-negative integer"}
04281 };
04282 
04283 #define TST_NONE 0
04284 #define TST_ANY "\001"
04285 #define TST_STRING "\002"
04286 #define TST_SYMBOL "\003"
04287 #define TST_PORT "\004"
04288 #define TST_INPORT "\005"
04289 #define TST_OUTPORT "\006"
04290 #define TST_ENVIRONMENT "\007"
04291 #define TST_PAIR "\010"
04292 #define TST_LIST "\011"
04293 #define TST_CHAR "\012"
04294 #define TST_VECTOR "\013"
04295 #define TST_NUMBER "\014"
04296 #define TST_INTEGER "\015"
04297 #define TST_NATURAL "\016"
04298 
04299 typedef struct {
04300   dispatch_func func;
04301   char *name;
04302   int min_arity;
04303   int max_arity;
04304   char *arg_tests_encoding;
04305 } op_code_info;
04306 
04307 #define INF_ARG 0xffff
04308 
04309 static op_code_info dispatch_table[]= {
04310 #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
04311 #include "opdefines.h"
04312   { 0 }
04313 };
04314 
04315 static const char *procname(cell_ptr x) {
04316  int n=procnum(x);
04317  const char *name=dispatch_table[n].name;
04318  if(name==0) {
04319      name="ILLEGAL!";
04320  }
04321  return name;
04322 }
04323 
04324 /* kernel of this interpreter */
04325 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
04326   sc->op = op;
04327   for (;;) {
04328     op_code_info *pcd=dispatch_table+sc->op;
04329     if (pcd->name!=0) { /* if built-in function, check arguments */
04330       char msg[STRBUFFSIZE];
04331       int ok=1;
04332       int n=list_length(sc,sc->args);
04333 
04334       /* Check number of arguments */
04335       if(n<pcd->min_arity) {
04336     ok=0;
04337     snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
04338         pcd->name,
04339         pcd->min_arity==pcd->max_arity?"":" at least",
04340         pcd->min_arity);
04341       }
04342       if(ok && n>pcd->max_arity) {
04343     ok=0;
04344     snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
04345         pcd->name,
04346         pcd->min_arity==pcd->max_arity?"":" at most",
04347         pcd->max_arity);
04348       }
04349       if(ok) {
04350     if(pcd->arg_tests_encoding!=0) {
04351       int i=0;
04352       int j;
04353       const char *t=pcd->arg_tests_encoding;
04354       cell_ptr arglist=sc->args;
04355       do {
04356         cell_ptr arg=car(arglist);
04357         j=(int)t[0];
04358         if(j==TST_LIST[0]) {
04359               if(arg!=sc->NIL && !is_pair(arg)) break;
04360         } else {
04361           if(!tests[j].fct(arg)) break;
04362         }
04363 
04364         if(t[1]!=0) {/* last test is replicated as necessary */
04365           t++;
04366         }
04367         arglist=cdr(arglist);
04368         i++;
04369       } while(i<n);
04370       if(i<n) {
04371         ok=0;
04372         snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
04373             pcd->name,
04374             i+1,
04375             tests[j].kind);
04376       }
04377     }
04378       }
04379       if(!ok) {
04380     if(_Error_1(sc,msg,0)==sc->NIL) {
04381       return;
04382     }
04383     pcd=dispatch_table+sc->op;
04384       }
04385     }
04386     ok_to_freely_gc(sc);
04387     if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
04388       return;
04389     }
04390     if(sc->no_memory) {
04391       fprintf(stderr,"No memory!\n");
04392       return;
04393     }
04394   }
04395 }
04396 
04397 /* ========== Initialization of internal keywords ========== */
04398 
04399 static void assign_syntax(scheme *sc, char *name) {
04400      cell_ptr x;
04401 
04402      x = oblist_add_by_name(sc, name);
04403      typeflag(x) |= T_SYNTAX;
04404 }
04405 
04406 static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
04407      cell_ptr x, y;
04408 
04409      x = mk_symbol(sc, name);
04410      y = mk_proc(sc,op);
04411      new_slot_in_env(sc, x, y);
04412 }
04413 
04414 static cell_ptr mk_proc(scheme *sc, enum scheme_opcodes op) {
04415      cell_ptr y;
04416 
04417      y = get_cell(sc, sc->NIL, sc->NIL);
04418      typeflag(y) = (T_PROC | T_ATOM);
04419      ivalue_unchecked(y) = (long) op;
04420      set_num_integer(y);
04421      return y;
04422 }
04423 
04424 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
04425 static int syntaxnum(cell_ptr p) {
04426      const char *s=strvalue(car(p));
04427      switch(strlength(car(p))) {
04428      case 2:
04429           if(s[0]=='i') return OP_IF0;        /* if */
04430           else return OP_OR0;                 /* or */
04431      case 3:
04432           if(s[0]=='a') return OP_AND0;      /* and */
04433           else return OP_LET0;               /* let */
04434      case 4:
04435           switch(s[3]) {
04436           case 'e': return OP_CASE0;         /* case */
04437           case 'd': return OP_COND0;         /* cond */
04438           case '*': return OP_LET0AST;       /* let* */
04439           default: return OP_SET0;           /* set! */
04440           }
04441      case 5:
04442           switch(s[2]) {
04443           case 'g': return OP_BEGIN;         /* begin */
04444           case 'l': return OP_DELAY;         /* delay */
04445           case 'c': return OP_MACRO0;        /* macro */
04446           default: return OP_QUOTE;          /* quote */
04447           }
04448      case 6:
04449           switch(s[2]) {
04450           case 'm': return OP_LAMBDA;        /* lambda */
04451           case 'f': return OP_DEF0;          /* define */
04452           default: return OP_LET0REC;        /* letrec */
04453           }
04454      default:
04455           return OP_C0STREAM;                /* cons-stream */
04456      }
04457 }
04458 
04459 /* initialization of TinyScheme */
04460 #if USE_INTERFACE
04461 INTERFACE static cell_ptr s_cons(scheme *sc, cell_ptr a, cell_ptr b) {
04462  return cons(sc,a,b);
04463 }
04464 INTERFACE static cell_ptr s_immutable_cons(scheme *sc, cell_ptr a, cell_ptr b) {
04465  return immutable_cons(sc,a,b);
04466 }
04467 
04468 static struct scheme_interface vtbl ={
04469   scheme_define,
04470   s_cons,
04471   s_immutable_cons,
04472   reserve_cells,
04473   mk_integer,
04474   mk_real,
04475   mk_symbol,
04476   gensym,
04477   mk_string,
04478   mk_counted_string,
04479   mk_character,
04480   mk_vector,
04481   mk_foreign_func,
04482   putstr,
04483   putcharacter,
04484 
04485   is_string,
04486   string_value,
04487   is_number,
04488   nvalue,
04489   ivalue,
04490   rvalue,
04491   is_integer,
04492   is_real,
04493   is_character,
04494   charvalue,
04495   is_list,
04496   is_vector,
04497   list_length,
04498   ivalue,
04499   fill_vector,
04500   vector_elem,
04501   set_vector_elem,
04502   is_port,
04503   is_pair,
04504   pair_car,
04505   pair_cdr,
04506   set_car,
04507   set_cdr,
04508 
04509   is_symbol,
04510   symname,
04511 
04512   is_syntax,
04513   is_proc,
04514   is_foreign,
04515   syntaxname,
04516   is_closure,
04517   is_macro,
04518   closure_code,
04519   closure_env,
04520 
04521   is_continuation,
04522   is_promise,
04523   is_environment,
04524   is_immutable,
04525   setimmutable,
04526 
04527   scheme_load_file,
04528   scheme_load_string
04529 };
04530 #endif
04531 
04532 scheme *scheme_init_new() {
04533   scheme *sc=(scheme*)malloc(sizeof(scheme));
04534   if(!scheme_init(sc)) {
04535     free(sc);
04536     return 0;
04537   } else {
04538     return sc;
04539   }
04540 }
04541 
04542 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
04543   scheme *sc=(scheme*)malloc(sizeof(scheme));
04544   if(!scheme_init_custom_alloc(sc,malloc,free)) {
04545     free(sc);
04546     return 0;
04547   } else {
04548     return sc;
04549   }
04550 }
04551 
04552 
04553 int scheme_init(scheme *sc) {
04554  return scheme_init_custom_alloc(sc,malloc,free);
04555 }
04556 
04557 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
04558   int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
04559   cell_ptr x;
04560 
04561   num_zero.is_fixnum=1;
04562   num_zero.value.ivalue=0;
04563   num_one.is_fixnum=1;
04564   num_one.value.ivalue=1;
04565 
04566 #if USE_INTERFACE
04567   sc->vptr=&vtbl;
04568 #endif
04569   sc->gensym_cnt=0;
04570   sc->malloc=malloc;
04571   sc->free=free;
04572   sc->last_cell_seg = -1;
04573   sc->sink = &sc->_sink;
04574   sc->NIL = &sc->_NIL;
04575   sc->T = &sc->_HASHT;
04576   sc->F = &sc->_HASHF;
04577   sc->EOF_OBJ=&sc->_EOF_OBJ;
04578   sc->free_cell = &sc->_NIL;
04579   sc->fcells = 0;
04580   sc->no_memory=0;
04581   sc->inport=sc->NIL;
04582   sc->outport=sc->NIL;
04583   sc->save_inport=sc->NIL;
04584   sc->loadport=sc->NIL;
04585   sc->nesting=0;
04586   sc->interactive_repl=0;
04587 
04588   if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
04589     sc->no_memory=1;
04590     return 0;
04591   }
04592   sc->gc_verbose = 0;
04593   dump_stack_initialize(sc);
04594   sc->code = sc->NIL;
04595   sc->tracing=0;
04596 
04597   /* init sc->NIL */
04598   typeflag(sc->NIL) = (T_ATOM | MARK);
04599   car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
04600   /* init T */
04601   typeflag(sc->T) = (T_ATOM | MARK);
04602   car(sc->T) = cdr(sc->T) = sc->T;
04603   /* init F */
04604   typeflag(sc->F) = (T_ATOM | MARK);
04605   car(sc->F) = cdr(sc->F) = sc->F;
04606   /* init sink */
04607   typeflag(sc->sink) = (T_PAIR | MARK);
04608   car(sc->sink) = sc->NIL;
04609   /* init c_nest */
04610   sc->c_nest = sc->NIL;
04611 
04612   sc->oblist = oblist_initial_value(sc);
04613   /* init global_env */
04614   new_frame_in_env(sc, sc->NIL);
04615   sc->global_env = sc->envir;
04616   /* init else */
04617   x = mk_symbol(sc,"else");
04618   new_slot_in_env(sc, x, sc->T);
04619 
04620   assign_syntax(sc, "lambda");
04621   assign_syntax(sc, "quote");
04622   assign_syntax(sc, "define");
04623   assign_syntax(sc, "if");
04624   assign_syntax(sc, "begin");
04625   assign_syntax(sc, "set!");
04626   assign_syntax(sc, "let");
04627   assign_syntax(sc, "let*");
04628   assign_syntax(sc, "letrec");
04629   assign_syntax(sc, "cond");
04630   assign_syntax(sc, "delay");
04631   assign_syntax(sc, "and");
04632   assign_syntax(sc, "or");
04633   assign_syntax(sc, "cons-stream");
04634   assign_syntax(sc, "macro");
04635   assign_syntax(sc, "case");
04636 
04637   for(i=0; i<n; i++) {
04638     if(dispatch_table[i].name!=0) {
04639       assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
04640     }
04641   }
04642 
04643   /* initialization of global pointers to special symbols */
04644   sc->LAMBDA = mk_symbol(sc, "lambda");
04645   sc->QUOTE = mk_symbol(sc, "quote");
04646   sc->QQUOTE = mk_symbol(sc, "quasiquote");
04647   sc->UNQUOTE = mk_symbol(sc, "unquote");
04648   sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
04649   sc->FEED_TO = mk_symbol(sc, "=>");
04650   sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
04651   sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
04652   sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
04653   sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
04654 
04655   return !sc->no_memory;
04656 }
04657 
04658 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
04659   sc->inport=port_from_file(sc,fin,port_input);
04660 }
04661 
04662 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
04663   sc->inport=port_from_string(sc,start,past_the_end,port_input);
04664 }
04665 
04666 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
04667   sc->outport=port_from_file(sc,fout,port_output);
04668 }
04669 
04670 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
04671   sc->outport=port_from_string(sc,start,past_the_end,port_output);
04672 }
04673 
04674 void scheme_set_external_data(scheme *sc, void *p) {
04675  sc->ext_data=p;
04676 }
04677 
04678 void scheme_deinit(scheme *sc) {
04679   int i;
04680 
04681 #if SHOW_ERROR_LINE
04682   char *fname;
04683 #endif
04684 
04685   sc->oblist=sc->NIL;
04686   sc->global_env=sc->NIL;
04687   dump_stack_free(sc);
04688   sc->envir=sc->NIL;
04689   sc->code=sc->NIL;
04690   sc->args=sc->NIL;
04691   sc->value=sc->NIL;
04692   if(is_port(sc->inport)) {
04693     typeflag(sc->inport) = T_ATOM;
04694   }
04695   sc->inport=sc->NIL;
04696   sc->outport=sc->NIL;
04697   if(is_port(sc->save_inport)) {
04698     typeflag(sc->save_inport) = T_ATOM;
04699   }
04700   sc->save_inport=sc->NIL;
04701   if(is_port(sc->loadport)) {
04702     typeflag(sc->loadport) = T_ATOM;
04703   }
04704   sc->loadport=sc->NIL;
04705   sc->gc_verbose=0;
04706   gc(sc,sc->NIL,sc->NIL);
04707 
04708   for(i=0; i<=sc->last_cell_seg; i++) {
04709     sc->free(sc->alloc_seg[i]);
04710   }
04711 
04712 #if SHOW_ERROR_LINE
04713   fname = sc->load_stack[i].rep.stdio.filename;
04714 
04715   for(i=0; i<sc->file_i; i++) {
04716     if(fname)
04717       sc->free(fname);
04718   }
04719 #endif
04720 }
04721 
04722 void scheme_load_file(scheme *sc, FILE *fin)
04723 { scheme_load_named_file(sc,fin,0); }
04724 void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
04725   dump_stack_reset(sc);
04726   sc->envir = sc->global_env;
04727   sc->file_i=0;
04728   sc->load_stack[0].kind=port_input|port_file;
04729   sc->load_stack[0].rep.stdio.file=fin;
04730   sc->loadport=mk_port(sc,sc->load_stack);
04731   sc->retcode=0;
04732   if(fin==stdin) {
04733     sc->interactive_repl=1;
04734   }
04735 
04736 #if SHOW_ERROR_LINE
04737   sc->load_stack[0].rep.stdio.curr_line = 0;
04738   if(fin!=stdin && filename)
04739     sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
04740 #endif
04741 
04742   sc->inport=sc->loadport;
04743   sc->args = mk_integer(sc,sc->file_i);
04744   Eval_Cycle(sc, OP_T0LVL);
04745   typeflag(sc->loadport)=T_ATOM;
04746   if(sc->retcode==0) {
04747     sc->retcode=sc->nesting!=0;
04748   }
04749 }
04750 
04751 void scheme_load_string(scheme *sc, const char *cmd) {
04752   dump_stack_reset(sc);
04753   sc->envir = sc->global_env;
04754   sc->file_i=0;
04755   sc->load_stack[0].kind=port_input|port_string;
04756   sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
04757   sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
04758   sc->load_stack[0].rep.string.curr=(char*)cmd;
04759   sc->loadport=mk_port(sc,sc->load_stack);
04760   sc->retcode=0;
04761   sc->interactive_repl=0;
04762   sc->inport=sc->loadport;
04763   sc->args = mk_integer(sc,sc->file_i);
04764   Eval_Cycle(sc, OP_T0LVL);
04765   typeflag(sc->loadport)=T_ATOM;
04766   if(sc->retcode==0) {
04767     sc->retcode=sc->nesting!=0;
04768   }
04769 }
04770 
04771 void scheme_define(scheme *sc, cell_ptr envir, cell_ptr symbol, cell_ptr value) {
04772      cell_ptr x;
04773 
04774      x=find_slot_in_env(sc,envir,symbol,0);
04775      if (x != sc->NIL) {
04776           set_slot_in_env(sc, x, value);
04777      } else {
04778           new_slot_spec_in_env(sc, envir, symbol, value);
04779      }
04780 }
04781 
04782 #if !STANDALONE
04783 void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
04784 {
04785   scheme_define(sc,
04786                 sc->global_env,
04787                 mk_symbol(sc,sr->name),
04788                 mk_foreign_func(sc, sr->f));
04789 }
04790 
04791 void scheme_register_foreign_func_list(scheme * sc,
04792                                        scheme_registerable * list,
04793                                        int count)
04794 {
04795   int i;
04796   for(i = 0; i < count; i++)
04797     {
04798       scheme_register_foreign_func(sc, list + i);
04799     }
04800 }
04801 
04802 cell_ptr scheme_apply0(scheme *sc, const char *procname)
04803 { return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
04804 
04805 void save_from_C_call(scheme *sc)
04806 {
04807   cell_ptr saved_data =
04808     cons(sc,
04809          car(sc->sink),
04810          cons(sc,
04811               sc->envir,
04812               sc->dump));
04813   /* Push */
04814   sc->c_nest = cons(sc, saved_data, sc->c_nest);
04815   /* Truncate the dump stack so TS will return here when done, not
04816      directly resume pre-C-call operations. */
04817   dump_stack_reset(sc);
04818 }
04819 void restore_from_C_call(scheme *sc)
04820 {
04821   car(sc->sink) = caar(sc->c_nest);
04822   sc->envir = cadar(sc->c_nest);
04823   sc->dump = cdr(cdar(sc->c_nest));
04824   /* Pop */
04825   sc->c_nest = cdr(sc->c_nest);
04826 }
04827 
04828 /* "func" and "args" are assumed to be already eval'ed. */
04829 cell_ptr scheme_call(scheme *sc, cell_ptr func, cell_ptr args)
04830 {
04831   int old_repl = sc->interactive_repl;
04832   sc->interactive_repl = 0;
04833   save_from_C_call(sc);
04834   sc->envir = sc->global_env;
04835   sc->args = args;
04836   sc->code = func;
04837   sc->retcode = 0;
04838   Eval_Cycle(sc, OP_APPLY);
04839   sc->interactive_repl = old_repl;
04840   restore_from_C_call(sc);
04841   return sc->value;
04842 }
04843 
04844 cell_ptr scheme_eval(scheme *sc, cell_ptr obj)
04845 {
04846   int old_repl = sc->interactive_repl;
04847   sc->interactive_repl = 0;
04848   save_from_C_call(sc);
04849   sc->args = sc->NIL;
04850   sc->code = obj;
04851   sc->retcode = 0;
04852   Eval_Cycle(sc, OP_EVAL);
04853   sc->interactive_repl = old_repl;
04854   restore_from_C_call(sc);
04855   return sc->value;
04856 }
04857 
04858 
04859 #endif
04860 
04861 /* ========== Main ========== */
04862 
04863 #if STANDALONE
04864 
04865 #if defined(__APPLE__) && !defined (OSX)
04866 int main()
04867 {
04868      extern MacTS_main(int argc, char **argv);
04869      char**    argv;
04870      int argc = ccommand(&argv);
04871      MacTS_main(argc,argv);
04872      return 0;
04873 }
04874 int MacTS_main(int argc, char **argv) {
04875 #else
04876 int main(int argc, char **argv) {
04877 #endif
04878   scheme sc;
04879   FILE *fin;
04880   char *file_name=InitFile;
04881   int retcode;
04882   int isfile=1;
04883 
04884   if(argc==1) {
04885     printf(banner);
04886   }
04887   if(argc==2 && strcmp(argv[1],"-?")==0) {
04888     printf("Usage: tinyscheme -?\n");
04889     printf("or:    tinyscheme [<file1> <file2> ...]\n");
04890     printf("followed by\n");
04891     printf("          -1 <file> [<arg1> <arg2> ...]\n");
04892     printf("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
04893     printf("assuming that the executable is named tinyscheme.\n");
04894     printf("Use - as filename for stdin.\n");
04895     return 1;
04896   }
04897   if(!scheme_init(&sc)) {
04898     fprintf(stderr,"Could not initialize!\n");
04899     return 2;
04900   }
04901   scheme_set_input_port_file(&sc, stdin);
04902   scheme_set_output_port_file(&sc, stdout);
04903 #if USE_DL
04904   scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
04905 #endif
04906   argv++;
04907   if(access(file_name,0)!=0) {
04908     char *p=getenv("TINYSCHEMEINIT");
04909     if(p!=0) {
04910       file_name=p;
04911     }
04912   }
04913   do {
04914     if(strcmp(file_name,"-")==0) {
04915       fin=stdin;
04916     } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
04917       cell_ptr args=sc.NIL;
04918       isfile=file_name[1]=='1';
04919       file_name=*argv++;
04920       if(strcmp(file_name,"-")==0) {
04921     fin=stdin;
04922       } else if(isfile) {
04923     fin=fopen(file_name,"r");
04924       }
04925       for(;*argv;argv++) {
04926     cell_ptr value=mk_string(&sc,*argv);
04927     args=cons(&sc,value,args);
04928       }
04929       args=reverse_in_place(&sc,sc.NIL,args);
04930       scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
04931 
04932     } else {
04933       fin=fopen(file_name,"r");
04934     }
04935     if(isfile && fin==0) {
04936       fprintf(stderr,"Could not open file %s\n",file_name);
04937     } else {
04938       if(isfile) {
04939         scheme_load_named_file(&sc,fin,file_name);
04940       } else {
04941         scheme_load_string(&sc,file_name);
04942       }
04943       if(!isfile || fin!=stdin) {
04944     if(sc.retcode!=0) {
04945       fprintf(stderr,"Errors encountered reading %s\n",file_name);
04946     }
04947     if(isfile) {
04948       fclose(fin);
04949     }
04950       }
04951     }
04952     file_name=*argv++;
04953   } while(file_name!=0);
04954   if(argc==1) {
04955     scheme_load_named_file(&sc,stdin,0);
04956   }
04957   retcode=sc.retcode;
04958   scheme_deinit(&sc);
04959 
04960   return retcode;
04961 }
04962 
04963 #endif
04964 
04965 /*
04966 Local variables:
04967 c-file-style: "k&r"
04968 End:
04969 */