tests/gpgscm/scheme.c

   1 /* T I N Y S C H E M E    1 . 4 1
   2  *   Dimitrios Souflis (dsouflis@acm.org)
   3  *   Based on MiniScheme (original credits follow)
   4  * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)
   5  * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
   6  * (MINISCM) This version has been modified by R.C. Secrist.
   7  * (MINISCM)
   8  * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
   9  * (MINISCM)
  10  * (MINISCM) This is a revised and modified version by Akira KIDA.
  11  * (MINISCM)    current version is 0.85k4 (15 May 1994)
  12  *
  13  */
  14
  15 #define _SCHEME_SOURCE
  16 #include "scheme-private.h"
  17 #ifndef WIN32
  18 # include <unistd.h>
  19 #endif
  20 #ifdef WIN32
  21 #define snprintf _snprintf
  22 #endif
  23 #if USE_DL
  24 # include "dynload.h"
  25 #endif
  26 #if USE_MATH
  27 # include <math.h>
  28 #endif
  29
  30 #include <limits.h>
  31 #include <float.h>
  32 #include <ctype.h>
  33
  34 #if USE_STRCASECMP
  35 #include <strings.h>
  36 # ifndef __APPLE__
  37 #  define stricmp strcasecmp
  38 # endif
  39 #endif
  40
  41 /* Used for documentation purposes, to signal functions in 'interface' */
  42 #define INTERFACE
  43
  44 #define TOK_EOF     (-1)
  45 #define TOK_LPAREN  0
  46 #define TOK_RPAREN  1
  47 #define TOK_DOT     2
  48 #define TOK_ATOM    3
  49 #define TOK_QUOTE   4
  50 #define TOK_COMMENT 5
  51 #define TOK_DQUOTE  6
  52 #define TOK_BQUOTE  7
  53 #define TOK_COMMA   8
  54 #define TOK_ATMARK  9
  55 #define TOK_SHARP   10
  56 #define TOK_SHARP_CONST 11
  57 #define TOK_VEC     12
  58
  59 #define BACKQUOTE '`'
  60 #define DELIMITERS  "()\";\f\t\v\n\r "
  61
  62 /*
  63  *  Basic memory allocation units
  64  */
  65
  66 #define banner "TinyScheme 1.41"
  67
  68 #include <string.h>
  69 #include <stdlib.h>
  70
  71 #ifdef __APPLE__
  72 static int stricmp(const char *s1, const char *s2)
  73 {
  74   unsigned char c1, c2;
  75   do {
  76     c1 = tolower(*s1);
  77     c2 = tolower(*s2);
  78     if (c1 < c2)
  79       return -1;
  80     else if (c1 > c2)
  81       return 1;
  82     s1++, s2++;
  83   } while (c1 != 0);
  84   return 0;
  85 }
  86 #endif /* __APPLE__ */
  87
  88 #if USE_STRLWR
  89 static const char *strlwr(char *s) {
  90   const char *p=s;
  91   while(*s) {
  92     *s=tolower(*s);
  93     s++;
  94   }
  95   return p;
  96 }
  97 #endif
  98
  99 #ifndef prompt
 100 # define prompt "ts> "
 101 #endif
 102
 103 #ifndef InitFile
 104 # define InitFile "init.scm"
 105 #endif
 106
 107 #ifndef FIRST_CELLSEGS
 108 # define FIRST_CELLSEGS 3
 109 #endif
 110
 111 enum scheme_types {
 112   T_STRING=1,
 113   T_NUMBER=2,
 114   T_SYMBOL=3,
 115   T_PROC=4,
 116   T_PAIR=5,
 117   T_CLOSURE=6,
 118   T_CONTINUATION=7,
 119   T_FOREIGN=8,
 120   T_CHARACTER=9,
 121   T_PORT=10,
 122   T_VECTOR=11,
 123   T_MACRO=12,
 124   T_PROMISE=13,
 125   T_ENVIRONMENT=14,
 126   T_LAST_SYSTEM_TYPE=14
 127 };
 128
 129 /* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
 130 #define ADJ 32
 131 #define TYPE_BITS 5
 132 #define T_MASKTYPE      31    /* 0000000000011111 */
 133 #define T_SYNTAX      4096    /* 0001000000000000 */
 134 #define T_IMMUTABLE   8192    /* 0010000000000000 */
 135 #define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
 136 #define CLRATOM      49151    /* 1011111111111111 */   /* only for gc */
 137 #define MARK         32768    /* 1000000000000000 */
 138 #define UNMARK       32767    /* 0111111111111111 */
 139
 140
 141 static num num_add(num a, num b);
 142 static num num_mul(num a, num b);
 143 static num num_div(num a, num b);
 144 static num num_intdiv(num a, num b);
 145 static num num_sub(num a, num b);
 146 static num num_rem(num a, num b);
 147 static num num_mod(num a, num b);
 148 static int num_eq(num a, num b);
 149 static int num_gt(num a, num b);
 150 static int num_ge(num a, num b);
 151 static int num_lt(num a, num b);
 152 static int num_le(num a, num b);
 153
 154 #if USE_MATH
 155 static double round_per_R5RS(double x);
 156 #endif
 157 static int is_zero_double(double x);
 158 static INLINE int num_is_integer(pointer p) {
 159   return ((p)->_object._number.is_fixnum);
 160 }
 161
 162 static num num_zero;
 163 static num num_one;
 164
 165 /* macros for cell operations */
 166 #define typeflag(p)      ((p)->_flag)
 167 #define type(p)          (typeflag(p)&T_MASKTYPE)
 168
 169 INTERFACE INLINE int is_string(pointer p)     { return (type(p)==T_STRING); }
 170 #define strvalue(p)      ((p)->_object._string._svalue)
 171 #define strlength(p)        ((p)->_object._string._length)
 172
 173 INTERFACE static int is_list(scheme *sc, pointer p);
 174 INTERFACE INLINE int is_vector(pointer p)    { return (type(p)==T_VECTOR); }
 175 INTERFACE static void fill_vector(pointer vec, pointer obj);
 176 INTERFACE static pointer vector_elem(pointer vec, int ielem);
 177 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
 178 INTERFACE INLINE int is_number(pointer p)    { return (type(p)==T_NUMBER); }
 179 INTERFACE INLINE int is_integer(pointer p) {
 180   if (!is_number(p))
 181       return 0;
 182   if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
 183       return 1;
 184   return 0;
 185 }
 186
 187 INTERFACE INLINE int is_real(pointer p) {
 188   return is_number(p) && (!(p)->_object._number.is_fixnum);
 189 }
 190
 191 INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
 192 INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
 193 INLINE num nvalue(pointer p)       { return ((p)->_object._number); }
 194 INTERFACE long ivalue(pointer p)      { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
 195 INTERFACE double rvalue(pointer p)    { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
 196 #define ivalue_unchecked(p)       ((p)->_object._number.value.ivalue)
 197 #define rvalue_unchecked(p)       ((p)->_object._number.value.rvalue)
 198 #define set_num_integer(p)   (p)->_object._number.is_fixnum=1;
 199 #define set_num_real(p)      (p)->_object._number.is_fixnum=0;
 200 INTERFACE  long charvalue(pointer p)  { return ivalue_unchecked(p); }
 201
 202 INTERFACE INLINE int is_port(pointer p)     { return (type(p)==T_PORT); }
 203 INTERFACE INLINE int is_inport(pointer p)  { return is_port(p) && p->_object._port->kind & port_input; }
 204 INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
 205
 206 INTERFACE INLINE int is_pair(pointer p)     { return (type(p)==T_PAIR); }
 207 #define car(p)           ((p)->_object._cons._car)
 208 #define cdr(p)           ((p)->_object._cons._cdr)
 209 INTERFACE pointer pair_car(pointer p)   { return car(p); }
 210 INTERFACE pointer pair_cdr(pointer p)   { return cdr(p); }
 211 INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
 212 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
 213
 214 INTERFACE INLINE int is_symbol(pointer p)   { return (type(p)==T_SYMBOL); }
 215 INTERFACE INLINE char *symname(pointer p)   { return strvalue(car(p)); }
 216 #if USE_PLIST
 217 SCHEME_EXPORT INLINE int hasprop(pointer p)     { return (typeflag(p)&T_SYMBOL); }
 218 #define symprop(p)       cdr(p)
 219 #endif
 220
 221 INTERFACE INLINE int is_syntax(pointer p)   { return (typeflag(p)&T_SYNTAX); }
 222 INTERFACE INLINE int is_proc(pointer p)     { return (type(p)==T_PROC); }
 223 INTERFACE INLINE int is_foreign(pointer p)  { return (type(p)==T_FOREIGN); }
 224 INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
 225 #define procnum(p)       ivalue(p)
 226 static const char *procname(pointer x);
 227
 228 INTERFACE INLINE int is_closure(pointer p)  { return (type(p)==T_CLOSURE); }
 229 INTERFACE INLINE int is_macro(pointer p)    { return (type(p)==T_MACRO); }
 230 INTERFACE INLINE pointer closure_code(pointer p)   { return car(p); }
 231 INTERFACE INLINE pointer closure_env(pointer p)    { return cdr(p); }
 232
 233 INTERFACE INLINE int is_continuation(pointer p)    { return (type(p)==T_CONTINUATION); }
 234 #define cont_dump(p)     cdr(p)
 235
 236 /* To do: promise should be forced ONCE only */
 237 INTERFACE INLINE int is_promise(pointer p)  { return (type(p)==T_PROMISE); }
 238
 239 INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
 240 #define setenvironment(p)    typeflag(p) = T_ENVIRONMENT
 241
 242 #define is_atom(p)       (typeflag(p)&T_ATOM)
 243 #define setatom(p)       typeflag(p) |= T_ATOM
 244 #define clratom(p)       typeflag(p) &= CLRATOM
 245
 246 #define is_mark(p)       (typeflag(p)&MARK)
 247 #define setmark(p)       typeflag(p) |= MARK
 248 #define clrmark(p)       typeflag(p) &= UNMARK
 249
 250 INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
 251 /*#define setimmutable(p)  typeflag(p) |= T_IMMUTABLE*/
 252 INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
 253
 254 #define caar(p)          car(car(p))
 255 #define cadr(p)          car(cdr(p))
 256 #define cdar(p)          cdr(car(p))
 257 #define cddr(p)          cdr(cdr(p))
 258 #define cadar(p)         car(cdr(car(p)))
 259 #define caddr(p)         car(cdr(cdr(p)))
 260 #define cdaar(p)         cdr(car(car(p)))
 261 #define cadaar(p)        car(cdr(car(car(p))))
 262 #define cadddr(p)        car(cdr(cdr(cdr(p))))
 263 #define cddddr(p)        cdr(cdr(cdr(cdr(p))))
 264
 265 #if USE_CHAR_CLASSIFIERS
 266 static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
 267 static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
 268 static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
 269 static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
 270 static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
 271 #endif
 272
 273 #if USE_ASCII_NAMES
 274 static const char *charnames[32]={
 275  "nul",
 276  "soh",
 277  "stx",
 278  "etx",
 279  "eot",
 280  "enq",
 281  "ack",
 282  "bel",
 283  "bs",
 284  "ht",
 285  "lf",
 286  "vt",
 287  "ff",
 288  "cr",
 289  "so",
 290  "si",
 291  "dle",
 292  "dc1",
 293  "dc2",
 294  "dc3",
 295  "dc4",
 296  "nak",
 297  "syn",
 298  "etb",
 299  "can",
 300  "em",
 301  "sub",
 302  "esc",
 303  "fs",
 304  "gs",
 305  "rs",
 306  "us"
 307 };
 308
 309 static int is_ascii_name(const char *name, int *pc) {
 310   int i;
 311   for(i=0; i<32; i++) {
 312      if(stricmp(name,charnames[i])==0) {
 313           *pc=i;
 314           return 1;
 315      }
 316   }
 317   if(stricmp(name,"del")==0) {
 318      *pc=127;
 319      return 1;
 320   }
 321   return 0;
 322 }
 323
 324 #endif
 325
 326 static int file_push(scheme *sc, const char *fname);
 327 static void file_pop(scheme *sc);
 328 static int file_interactive(scheme *sc);
 329 static INLINE int is_one_of(char *s, int c);
 330 static int alloc_cellseg(scheme *sc, int n);
 331 static long binary_decode(const char *s);
 332 static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
 333 static pointer _get_cell(scheme *sc, pointer a, pointer b);
 334 static pointer reserve_cells(scheme *sc, int n);
 335 static pointer get_consecutive_cells(scheme *sc, int n);
 336 static pointer find_consecutive_cells(scheme *sc, int n);
 337 static void finalize_cell(scheme *sc, pointer a);
 338 static int count_consecutive_cells(pointer x, int needed);
 339 static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
 340 static pointer mk_number(scheme *sc, num n);
 341 static char *store_string(scheme *sc, int len, const char *str, char fill);
 342 static pointer mk_vector(scheme *sc, int len);
 343 static pointer mk_atom(scheme *sc, char *q);
 344 static pointer mk_sharp_const(scheme *sc, char *name);
 345 static pointer mk_port(scheme *sc, port *p);
 346 static pointer port_from_filename(scheme *sc, const char *fn, int prop);
 347 static pointer port_from_file(scheme *sc, FILE *, int prop);
 348 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
 349 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
 350 static port *port_rep_from_file(scheme *sc, FILE *, int prop);
 351 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
 352 static void port_close(scheme *sc, pointer p, int flag);
 353 static void mark(pointer a);
 354 static void gc(scheme *sc, pointer a, pointer b);
 355 static int basic_inchar(port *pt);
 356 static int inchar(scheme *sc);
 357 static void backchar(scheme *sc, int c);
 358 static char   *readstr_upto(scheme *sc, char *delim);
 359 static pointer readstrexp(scheme *sc);
 360 static INLINE int skipspace(scheme *sc);
 361 static int token(scheme *sc);
 362 static void printslashstring(scheme *sc, char *s, int len);
 363 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
 364 static void printatom(scheme *sc, pointer l, int f);
 365 static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
 366 static pointer mk_closure(scheme *sc, pointer c, pointer e);
 367 static pointer mk_continuation(scheme *sc, pointer d);
 368 static pointer reverse(scheme *sc, pointer a);
 369 static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
 370 static pointer revappend(scheme *sc, pointer a, pointer b);
 371 static void dump_stack_mark(scheme *);
 372 static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
 373 static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
 374 static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
 375 static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
 376 static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
 377 static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
 378 static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
 379 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
 380 static void assign_syntax(scheme *sc, char *name);
 381 static int syntaxnum(pointer p);
 382 static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
 383
 384 #define num_ivalue(n)       (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
 385 #define num_rvalue(n)       (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
 386
 387 static num num_add(num a, num b) {
 388  num ret;
 389  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 390  if(ret.is_fixnum) {
 391      ret.value.ivalue= a.value.ivalue+b.value.ivalue;
 392  } else {
 393      ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
 394  }
 395  return ret;
 396 }
 397
 398 static num num_mul(num a, num b) {
 399  num ret;
 400  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 401  if(ret.is_fixnum) {
 402      ret.value.ivalue= a.value.ivalue*b.value.ivalue;
 403  } else {
 404      ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
 405  }
 406  return ret;
 407 }
 408
 409 static num num_div(num a, num b) {
 410  num ret;
 411  ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
 412  if(ret.is_fixnum) {
 413      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
 414  } else {
 415      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
 416  }
 417  return ret;
 418 }
 419
 420 static num num_intdiv(num a, num b) {
 421  num ret;
 422  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 423  if(ret.is_fixnum) {
 424      ret.value.ivalue= a.value.ivalue/b.value.ivalue;
 425  } else {
 426      ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
 427  }
 428  return ret;
 429 }
 430
 431 static num num_sub(num a, num b) {
 432  num ret;
 433  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 434  if(ret.is_fixnum) {
 435      ret.value.ivalue= a.value.ivalue-b.value.ivalue;
 436  } else {
 437      ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
 438  }
 439  return ret;
 440 }
 441
 442 static num num_rem(num a, num b) {
 443  num ret;
 444  long e1, e2, res;
 445  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 446  e1=num_ivalue(a);
 447  e2=num_ivalue(b);
 448  res=e1%e2;
 449  /* remainder should have same sign as second operand */
 450  if (res > 0) {
 451      if (e1 < 0) {
 452         res -= labs(e2);
 453      }
 454  } else if (res < 0) {
 455      if (e1 > 0) {
 456          res += labs(e2);
 457      }
 458  }
 459  ret.value.ivalue=res;
 460  return ret;
 461 }
 462
 463 static num num_mod(num a, num b) {
 464  num ret;
 465  long e1, e2, res;
 466  ret.is_fixnum=a.is_fixnum && b.is_fixnum;
 467  e1=num_ivalue(a);
 468  e2=num_ivalue(b);
 469  res=e1%e2;
 470  /* modulo should have same sign as second operand */
 471  if (res * e2 < 0) {
 472     res += e2;
 473  }
 474  ret.value.ivalue=res;
 475  return ret;
 476 }
 477
 478 static int num_eq(num a, num b) {
 479  int ret;
 480  int is_fixnum=a.is_fixnum && b.is_fixnum;
 481  if(is_fixnum) {
 482      ret= a.value.ivalue==b.value.ivalue;
 483  } else {
 484      ret=num_rvalue(a)==num_rvalue(b);
 485  }
 486  return ret;
 487 }
 488
 489
 490 static int num_gt(num a, num b) {
 491  int ret;
 492  int is_fixnum=a.is_fixnum && b.is_fixnum;
 493  if(is_fixnum) {
 494      ret= a.value.ivalue>b.value.ivalue;
 495  } else {
 496      ret=num_rvalue(a)>num_rvalue(b);
 497  }
 498  return ret;
 499 }
 500
 501 static int num_ge(num a, num b) {
 502  return !num_lt(a,b);
 503 }
 504
 505 static int num_lt(num a, num b) {
 506  int ret;
 507  int is_fixnum=a.is_fixnum && b.is_fixnum;
 508  if(is_fixnum) {
 509      ret= a.value.ivalue<b.value.ivalue;
 510  } else {
 511      ret=num_rvalue(a)<num_rvalue(b);
 512  }
 513  return ret;
 514 }
 515
 516 static int num_le(num a, num b) {
 517  return !num_gt(a,b);
 518 }
 519
 520 #if USE_MATH
 521 /* Round to nearest. Round to even if midway */
 522 static double round_per_R5RS(double x) {
 523  double fl=floor(x);
 524  double ce=ceil(x);
 525  double dfl=x-fl;
 526  double dce=ce-x;
 527  if(dfl>dce) {
 528      return ce;
 529  } else if(dfl<dce) {
 530      return fl;
 531  } else {
 532      if(fmod(fl,2.0)==0.0) {       /* I imagine this holds */
 533           return fl;
 534      } else {
 535           return ce;
 536      }
 537  }
 538 }
 539 #endif
 540
 541 static int is_zero_double(double x) {
 542  return x<DBL_MIN && x>-DBL_MIN;
 543 }
 544
 545 static long binary_decode(const char *s) {
 546  long x=0;
 547
 548  while(*s!=0 && (*s=='1' || *s=='0')) {
 549      x<<=1;
 550      x+=*s-'0';
 551      s++;
 552  }
 553
 554  return x;
 555 }
 556
 557 /* allocate new cell segment */
 558 static int alloc_cellseg(scheme *sc, int n) {
 559      pointer newp;
 560      pointer last;
 561      pointer p;
 562      char *cp;
 563      long i;
 564      int k;
 565      int adj=ADJ;
 566
 567      if(adj<sizeof(struct cell)) {
 568        adj=sizeof(struct cell);
 569      }
 570
 571      for (k = 0; k < n; k++) {
 572          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
 573               return k;
 574          cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
 575          if (cp == 0)
 576               return k;
 577          i = ++sc->last_cell_seg ;
 578          sc->alloc_seg[i] = cp;
 579          /* adjust in TYPE_BITS-bit boundary */
 580          if(((unsigned long)cp)%adj!=0) {
 581            cp=(char*)(adj*((unsigned long)cp/adj+1));
 582          }
 583          /* insert new segment in address order */
 584          newp=(pointer)cp;
 585          sc->cell_seg[i] = newp;
 586          while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
 587              p = sc->cell_seg[i];
 588              sc->cell_seg[i] = sc->cell_seg[i - 1];
 589              sc->cell_seg[--i] = p;
 590          }
 591          sc->fcells += CELL_SEGSIZE;
 592          last = newp + CELL_SEGSIZE - 1;
 593          for (p = newp; p <= last; p++) {
 594               typeflag(p) = 0;
 595               cdr(p) = p + 1;
 596               car(p) = sc->NIL;
 597          }
 598          /* insert new cells in address order on free list */
 599          if (sc->free_cell == sc->NIL || p < sc->free_cell) {
 600               cdr(last) = sc->free_cell;
 601               sc->free_cell = newp;
 602          } else {
 603                p = sc->free_cell;
 604                while (cdr(p) != sc->NIL && newp > cdr(p))
 605                     p = cdr(p);
 606                cdr(last) = cdr(p);
 607                cdr(p) = newp;
 608          }
 609      }
 610      return n;
 611 }
 612
 613 static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
 614   if (sc->free_cell != sc->NIL) {
 615     pointer x = sc->free_cell;
 616     sc->free_cell = cdr(x);
 617     --sc->fcells;
 618     return (x);
 619   }
 620   return _get_cell (sc, a, b);
 621 }
 622
 623
 624 /* get new cell.  parameter a, b is marked by gc. */
 625 static pointer _get_cell(scheme *sc, pointer a, pointer b) {
 626   pointer x;
 627
 628   if(sc->no_memory) {
 629     return sc->sink;
 630   }
 631
 632   if (sc->free_cell == sc->NIL) {
 633     const int min_to_be_recovered = sc->last_cell_seg*8;
 634     gc(sc,a, b);
 635     if (sc->fcells < min_to_be_recovered
 636         || sc->free_cell == sc->NIL) {
 637       /* if only a few recovered, get more to avoid fruitless gc's */
 638       if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) {
 639         sc->no_memory=1;
 640         return sc->sink;
 641       }
 642     }
 643   }
 644   x = sc->free_cell;
 645   sc->free_cell = cdr(x);
 646   --sc->fcells;
 647   return (x);
 648 }
 649
 650 /* make sure that there is a given number of cells free */
 651 static pointer reserve_cells(scheme *sc, int n) {
 652     if(sc->no_memory) {
 653         return sc->NIL;
 654     }
 655
 656     /* Are there enough cells available? */
 657     if (sc->fcells < n) {
 658         /* If not, try gc'ing some */
 659         gc(sc, sc->NIL, sc->NIL);
 660         if (sc->fcells < n) {
 661             /* If there still aren't, try getting more heap */
 662             if (!alloc_cellseg(sc,1)) {
 663                 sc->no_memory=1;
 664                 return sc->NIL;
 665             }
 666         }
 667         if (sc->fcells < n) {
 668             /* If all fail, report failure */
 669             sc->no_memory=1;
 670             return sc->NIL;
 671         }
 672     }
 673     return (sc->T);
 674 }
 675
 676 static pointer get_consecutive_cells(scheme *sc, int n) {
 677   pointer x;
 678
 679   if(sc->no_memory) { return sc->sink; }
 680
 681   /* Are there any cells available? */
 682   x=find_consecutive_cells(sc,n);
 683   if (x != sc->NIL) { return x; }
 684
 685   /* If not, try gc'ing some */
 686   gc(sc, sc->NIL, sc->NIL);
 687   x=find_consecutive_cells(sc,n);
 688   if (x != sc->NIL) { return x; }
 689
 690   /* If there still aren't, try getting more heap */
 691   if (!alloc_cellseg(sc,1))
 692     {
 693       sc->no_memory=1;
 694       return sc->sink;
 695     }
 696
 697   x=find_consecutive_cells(sc,n);
 698   if (x != sc->NIL) { return x; }
 699
 700   /* If all fail, report failure */
 701   sc->no_memory=1;
 702   return sc->sink;
 703 }
 704
 705 static int count_consecutive_cells(pointer x, int needed) {
 706  int n=1;
 707  while(cdr(x)==x+1) {
 708      x=cdr(x);
 709      n++;
 710      if(n>needed) return n;
 711  }
 712  return n;
 713 }
 714
 715 static pointer find_consecutive_cells(scheme *sc, int n) {
 716   pointer *pp;
 717   int cnt;
 718
 719   pp=&sc->free_cell;
 720   while(*pp!=sc->NIL) {
 721     cnt=count_consecutive_cells(*pp,n);
 722     if(cnt>=n) {
 723       pointer x=*pp;
 724       *pp=cdr(*pp+n-1);
 725       sc->fcells -= n;
 726       return x;
 727     }
 728     pp=&cdr(*pp+cnt-1);
 729   }
 730   return sc->NIL;
 731 }
 732
 733 /* To retain recent allocs before interpreter knows about them -
 734    Tehom */
 735
 736 static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
 737 {
 738   pointer holder = get_cell_x(sc, recent, extra);
 739   typeflag(holder) = T_PAIR | T_IMMUTABLE;
 740   car(holder) = recent;
 741   cdr(holder) = car(sc->sink);
 742   car(sc->sink) = holder;
 743 }
 744
 745
 746 static pointer get_cell(scheme *sc, pointer a, pointer b)
 747 {
 748   pointer cell   = get_cell_x(sc, a, b);
 749   /* For right now, include "a" and "b" in "cell" so that gc doesn't
 750      think they are garbage. */
 751   /* Tentatively record it as a pair so gc understands it. */
 752   typeflag(cell) = T_PAIR;
 753   car(cell) = a;
 754   cdr(cell) = b;
 755   push_recent_alloc(sc, cell, sc->NIL);
 756   return cell;
 757 }
 758
 759 static pointer get_vector_object(scheme *sc, int len, pointer init)
 760 {
 761   pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
 762   if(sc->no_memory) { return sc->sink; }
 763   /* Record it as a vector so that gc understands it. */
 764   typeflag(cells) = (T_VECTOR | T_ATOM);
 765   ivalue_unchecked(cells)=len;
 766   set_num_integer(cells);
 767   fill_vector(cells,init);
 768   push_recent_alloc(sc, cells, sc->NIL);
 769   return cells;
 770 }
 771
 772 static INLINE void ok_to_freely_gc(scheme *sc)
 773 {
 774   car(sc->sink) = sc->NIL;
 775 }
 776
 777
 778 #if defined TSGRIND
 779 static void check_cell_alloced(pointer p, int expect_alloced)
 780 {
 781   /* Can't use putstr(sc,str) because callers have no access to
 782      sc.  */
 783   if(typeflag(p) & !expect_alloced)
 784     {
 785       fprintf(stderr,"Cell is already allocated!\n");
 786     }
 787   if(!(typeflag(p)) & expect_alloced)
 788     {
 789       fprintf(stderr,"Cell is not allocated!\n");
 790     }
 791
 792 }
 793 static void check_range_alloced(pointer p, int n, int expect_alloced)
 794 {
 795   int i;
 796   for(i = 0;i<n;i++)
 797     { (void)check_cell_alloced(p+i,expect_alloced); }
 798 }
 799
 800 #endif
 801
 802 /* Medium level cell allocation */
 803
 804 /* get new cons cell */
 805 pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
 806   pointer x = get_cell(sc,a, b);
 807
 808   typeflag(x) = T_PAIR;
 809   if(immutable) {
 810     setimmutable(x);
 811   }
 812   car(x) = a;
 813   cdr(x) = b;
 814   return (x);
 815 }
 816
 817 /* ========== oblist implementation  ========== */
 818
 819 #ifndef USE_OBJECT_LIST
 820
 821 static int hash_fn(const char *key, int table_size);
 822
 823 static pointer oblist_initial_value(scheme *sc)
 824 {
 825   return mk_vector(sc, 461); /* probably should be bigger */
 826 }
 827
 828 /* returns the new symbol */
 829 static pointer oblist_add_by_name(scheme *sc, const char *name)
 830 {
 831   pointer x;
 832   int location;
 833
 834   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
 835   typeflag(x) = T_SYMBOL;
 836   setimmutable(car(x));
 837
 838   location = hash_fn(name, ivalue_unchecked(sc->oblist));
 839   set_vector_elem(sc->oblist, location,
 840                   immutable_cons(sc, x, vector_elem(sc->oblist, location)));
 841   return x;
 842 }
 843
 844 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
 845 {
 846   int location;
 847   pointer x;
 848   char *s;
 849
 850   location = hash_fn(name, ivalue_unchecked(sc->oblist));
 851   for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
 852     s = symname(car(x));
 853     /* case-insensitive, per R5RS section 2. */
 854     if(stricmp(name, s) == 0) {
 855       return car(x);
 856     }
 857   }
 858   return sc->NIL;
 859 }
 860
 861 static pointer oblist_all_symbols(scheme *sc)
 862 {
 863   int i;
 864   pointer x;
 865   pointer ob_list = sc->NIL;
 866
 867   for (i = 0; i < ivalue_unchecked(sc->oblist); i++) {
 868     for (x  = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
 869       ob_list = cons(sc, x, ob_list);
 870     }
 871   }
 872   return ob_list;
 873 }
 874
 875 #else
 876
 877 static pointer oblist_initial_value(scheme *sc)
 878 {
 879   return sc->NIL;
 880 }
 881
 882 static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
 883 {
 884      pointer x;
 885      char    *s;
 886
 887      for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
 888         s = symname(car(x));
 889         /* case-insensitive, per R5RS section 2. */
 890         if(stricmp(name, s) == 0) {
 891           return car(x);
 892         }
 893      }
 894      return sc->NIL;
 895 }
 896
 897 /* returns the new symbol */
 898 static pointer oblist_add_by_name(scheme *sc, const char *name)
 899 {
 900   pointer x;
 901
 902   x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
 903   typeflag(x) = T_SYMBOL;
 904   setimmutable(car(x));
 905   sc->oblist = immutable_cons(sc, x, sc->oblist);
 906   return x;
 907 }
 908 static pointer oblist_all_symbols(scheme *sc)
 909 {
 910   return sc->oblist;
 911 }
 912
 913 #endif
 914
 915 static pointer mk_port(scheme *sc, port *p) {
 916   pointer x = get_cell(sc, sc->NIL, sc->NIL);
 917
 918   typeflag(x) = T_PORT|T_ATOM;
 919   x->_object._port=p;
 920   return (x);
 921 }
 922
 923 pointer mk_foreign_func(scheme *sc, foreign_func f) {
 924   pointer x = get_cell(sc, sc->NIL, sc->NIL);
 925
 926   typeflag(x) = (T_FOREIGN | T_ATOM);
 927   x->_object._ff=f;
 928   return (x);
 929 }
 930
 931 INTERFACE pointer mk_character(scheme *sc, int c) {
 932   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 933
 934   typeflag(x) = (T_CHARACTER | T_ATOM);
 935   ivalue_unchecked(x)= c;
 936   set_num_integer(x);
 937   return (x);
 938 }
 939
 940 /* get number atom (integer) */
 941 INTERFACE pointer mk_integer(scheme *sc, long num) {
 942   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 943
 944   typeflag(x) = (T_NUMBER | T_ATOM);
 945   ivalue_unchecked(x)= num;
 946   set_num_integer(x);
 947   return (x);
 948 }
 949
 950 INTERFACE pointer mk_real(scheme *sc, double n) {
 951   pointer x = get_cell(sc,sc->NIL, sc->NIL);
 952
 953   typeflag(x) = (T_NUMBER | T_ATOM);
 954   rvalue_unchecked(x)= n;
 955   set_num_real(x);
 956   return (x);
 957 }
 958
 959 static pointer mk_number(scheme *sc, num n) {
 960  if(n.is_fixnum) {
 961      return mk_integer(sc,n.value.ivalue);
 962  } else {
 963      return mk_real(sc,n.value.rvalue);
 964  }
 965 }
 966
 967 /* allocate name to string area */
 968 static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
 969      char *q;
 970
 971      q=(char*)sc->malloc(len_str+1);
 972      if(q==0) {
 973           sc->no_memory=1;
 974           return sc->strbuff;
 975      }
 976      if(str!=0) {
 977           snprintf(q, len_str+1, "%s", str);
 978      } else {
 979           memset(q, fill, len_str);
 980           q[len_str]=0;
 981      }
 982      return (q);
 983 }
 984
 985 /* get new string */
 986 INTERFACE pointer mk_string(scheme *sc, const char *str) {
 987      return mk_counted_string(sc,str,strlen(str));
 988 }
 989
 990 INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
 991      pointer x = get_cell(sc, sc->NIL, sc->NIL);
 992      typeflag(x) = (T_STRING | T_ATOM);
 993      strvalue(x) = store_string(sc,len,str,0);
 994      strlength(x) = len;
 995      return (x);
 996 }
 997
 998 INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
 999      pointer x = get_cell(sc, sc->NIL, sc->NIL);
1000      typeflag(x) = (T_STRING | T_ATOM);
1001      strvalue(x) = store_string(sc,len,0,fill);
1002      strlength(x) = len;
1003      return (x);
1004 }
1005
1006 INTERFACE static pointer mk_vector(scheme *sc, int len)
1007 { return get_vector_object(sc,len,sc->NIL); }
1008
1009 INTERFACE static void fill_vector(pointer vec, pointer obj) {
1010      int i;
1011      int num=ivalue(vec)/2+ivalue(vec)%2;
1012      for(i=0; i<num; i++) {
1013           typeflag(vec+1+i) = T_PAIR;
1014           setimmutable(vec+1+i);
1015           car(vec+1+i)=obj;
1016           cdr(vec+1+i)=obj;
1017      }
1018 }
1019
1020 INTERFACE static pointer vector_elem(pointer vec, int ielem) {
1021      int n=ielem/2;
1022      if(ielem%2==0) {
1023           return car(vec+1+n);
1024      } else {
1025           return cdr(vec+1+n);
1026      }
1027 }
1028
1029 INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
1030      int n=ielem/2;
1031      if(ielem%2==0) {
1032           return car(vec+1+n)=a;
1033      } else {
1034           return cdr(vec+1+n)=a;
1035      }
1036 }
1037
1038 /* get new symbol */
1039 INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
1040      pointer x;
1041
1042      /* first check oblist */
1043      x = oblist_find_by_name(sc, name);
1044      if (x != sc->NIL) {
1045           return (x);
1046      } else {
1047           x = oblist_add_by_name(sc, name);
1048           return (x);
1049      }
1050 }
1051
1052 INTERFACE pointer gensym(scheme *sc) {
1053      pointer x;
1054      char name[40];
1055
1056      for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
1057           snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
1058
1059           /* first check oblist */
1060           x = oblist_find_by_name(sc, name);
1061
1062           if (x != sc->NIL) {
1063                continue;
1064           } else {
1065                x = oblist_add_by_name(sc, name);
1066                return (x);
1067           }
1068      }
1069
1070      return sc->NIL;
1071 }
1072
1073 /* make symbol or number atom from string */
1074 static pointer mk_atom(scheme *sc, char *q) {
1075      char    c, *p;
1076      int has_dec_point=0;
1077      int has_fp_exp = 0;
1078
1079 #if USE_COLON_HOOK
1080      if((p=strstr(q,"::"))!=0) {
1081           *p=0;
1082           return cons(sc, sc->COLON_HOOK,
1083                           cons(sc,
1084                               cons(sc,
1085                                    sc->QUOTE,
1086                                    cons(sc, mk_atom(sc,p+2), sc->NIL)),
1087                               cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
1088      }
1089 #endif
1090
1091      p = q;
1092      c = *p++;
1093      if ((c == '+') || (c == '-')) {
1094        c = *p++;
1095        if (c == '.') {
1096          has_dec_point=1;
1097          c = *p++;
1098        }
1099        if (!isdigit(c)) {
1100          return (mk_symbol(sc, strlwr(q)));
1101        }
1102      } else if (c == '.') {
1103        has_dec_point=1;
1104        c = *p++;
1105        if (!isdigit(c)) {
1106          return (mk_symbol(sc, strlwr(q)));
1107        }
1108      } else if (!isdigit(c)) {
1109        return (mk_symbol(sc, strlwr(q)));
1110      }
1111
1112      for ( ; (c = *p) != 0; ++p) {
1113           if (!isdigit(c)) {
1114                if(c=='.') {
1115                     if(!has_dec_point) {
1116                          has_dec_point=1;
1117                          continue;
1118                     }
1119                }
1120                else if ((c == 'e') || (c == 'E')) {
1121                        if(!has_fp_exp) {
1122                           has_dec_point = 1; /* decimal point illegal
1123                                                 from now on */
1124                           p++;
1125                           if ((*p == '-') || (*p == '+') || isdigit(*p)) {
1126                              continue;
1127                           }
1128                        }
1129                }
1130                return (mk_symbol(sc, strlwr(q)));
1131           }
1132      }
1133      if(has_dec_point) {
1134           return mk_real(sc,atof(q));
1135      }
1136      return (mk_integer(sc, atol(q)));
1137 }
1138
1139 /* make constant */
1140 static pointer mk_sharp_const(scheme *sc, char *name) {
1141      long    x;
1142      char    tmp[STRBUFFSIZE];
1143
1144      if (!strcmp(name, "t"))
1145           return (sc->T);
1146      else if (!strcmp(name, "f"))
1147           return (sc->F);
1148      else if (*name == 'o') {/* #o (octal) */
1149           snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
1150           sscanf(tmp, "%lo", (long unsigned *)&x);
1151           return (mk_integer(sc, x));
1152      } else if (*name == 'd') {    /* #d (decimal) */
1153           sscanf(name+1, "%ld", (long int *)&x);
1154           return (mk_integer(sc, x));
1155      } else if (*name == 'x') {    /* #x (hex) */
1156           snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
1157           sscanf(tmp, "%lx", (long unsigned *)&x);
1158           return (mk_integer(sc, x));
1159      } else if (*name == 'b') {    /* #b (binary) */
1160           x = binary_decode(name+1);
1161           return (mk_integer(sc, x));
1162      } else if (*name == '\\') { /* #\w (character) */
1163           int c=0;
1164           if(stricmp(name+1,"space")==0) {
1165                c=' ';
1166           } else if(stricmp(name+1,"newline")==0) {
1167                c='\n';
1168           } else if(stricmp(name+1,"return")==0) {
1169                c='\r';
1170           } else if(stricmp(name+1,"tab")==0) {
1171                c='\t';
1172      } else if(name[1]=='x' && name[2]!=0) {
1173           int c1=0;
1174           if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
1175                c=c1;
1176           } else {
1177                return sc->NIL;
1178      }
1179 #if USE_ASCII_NAMES
1180           } else if(is_ascii_name(name+1,&c)) {
1181                /* nothing */
1182 #endif
1183           } else if(name[2]==0) {
1184                c=name[1];
1185           } else {
1186                return sc->NIL;
1187           }
1188           return mk_character(sc,c);
1189      } else
1190           return (sc->NIL);
1191 }
1192
1193 /* ========== garbage collector ========== */
1194
1195 /*--
1196  *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1197  *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1198  *  for marking.
1199  */
1200 static void mark(pointer a) {
1201      pointer t, q, p;
1202
1203      t = (pointer) 0;
1204      p = a;
1205 E2:  setmark(p);
1206      if(is_vector(p)) {
1207           int i;
1208           int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
1209           for(i=0; i<num; i++) {
1210                /* Vector cells will be treated like ordinary cells */
1211                mark(p+1+i);
1212           }
1213      }
1214      if (is_atom(p))
1215           goto E6;
1216      /* E4: down car */
1217      q = car(p);
1218      if (q && !is_mark(q)) {
1219           setatom(p);  /* a note that we have moved car */
1220           car(p) = t;
1221           t = p;
1222           p = q;
1223           goto E2;
1224      }
1225 E5:  q = cdr(p); /* down cdr */
1226      if (q && !is_mark(q)) {
1227           cdr(p) = t;
1228           t = p;
1229           p = q;
1230           goto E2;
1231      }
1232 E6:   /* up.  Undo the link switching from steps E4 and E5. */
1233      if (!t)
1234           return;
1235      q = t;
1236      if (is_atom(q)) {
1237           clratom(q);
1238           t = car(q);
1239           car(q) = p;
1240           p = q;
1241           goto E5;
1242      } else {
1243           t = cdr(q);
1244           cdr(q) = p;
1245           p = q;
1246           goto E6;
1247      }
1248 }
1249
1250 /* garbage collection. parameter a, b is marked. */
1251 static void gc(scheme *sc, pointer a, pointer b) {
1252   pointer p;
1253   int i;
1254
1255   if(sc->gc_verbose) {
1256     putstr(sc, "gc...");
1257   }
1258
1259   /* mark system globals */
1260   mark(sc->oblist);
1261   mark(sc->global_env);
1262
1263   /* mark current registers */
1264   mark(sc->args);
1265   mark(sc->envir);
1266   mark(sc->code);
1267   dump_stack_mark(sc);
1268   mark(sc->value);
1269   mark(sc->inport);
1270   mark(sc->save_inport);
1271   mark(sc->outport);
1272   mark(sc->loadport);
1273
1274   /* Mark recent objects the interpreter doesn't know about yet. */
1275   mark(car(sc->sink));
1276   /* Mark any older stuff above nested C calls */
1277   mark(sc->c_nest);
1278
1279   /* mark variables a, b */
1280   mark(a);
1281   mark(b);
1282
1283   /* garbage collect */
1284   clrmark(sc->NIL);
1285   sc->fcells = 0;
1286   sc->free_cell = sc->NIL;
1287   /* free-list is kept sorted by address so as to maintain consecutive
1288      ranges, if possible, for use with vectors. Here we scan the cells
1289      (which are also kept sorted by address) downwards to build the
1290      free-list in sorted order.
1291   */
1292   for (i = sc->last_cell_seg; i >= 0; i--) {
1293     p = sc->cell_seg[i] + CELL_SEGSIZE;
1294     while (--p >= sc->cell_seg[i]) {
1295       if (is_mark(p)) {
1296     clrmark(p);
1297       } else {
1298     /* reclaim cell */
1299         if (typeflag(p) != 0) {
1300           finalize_cell(sc, p);
1301           typeflag(p) = 0;
1302           car(p) = sc->NIL;
1303         }
1304         ++sc->fcells;
1305         cdr(p) = sc->free_cell;
1306         sc->free_cell = p;
1307       }
1308     }
1309   }
1310
1311   if (sc->gc_verbose) {
1312     char msg[80];
1313     snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
1314     putstr(sc,msg);
1315   }
1316 }
1317
1318 static void finalize_cell(scheme *sc, pointer a) {
1319   if(is_string(a)) {
1320     sc->free(strvalue(a));
1321   } else if(is_port(a)) {
1322     if(a->_object._port->kind&port_file
1323        && a->_object._port->rep.stdio.closeit) {
1324       port_close(sc,a,port_input|port_output);
1325     }
1326     sc->free(a->_object._port);
1327   }
1328 }
1329
1330 /* ========== Routines for Reading ========== */
1331
1332 static int file_push(scheme *sc, const char *fname) {
1333   FILE *fin = NULL;
1334
1335   if (sc->file_i == MAXFIL-1)
1336      return 0;
1337   fin=fopen(fname,"r");
1338   if(fin!=0) {
1339     sc->file_i++;
1340     sc->load_stack[sc->file_i].kind=port_file|port_input;
1341     sc->load_stack[sc->file_i].rep.stdio.file=fin;
1342     sc->load_stack[sc->file_i].rep.stdio.closeit=1;
1343     sc->nesting_stack[sc->file_i]=0;
1344     sc->loadport->_object._port=sc->load_stack+sc->file_i;
1345
1346 #if SHOW_ERROR_LINE
1347     sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
1348     if(fname)
1349       sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
1350 #endif
1351   }
1352   return fin!=0;
1353 }
1354
1355 static void file_pop(scheme *sc) {
1356  if(sc->file_i != 0) {
1357    sc->nesting=sc->nesting_stack[sc->file_i];
1358    port_close(sc,sc->loadport,port_input);
1359    sc->file_i--;
1360    sc->loadport->_object._port=sc->load_stack+sc->file_i;
1361  }
1362 }
1363
1364 static int file_interactive(scheme *sc) {
1365  return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
1366      && sc->inport->_object._port->kind&port_file;
1367 }
1368
1369 static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
1370   FILE *f;
1371   char *rw;
1372   port *pt;
1373   if(prop==(port_input|port_output)) {
1374     rw="a+";
1375   } else if(prop==port_output) {
1376     rw="w";
1377   } else {
1378     rw="r";
1379   }
1380   f=fopen(fn,rw);
1381   if(f==0) {
1382     return 0;
1383   }
1384   pt=port_rep_from_file(sc,f,prop);
1385   pt->rep.stdio.closeit=1;
1386
1387 #if SHOW_ERROR_LINE
1388   if(fn)
1389     pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
1390
1391   pt->rep.stdio.curr_line = 0;
1392 #endif
1393   return pt;
1394 }
1395
1396 static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
1397   port *pt;
1398   pt=port_rep_from_filename(sc,fn,prop);
1399   if(pt==0) {
1400     return sc->NIL;
1401   }
1402   return mk_port(sc,pt);
1403 }
1404
1405 static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
1406 {
1407     port *pt;
1408
1409     pt = (port *)sc->malloc(sizeof *pt);
1410     if (pt == NULL) {
1411         return NULL;
1412     }
1413     pt->kind = port_file | prop;
1414     pt->rep.stdio.file = f;
1415     pt->rep.stdio.closeit = 0;
1416     return pt;
1417 }
1418
1419 static pointer port_from_file(scheme *sc, FILE *f, int prop) {
1420   port *pt;
1421   pt=port_rep_from_file(sc,f,prop);
1422   if(pt==0) {
1423     return sc->NIL;
1424   }
1425   return mk_port(sc,pt);
1426 }
1427
1428 static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1429   port *pt;
1430   pt=(port*)sc->malloc(sizeof(port));
1431   if(pt==0) {
1432     return 0;
1433   }
1434   pt->kind=port_string|prop;
1435   pt->rep.string.start=start;
1436   pt->rep.string.curr=start;
1437   pt->rep.string.past_the_end=past_the_end;
1438   return pt;
1439 }
1440
1441 static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
1442   port *pt;
1443   pt=port_rep_from_string(sc,start,past_the_end,prop);
1444   if(pt==0) {
1445     return sc->NIL;
1446   }
1447   return mk_port(sc,pt);
1448 }
1449
1450 #define BLOCK_SIZE 256
1451
1452 static port *port_rep_from_scratch(scheme *sc) {
1453   port *pt;
1454   char *start;
1455   pt=(port*)sc->malloc(sizeof(port));
1456   if(pt==0) {
1457     return 0;
1458   }
1459   start=sc->malloc(BLOCK_SIZE);
1460   if(start==0) {
1461     return 0;
1462   }
1463   memset(start,' ',BLOCK_SIZE-1);
1464   start[BLOCK_SIZE-1]='\0';
1465   pt->kind=port_string|port_output|port_srfi6;
1466   pt->rep.string.start=start;
1467   pt->rep.string.curr=start;
1468   pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
1469   return pt;
1470 }
1471
1472 static pointer port_from_scratch(scheme *sc) {
1473   port *pt;
1474   pt=port_rep_from_scratch(sc);
1475   if(pt==0) {
1476     return sc->NIL;
1477   }
1478   return mk_port(sc,pt);
1479 }
1480
1481 static void port_close(scheme *sc, pointer p, int flag) {
1482   port *pt=p->_object._port;
1483   pt->kind&=~flag;
1484   if((pt->kind & (port_input|port_output))==0) {
1485     if(pt->kind&port_file) {
1486
1487 #if SHOW_ERROR_LINE
1488       /* Cleanup is here so (close-*-port) functions could work too */
1489       pt->rep.stdio.curr_line = 0;
1490
1491       if(pt->rep.stdio.filename)
1492         sc->free(pt->rep.stdio.filename);
1493 #endif
1494
1495       fclose(pt->rep.stdio.file);
1496     }
1497     pt->kind=port_free;
1498   }
1499 }
1500
1501 /* get new character from input file */
1502 static int inchar(scheme *sc) {
1503   int c;
1504   port *pt;
1505
1506   pt = sc->inport->_object._port;
1507   if(pt->kind & port_saw_EOF)
1508     { return EOF; }
1509   c = basic_inchar(pt);
1510   if(c == EOF && sc->inport == sc->loadport) {
1511     /* Instead, set port_saw_EOF */
1512     pt->kind |= port_saw_EOF;
1513
1514     /* file_pop(sc); */
1515     return EOF;
1516     /* NOTREACHED */
1517   }
1518   return c;
1519 }
1520
1521 static int basic_inchar(port *pt) {
1522   if(pt->kind & port_file) {
1523     return fgetc(pt->rep.stdio.file);
1524   } else {
1525     if(*pt->rep.string.curr == 0 ||
1526        pt->rep.string.curr == pt->rep.string.past_the_end) {
1527       return EOF;
1528     } else {
1529       return *pt->rep.string.curr++;
1530     }
1531   }
1532 }
1533
1534 /* back character to input buffer */
1535 static void backchar(scheme *sc, int c) {
1536   port *pt;
1537   if(c==EOF) return;
1538   pt=sc->inport->_object._port;
1539   if(pt->kind&port_file) {
1540     ungetc(c,pt->rep.stdio.file);
1541   } else {
1542     if(pt->rep.string.curr!=pt->rep.string.start) {
1543       --pt->rep.string.curr;
1544     }
1545   }
1546 }
1547
1548 static int realloc_port_string(scheme *sc, port *p)
1549 {
1550   char *start=p->rep.string.start;
1551   size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
1552   char *str=sc->malloc(new_size);
1553   if(str) {
1554     memset(str,' ',new_size-1);
1555     str[new_size-1]='\0';
1556     strcpy(str,start);
1557     p->rep.string.start=str;
1558     p->rep.string.past_the_end=str+new_size-1;
1559     p->rep.string.curr-=start-str;
1560     sc->free(start);
1561     return 1;
1562   } else {
1563     return 0;
1564   }
1565 }
1566
1567 INTERFACE void putstr(scheme *sc, const char *s) {
1568   port *pt=sc->outport->_object._port;
1569   if(pt->kind&port_file) {
1570     fputs(s,pt->rep.stdio.file);
1571   } else {
1572     for(;*s;s++) {
1573       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1574         *pt->rep.string.curr++=*s;
1575       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1576         *pt->rep.string.curr++=*s;
1577       }
1578     }
1579   }
1580 }
1581
1582 static void putchars(scheme *sc, const char *s, int len) {
1583   port *pt=sc->outport->_object._port;
1584   if(pt->kind&port_file) {
1585     fwrite(s,1,len,pt->rep.stdio.file);
1586   } else {
1587     for(;len;len--) {
1588       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1589         *pt->rep.string.curr++=*s++;
1590       } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1591         *pt->rep.string.curr++=*s++;
1592       }
1593     }
1594   }
1595 }
1596
1597 INTERFACE void putcharacter(scheme *sc, int c) {
1598   port *pt=sc->outport->_object._port;
1599   if(pt->kind&port_file) {
1600     fputc(c,pt->rep.stdio.file);
1601   } else {
1602     if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
1603       *pt->rep.string.curr++=c;
1604     } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
1605         *pt->rep.string.curr++=c;
1606     }
1607   }
1608 }
1609
1610 /* read characters up to delimiter, but cater to character constants */
1611 static char *readstr_upto(scheme *sc, char *delim) {
1612   char *p = sc->strbuff;
1613
1614   while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
1615          !is_one_of(delim, (*p++ = inchar(sc))));
1616
1617   if(p == sc->strbuff+2 && p[-2] == '\\') {
1618     *p=0;
1619   } else {
1620     backchar(sc,p[-1]);
1621     *--p = '\0';
1622   }
1623   return sc->strbuff;
1624 }
1625
1626 /* read string expression "xxx...xxx" */
1627 static pointer readstrexp(scheme *sc) {
1628   char *p = sc->strbuff;
1629   int c;
1630   int c1=0;
1631   enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
1632
1633   for (;;) {
1634     c=inchar(sc);
1635     if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
1636       return sc->F;
1637     }
1638     switch(state) {
1639         case st_ok:
1640             switch(c) {
1641                 case '\\':
1642                     state=st_bsl;
1643                     break;
1644                 case '"':
1645                     *p=0;
1646                     return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
1647                 default:
1648                     *p++=c;
1649                     break;
1650             }
1651             break;
1652         case st_bsl:
1653             switch(c) {
1654                 case '0':
1655                 case '1':
1656                 case '2':
1657                 case '3':
1658                 case '4':
1659                 case '5':
1660                 case '6':
1661                 case '7':
1662                         state=st_oct1;
1663                         c1=c-'0';
1664                         break;
1665                 case 'x':
1666                 case 'X':
1667                     state=st_x1;
1668                     c1=0;
1669                     break;
1670                 case 'n':
1671                     *p++='\n';
1672                     state=st_ok;
1673                     break;
1674                 case 't':
1675                     *p++='\t';
1676                     state=st_ok;
1677                     break;
1678                 case 'r':
1679                     *p++='\r';
1680                     state=st_ok;
1681                     break;
1682                 case '"':
1683                     *p++='"';
1684                     state=st_ok;
1685                     break;
1686                 default:
1687                     *p++=c;
1688                     state=st_ok;
1689                     break;
1690             }
1691             break;
1692         case st_x1:
1693         case st_x2:
1694             c=toupper(c);
1695             if(c>='0' && c<='F') {
1696                 if(c<='9') {
1697                     c1=(c1<<4)+c-'0';
1698                 } else {
1699                     c1=(c1<<4)+c-'A'+10;
1700                 }
1701                 if(state==st_x1) {
1702                     state=st_x2;
1703                 } else {
1704                     *p++=c1;
1705                     state=st_ok;
1706                 }
1707             } else {
1708                 return sc->F;
1709             }
1710             break;
1711         case st_oct1:
1712         case st_oct2:
1713             if (c < '0' || c > '7')
1714             {
1715                    *p++=c1;
1716                    backchar(sc, c);
1717                    state=st_ok;
1718             }
1719             else
1720             {
1721                 if (state==st_oct2 && c1 >= 32)
1722                     return sc->F;
1723
1724                    c1=(c1<<3)+(c-'0');
1725
1726                 if (state == st_oct1)
1727                         state=st_oct2;
1728                 else
1729                 {
1730                         *p++=c1;
1731                         state=st_ok;
1732                    }
1733             }
1734             break;
1735
1736     }
1737   }
1738 }
1739
1740 /* check c is in chars */
1741 static INLINE int is_one_of(char *s, int c) {
1742      if(c==EOF) return 1;
1743      while (*s)
1744           if (*s++ == c)
1745                return (1);
1746      return (0);
1747 }
1748
1749 /* skip white characters */
1750 static INLINE int skipspace(scheme *sc) {
1751      int c = 0, curr_line = 0;
1752
1753      do {
1754          c=inchar(sc);
1755 #if SHOW_ERROR_LINE
1756          if(c=='\n')
1757            curr_line++;
1758 #endif
1759      } while (isspace(c));
1760
1761 /* record it */
1762 #if SHOW_ERROR_LINE
1763      if (sc->load_stack[sc->file_i].kind & port_file)
1764        sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
1765 #endif
1766
1767      if(c!=EOF) {
1768           backchar(sc,c);
1769       return 1;
1770      }
1771      else
1772        { return EOF; }
1773 }
1774
1775 /* get token */
1776 static int token(scheme *sc) {
1777      int c;
1778      c = skipspace(sc);
1779      if(c == EOF) { return (TOK_EOF); }
1780      switch (c=inchar(sc)) {
1781      case EOF:
1782           return (TOK_EOF);
1783      case '(':
1784           return (TOK_LPAREN);
1785      case ')':
1786           return (TOK_RPAREN);
1787      case '.':
1788           c=inchar(sc);
1789           if(is_one_of(" \n\t",c)) {
1790                return (TOK_DOT);
1791           } else {
1792                backchar(sc,c);
1793                backchar(sc,'.');
1794                return TOK_ATOM;
1795           }
1796      case '\'':
1797           return (TOK_QUOTE);
1798      case ';':
1799            while ((c=inchar(sc)) != '\n' && c!=EOF)
1800              ;
1801
1802 #if SHOW_ERROR_LINE
1803            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1804              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1805 #endif
1806
1807        if(c == EOF)
1808          { return (TOK_EOF); }
1809        else
1810          { return (token(sc));}
1811      case '"':
1812           return (TOK_DQUOTE);
1813      case BACKQUOTE:
1814           return (TOK_BQUOTE);
1815      case ',':
1816          if ((c=inchar(sc)) == '@') {
1817                return (TOK_ATMARK);
1818          } else {
1819                backchar(sc,c);
1820                return (TOK_COMMA);
1821          }
1822      case '#':
1823           c=inchar(sc);
1824           if (c == '(') {
1825                return (TOK_VEC);
1826           } else if(c == '!') {
1827                while ((c=inchar(sc)) != '\n' && c!=EOF)
1828                    ;
1829
1830 #if SHOW_ERROR_LINE
1831            if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
1832              sc->load_stack[sc->file_i].rep.stdio.curr_line++;
1833 #endif
1834
1835            if(c == EOF)
1836              { return (TOK_EOF); }
1837            else
1838              { return (token(sc));}
1839           } else {
1840                backchar(sc,c);
1841                if(is_one_of(" tfodxb\\",c)) {
1842                     return TOK_SHARP_CONST;
1843                } else {
1844                     return (TOK_SHARP);
1845                }
1846           }
1847      default:
1848           backchar(sc,c);
1849           return (TOK_ATOM);
1850      }
1851 }
1852
1853 /* ========== Routines for Printing ========== */
1854 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
1855
1856 static void printslashstring(scheme *sc, char *p, int len) {
1857   int i;
1858   unsigned char *s=(unsigned char*)p;
1859   putcharacter(sc,'"');
1860   for ( i=0; i<len; i++) {
1861     if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
1862       putcharacter(sc,'\\');
1863       switch(*s) {
1864       case '"':
1865         putcharacter(sc,'"');
1866         break;
1867       case '\n':
1868         putcharacter(sc,'n');
1869         break;
1870       case '\t':
1871         putcharacter(sc,'t');
1872         break;
1873       case '\r':
1874         putcharacter(sc,'r');
1875         break;
1876       case '\\':
1877         putcharacter(sc,'\\');
1878         break;
1879       default: {
1880           int d=*s/16;
1881           putcharacter(sc,'x');
1882           if(d<10) {
1883             putcharacter(sc,d+'0');
1884           } else {
1885             putcharacter(sc,d-10+'A');
1886           }
1887           d=*s%16;
1888           if(d<10) {
1889             putcharacter(sc,d+'0');
1890           } else {
1891             putcharacter(sc,d-10+'A');
1892           }
1893         }
1894       }
1895     } else {
1896       putcharacter(sc,*s);
1897     }
1898     s++;
1899   }
1900   putcharacter(sc,'"');
1901 }
1902
1903
1904 /* print atoms */
1905 static void printatom(scheme *sc, pointer l, int f) {
1906   char *p;
1907   int len;
1908   atom2str(sc,l,f,&p,&len);
1909   putchars(sc,p,len);
1910 }
1911
1912
1913 /* Uses internal buffer unless string pointer is already available */
1914 static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
1915      char *p;
1916
1917      if (l == sc->NIL) {
1918           p = "()";
1919      } else if (l == sc->T) {
1920           p = "#t";
1921      } else if (l == sc->F) {
1922           p = "#f";
1923      } else if (l == sc->EOF_OBJ) {
1924           p = "#<EOF>";
1925      } else if (is_port(l)) {
1926           p = "#<PORT>";
1927      } else if (is_number(l)) {
1928           p = sc->strbuff;
1929           if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
1930               if(num_is_integer(l)) {
1931                    snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
1932               } else {
1933                    snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
1934                    /* r5rs says there must be a '.' (unless 'e'?) */
1935                    f = strcspn(p, ".e");
1936                    if (p[f] == 0) {
1937                         p[f] = '.'; /* not found, so add '.0' at the end */
1938                         p[f+1] = '0';
1939                         p[f+2] = 0;
1940                    }
1941               }
1942           } else {
1943               long v = ivalue(l);
1944               if (f == 16) {
1945                   if (v >= 0)
1946                     snprintf(p, STRBUFFSIZE, "%lx", v);
1947                   else
1948                     snprintf(p, STRBUFFSIZE, "-%lx", -v);
1949               } else if (f == 8) {
1950                   if (v >= 0)
1951                     snprintf(p, STRBUFFSIZE, "%lo", v);
1952                   else
1953                     snprintf(p, STRBUFFSIZE, "-%lo", -v);
1954               } else if (f == 2) {
1955                   unsigned long b = (v < 0) ? -v : v;
1956                   p = &p[STRBUFFSIZE-1];
1957                   *p = 0;
1958                   do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
1959                   if (v < 0) *--p = '-';
1960               }
1961           }
1962      } else if (is_string(l)) {
1963           if (!f) {
1964                p = strvalue(l);
1965           } else { /* Hack, uses the fact that printing is needed */
1966                *pp=sc->strbuff;
1967                *plen=0;
1968                printslashstring(sc, strvalue(l), strlength(l));
1969                return;
1970           }
1971      } else if (is_character(l)) {
1972           int c=charvalue(l);
1973           p = sc->strbuff;
1974           if (!f) {
1975                p[0]=c;
1976                p[1]=0;
1977           } else {
1978                switch(c) {
1979                case ' ':
1980                     p = "#\\space";
1981                     break;
1982                case '\n':
1983                     p = "#\\newline";
1984                     break;
1985                case '\r':
1986                     p = "#\\return";
1987                     break;
1988                case '\t':
1989                     p = "#\\tab";
1990                     break;
1991                default:
1992 #if USE_ASCII_NAMES
1993                     if(c==127) {
1994                          p = "#\\del";
1995                          break;
1996                     } else if(c<32) {
1997                          snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
1998                          break;
1999                     }
2000 #else
2001                     if(c<32) {
2002                       snprintf(p,STRBUFFSIZE,"#\\x%x",c);
2003                       break;
2004                     }
2005 #endif
2006                     snprintf(p,STRBUFFSIZE,"#\\%c",c);
2007                     break;
2008                }
2009           }
2010      } else if (is_symbol(l)) {
2011           p = symname(l);
2012      } else if (is_proc(l)) {
2013           p = sc->strbuff;
2014           snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
2015      } else if (is_macro(l)) {
2016           p = "#<MACRO>";
2017      } else if (is_closure(l)) {
2018           p = "#<CLOSURE>";
2019      } else if (is_promise(l)) {
2020           p = "#<PROMISE>";
2021      } else if (is_foreign(l)) {
2022           p = sc->strbuff;
2023           snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
2024      } else if (is_continuation(l)) {
2025           p = "#<CONTINUATION>";
2026      } else {
2027           p = "#<ERROR>";
2028      }
2029      *pp=p;
2030      *plen=strlen(p);
2031 }
2032 /* ========== Routines for Evaluation Cycle ========== */
2033
2034 /* make closure. c is code. e is environment */
2035 static pointer mk_closure(scheme *sc, pointer c, pointer e) {
2036      pointer x = get_cell(sc, c, e);
2037
2038      typeflag(x) = T_CLOSURE;
2039      car(x) = c;
2040      cdr(x) = e;
2041      return (x);
2042 }
2043
2044 /* make continuation. */
2045 static pointer mk_continuation(scheme *sc, pointer d) {
2046      pointer x = get_cell(sc, sc->NIL, d);
2047
2048      typeflag(x) = T_CONTINUATION;
2049      cont_dump(x) = d;
2050      return (x);
2051 }
2052
2053 static pointer list_star(scheme *sc, pointer d) {
2054   pointer p, q;
2055   if(cdr(d)==sc->NIL) {
2056     return car(d);
2057   }
2058   p=cons(sc,car(d),cdr(d));
2059   q=p;
2060   while(cdr(cdr(p))!=sc->NIL) {
2061     d=cons(sc,car(p),cdr(p));
2062     if(cdr(cdr(p))!=sc->NIL) {
2063       p=cdr(d);
2064     }
2065   }
2066   cdr(p)=car(cdr(p));
2067   return q;
2068 }
2069
2070 /* reverse list -- produce new list */
2071 static pointer reverse(scheme *sc, pointer a) {
2072 /* a must be checked by gc */
2073      pointer p = sc->NIL;
2074
2075      for ( ; is_pair(a); a = cdr(a)) {
2076           p = cons(sc, car(a), p);
2077      }
2078      return (p);
2079 }
2080
2081 /* reverse list --- in-place */
2082 static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
2083      pointer p = list, result = term, q;
2084
2085      while (p != sc->NIL) {
2086           q = cdr(p);
2087           cdr(p) = result;
2088           result = p;
2089           p = q;
2090      }
2091      return (result);
2092 }
2093
2094 /* append list -- produce new list (in reverse order) */
2095 static pointer revappend(scheme *sc, pointer a, pointer b) {
2096     pointer result = a;
2097     pointer p = b;
2098
2099     while (is_pair(p)) {
2100         result = cons(sc, car(p), result);
2101         p = cdr(p);
2102     }
2103
2104     if (p == sc->NIL) {
2105         return result;
2106     }
2107
2108     return sc->F;   /* signal an error */
2109 }
2110
2111 /* equivalence of atoms */
2112 int eqv(pointer a, pointer b) {
2113      if (is_string(a)) {
2114           if (is_string(b))
2115                return (strvalue(a) == strvalue(b));
2116           else
2117                return (0);
2118      } else if (is_number(a)) {
2119           if (is_number(b)) {
2120                if (num_is_integer(a) == num_is_integer(b))
2121                     return num_eq(nvalue(a),nvalue(b));
2122           }
2123           return (0);
2124      } else if (is_character(a)) {
2125           if (is_character(b))
2126                return charvalue(a)==charvalue(b);
2127           else
2128                return (0);
2129      } else if (is_port(a)) {
2130           if (is_port(b))
2131                return a==b;
2132           else
2133                return (0);
2134      } else if (is_proc(a)) {
2135           if (is_proc(b))
2136                return procnum(a)==procnum(b);
2137           else
2138                return (0);
2139      } else {
2140           return (a == b);
2141      }
2142 }
2143
2144 /* true or false value macro */
2145 /* () is #t in R5RS */
2146 #define is_true(p)       ((p) != sc->F)
2147 #define is_false(p)      ((p) == sc->F)
2148
2149 /* ========== Environment implementation  ========== */
2150
2151 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2152
2153 static int hash_fn(const char *key, int table_size)
2154 {
2155   unsigned int hashed = 0;
2156   const char *c;
2157   int bits_per_int = sizeof(unsigned int)*8;
2158
2159   for (c = key; *c; c++) {
2160     /* letters have about 5 bits in them */
2161     hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
2162     hashed ^= *c;
2163   }
2164   return hashed % table_size;
2165 }
2166 #endif
2167
2168 #ifndef USE_ALIST_ENV
2169
2170 /*
2171  * In this implementation, each frame of the environment may be
2172  * a hash table: a vector of alists hashed by variable name.
2173  * In practice, we use a vector only for the initial frame;
2174  * subsequent frames are too small and transient for the lookup
2175  * speed to out-weigh the cost of making a new vector.
2176  */
2177
2178 static void new_frame_in_env(scheme *sc, pointer old_env)
2179 {
2180   pointer new_frame;
2181
2182   /* The interaction-environment has about 300 variables in it. */
2183   if (old_env == sc->NIL) {
2184     new_frame = mk_vector(sc, 461);
2185   } else {
2186     new_frame = sc->NIL;
2187   }
2188
2189   sc->envir = immutable_cons(sc, new_frame, old_env);
2190   setenvironment(sc->envir);
2191 }
2192
2193 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2194                                         pointer variable, pointer value)
2195 {
2196   pointer slot = immutable_cons(sc, variable, value);
2197
2198   if (is_vector(car(env))) {
2199     int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
2200
2201     set_vector_elem(car(env), location,
2202                     immutable_cons(sc, slot, vector_elem(car(env), location)));
2203   } else {
2204     car(env) = immutable_cons(sc, slot, car(env));
2205   }
2206 }
2207
2208 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2209 {
2210   pointer x,y;
2211   int location;
2212
2213   for (x = env; x != sc->NIL; x = cdr(x)) {
2214     if (is_vector(car(x))) {
2215       location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
2216       y = vector_elem(car(x), location);
2217     } else {
2218       y = car(x);
2219     }
2220     for ( ; y != sc->NIL; y = cdr(y)) {
2221               if (caar(y) == hdl) {
2222                    break;
2223               }
2224          }
2225          if (y != sc->NIL) {
2226               break;
2227          }
2228          if(!all) {
2229            return sc->NIL;
2230          }
2231     }
2232     if (x != sc->NIL) {
2233           return car(y);
2234     }
2235     return sc->NIL;
2236 }
2237
2238 #else /* USE_ALIST_ENV */
2239
2240 static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
2241 {
2242   sc->envir = immutable_cons(sc, sc->NIL, old_env);
2243   setenvironment(sc->envir);
2244 }
2245
2246 static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
2247                                         pointer variable, pointer value)
2248 {
2249   car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
2250 }
2251
2252 static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
2253 {
2254     pointer x,y;
2255     for (x = env; x != sc->NIL; x = cdr(x)) {
2256          for (y = car(x); y != sc->NIL; y = cdr(y)) {
2257               if (caar(y) == hdl) {
2258                    break;
2259               }
2260          }
2261          if (y != sc->NIL) {
2262               break;
2263          }
2264          if(!all) {
2265            return sc->NIL;
2266          }
2267     }
2268     if (x != sc->NIL) {
2269           return car(y);
2270     }
2271     return sc->NIL;
2272 }
2273
2274 #endif /* USE_ALIST_ENV else */
2275
2276 static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
2277 {
2278   new_slot_spec_in_env(sc, sc->envir, variable, value);
2279 }
2280
2281 static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
2282 {
2283   cdr(slot) = value;
2284 }
2285
2286 static INLINE pointer slot_value_in_env(pointer slot)
2287 {
2288   return cdr(slot);
2289 }
2290
2291 /* ========== Evaluation Cycle ========== */
2292
2293
2294 static pointer _Error_1(scheme *sc, const char *s, pointer a) {
2295      const char *str = s;
2296 #if USE_ERROR_HOOK
2297      pointer x;
2298      pointer hdl=sc->ERROR_HOOK;
2299 #endif
2300
2301 #if SHOW_ERROR_LINE
2302      char sbuf[STRBUFFSIZE];
2303
2304      /* make sure error is not in REPL */
2305      if (sc->load_stack[sc->file_i].kind & port_file &&
2306          sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
2307        int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
2308        const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
2309
2310        /* should never happen */
2311        if(!fname) fname = "<unknown>";
2312
2313        /* we started from 0 */
2314        ln++;
2315        snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
2316
2317        str = (const char*)sbuf;
2318      }
2319 #endif
2320
2321 #if USE_ERROR_HOOK
2322      x=find_slot_in_env(sc,sc->envir,hdl,1);
2323     if (x != sc->NIL) {
2324          if(a!=0) {
2325                sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
2326          } else {
2327                sc->code = sc->NIL;
2328          }
2329          sc->code = cons(sc, mk_string(sc, str), sc->code);
2330          setimmutable(car(sc->code));
2331          sc->code = cons(sc, slot_value_in_env(x), sc->code);
2332          sc->op = (int)OP_EVAL;
2333          return sc->T;
2334     }
2335 #endif
2336
2337     if(a!=0) {
2338           sc->args = cons(sc, (a), sc->NIL);
2339     } else {
2340           sc->args = sc->NIL;
2341     }
2342     sc->args = cons(sc, mk_string(sc, str), sc->args);
2343     setimmutable(car(sc->args));
2344     sc->op = (int)OP_ERR0;
2345     return sc->T;
2346 }
2347 #define Error_1(sc,s, a) return _Error_1(sc,s,a)
2348 #define Error_0(sc,s)    return _Error_1(sc,s,0)
2349
2350 /* Too small to turn into function */
2351 # define  BEGIN     do {
2352 # define  END  } while (0)
2353 #define s_goto(sc,a) BEGIN                                  \
2354     sc->op = (int)(a);                                      \
2355     return sc->T; END
2356
2357 #define s_return(sc,a) return _s_return(sc,a)
2358
2359 #ifndef USE_SCHEME_STACK
2360
2361 /* this structure holds all the interpreter's registers */
2362 struct dump_stack_frame {
2363   enum scheme_opcodes op;
2364   pointer args;
2365   pointer envir;
2366   pointer code;
2367 };
2368
2369 #define STACK_GROWTH 3
2370
2371 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
2372 {
2373   int nframes = (int)sc->dump;
2374   struct dump_stack_frame *next_frame;
2375
2376   /* enough room for the next frame? */
2377   if (nframes >= sc->dump_size) {
2378     sc->dump_size += STACK_GROWTH;
2379     /* alas there is no sc->realloc */
2380     sc->dump_base = realloc(sc->dump_base,
2381                             sizeof(struct dump_stack_frame) * sc->dump_size);
2382   }
2383   next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2384   next_frame->op = op;
2385   next_frame->args = args;
2386   next_frame->envir = sc->envir;
2387   next_frame->code = code;
2388   sc->dump = (pointer)(nframes+1);
2389 }
2390
2391 static pointer _s_return(scheme *sc, pointer a)
2392 {
2393   int nframes = (int)sc->dump;
2394   struct dump_stack_frame *frame;
2395
2396   sc->value = (a);
2397   if (nframes <= 0) {
2398     return sc->NIL;
2399   }
2400   nframes--;
2401   frame = (struct dump_stack_frame *)sc->dump_base + nframes;
2402   sc->op = frame->op;
2403   sc->args = frame->args;
2404   sc->envir = frame->envir;
2405   sc->code = frame->code;
2406   sc->dump = (pointer)nframes;
2407   return sc->T;
2408 }
2409
2410 static INLINE void dump_stack_reset(scheme *sc)
2411 {
2412   /* in this implementation, sc->dump is the number of frames on the stack */
2413   sc->dump = (pointer)0;
2414 }
2415
2416 static INLINE void dump_stack_initialize(scheme *sc)
2417 {
2418   sc->dump_size = 0;
2419   sc->dump_base = NULL;
2420   dump_stack_reset(sc);
2421 }
2422
2423 static void dump_stack_free(scheme *sc)
2424 {
2425   free(sc->dump_base);
2426   sc->dump_base = NULL;
2427   sc->dump = (pointer)0;
2428   sc->dump_size = 0;
2429 }
2430
2431 static INLINE void dump_stack_mark(scheme *sc)
2432 {
2433   int nframes = (int)sc->dump;
2434   int i;
2435   for(i=0; i<nframes; i++) {
2436     struct dump_stack_frame *frame;
2437     frame = (struct dump_stack_frame *)sc->dump_base + i;
2438     mark(frame->args);
2439     mark(frame->envir);
2440     mark(frame->code);
2441   }
2442 }
2443
2444 #else
2445
2446 static INLINE void dump_stack_reset(scheme *sc)
2447 {
2448   sc->dump = sc->NIL;
2449 }
2450
2451 static INLINE void dump_stack_initialize(scheme *sc)
2452 {
2453   dump_stack_reset(sc);
2454 }
2455
2456 static void dump_stack_free(scheme *sc)
2457 {
2458   sc->dump = sc->NIL;
2459 }
2460
2461 static pointer _s_return(scheme *sc, pointer a) {
2462     sc->value = (a);
2463     if(sc->dump==sc->NIL) return sc->NIL;
2464     sc->op = ivalue(car(sc->dump));
2465     sc->args = cadr(sc->dump);
2466     sc->envir = caddr(sc->dump);
2467     sc->code = cadddr(sc->dump);
2468     sc->dump = cddddr(sc->dump);
2469     return sc->T;
2470 }
2471
2472 static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
2473     sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
2474     sc->dump = cons(sc, (args), sc->dump);
2475     sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
2476 }
2477
2478 static INLINE void dump_stack_mark(scheme *sc)
2479 {
2480   mark(sc->dump);
2481 }
2482 #endif
2483
2484 #define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
2485
2486 static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
2487      pointer x, y;
2488
2489      switch (op) {
2490      case OP_LOAD:       /* load */
2491           if(file_interactive(sc)) {
2492                fprintf(sc->outport->_object._port->rep.stdio.file,
2493                "Loading %s\n", strvalue(car(sc->args)));
2494           }
2495           if (!file_push(sc,strvalue(car(sc->args)))) {
2496                Error_1(sc,"unable to open", car(sc->args));
2497           }
2498       else
2499         {
2500           sc->args = mk_integer(sc,sc->file_i);
2501           s_goto(sc,OP_T0LVL);
2502         }
2503
2504      case OP_T0LVL: /* top level */
2505        /* If we reached the end of file, this loop is done. */
2506        if(sc->loadport->_object._port->kind & port_saw_EOF)
2507      {
2508        if(sc->file_i == 0)
2509          {
2510            sc->args=sc->NIL;
2511            s_goto(sc,OP_QUIT);
2512          }
2513        else
2514          {
2515            file_pop(sc);
2516            s_return(sc,sc->value);
2517          }
2518        /* NOTREACHED */
2519      }
2520
2521        /* If interactive, be nice to user. */
2522        if(file_interactive(sc))
2523      {
2524        sc->envir = sc->global_env;
2525        dump_stack_reset(sc);
2526        putstr(sc,"\n");
2527        putstr(sc,prompt);
2528      }
2529
2530        /* Set up another iteration of REPL */
2531        sc->nesting=0;
2532        sc->save_inport=sc->inport;
2533        sc->inport = sc->loadport;
2534        s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
2535        s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
2536        s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
2537        s_goto(sc,OP_READ_INTERNAL);
2538
2539      case OP_T1LVL: /* top level */
2540           sc->code = sc->value;
2541           sc->inport=sc->save_inport;
2542           s_goto(sc,OP_EVAL);
2543
2544      case OP_READ_INTERNAL:       /* internal read */
2545           sc->tok = token(sc);
2546           if(sc->tok==TOK_EOF)
2547         { s_return(sc,sc->EOF_OBJ); }
2548           s_goto(sc,OP_RDSEXPR);
2549
2550      case OP_GENSYM:
2551           s_return(sc, gensym(sc));
2552
2553      case OP_VALUEPRINT: /* print evaluation result */
2554           /* OP_VALUEPRINT is always pushed, because when changing from
2555              non-interactive to interactive mode, it needs to be
2556              already on the stack */
2557        if(sc->tracing) {
2558          putstr(sc,"\nGives: ");
2559        }
2560        if(file_interactive(sc)) {
2561          sc->print_flag = 1;
2562          sc->args = sc->value;
2563          s_goto(sc,OP_P0LIST);
2564        } else {
2565          s_return(sc,sc->value);
2566        }
2567
2568      case OP_EVAL:       /* main part of evaluation */
2569 #if USE_TRACING
2570        if(sc->tracing) {
2571          /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
2572          s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
2573          sc->args=sc->code;
2574          putstr(sc,"\nEval: ");
2575          s_goto(sc,OP_P0LIST);
2576        }
2577        /* fall through */
2578      case OP_REAL_EVAL:
2579 #endif
2580           if (is_symbol(sc->code)) {    /* symbol */
2581                x=find_slot_in_env(sc,sc->envir,sc->code,1);
2582                if (x != sc->NIL) {
2583                     s_return(sc,slot_value_in_env(x));
2584                } else {
2585                     Error_1(sc,"eval: unbound variable:", sc->code);
2586                }
2587           } else if (is_pair(sc->code)) {
2588                if (is_syntax(x = car(sc->code))) {     /* SYNTAX */
2589                     sc->code = cdr(sc->code);
2590                     s_goto(sc,syntaxnum(x));
2591                } else {/* first, eval top element and eval arguments */
2592                     s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
2593                     /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
2594                     sc->code = car(sc->code);
2595                     s_goto(sc,OP_EVAL);
2596                }
2597           } else {
2598                s_return(sc,sc->code);
2599           }
2600
2601      case OP_E0ARGS:     /* eval arguments */
2602           if (is_macro(sc->value)) {    /* macro expansion */
2603                s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
2604                sc->args = cons(sc,sc->code, sc->NIL);
2605                sc->code = sc->value;
2606                s_goto(sc,OP_APPLY);
2607           } else {
2608                sc->code = cdr(sc->code);
2609                s_goto(sc,OP_E1ARGS);
2610           }
2611
2612      case OP_E1ARGS:     /* eval arguments */
2613           sc->args = cons(sc, sc->value, sc->args);
2614           if (is_pair(sc->code)) { /* continue */
2615                s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
2616                sc->code = car(sc->code);
2617                sc->args = sc->NIL;
2618                s_goto(sc,OP_EVAL);
2619           } else {  /* end */
2620                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2621                sc->code = car(sc->args);
2622                sc->args = cdr(sc->args);
2623                s_goto(sc,OP_APPLY);
2624           }
2625
2626 #if USE_TRACING
2627      case OP_TRACING: {
2628        int tr=sc->tracing;
2629        sc->tracing=ivalue(car(sc->args));
2630        s_return(sc,mk_integer(sc,tr));
2631      }
2632 #endif
2633
2634      case OP_APPLY:      /* apply 'code' to 'args' */
2635 #if USE_TRACING
2636        if(sc->tracing) {
2637          s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
2638          sc->print_flag = 1;
2639          /*  sc->args=cons(sc,sc->code,sc->args);*/
2640          putstr(sc,"\nApply to: ");
2641          s_goto(sc,OP_P0LIST);
2642        }
2643        /* fall through */
2644      case OP_REAL_APPLY:
2645 #endif
2646           if (is_proc(sc->code)) {
2647                s_goto(sc,procnum(sc->code));   /* PROCEDURE */
2648           } else if (is_foreign(sc->code))
2649             {
2650               /* Keep nested calls from GC'ing the arglist */
2651               push_recent_alloc(sc,sc->args,sc->NIL);
2652                x=sc->code->_object._ff(sc,sc->args);
2653                s_return(sc,x);
2654           } else if (is_closure(sc->code) || is_macro(sc->code)
2655              || is_promise(sc->code)) { /* CLOSURE */
2656         /* Should not accept promise */
2657                /* make environment */
2658                new_frame_in_env(sc, closure_env(sc->code));
2659                for (x = car(closure_code(sc->code)), y = sc->args;
2660                     is_pair(x); x = cdr(x), y = cdr(y)) {
2661                     if (y == sc->NIL) {
2662                          Error_0(sc,"not enough arguments");
2663                     } else {
2664                          new_slot_in_env(sc, car(x), car(y));
2665                     }
2666                }
2667                if (x == sc->NIL) {
2668                     /*--
2669                      * if (y != sc->NIL) {
2670                      *   Error_0(sc,"too many arguments");
2671                      * }
2672                      */
2673                } else if (is_symbol(x))
2674                     new_slot_in_env(sc, x, y);
2675                else {
2676                     Error_1(sc,"syntax error in closure: not a symbol:", x);
2677                }
2678                sc->code = cdr(closure_code(sc->code));
2679                sc->args = sc->NIL;
2680                s_goto(sc,OP_BEGIN);
2681           } else if (is_continuation(sc->code)) { /* CONTINUATION */
2682                sc->dump = cont_dump(sc->code);
2683                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
2684           } else {
2685                Error_0(sc,"illegal function");
2686           }
2687
2688      case OP_DOMACRO:    /* do macro */
2689           sc->code = sc->value;
2690           s_goto(sc,OP_EVAL);
2691
2692 #if 1
2693      case OP_LAMBDA:     /* lambda */
2694           /* If the hook is defined, apply it to sc->code, otherwise
2695              set sc->value fall thru */
2696           {
2697                pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
2698                if(f==sc->NIL) {
2699                     sc->value = sc->code;
2700                     /* Fallthru */
2701                } else {
2702                     s_save(sc,OP_LAMBDA1,sc->args,sc->code);
2703                     sc->args=cons(sc,sc->code,sc->NIL);
2704                     sc->code=slot_value_in_env(f);
2705                     s_goto(sc,OP_APPLY);
2706                }
2707           }
2708
2709      case OP_LAMBDA1:
2710           s_return(sc,mk_closure(sc, sc->value, sc->envir));
2711
2712 #else
2713      case OP_LAMBDA:     /* lambda */
2714           s_return(sc,mk_closure(sc, sc->code, sc->envir));
2715
2716 #endif
2717
2718      case OP_MKCLOSURE: /* make-closure */
2719        x=car(sc->args);
2720        if(car(x)==sc->LAMBDA) {
2721          x=cdr(x);
2722        }
2723        if(cdr(sc->args)==sc->NIL) {
2724          y=sc->envir;
2725        } else {
2726          y=cadr(sc->args);
2727        }
2728        s_return(sc,mk_closure(sc, x, y));
2729
2730      case OP_QUOTE:      /* quote */
2731           s_return(sc,car(sc->code));
2732
2733      case OP_DEF0:  /* define */
2734           if(is_immutable(car(sc->code)))
2735             Error_1(sc,"define: unable to alter immutable", car(sc->code));
2736
2737           if (is_pair(car(sc->code))) {
2738                x = caar(sc->code);
2739                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
2740           } else {
2741                x = car(sc->code);
2742                sc->code = cadr(sc->code);
2743           }
2744           if (!is_symbol(x)) {
2745                Error_0(sc,"variable is not a symbol");
2746           }
2747           s_save(sc,OP_DEF1, sc->NIL, x);
2748           s_goto(sc,OP_EVAL);
2749
2750      case OP_DEF1:  /* define */
2751           x=find_slot_in_env(sc,sc->envir,sc->code,0);
2752           if (x != sc->NIL) {
2753                set_slot_in_env(sc, x, sc->value);
2754           } else {
2755                new_slot_in_env(sc, sc->code, sc->value);
2756           }
2757           s_return(sc,sc->code);
2758
2759
2760      case OP_DEFP:  /* defined? */
2761           x=sc->envir;
2762           if(cdr(sc->args)!=sc->NIL) {
2763                x=cadr(sc->args);
2764           }
2765           s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
2766
2767      case OP_SET0:       /* set! */
2768           if(is_immutable(car(sc->code)))
2769                 Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
2770           s_save(sc,OP_SET1, sc->NIL, car(sc->code));
2771           sc->code = cadr(sc->code);
2772           s_goto(sc,OP_EVAL);
2773
2774      case OP_SET1:       /* set! */
2775           y=find_slot_in_env(sc,sc->envir,sc->code,1);
2776           if (y != sc->NIL) {
2777                set_slot_in_env(sc, y, sc->value);
2778                s_return(sc,sc->value);
2779           } else {
2780                Error_1(sc,"set!: unbound variable:", sc->code);
2781           }
2782
2783
2784      case OP_BEGIN:      /* begin */
2785           if (!is_pair(sc->code)) {
2786                s_return(sc,sc->code);
2787           }
2788           if (cdr(sc->code) != sc->NIL) {
2789                s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
2790           }
2791           sc->code = car(sc->code);
2792           s_goto(sc,OP_EVAL);
2793
2794      case OP_IF0:        /* if */
2795           s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
2796           sc->code = car(sc->code);
2797           s_goto(sc,OP_EVAL);
2798
2799      case OP_IF1:        /* if */
2800           if (is_true(sc->value))
2801                sc->code = car(sc->code);
2802           else
2803                sc->code = cadr(sc->code);  /* (if #f 1) ==> () because
2804                                             * car(sc->NIL) = sc->NIL */
2805           s_goto(sc,OP_EVAL);
2806
2807      case OP_LET0:       /* let */
2808           sc->args = sc->NIL;
2809           sc->value = sc->code;
2810           sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
2811           s_goto(sc,OP_LET1);
2812
2813      case OP_LET1:       /* let (calculate parameters) */
2814           sc->args = cons(sc, sc->value, sc->args);
2815           if (is_pair(sc->code)) { /* continue */
2816                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2817                     Error_1(sc, "Bad syntax of binding spec in let :",
2818                             car(sc->code));
2819                }
2820                s_save(sc,OP_LET1, sc->args, cdr(sc->code));
2821                sc->code = cadar(sc->code);
2822                sc->args = sc->NIL;
2823                s_goto(sc,OP_EVAL);
2824           } else {  /* end */
2825                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2826                sc->code = car(sc->args);
2827                sc->args = cdr(sc->args);
2828                s_goto(sc,OP_LET2);
2829           }
2830
2831      case OP_LET2:       /* let */
2832           new_frame_in_env(sc, sc->envir);
2833           for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
2834                y != sc->NIL; x = cdr(x), y = cdr(y)) {
2835                new_slot_in_env(sc, caar(x), car(y));
2836           }
2837           if (is_symbol(car(sc->code))) {    /* named let */
2838                for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
2839                     if (!is_pair(x))
2840                         Error_1(sc, "Bad syntax of binding in let :", x);
2841                     if (!is_list(sc, car(x)))
2842                         Error_1(sc, "Bad syntax of binding in let :", car(x));
2843                     sc->args = cons(sc, caar(x), sc->args);
2844                }
2845                x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
2846                new_slot_in_env(sc, car(sc->code), x);
2847                sc->code = cddr(sc->code);
2848                sc->args = sc->NIL;
2849           } else {
2850                sc->code = cdr(sc->code);
2851                sc->args = sc->NIL;
2852           }
2853           s_goto(sc,OP_BEGIN);
2854
2855      case OP_LET0AST:    /* let* */
2856           if (car(sc->code) == sc->NIL) {
2857                new_frame_in_env(sc, sc->envir);
2858                sc->code = cdr(sc->code);
2859                s_goto(sc,OP_BEGIN);
2860           }
2861           if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
2862                Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
2863           }
2864           s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
2865           sc->code = cadaar(sc->code);
2866           s_goto(sc,OP_EVAL);
2867
2868      case OP_LET1AST:    /* let* (make new frame) */
2869           new_frame_in_env(sc, sc->envir);
2870           s_goto(sc,OP_LET2AST);
2871
2872      case OP_LET2AST:    /* let* (calculate parameters) */
2873           new_slot_in_env(sc, caar(sc->code), sc->value);
2874           sc->code = cdr(sc->code);
2875           if (is_pair(sc->code)) { /* continue */
2876                s_save(sc,OP_LET2AST, sc->args, sc->code);
2877                sc->code = cadar(sc->code);
2878                sc->args = sc->NIL;
2879                s_goto(sc,OP_EVAL);
2880           } else {  /* end */
2881                sc->code = sc->args;
2882                sc->args = sc->NIL;
2883                s_goto(sc,OP_BEGIN);
2884           }
2885      default:
2886           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
2887           Error_0(sc,sc->strbuff);
2888      }
2889      return sc->T;
2890 }
2891
2892 static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
2893      pointer x, y;
2894
2895      switch (op) {
2896      case OP_LET0REC:    /* letrec */
2897           new_frame_in_env(sc, sc->envir);
2898           sc->args = sc->NIL;
2899           sc->value = sc->code;
2900           sc->code = car(sc->code);
2901           s_goto(sc,OP_LET1REC);
2902
2903      case OP_LET1REC:    /* letrec (calculate parameters) */
2904           sc->args = cons(sc, sc->value, sc->args);
2905           if (is_pair(sc->code)) { /* continue */
2906                if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
2907                     Error_1(sc, "Bad syntax of binding spec in letrec :",
2908                             car(sc->code));
2909                }
2910                s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
2911                sc->code = cadar(sc->code);
2912                sc->args = sc->NIL;
2913                s_goto(sc,OP_EVAL);
2914           } else {  /* end */
2915                sc->args = reverse_in_place(sc, sc->NIL, sc->args);
2916                sc->code = car(sc->args);
2917                sc->args = cdr(sc->args);
2918                s_goto(sc,OP_LET2REC);
2919           }
2920
2921      case OP_LET2REC:    /* letrec */
2922           for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
2923                new_slot_in_env(sc, caar(x), car(y));
2924           }
2925           sc->code = cdr(sc->code);
2926           sc->args = sc->NIL;
2927           s_goto(sc,OP_BEGIN);
2928
2929      case OP_COND0:      /* cond */
2930           if (!is_pair(sc->code)) {
2931                Error_0(sc,"syntax error in cond");
2932           }
2933           s_save(sc,OP_COND1, sc->NIL, sc->code);
2934           sc->code = caar(sc->code);
2935           s_goto(sc,OP_EVAL);
2936
2937      case OP_COND1:      /* cond */
2938           if (is_true(sc->value)) {
2939                if ((sc->code = cdar(sc->code)) == sc->NIL) {
2940                     s_return(sc,sc->value);
2941                }
2942                if(!sc->code || car(sc->code)==sc->FEED_TO) {
2943                     if(!is_pair(cdr(sc->code))) {
2944                          Error_0(sc,"syntax error in cond");
2945                     }
2946                     x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
2947                     sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
2948                     s_goto(sc,OP_EVAL);
2949                }
2950                s_goto(sc,OP_BEGIN);
2951           } else {
2952                if ((sc->code = cdr(sc->code)) == sc->NIL) {
2953                     s_return(sc,sc->NIL);
2954                } else {
2955                     s_save(sc,OP_COND1, sc->NIL, sc->code);
2956                     sc->code = caar(sc->code);
2957                     s_goto(sc,OP_EVAL);
2958                }
2959           }
2960
2961      case OP_DELAY:      /* delay */
2962           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
2963           typeflag(x)=T_PROMISE;
2964           s_return(sc,x);
2965
2966      case OP_AND0:       /* and */
2967           if (sc->code == sc->NIL) {
2968                s_return(sc,sc->T);
2969           }
2970           s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
2971           sc->code = car(sc->code);
2972           s_goto(sc,OP_EVAL);
2973
2974      case OP_AND1:       /* and */
2975           if (is_false(sc->value)) {
2976                s_return(sc,sc->value);
2977           } else if (sc->code == sc->NIL) {
2978                s_return(sc,sc->value);
2979           } else {
2980                s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
2981                sc->code = car(sc->code);
2982                s_goto(sc,OP_EVAL);
2983           }
2984
2985      case OP_OR0:        /* or */
2986           if (sc->code == sc->NIL) {
2987                s_return(sc,sc->F);
2988           }
2989           s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
2990           sc->code = car(sc->code);
2991           s_goto(sc,OP_EVAL);
2992
2993      case OP_OR1:        /* or */
2994           if (is_true(sc->value)) {
2995                s_return(sc,sc->value);
2996           } else if (sc->code == sc->NIL) {
2997                s_return(sc,sc->value);
2998           } else {
2999                s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
3000                sc->code = car(sc->code);
3001                s_goto(sc,OP_EVAL);
3002           }
3003
3004      case OP_C0STREAM:   /* cons-stream */
3005           s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
3006           sc->code = car(sc->code);
3007           s_goto(sc,OP_EVAL);
3008
3009      case OP_C1STREAM:   /* cons-stream */
3010           sc->args = sc->value;  /* save sc->value to register sc->args for gc */
3011           x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
3012           typeflag(x)=T_PROMISE;
3013           s_return(sc,cons(sc, sc->args, x));
3014
3015      case OP_MACRO0:     /* macro */
3016           if (is_pair(car(sc->code))) {
3017                x = caar(sc->code);
3018                sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
3019           } else {
3020                x = car(sc->code);
3021                sc->code = cadr(sc->code);
3022           }
3023           if (!is_symbol(x)) {
3024                Error_0(sc,"variable is not a symbol");
3025           }
3026           s_save(sc,OP_MACRO1, sc->NIL, x);
3027           s_goto(sc,OP_EVAL);
3028
3029      case OP_MACRO1:     /* macro */
3030           typeflag(sc->value) = T_MACRO;
3031           x = find_slot_in_env(sc, sc->envir, sc->code, 0);
3032           if (x != sc->NIL) {
3033                set_slot_in_env(sc, x, sc->value);
3034           } else {
3035                new_slot_in_env(sc, sc->code, sc->value);
3036           }
3037           s_return(sc,sc->code);
3038
3039      case OP_CASE0:      /* case */
3040           s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
3041           sc->code = car(sc->code);
3042           s_goto(sc,OP_EVAL);
3043
3044      case OP_CASE1:      /* case */
3045           for (x = sc->code; x != sc->NIL; x = cdr(x)) {
3046                if (!is_pair(y = caar(x))) {
3047                     break;
3048                }
3049                for ( ; y != sc->NIL; y = cdr(y)) {
3050                     if (eqv(car(y), sc->value)) {
3051                          break;
3052                     }
3053                }
3054                if (y != sc->NIL) {
3055                     break;
3056                }
3057           }
3058           if (x != sc->NIL) {
3059                if (is_pair(caar(x))) {
3060                     sc->code = cdar(x);
3061                     s_goto(sc,OP_BEGIN);
3062                } else {/* else */
3063                     s_save(sc,OP_CASE2, sc->NIL, cdar(x));
3064                     sc->code = caar(x);
3065                     s_goto(sc,OP_EVAL);
3066                }
3067           } else {
3068                s_return(sc,sc->NIL);
3069           }
3070
3071      case OP_CASE2:      /* case */
3072           if (is_true(sc->value)) {
3073                s_goto(sc,OP_BEGIN);
3074           } else {
3075                s_return(sc,sc->NIL);
3076           }
3077
3078      case OP_PAPPLY:     /* apply */
3079           sc->code = car(sc->args);
3080           sc->args = list_star(sc,cdr(sc->args));
3081           /*sc->args = cadr(sc->args);*/
3082           s_goto(sc,OP_APPLY);
3083
3084      case OP_PEVAL: /* eval */
3085           if(cdr(sc->args)!=sc->NIL) {
3086                sc->envir=cadr(sc->args);
3087           }
3088           sc->code = car(sc->args);
3089           s_goto(sc,OP_EVAL);
3090
3091      case OP_CONTINUATION:    /* call-with-current-continuation */
3092           sc->code = car(sc->args);
3093           sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
3094           s_goto(sc,OP_APPLY);
3095
3096      default:
3097           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3098           Error_0(sc,sc->strbuff);
3099      }
3100      return sc->T;
3101 }
3102
3103 static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
3104      pointer x;
3105      num v;
3106 #if USE_MATH
3107      double dd;
3108 #endif
3109
3110      switch (op) {
3111 #if USE_MATH
3112      case OP_INEX2EX:    /* inexact->exact */
3113           x=car(sc->args);
3114           if(num_is_integer(x)) {
3115                s_return(sc,x);
3116           } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
3117                s_return(sc,mk_integer(sc,ivalue(x)));
3118           } else {
3119                Error_1(sc,"inexact->exact: not integral:",x);
3120           }
3121
3122      case OP_EXP:
3123           x=car(sc->args);
3124           s_return(sc, mk_real(sc, exp(rvalue(x))));
3125
3126      case OP_LOG:
3127           x=car(sc->args);
3128           s_return(sc, mk_real(sc, log(rvalue(x))));
3129
3130      case OP_SIN:
3131           x=car(sc->args);
3132           s_return(sc, mk_real(sc, sin(rvalue(x))));
3133
3134      case OP_COS:
3135           x=car(sc->args);
3136           s_return(sc, mk_real(sc, cos(rvalue(x))));
3137
3138      case OP_TAN:
3139           x=car(sc->args);
3140           s_return(sc, mk_real(sc, tan(rvalue(x))));
3141
3142      case OP_ASIN:
3143           x=car(sc->args);
3144           s_return(sc, mk_real(sc, asin(rvalue(x))));
3145
3146      case OP_ACOS:
3147           x=car(sc->args);
3148           s_return(sc, mk_real(sc, acos(rvalue(x))));
3149
3150      case OP_ATAN:
3151           x=car(sc->args);
3152           if(cdr(sc->args)==sc->NIL) {
3153                s_return(sc, mk_real(sc, atan(rvalue(x))));
3154           } else {
3155                pointer y=cadr(sc->args);
3156                s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
3157           }
3158
3159      case OP_SQRT:
3160           x=car(sc->args);
3161           s_return(sc, mk_real(sc, sqrt(rvalue(x))));
3162
3163      case OP_EXPT: {
3164           double result;
3165           int real_result=1;
3166           pointer y=cadr(sc->args);
3167           x=car(sc->args);
3168           if (num_is_integer(x) && num_is_integer(y))
3169              real_result=0;
3170           /* This 'if' is an R5RS compatibility fix. */
3171           /* NOTE: Remove this 'if' fix for R6RS.    */
3172           if (rvalue(x) == 0 && rvalue(y) < 0) {
3173              result = 0.0;
3174           } else {
3175              result = pow(rvalue(x),rvalue(y));
3176           }
3177           /* Before returning integer result make sure we can. */
3178           /* If the test fails, result is too big for integer. */
3179           if (!real_result)
3180           {
3181             long result_as_long = (long)result;
3182             if (result != (double)result_as_long)
3183               real_result = 1;
3184           }
3185           if (real_result) {
3186              s_return(sc, mk_real(sc, result));
3187           } else {
3188              s_return(sc, mk_integer(sc, result));
3189           }
3190      }
3191
3192      case OP_FLOOR:
3193           x=car(sc->args);
3194           s_return(sc, mk_real(sc, floor(rvalue(x))));
3195
3196      case OP_CEILING:
3197           x=car(sc->args);
3198           s_return(sc, mk_real(sc, ceil(rvalue(x))));
3199
3200      case OP_TRUNCATE : {
3201           double rvalue_of_x ;
3202           x=car(sc->args);
3203           rvalue_of_x = rvalue(x) ;
3204           if (rvalue_of_x > 0) {
3205             s_return(sc, mk_real(sc, floor(rvalue_of_x)));
3206           } else {
3207             s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
3208           }
3209      }
3210
3211      case OP_ROUND:
3212         x=car(sc->args);
3213         if (num_is_integer(x))
3214             s_return(sc, x);
3215         s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
3216 #endif
3217
3218      case OP_ADD:        /* + */
3219        v=num_zero;
3220        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3221          v=num_add(v,nvalue(car(x)));
3222        }
3223        s_return(sc,mk_number(sc, v));
3224
3225      case OP_MUL:        /* * */
3226        v=num_one;
3227        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3228          v=num_mul(v,nvalue(car(x)));
3229        }
3230        s_return(sc,mk_number(sc, v));
3231
3232      case OP_SUB:        /* - */
3233        if(cdr(sc->args)==sc->NIL) {
3234          x=sc->args;
3235          v=num_zero;
3236        } else {
3237          x = cdr(sc->args);
3238          v = nvalue(car(sc->args));
3239        }
3240        for (; x != sc->NIL; x = cdr(x)) {
3241          v=num_sub(v,nvalue(car(x)));
3242        }
3243        s_return(sc,mk_number(sc, v));
3244
3245      case OP_DIV:        /* / */
3246        if(cdr(sc->args)==sc->NIL) {
3247          x=sc->args;
3248          v=num_one;
3249        } else {
3250          x = cdr(sc->args);
3251          v = nvalue(car(sc->args));
3252        }
3253        for (; x != sc->NIL; x = cdr(x)) {
3254          if (!is_zero_double(rvalue(car(x))))
3255            v=num_div(v,nvalue(car(x)));
3256          else {
3257            Error_0(sc,"/: division by zero");
3258          }
3259        }
3260        s_return(sc,mk_number(sc, v));
3261
3262      case OP_INTDIV:        /* quotient */
3263           if(cdr(sc->args)==sc->NIL) {
3264                x=sc->args;
3265                v=num_one;
3266           } else {
3267                x = cdr(sc->args);
3268                v = nvalue(car(sc->args));
3269           }
3270           for (; x != sc->NIL; x = cdr(x)) {
3271                if (ivalue(car(x)) != 0)
3272                     v=num_intdiv(v,nvalue(car(x)));
3273                else {
3274                     Error_0(sc,"quotient: division by zero");
3275                }
3276           }
3277           s_return(sc,mk_number(sc, v));
3278
3279      case OP_REM:        /* remainder */
3280           v = nvalue(car(sc->args));
3281           if (ivalue(cadr(sc->args)) != 0)
3282                v=num_rem(v,nvalue(cadr(sc->args)));
3283           else {
3284                Error_0(sc,"remainder: division by zero");
3285           }
3286           s_return(sc,mk_number(sc, v));
3287
3288      case OP_MOD:        /* modulo */
3289           v = nvalue(car(sc->args));
3290           if (ivalue(cadr(sc->args)) != 0)
3291                v=num_mod(v,nvalue(cadr(sc->args)));
3292           else {
3293                Error_0(sc,"modulo: division by zero");
3294           }
3295           s_return(sc,mk_number(sc, v));
3296
3297      case OP_CAR:        /* car */
3298           s_return(sc,caar(sc->args));
3299
3300      case OP_CDR:        /* cdr */
3301           s_return(sc,cdar(sc->args));
3302
3303      case OP_CONS:       /* cons */
3304           cdr(sc->args) = cadr(sc->args);
3305           s_return(sc,sc->args);
3306
3307      case OP_SETCAR:     /* set-car! */
3308        if(!is_immutable(car(sc->args))) {
3309          caar(sc->args) = cadr(sc->args);
3310          s_return(sc,car(sc->args));
3311        } else {
3312          Error_0(sc,"set-car!: unable to alter immutable pair");
3313        }
3314
3315      case OP_SETCDR:     /* set-cdr! */
3316        if(!is_immutable(car(sc->args))) {
3317          cdar(sc->args) = cadr(sc->args);
3318          s_return(sc,car(sc->args));
3319        } else {
3320          Error_0(sc,"set-cdr!: unable to alter immutable pair");
3321        }
3322
3323      case OP_CHAR2INT: { /* char->integer */
3324           char c;
3325           c=(char)ivalue(car(sc->args));
3326           s_return(sc,mk_integer(sc,(unsigned char)c));
3327      }
3328
3329      case OP_INT2CHAR: { /* integer->char */
3330           unsigned char c;
3331           c=(unsigned char)ivalue(car(sc->args));
3332           s_return(sc,mk_character(sc,(char)c));
3333      }
3334
3335      case OP_CHARUPCASE: {
3336           unsigned char c;
3337           c=(unsigned char)ivalue(car(sc->args));
3338           c=toupper(c);
3339           s_return(sc,mk_character(sc,(char)c));
3340      }
3341
3342      case OP_CHARDNCASE: {
3343           unsigned char c;
3344           c=(unsigned char)ivalue(car(sc->args));
3345           c=tolower(c);
3346           s_return(sc,mk_character(sc,(char)c));
3347      }
3348
3349      case OP_STR2SYM:  /* string->symbol */
3350           s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
3351
3352      case OP_STR2ATOM: /* string->atom */ {
3353           char *s=strvalue(car(sc->args));
3354           long pf = 0;
3355           if(cdr(sc->args)!=sc->NIL) {
3356             /* we know cadr(sc->args) is a natural number */
3357             /* see if it is 2, 8, 10, or 16, or error */
3358             pf = ivalue_unchecked(cadr(sc->args));
3359             if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
3360                /* base is OK */
3361             }
3362             else {
3363               pf = -1;
3364             }
3365           }
3366           if (pf < 0) {
3367             Error_1(sc, "string->atom: bad base:", cadr(sc->args));
3368           } else if(*s=='#') /* no use of base! */ {
3369             s_return(sc, mk_sharp_const(sc, s+1));
3370           } else {
3371             if (pf == 0 || pf == 10) {
3372               s_return(sc, mk_atom(sc, s));
3373             }
3374             else {
3375               char *ep;
3376               long iv = strtol(s,&ep,(int )pf);
3377               if (*ep == 0) {
3378                 s_return(sc, mk_integer(sc, iv));
3379               }
3380               else {
3381                 s_return(sc, sc->F);
3382               }
3383             }
3384           }
3385         }
3386
3387      case OP_SYM2STR: /* symbol->string */
3388           x=mk_string(sc,symname(car(sc->args)));
3389           setimmutable(x);
3390           s_return(sc,x);
3391
3392      case OP_ATOM2STR: /* atom->string */ {
3393           long pf = 0;
3394           x=car(sc->args);
3395           if(cdr(sc->args)!=sc->NIL) {
3396             /* we know cadr(sc->args) is a natural number */
3397             /* see if it is 2, 8, 10, or 16, or error */
3398             pf = ivalue_unchecked(cadr(sc->args));
3399             if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
3400               /* base is OK */
3401             }
3402             else {
3403               pf = -1;
3404             }
3405           }
3406           if (pf < 0) {
3407             Error_1(sc, "atom->string: bad base:", cadr(sc->args));
3408           } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
3409             char *p;
3410             int len;
3411             atom2str(sc,x,(int )pf,&p,&len);
3412             s_return(sc,mk_counted_string(sc,p,len));
3413           } else {
3414             Error_1(sc, "atom->string: not an atom:", x);
3415           }
3416         }
3417
3418      case OP_MKSTRING: { /* make-string */
3419           int fill=' ';
3420           int len;
3421
3422           len=ivalue(car(sc->args));
3423
3424           if(cdr(sc->args)!=sc->NIL) {
3425                fill=charvalue(cadr(sc->args));
3426           }
3427           s_return(sc,mk_empty_string(sc,len,(char)fill));
3428      }
3429
3430      case OP_STRLEN:  /* string-length */
3431           s_return(sc,mk_integer(sc,strlength(car(sc->args))));
3432
3433      case OP_STRREF: { /* string-ref */
3434           char *str;
3435           int index;
3436
3437           str=strvalue(car(sc->args));
3438
3439           index=ivalue(cadr(sc->args));
3440
3441           if(index>=strlength(car(sc->args))) {
3442                Error_1(sc,"string-ref: out of bounds:",cadr(sc->args));
3443           }
3444
3445           s_return(sc,mk_character(sc,((unsigned char*)str)[index]));
3446      }
3447
3448      case OP_STRSET: { /* string-set! */
3449           char *str;
3450           int index;
3451           int c;
3452
3453           if(is_immutable(car(sc->args))) {
3454                Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args));
3455           }
3456           str=strvalue(car(sc->args));
3457
3458           index=ivalue(cadr(sc->args));
3459           if(index>=strlength(car(sc->args))) {
3460                Error_1(sc,"string-set!: out of bounds:",cadr(sc->args));
3461           }
3462
3463           c=charvalue(caddr(sc->args));
3464
3465           str[index]=(char)c;
3466           s_return(sc,car(sc->args));
3467      }
3468
3469      case OP_STRAPPEND: { /* string-append */
3470        /* in 1.29 string-append was in Scheme in init.scm but was too slow */
3471        int len = 0;
3472        pointer newstr;
3473        char *pos;
3474
3475        /* compute needed length for new string */
3476        for (x = sc->args; x != sc->NIL; x = cdr(x)) {
3477           len += strlength(car(x));
3478        }
3479        newstr = mk_empty_string(sc, len, ' ');
3480        /* store the contents of the argument strings into the new string */
3481        for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
3482            pos += strlength(car(x)), x = cdr(x)) {
3483            memcpy(pos, strvalue(car(x)), strlength(car(x)));
3484        }
3485        s_return(sc, newstr);
3486      }
3487
3488      case OP_SUBSTR: { /* substring */
3489           char *str;
3490           int index0;
3491           int index1;
3492           int len;
3493
3494           str=strvalue(car(sc->args));
3495
3496           index0=ivalue(cadr(sc->args));
3497
3498           if(index0>strlength(car(sc->args))) {
3499                Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
3500           }
3501
3502           if(cddr(sc->args)!=sc->NIL) {
3503                index1=ivalue(caddr(sc->args));
3504                if(index1>strlength(car(sc->args)) || index1<index0) {
3505                     Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
3506                }
3507           } else {
3508                index1=strlength(car(sc->args));
3509           }
3510
3511           len=index1-index0;
3512           x=mk_empty_string(sc,len,' ');
3513           memcpy(strvalue(x),str+index0,len);
3514           strvalue(x)[len]=0;
3515
3516           s_return(sc,x);
3517      }
3518
3519      case OP_VECTOR: {   /* vector */
3520           int i;
3521           pointer vec;
3522           int len=list_length(sc,sc->args);
3523           if(len<0) {
3524                Error_1(sc,"vector: not a proper list:",sc->args);
3525           }
3526           vec=mk_vector(sc,len);
3527           if(sc->no_memory) { s_return(sc, sc->sink); }
3528           for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
3529                set_vector_elem(vec,i,car(x));
3530           }
3531           s_return(sc,vec);
3532      }
3533
3534      case OP_MKVECTOR: { /* make-vector */
3535           pointer fill=sc->NIL;
3536           int len;
3537           pointer vec;
3538
3539           len=ivalue(car(sc->args));
3540
3541           if(cdr(sc->args)!=sc->NIL) {
3542                fill=cadr(sc->args);
3543           }
3544           vec=mk_vector(sc,len);
3545           if(sc->no_memory) { s_return(sc, sc->sink); }
3546           if(fill!=sc->NIL) {
3547                fill_vector(vec,fill);
3548           }
3549           s_return(sc,vec);
3550      }
3551
3552      case OP_VECLEN:  /* vector-length */
3553           s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
3554
3555      case OP_VECREF: { /* vector-ref */
3556           int index;
3557
3558           index=ivalue(cadr(sc->args));
3559
3560           if(index>=ivalue(car(sc->args))) {
3561                Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args));
3562           }
3563
3564           s_return(sc,vector_elem(car(sc->args),index));
3565      }
3566
3567      case OP_VECSET: {   /* vector-set! */
3568           int index;
3569
3570           if(is_immutable(car(sc->args))) {
3571                Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
3572           }
3573
3574           index=ivalue(cadr(sc->args));
3575           if(index>=ivalue(car(sc->args))) {
3576                Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
3577           }
3578
3579           set_vector_elem(car(sc->args),index,caddr(sc->args));
3580           s_return(sc,car(sc->args));
3581      }
3582
3583      default:
3584           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3585           Error_0(sc,sc->strbuff);
3586      }
3587      return sc->T;
3588 }
3589
3590 static int is_list(scheme *sc, pointer a)
3591 { return list_length(sc,a) >= 0; }
3592
3593 /* Result is:
3594    proper list: length
3595    circular list: -1
3596    not even a pair: -2
3597    dotted list: -2 minus length before dot
3598 */
3599 int list_length(scheme *sc, pointer a) {
3600     int i=0;
3601     pointer slow, fast;
3602
3603     slow = fast = a;
3604     while (1)
3605     {
3606         if (fast == sc->NIL)
3607                 return i;
3608         if (!is_pair(fast))
3609                 return -2 - i;
3610         fast = cdr(fast);
3611         ++i;
3612         if (fast == sc->NIL)
3613                 return i;
3614         if (!is_pair(fast))
3615                 return -2 - i;
3616         ++i;
3617         fast = cdr(fast);
3618
3619         /* Safe because we would have already returned if `fast'
3620            encountered a non-pair. */
3621         slow = cdr(slow);
3622         if (fast == slow)
3623         {
3624             /* the fast pointer has looped back around and caught up
3625                with the slow pointer, hence the structure is circular,
3626                not of finite length, and therefore not a list */
3627             return -1;
3628         }
3629     }
3630 }
3631
3632 static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
3633      pointer x;
3634      num v;
3635      int (*comp_func)(num,num)=0;
3636
3637      switch (op) {
3638      case OP_NOT:        /* not */
3639           s_retbool(is_false(car(sc->args)));
3640      case OP_BOOLP:       /* boolean? */
3641           s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
3642      case OP_EOFOBJP:       /* boolean? */
3643           s_retbool(car(sc->args) == sc->EOF_OBJ);
3644      case OP_NULLP:       /* null? */
3645           s_retbool(car(sc->args) == sc->NIL);
3646      case OP_NUMEQ:      /* = */
3647      case OP_LESS:       /* < */
3648      case OP_GRE:        /* > */
3649      case OP_LEQ:        /* <= */
3650      case OP_GEQ:        /* >= */
3651           switch(op) {
3652                case OP_NUMEQ: comp_func=num_eq; break;
3653                case OP_LESS:  comp_func=num_lt; break;
3654                case OP_GRE:   comp_func=num_gt; break;
3655                case OP_LEQ:   comp_func=num_le; break;
3656                case OP_GEQ:   comp_func=num_ge; break;
3657           }
3658           x=sc->args;
3659           v=nvalue(car(x));
3660           x=cdr(x);
3661
3662           for (; x != sc->NIL; x = cdr(x)) {
3663                if(!comp_func(v,nvalue(car(x)))) {
3664                     s_retbool(0);
3665                }
3666            v=nvalue(car(x));
3667           }
3668           s_retbool(1);
3669      case OP_SYMBOLP:     /* symbol? */
3670           s_retbool(is_symbol(car(sc->args)));
3671      case OP_NUMBERP:     /* number? */
3672           s_retbool(is_number(car(sc->args)));
3673      case OP_STRINGP:     /* string? */
3674           s_retbool(is_string(car(sc->args)));
3675      case OP_INTEGERP:     /* integer? */
3676           s_retbool(is_integer(car(sc->args)));
3677      case OP_REALP:     /* real? */
3678           s_retbool(is_number(car(sc->args))); /* All numbers are real */
3679      case OP_CHARP:     /* char? */
3680           s_retbool(is_character(car(sc->args)));
3681 #if USE_CHAR_CLASSIFIERS
3682      case OP_CHARAP:     /* char-alphabetic? */
3683           s_retbool(Cisalpha(ivalue(car(sc->args))));
3684      case OP_CHARNP:     /* char-numeric? */
3685           s_retbool(Cisdigit(ivalue(car(sc->args))));
3686      case OP_CHARWP:     /* char-whitespace? */
3687           s_retbool(Cisspace(ivalue(car(sc->args))));
3688      case OP_CHARUP:     /* char-upper-case? */
3689           s_retbool(Cisupper(ivalue(car(sc->args))));
3690      case OP_CHARLP:     /* char-lower-case? */
3691           s_retbool(Cislower(ivalue(car(sc->args))));
3692 #endif
3693      case OP_PORTP:     /* port? */
3694           s_retbool(is_port(car(sc->args)));
3695      case OP_INPORTP:     /* input-port? */
3696           s_retbool(is_inport(car(sc->args)));
3697      case OP_OUTPORTP:     /* output-port? */
3698           s_retbool(is_outport(car(sc->args)));
3699      case OP_PROCP:       /* procedure? */
3700           /*--
3701               * continuation should be procedure by the example
3702               * (call-with-current-continuation procedure?) ==> #t
3703                  * in R^3 report sec. 6.9
3704               */
3705           s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
3706                  || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
3707      case OP_PAIRP:       /* pair? */
3708           s_retbool(is_pair(car(sc->args)));
3709      case OP_LISTP:       /* list? */
3710        s_retbool(list_length(sc,car(sc->args)) >= 0);
3711
3712      case OP_ENVP:        /* environment? */
3713           s_retbool(is_environment(car(sc->args)));
3714      case OP_VECTORP:     /* vector? */
3715           s_retbool(is_vector(car(sc->args)));
3716      case OP_EQ:         /* eq? */
3717           s_retbool(car(sc->args) == cadr(sc->args));
3718      case OP_EQV:        /* eqv? */
3719           s_retbool(eqv(car(sc->args), cadr(sc->args)));
3720      default:
3721           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
3722           Error_0(sc,sc->strbuff);
3723      }
3724      return sc->T;
3725 }
3726
3727 static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
3728      pointer x, y;
3729
3730      switch (op) {
3731      case OP_FORCE:      /* force */
3732           sc->code = car(sc->args);
3733           if (is_promise(sc->code)) {
3734                /* Should change type to closure here */
3735                s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
3736                sc->args = sc->NIL;
3737                s_goto(sc,OP_APPLY);
3738           } else {
3739                s_return(sc,sc->code);
3740           }
3741
3742      case OP_SAVE_FORCED:     /* Save forced value replacing promise */
3743           memcpy(sc->code,sc->value,sizeof(struct cell));
3744           s_return(sc,sc->value);
3745
3746      case OP_WRITE:      /* write */
3747      case OP_DISPLAY:    /* display */
3748      case OP_WRITE_CHAR: /* write-char */
3749           if(is_pair(cdr(sc->args))) {
3750                if(cadr(sc->args)!=sc->outport) {
3751                     x=cons(sc,sc->outport,sc->NIL);
3752                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3753                     sc->outport=cadr(sc->args);
3754                }
3755           }
3756           sc->args = car(sc->args);
3757           if(op==OP_WRITE) {
3758                sc->print_flag = 1;
3759           } else {
3760                sc->print_flag = 0;
3761           }
3762           s_goto(sc,OP_P0LIST);
3763
3764      case OP_NEWLINE:    /* newline */
3765           if(is_pair(sc->args)) {
3766                if(car(sc->args)!=sc->outport) {
3767                     x=cons(sc,sc->outport,sc->NIL);
3768                     s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
3769                     sc->outport=car(sc->args);
3770                }
3771           }
3772           putstr(sc, "\n");
3773           s_return(sc,sc->T);
3774
3775      case OP_ERR0:  /* error */
3776           sc->retcode=-1;
3777           if (!is_string(car(sc->args))) {
3778                sc->args=cons(sc,mk_string(sc," -- "),sc->args);
3779                setimmutable(car(sc->args));
3780           }
3781           putstr(sc, "Error: ");
3782           putstr(sc, strvalue(car(sc->args)));
3783           sc->args = cdr(sc->args);
3784           s_goto(sc,OP_ERR1);
3785
3786      case OP_ERR1:  /* error */
3787           putstr(sc, " ");
3788           if (sc->args != sc->NIL) {
3789                s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
3790                sc->args = car(sc->args);
3791                sc->print_flag = 1;
3792                s_goto(sc,OP_P0LIST);
3793           } else {
3794                putstr(sc, "\n");
3795                if(sc->interactive_repl) {
3796                     s_goto(sc,OP_T0LVL);
3797                } else {
3798                     return sc->NIL;
3799                }
3800           }
3801
3802      case OP_REVERSE:   /* reverse */
3803           s_return(sc,reverse(sc, car(sc->args)));
3804
3805      case OP_LIST_STAR: /* list* */
3806           s_return(sc,list_star(sc,sc->args));
3807
3808      case OP_APPEND:    /* append */
3809           x = sc->NIL;
3810           y = sc->args;
3811           if (y == x) {
3812               s_return(sc, x);
3813           }
3814
3815           /* cdr() in the while condition is not a typo. If car() */
3816           /* is used (append '() 'a) will return the wrong result.*/
3817           while (cdr(y) != sc->NIL) {
3818               x = revappend(sc, x, car(y));
3819               y = cdr(y);
3820               if (x == sc->F) {
3821                   Error_0(sc, "non-list argument to append");
3822               }
3823           }
3824
3825           s_return(sc, reverse_in_place(sc, car(y), x));
3826
3827 #if USE_PLIST
3828      case OP_PUT:        /* put */
3829           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3830                Error_0(sc,"illegal use of put");
3831           }
3832           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3833                if (caar(x) == y) {
3834                     break;
3835                }
3836           }
3837           if (x != sc->NIL)
3838                cdar(x) = caddr(sc->args);
3839           else
3840                symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
3841                                 symprop(car(sc->args)));
3842           s_return(sc,sc->T);
3843
3844      case OP_GET:        /* get */
3845           if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
3846                Error_0(sc,"illegal use of get");
3847           }
3848           for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
3849                if (caar(x) == y) {
3850                     break;
3851                }
3852           }
3853           if (x != sc->NIL) {
3854                s_return(sc,cdar(x));
3855           } else {
3856                s_return(sc,sc->NIL);
3857           }
3858 #endif /* USE_PLIST */
3859      case OP_QUIT:       /* quit */
3860           if(is_pair(sc->args)) {
3861                sc->retcode=ivalue(car(sc->args));
3862           }
3863           return (sc->NIL);
3864
3865      case OP_GC:         /* gc */
3866           gc(sc, sc->NIL, sc->NIL);
3867           s_return(sc,sc->T);
3868
3869      case OP_GCVERB:          /* gc-verbose */
3870      {    int  was = sc->gc_verbose;
3871
3872           sc->gc_verbose = (car(sc->args) != sc->F);
3873           s_retbool(was);
3874      }
3875
3876      case OP_NEWSEGMENT: /* new-segment */
3877           if (!is_pair(sc->args) || !is_number(car(sc->args))) {
3878                Error_0(sc,"new-segment: argument must be a number");
3879           }
3880           alloc_cellseg(sc, (int) ivalue(car(sc->args)));
3881           s_return(sc,sc->T);
3882
3883      case OP_OBLIST: /* oblist */
3884           s_return(sc, oblist_all_symbols(sc));
3885
3886      case OP_CURR_INPORT: /* current-input-port */
3887           s_return(sc,sc->inport);
3888
3889      case OP_CURR_OUTPORT: /* current-output-port */
3890           s_return(sc,sc->outport);
3891
3892      case OP_OPEN_INFILE: /* open-input-file */
3893      case OP_OPEN_OUTFILE: /* open-output-file */
3894      case OP_OPEN_INOUTFILE: /* open-input-output-file */ {
3895           int prop=0;
3896           pointer p;
3897           switch(op) {
3898                case OP_OPEN_INFILE:     prop=port_input; break;
3899                case OP_OPEN_OUTFILE:    prop=port_output; break;
3900                case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
3901           }
3902           p=port_from_filename(sc,strvalue(car(sc->args)),prop);
3903           if(p==sc->NIL) {
3904                s_return(sc,sc->F);
3905           }
3906           s_return(sc,p);
3907      }
3908
3909 #if USE_STRING_PORTS
3910      case OP_OPEN_INSTRING: /* open-input-string */
3911      case OP_OPEN_INOUTSTRING: /* open-input-output-string */ {
3912           int prop=0;
3913           pointer p;
3914           switch(op) {
3915                case OP_OPEN_INSTRING:     prop=port_input; break;
3916                case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
3917           }
3918           p=port_from_string(sc, strvalue(car(sc->args)),
3919                  strvalue(car(sc->args))+strlength(car(sc->args)), prop);
3920           if(p==sc->NIL) {
3921                s_return(sc,sc->F);
3922           }
3923           s_return(sc,p);
3924      }
3925      case OP_OPEN_OUTSTRING: /* open-output-string */ {
3926           pointer p;
3927           if(car(sc->args)==sc->NIL) {
3928                p=port_from_scratch(sc);
3929                if(p==sc->NIL) {
3930                     s_return(sc,sc->F);
3931                }
3932           } else {
3933                p=port_from_string(sc, strvalue(car(sc->args)),
3934                       strvalue(car(sc->args))+strlength(car(sc->args)),
3935                           port_output);
3936                if(p==sc->NIL) {
3937                     s_return(sc,sc->F);
3938                }
3939           }
3940           s_return(sc,p);
3941      }
3942      case OP_GET_OUTSTRING: /* get-output-string */ {
3943           port *p;
3944
3945           if ((p=car(sc->args)->_object._port)->kind&port_string) {
3946                off_t size;
3947                char *str;
3948
3949                size=p->rep.string.curr-p->rep.string.start+1;
3950                str=sc->malloc(size);
3951                if(str != NULL) {
3952                     pointer s;
3953
3954                     memcpy(str,p->rep.string.start,size-1);
3955                     str[size-1]='\0';
3956                     s=mk_string(sc,str);
3957                     sc->free(str);
3958                     s_return(sc,s);
3959                }
3960           }
3961           s_return(sc,sc->F);
3962      }
3963 #endif
3964
3965      case OP_CLOSE_INPORT: /* close-input-port */
3966           port_close(sc,car(sc->args),port_input);
3967           s_return(sc,sc->T);
3968
3969      case OP_CLOSE_OUTPORT: /* close-output-port */
3970           port_close(sc,car(sc->args),port_output);
3971           s_return(sc,sc->T);
3972
3973      case OP_INT_ENV: /* interaction-environment */
3974           s_return(sc,sc->global_env);
3975
3976      case OP_CURR_ENV: /* current-environment */
3977           s_return(sc,sc->envir);
3978
3979      }
3980      return sc->T;
3981 }
3982
3983 static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
3984      pointer x;
3985
3986      if(sc->nesting!=0) {
3987           int n=sc->nesting;
3988           sc->nesting=0;
3989           sc->retcode=-1;
3990           Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
3991      }
3992
3993      switch (op) {
3994      /* ========== reading part ========== */
3995      case OP_READ:
3996           if(!is_pair(sc->args)) {
3997                s_goto(sc,OP_READ_INTERNAL);
3998           }
3999           if(!is_inport(car(sc->args))) {
4000                Error_1(sc,"read: not an input port:",car(sc->args));
4001           }
4002           if(car(sc->args)==sc->inport) {
4003                s_goto(sc,OP_READ_INTERNAL);
4004           }
4005           x=sc->inport;
4006           sc->inport=car(sc->args);
4007           x=cons(sc,x,sc->NIL);
4008           s_save(sc,OP_SET_INPORT, x, sc->NIL);
4009           s_goto(sc,OP_READ_INTERNAL);
4010
4011      case OP_READ_CHAR: /* read-char */
4012      case OP_PEEK_CHAR: /* peek-char */ {
4013           int c;
4014           if(is_pair(sc->args)) {
4015                if(car(sc->args)!=sc->inport) {
4016                     x=sc->inport;
4017                     x=cons(sc,x,sc->NIL);
4018                     s_save(sc,OP_SET_INPORT, x, sc->NIL);
4019                     sc->inport=car(sc->args);
4020                }
4021           }
4022           c=inchar(sc);
4023           if(c==EOF) {
4024                s_return(sc,sc->EOF_OBJ);
4025           }
4026           if(sc->op==OP_PEEK_CHAR) {
4027                backchar(sc,c);
4028           }
4029           s_return(sc,mk_character(sc,c));
4030      }
4031
4032      case OP_CHAR_READY: /* char-ready? */ {
4033           pointer p=sc->inport;
4034           int res;
4035           if(is_pair(sc->args)) {
4036                p=car(sc->args);
4037           }
4038           res=p->_object._port->kind&port_string;
4039           s_retbool(res);
4040      }
4041
4042      case OP_SET_INPORT: /* set-input-port */
4043           sc->inport=car(sc->args);
4044           s_return(sc,sc->value);
4045
4046      case OP_SET_OUTPORT: /* set-output-port */
4047           sc->outport=car(sc->args);
4048           s_return(sc,sc->value);
4049
4050      case OP_RDSEXPR:
4051           switch (sc->tok) {
4052           case TOK_EOF:
4053                s_return(sc,sc->EOF_OBJ);
4054           /* NOTREACHED */
4055 /*
4056  * Commented out because we now skip comments in the scanner
4057  *
4058           case TOK_COMMENT: {
4059                int c;
4060                while ((c=inchar(sc)) != '\n' && c!=EOF)
4061                     ;
4062                sc->tok = token(sc);
4063                s_goto(sc,OP_RDSEXPR);
4064           }
4065 */
4066           case TOK_VEC:
4067                s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
4068                /* fall through */
4069           case TOK_LPAREN:
4070                sc->tok = token(sc);
4071                if (sc->tok == TOK_RPAREN) {
4072                     s_return(sc,sc->NIL);
4073                } else if (sc->tok == TOK_DOT) {
4074                     Error_0(sc,"syntax error: illegal dot expression");
4075                } else {
4076                     sc->nesting_stack[sc->file_i]++;
4077                     s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
4078                     s_goto(sc,OP_RDSEXPR);
4079                }
4080           case TOK_QUOTE:
4081                s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
4082                sc->tok = token(sc);
4083                s_goto(sc,OP_RDSEXPR);
4084           case TOK_BQUOTE:
4085                sc->tok = token(sc);
4086                if(sc->tok==TOK_VEC) {
4087                  s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
4088                  sc->tok=TOK_LPAREN;
4089                  s_goto(sc,OP_RDSEXPR);
4090                } else {
4091                  s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
4092                }
4093                s_goto(sc,OP_RDSEXPR);
4094           case TOK_COMMA:
4095                s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
4096                sc->tok = token(sc);
4097                s_goto(sc,OP_RDSEXPR);
4098           case TOK_ATMARK:
4099                s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
4100                sc->tok = token(sc);
4101                s_goto(sc,OP_RDSEXPR);
4102           case TOK_ATOM:
4103                s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
4104           case TOK_DQUOTE:
4105                x=readstrexp(sc);
4106                if(x==sc->F) {
4107                  Error_0(sc,"Error reading string");
4108                }
4109                setimmutable(x);
4110                s_return(sc,x);
4111           case TOK_SHARP: {
4112                pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
4113                if(f==sc->NIL) {
4114                     Error_0(sc,"undefined sharp expression");
4115                } else {
4116                     sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
4117                     s_goto(sc,OP_EVAL);
4118                }
4119           }
4120           case TOK_SHARP_CONST:
4121                if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
4122                     Error_0(sc,"undefined sharp expression");
4123                } else {
4124                     s_return(sc,x);
4125                }
4126           default:
4127                Error_0(sc,"syntax error: illegal token");
4128           }
4129           break;
4130
4131      case OP_RDLIST: {
4132           sc->args = cons(sc, sc->value, sc->args);
4133           sc->tok = token(sc);
4134 /* We now skip comments in the scanner
4135           while (sc->tok == TOK_COMMENT) {
4136                int c;
4137                while ((c=inchar(sc)) != '\n' && c!=EOF)
4138                     ;
4139                sc->tok = token(sc);
4140           }
4141 */
4142           if (sc->tok == TOK_EOF)
4143                { s_return(sc,sc->EOF_OBJ); }
4144           else if (sc->tok == TOK_RPAREN) {
4145                int c = inchar(sc);
4146                if (c != '\n')
4147                  backchar(sc,c);
4148 #if SHOW_ERROR_LINE
4149                else if (sc->load_stack[sc->file_i].kind & port_file)
4150                   sc->load_stack[sc->file_i].rep.stdio.curr_line++;
4151 #endif
4152                sc->nesting_stack[sc->file_i]--;
4153                s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
4154           } else if (sc->tok == TOK_DOT) {
4155                s_save(sc,OP_RDDOT, sc->args, sc->NIL);
4156                sc->tok = token(sc);
4157                s_goto(sc,OP_RDSEXPR);
4158           } else {
4159                s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
4160                s_goto(sc,OP_RDSEXPR);
4161           }
4162      }
4163
4164      case OP_RDDOT:
4165           if (token(sc) != TOK_RPAREN) {
4166                Error_0(sc,"syntax error: illegal dot expression");
4167           } else {
4168                sc->nesting_stack[sc->file_i]--;
4169                s_return(sc,reverse_in_place(sc, sc->value, sc->args));
4170           }
4171
4172      case OP_RDQUOTE:
4173           s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
4174
4175      case OP_RDQQUOTE:
4176           s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
4177
4178      case OP_RDQQUOTEVEC:
4179            s_return(sc,cons(sc, mk_symbol(sc,"apply"),
4180            cons(sc, mk_symbol(sc,"vector"),
4181                  cons(sc,cons(sc, sc->QQUOTE,
4182                   cons(sc,sc->value,sc->NIL)),
4183                   sc->NIL))));
4184
4185      case OP_RDUNQUOTE:
4186           s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
4187
4188      case OP_RDUQTSP:
4189           s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
4190
4191      case OP_RDVEC:
4192           /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
4193           s_goto(sc,OP_EVAL); Cannot be quoted*/
4194           /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
4195           s_return(sc,x); Cannot be part of pairs*/
4196           /*sc->code=mk_proc(sc,OP_VECTOR);
4197           sc->args=sc->value;
4198           s_goto(sc,OP_APPLY);*/
4199           sc->args=sc->value;
4200           s_goto(sc,OP_VECTOR);
4201
4202      /* ========== printing part ========== */
4203      case OP_P0LIST:
4204           if(is_vector(sc->args)) {
4205                putstr(sc,"#(");
4206                sc->args=cons(sc,sc->args,mk_integer(sc,0));
4207                s_goto(sc,OP_PVECFROM);
4208           } else if(is_environment(sc->args)) {
4209                putstr(sc,"#<ENVIRONMENT>");
4210                s_return(sc,sc->T);
4211           } else if (!is_pair(sc->args)) {
4212                printatom(sc, sc->args, sc->print_flag);
4213                s_return(sc,sc->T);
4214           } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
4215                putstr(sc, "'");
4216                sc->args = cadr(sc->args);
4217                s_goto(sc,OP_P0LIST);
4218           } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
4219                putstr(sc, "`");
4220                sc->args = cadr(sc->args);
4221                s_goto(sc,OP_P0LIST);
4222           } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
4223                putstr(sc, ",");
4224                sc->args = cadr(sc->args);
4225                s_goto(sc,OP_P0LIST);
4226           } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
4227                putstr(sc, ",@");
4228                sc->args = cadr(sc->args);
4229                s_goto(sc,OP_P0LIST);
4230           } else {
4231                putstr(sc, "(");
4232                s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
4233                sc->args = car(sc->args);
4234                s_goto(sc,OP_P0LIST);
4235           }
4236
4237      case OP_P1LIST:
4238           if (is_pair(sc->args)) {
4239             s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
4240             putstr(sc, " ");
4241             sc->args = car(sc->args);
4242             s_goto(sc,OP_P0LIST);
4243           } else if(is_vector(sc->args)) {
4244             s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
4245             putstr(sc, " . ");
4246             s_goto(sc,OP_P0LIST);
4247           } else {
4248             if (sc->args != sc->NIL) {
4249               putstr(sc, " . ");
4250               printatom(sc, sc->args, sc->print_flag);
4251             }
4252             putstr(sc, ")");
4253             s_return(sc,sc->T);
4254           }
4255      case OP_PVECFROM: {
4256           int i=ivalue_unchecked(cdr(sc->args));
4257           pointer vec=car(sc->args);
4258           int len=ivalue_unchecked(vec);
4259           if(i==len) {
4260                putstr(sc,")");
4261                s_return(sc,sc->T);
4262           } else {
4263                pointer elem=vector_elem(vec,i);
4264                ivalue_unchecked(cdr(sc->args))=i+1;
4265                s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
4266                sc->args=elem;
4267                if (i > 0)
4268                    putstr(sc," ");
4269                s_goto(sc,OP_P0LIST);
4270           }
4271      }
4272
4273      default:
4274           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
4275           Error_0(sc,sc->strbuff);
4276
4277      }
4278      return sc->T;
4279 }
4280
4281 static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
4282      pointer x, y;
4283      long v;
4284
4285      switch (op) {
4286      case OP_LIST_LENGTH:     /* length */   /* a.k */
4287           v=list_length(sc,car(sc->args));
4288           if(v<0) {
4289                Error_1(sc,"length: not a list:",car(sc->args));
4290           }
4291           s_return(sc,mk_integer(sc, v));
4292
4293      case OP_ASSQ:       /* assq */     /* a.k */
4294           x = car(sc->args);
4295           for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
4296                if (!is_pair(car(y))) {
4297                     Error_0(sc,"unable to handle non pair element");
4298                }
4299                if (x == caar(y))
4300                     break;
4301           }
4302           if (is_pair(y)) {
4303                s_return(sc,car(y));
4304           } else {
4305                s_return(sc,sc->F);
4306           }
4307
4308
4309      case OP_GET_CLOSURE:     /* get-closure-code */   /* a.k */
4310           sc->args = car(sc->args);
4311           if (sc->args == sc->NIL) {
4312                s_return(sc,sc->F);
4313           } else if (is_closure(sc->args)) {
4314                s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
4315           } else if (is_macro(sc->args)) {
4316                s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
4317           } else {
4318                s_return(sc,sc->F);
4319           }
4320      case OP_CLOSUREP:        /* closure? */
4321           /*
4322            * Note, macro object is also a closure.
4323            * Therefore, (closure? <#MACRO>) ==> #t
4324            */
4325           s_retbool(is_closure(car(sc->args)));
4326      case OP_MACROP:          /* macro? */
4327           s_retbool(is_macro(car(sc->args)));
4328      default:
4329           snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
4330           Error_0(sc,sc->strbuff);
4331      }
4332      return sc->T; /* NOTREACHED */
4333 }
4334
4335 typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
4336
4337 typedef int (*test_predicate)(pointer);
4338 static int is_any(pointer p) { return 1;}
4339
4340 static int is_nonneg(pointer p) {
4341   return ivalue(p)>=0 && is_integer(p);
4342 }
4343
4344 /* Correspond carefully with following defines! */
4345 static struct {
4346   test_predicate fct;
4347   const char *kind;
4348 } tests[]={
4349   {0,0}, /* unused */
4350   {is_any, 0},
4351   {is_string, "string"},
4352   {is_symbol, "symbol"},
4353   {is_port, "port"},
4354   {is_inport,"input port"},
4355   {is_outport,"output port"},
4356   {is_environment, "environment"},
4357   {is_pair, "pair"},
4358   {0, "pair or '()"},
4359   {is_character, "character"},
4360   {is_vector, "vector"},
4361   {is_number, "number"},
4362   {is_integer, "integer"},
4363   {is_nonneg, "non-negative integer"}
4364 };
4365
4366 #define TST_NONE 0
4367 #define TST_ANY "\001"
4368 #define TST_STRING "\002"
4369 #define TST_SYMBOL "\003"
4370 #define TST_PORT "\004"
4371 #define TST_INPORT "\005"
4372 #define TST_OUTPORT "\006"
4373 #define TST_ENVIRONMENT "\007"
4374 #define TST_PAIR "\010"
4375 #define TST_LIST "\011"
4376 #define TST_CHAR "\012"
4377 #define TST_VECTOR "\013"
4378 #define TST_NUMBER "\014"
4379 #define TST_INTEGER "\015"
4380 #define TST_NATURAL "\016"
4381
4382 typedef struct {
4383   dispatch_func func;
4384   char *name;
4385   int min_arity;
4386   int max_arity;
4387   char *arg_tests_encoding;
4388 } op_code_info;
4389
4390 #define INF_ARG 0xffff
4391
4392 static op_code_info dispatch_table[]= {
4393 #define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
4394 #include "opdefines.h"
4395   { 0 }
4396 };
4397
4398 static const char *procname(pointer x) {
4399  int n=procnum(x);
4400  const char *name=dispatch_table[n].name;
4401  if(name==0) {
4402      name="ILLEGAL!";
4403  }
4404  return name;
4405 }
4406
4407 /* kernel of this interpreter */
4408 static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
4409   sc->op = op;
4410   for (;;) {
4411     op_code_info *pcd=dispatch_table+sc->op;
4412     if (pcd->name!=0) { /* if built-in function, check arguments */
4413       char msg[STRBUFFSIZE];
4414       int ok=1;
4415       int n=list_length(sc,sc->args);
4416
4417       /* Check number of arguments */
4418       if(n<pcd->min_arity) {
4419         ok=0;
4420         snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
4421         pcd->name,
4422         pcd->min_arity==pcd->max_arity?"":" at least",
4423         pcd->min_arity);
4424       }
4425       if(ok && n>pcd->max_arity) {
4426         ok=0;
4427         snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
4428         pcd->name,
4429         pcd->min_arity==pcd->max_arity?"":" at most",
4430         pcd->max_arity);
4431       }
4432       if(ok) {
4433         if(pcd->arg_tests_encoding!=0) {
4434           int i=0;
4435           int j;
4436           const char *t=pcd->arg_tests_encoding;
4437           pointer arglist=sc->args;
4438           do {
4439             pointer arg=car(arglist);
4440             j=(int)t[0];
4441             if(j==TST_LIST[0]) {
4442                   if(arg!=sc->NIL && !is_pair(arg)) break;
4443             } else {
4444               if(!tests[j].fct(arg)) break;
4445             }
4446
4447             if(t[1]!=0) {/* last test is replicated as necessary */
4448               t++;
4449             }
4450             arglist=cdr(arglist);
4451             i++;
4452           } while(i<n);
4453           if(i<n) {
4454             ok=0;
4455             snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
4456                 pcd->name,
4457                 i+1,
4458                 tests[j].kind);
4459           }
4460         }
4461       }
4462       if(!ok) {
4463         if(_Error_1(sc,msg,0)==sc->NIL) {
4464           return;
4465         }
4466         pcd=dispatch_table+sc->op;
4467       }
4468     }
4469     ok_to_freely_gc(sc);
4470     if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
4471       return;
4472     }
4473     if(sc->no_memory) {
4474       fprintf(stderr,"No memory!\n");
4475       return;
4476     }
4477   }
4478 }
4479
4480 /* ========== Initialization of internal keywords ========== */
4481
4482 static void assign_syntax(scheme *sc, char *name) {
4483      pointer x;
4484
4485      x = oblist_add_by_name(sc, name);
4486      typeflag(x) |= T_SYNTAX;
4487 }
4488
4489 static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) {
4490      pointer x, y;
4491
4492      x = mk_symbol(sc, name);
4493      y = mk_proc(sc,op);
4494      new_slot_in_env(sc, x, y);
4495 }
4496
4497 static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
4498      pointer y;
4499
4500      y = get_cell(sc, sc->NIL, sc->NIL);
4501      typeflag(y) = (T_PROC | T_ATOM);
4502      ivalue_unchecked(y) = (long) op;
4503      set_num_integer(y);
4504      return y;
4505 }
4506
4507 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
4508 static int syntaxnum(pointer p) {
4509      const char *s=strvalue(car(p));
4510      switch(strlength(car(p))) {
4511      case 2:
4512           if(s[0]=='i') return OP_IF0;        /* if */
4513           else return OP_OR0;                 /* or */
4514      case 3:
4515           if(s[0]=='a') return OP_AND0;      /* and */
4516           else return OP_LET0;               /* let */
4517      case 4:
4518           switch(s[3]) {
4519           case 'e': return OP_CASE0;         /* case */
4520           case 'd': return OP_COND0;         /* cond */
4521           case '*': return OP_LET0AST;       /* let* */
4522           default: return OP_SET0;           /* set! */
4523           }
4524      case 5:
4525           switch(s[2]) {
4526           case 'g': return OP_BEGIN;         /* begin */
4527           case 'l': return OP_DELAY;         /* delay */
4528           case 'c': return OP_MACRO0;        /* macro */
4529           default: return OP_QUOTE;          /* quote */
4530           }
4531      case 6:
4532           switch(s[2]) {
4533           case 'm': return OP_LAMBDA;        /* lambda */
4534           case 'f': return OP_DEF0;          /* define */
4535           default: return OP_LET0REC;        /* letrec */
4536           }
4537      default:
4538           return OP_C0STREAM;                /* cons-stream */
4539      }
4540 }
4541
4542 /* initialization of TinyScheme */
4543 #if USE_INTERFACE
4544 INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
4545  return cons(sc,a,b);
4546 }
4547 INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
4548  return immutable_cons(sc,a,b);
4549 }
4550
4551 static struct scheme_interface vtbl ={
4552   scheme_define,
4553   s_cons,
4554   s_immutable_cons,
4555   reserve_cells,
4556   mk_integer,
4557   mk_real,
4558   mk_symbol,
4559   gensym,
4560   mk_string,
4561   mk_counted_string,
4562   mk_character,
4563   mk_vector,
4564   mk_foreign_func,
4565   putstr,
4566   putcharacter,
4567
4568   is_string,
4569   string_value,
4570   is_number,
4571   nvalue,
4572   ivalue,
4573   rvalue,
4574   is_integer,
4575   is_real,
4576   is_character,
4577   charvalue,
4578   is_list,
4579   is_vector,
4580   list_length,
4581   ivalue,
4582   fill_vector,
4583   vector_elem,
4584   set_vector_elem,
4585   is_port,
4586   is_pair,
4587   pair_car,
4588   pair_cdr,
4589   set_car,
4590   set_cdr,
4591
4592   is_symbol,
4593   symname,
4594
4595   is_syntax,
4596   is_proc,
4597   is_foreign,
4598   syntaxname,
4599   is_closure,
4600   is_macro,
4601   closure_code,
4602   closure_env,
4603
4604   is_continuation,
4605   is_promise,
4606   is_environment,
4607   is_immutable,
4608   setimmutable,
4609
4610   scheme_load_file,
4611   scheme_load_string
4612 };
4613 #endif
4614
4615 scheme *scheme_init_new() {
4616   scheme *sc=(scheme*)malloc(sizeof(scheme));
4617   if(!scheme_init(sc)) {
4618     free(sc);
4619     return 0;
4620   } else {
4621     return sc;
4622   }
4623 }
4624
4625 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
4626   scheme *sc=(scheme*)malloc(sizeof(scheme));
4627   if(!scheme_init_custom_alloc(sc,malloc,free)) {
4628     free(sc);
4629     return 0;
4630   } else {
4631     return sc;
4632   }
4633 }
4634
4635
4636 int scheme_init(scheme *sc) {
4637  return scheme_init_custom_alloc(sc,malloc,free);
4638 }
4639
4640 int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
4641   int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
4642   pointer x;
4643
4644   num_zero.is_fixnum=1;
4645   num_zero.value.ivalue=0;
4646   num_one.is_fixnum=1;
4647   num_one.value.ivalue=1;
4648
4649 #if USE_INTERFACE
4650   sc->vptr=&vtbl;
4651 #endif
4652   sc->gensym_cnt=0;
4653   sc->malloc=malloc;
4654   sc->free=free;
4655   sc->last_cell_seg = -1;
4656   sc->sink = &sc->_sink;
4657   sc->NIL = &sc->_NIL;
4658   sc->T = &sc->_HASHT;
4659   sc->F = &sc->_HASHF;
4660   sc->EOF_OBJ=&sc->_EOF_OBJ;
4661   sc->free_cell = &sc->_NIL;
4662   sc->fcells = 0;
4663   sc->no_memory=0;
4664   sc->inport=sc->NIL;
4665   sc->outport=sc->NIL;
4666   sc->save_inport=sc->NIL;
4667   sc->loadport=sc->NIL;
4668   sc->nesting=0;
4669   sc->interactive_repl=0;
4670
4671   if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
4672     sc->no_memory=1;
4673     return 0;
4674   }
4675   sc->gc_verbose = 0;
4676   dump_stack_initialize(sc);
4677   sc->code = sc->NIL;
4678   sc->tracing=0;
4679
4680   /* init sc->NIL */
4681   typeflag(sc->NIL) = (T_ATOM | MARK);
4682   car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
4683   /* init T */
4684   typeflag(sc->T) = (T_ATOM | MARK);
4685   car(sc->T) = cdr(sc->T) = sc->T;
4686   /* init F */
4687   typeflag(sc->F) = (T_ATOM | MARK);
4688   car(sc->F) = cdr(sc->F) = sc->F;
4689   /* init sink */
4690   typeflag(sc->sink) = (T_PAIR | MARK);
4691   car(sc->sink) = sc->NIL;
4692   /* init c_nest */
4693   sc->c_nest = sc->NIL;
4694
4695   sc->oblist = oblist_initial_value(sc);
4696   /* init global_env */
4697   new_frame_in_env(sc, sc->NIL);
4698   sc->global_env = sc->envir;
4699   /* init else */
4700   x = mk_symbol(sc,"else");
4701   new_slot_in_env(sc, x, sc->T);
4702
4703   assign_syntax(sc, "lambda");
4704   assign_syntax(sc, "quote");
4705   assign_syntax(sc, "define");
4706   assign_syntax(sc, "if");
4707   assign_syntax(sc, "begin");
4708   assign_syntax(sc, "set!");
4709   assign_syntax(sc, "let");
4710   assign_syntax(sc, "let*");
4711   assign_syntax(sc, "letrec");
4712   assign_syntax(sc, "cond");
4713   assign_syntax(sc, "delay");
4714   assign_syntax(sc, "and");
4715   assign_syntax(sc, "or");
4716   assign_syntax(sc, "cons-stream");
4717   assign_syntax(sc, "macro");
4718   assign_syntax(sc, "case");
4719
4720   for(i=0; i<n; i++) {
4721     if(dispatch_table[i].name!=0) {
4722       assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
4723     }
4724   }
4725
4726   /* initialization of global pointers to special symbols */
4727   sc->LAMBDA = mk_symbol(sc, "lambda");
4728   sc->QUOTE = mk_symbol(sc, "quote");
4729   sc->QQUOTE = mk_symbol(sc, "quasiquote");
4730   sc->UNQUOTE = mk_symbol(sc, "unquote");
4731   sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
4732   sc->FEED_TO = mk_symbol(sc, "=>");
4733   sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
4734   sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
4735   sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
4736   sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
4737
4738   return !sc->no_memory;
4739 }
4740
4741 void scheme_set_input_port_file(scheme *sc, FILE *fin) {
4742   sc->inport=port_from_file(sc,fin,port_input);
4743 }
4744
4745 void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
4746   sc->inport=port_from_string(sc,start,past_the_end,port_input);
4747 }
4748
4749 void scheme_set_output_port_file(scheme *sc, FILE *fout) {
4750   sc->outport=port_from_file(sc,fout,port_output);
4751 }
4752
4753 void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
4754   sc->outport=port_from_string(sc,start,past_the_end,port_output);
4755 }
4756
4757 void scheme_set_external_data(scheme *sc, void *p) {
4758  sc->ext_data=p;
4759 }
4760
4761 void scheme_deinit(scheme *sc) {
4762   int i;
4763
4764 #if SHOW_ERROR_LINE
4765   char *fname;
4766 #endif
4767
4768   sc->oblist=sc->NIL;
4769   sc->global_env=sc->NIL;
4770   dump_stack_free(sc);
4771   sc->envir=sc->NIL;
4772   sc->code=sc->NIL;
4773   sc->args=sc->NIL;
4774   sc->value=sc->NIL;
4775   if(is_port(sc->inport)) {
4776     typeflag(sc->inport) = T_ATOM;
4777   }
4778   sc->inport=sc->NIL;
4779   sc->outport=sc->NIL;
4780   if(is_port(sc->save_inport)) {
4781     typeflag(sc->save_inport) = T_ATOM;
4782   }
4783   sc->save_inport=sc->NIL;
4784   if(is_port(sc->loadport)) {
4785     typeflag(sc->loadport) = T_ATOM;
4786   }
4787   sc->loadport=sc->NIL;
4788   sc->gc_verbose=0;
4789   gc(sc,sc->NIL,sc->NIL);
4790
4791   for(i=0; i<=sc->last_cell_seg; i++) {
4792     sc->free(sc->alloc_seg[i]);
4793   }
4794
4795 #if SHOW_ERROR_LINE
4796   for(i=0; i<=sc->file_i; i++) {
4797     if (sc->load_stack[i].kind & port_file) {
4798       fname = sc->load_stack[i].rep.stdio.filename;
4799       if(fname)
4800         sc->free(fname);
4801     }
4802   }
4803 #endif
4804 }
4805
4806 void scheme_load_file(scheme *sc, FILE *fin)
4807 { scheme_load_named_file(sc,fin,0); }
4808
4809 void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
4810   dump_stack_reset(sc);
4811   sc->envir = sc->global_env;
4812   sc->file_i=0;
4813   sc->load_stack[0].kind=port_input|port_file;
4814   sc->load_stack[0].rep.stdio.file=fin;
4815   sc->loadport=mk_port(sc,sc->load_stack);
4816   sc->retcode=0;
4817   if(fin==stdin) {
4818     sc->interactive_repl=1;
4819   }
4820
4821 #if SHOW_ERROR_LINE
4822   sc->load_stack[0].rep.stdio.curr_line = 0;
4823   if(fin!=stdin && filename)
4824     sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
4825   else
4826     sc->load_stack[0].rep.stdio.filename = NULL;
4827 #endif
4828
4829   sc->inport=sc->loadport;
4830   sc->args = mk_integer(sc,sc->file_i);
4831   Eval_Cycle(sc, OP_T0LVL);
4832   typeflag(sc->loadport)=T_ATOM;
4833   if(sc->retcode==0) {
4834     sc->retcode=sc->nesting!=0;
4835   }
4836 }
4837
4838 void scheme_load_string(scheme *sc, const char *cmd) {
4839   dump_stack_reset(sc);
4840   sc->envir = sc->global_env;
4841   sc->file_i=0;
4842   sc->load_stack[0].kind=port_input|port_string;
4843   sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */
4844   sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
4845   sc->load_stack[0].rep.string.curr=(char*)cmd;
4846   sc->loadport=mk_port(sc,sc->load_stack);
4847   sc->retcode=0;
4848   sc->interactive_repl=0;
4849   sc->inport=sc->loadport;
4850   sc->args = mk_integer(sc,sc->file_i);
4851   Eval_Cycle(sc, OP_T0LVL);
4852   typeflag(sc->loadport)=T_ATOM;
4853   if(sc->retcode==0) {
4854     sc->retcode=sc->nesting!=0;
4855   }
4856 }
4857
4858 void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
4859      pointer x;
4860
4861      x=find_slot_in_env(sc,envir,symbol,0);
4862      if (x != sc->NIL) {
4863           set_slot_in_env(sc, x, value);
4864      } else {
4865           new_slot_spec_in_env(sc, envir, symbol, value);
4866      }
4867 }
4868
4869 #if !STANDALONE
4870 void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
4871 {
4872   scheme_define(sc,
4873                 sc->global_env,
4874                 mk_symbol(sc,sr->name),
4875                 mk_foreign_func(sc, sr->f));
4876 }
4877
4878 void scheme_register_foreign_func_list(scheme * sc,
4879                                        scheme_registerable * list,
4880                                        int count)
4881 {
4882   int i;
4883   for(i = 0; i < count; i++)
4884     {
4885       scheme_register_foreign_func(sc, list + i);
4886     }
4887 }
4888
4889 pointer scheme_apply0(scheme *sc, const char *procname)
4890 { return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
4891
4892 void save_from_C_call(scheme *sc)
4893 {
4894   pointer saved_data =
4895     cons(sc,
4896          car(sc->sink),
4897          cons(sc,
4898               sc->envir,
4899               sc->dump));
4900   /* Push */
4901   sc->c_nest = cons(sc, saved_data, sc->c_nest);
4902   /* Truncate the dump stack so TS will return here when done, not
4903      directly resume pre-C-call operations. */
4904   dump_stack_reset(sc);
4905 }
4906 void restore_from_C_call(scheme *sc)
4907 {
4908   car(sc->sink) = caar(sc->c_nest);
4909   sc->envir = cadar(sc->c_nest);
4910   sc->dump = cdr(cdar(sc->c_nest));
4911   /* Pop */
4912   sc->c_nest = cdr(sc->c_nest);
4913 }
4914
4915 /* "func" and "args" are assumed to be already eval'ed. */
4916 pointer scheme_call(scheme *sc, pointer func, pointer args)
4917 {
4918   int old_repl = sc->interactive_repl;
4919   sc->interactive_repl = 0;
4920   save_from_C_call(sc);
4921   sc->envir = sc->global_env;
4922   sc->args = args;
4923   sc->code = func;
4924   sc->retcode = 0;
4925   Eval_Cycle(sc, OP_APPLY);
4926   sc->interactive_repl = old_repl;
4927   restore_from_C_call(sc);
4928   return sc->value;
4929 }
4930
4931 pointer scheme_eval(scheme *sc, pointer obj)
4932 {
4933   int old_repl = sc->interactive_repl;
4934   sc->interactive_repl = 0;
4935   save_from_C_call(sc);
4936   sc->args = sc->NIL;
4937   sc->code = obj;
4938   sc->retcode = 0;
4939   Eval_Cycle(sc, OP_EVAL);
4940   sc->interactive_repl = old_repl;
4941   restore_from_C_call(sc);
4942   return sc->value;
4943 }
4944
4945
4946 #endif
4947
4948 /* ========== Main ========== */
4949
4950 #if STANDALONE
4951
4952 #if defined(__APPLE__) && !defined (OSX)
4953 int main()
4954 {
4955      extern MacTS_main(int argc, char **argv);
4956      char**    argv;
4957      int argc = ccommand(&argv);
4958      MacTS_main(argc,argv);
4959      return 0;
4960 }
4961 int MacTS_main(int argc, char **argv) {
4962 #else
4963 int main(int argc, char **argv) {
4964 #endif
4965   scheme sc;
4966   FILE *fin;
4967   char *file_name=InitFile;
4968   int retcode;
4969   int isfile=1;
4970
4971   if(argc==1) {
4972     printf(banner);
4973   }
4974   if(argc==2 && strcmp(argv[1],"-?")==0) {
4975     printf("Usage: tinyscheme -?\n");
4976     printf("or:    tinyscheme [<file1> <file2> ...]\n");
4977     printf("followed by\n");
4978     printf("          -1 <file> [<arg1> <arg2> ...]\n");
4979     printf("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
4980     printf("assuming that the executable is named tinyscheme.\n");
4981     printf("Use - as filename for stdin.\n");
4982     return 1;
4983   }
4984   if(!scheme_init(&sc)) {
4985     fprintf(stderr,"Could not initialize!\n");
4986     return 2;
4987   }
4988   scheme_set_input_port_file(&sc, stdin);
4989   scheme_set_output_port_file(&sc, stdout);
4990 #if USE_DL
4991   scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
4992 #endif
4993   argv++;
4994   if(access(file_name,0)!=0) {
4995     char *p=getenv("TINYSCHEMEINIT");
4996     if(p!=0) {
4997       file_name=p;
4998     }
4999   }
5000   do {
5001     if(strcmp(file_name,"-")==0) {
5002       fin=stdin;
5003     } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
5004       pointer args=sc.NIL;
5005       isfile=file_name[1]=='1';
5006       file_name=*argv++;
5007       if(strcmp(file_name,"-")==0) {
5008         fin=stdin;
5009       } else if(isfile) {
5010         fin=fopen(file_name,"r");
5011       }
5012       for(;*argv;argv++) {
5013         pointer value=mk_string(&sc,*argv);
5014         args=cons(&sc,value,args);
5015       }
5016       args=reverse_in_place(&sc,sc.NIL,args);
5017       scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
5018
5019     } else {
5020       fin=fopen(file_name,"r");
5021     }
5022     if(isfile && fin==0) {
5023       fprintf(stderr,"Could not open file %s\n",file_name);
5024     } else {
5025       if(isfile) {
5026         scheme_load_named_file(&sc,fin,file_name);
5027       } else {
5028         scheme_load_string(&sc,file_name);
5029       }
5030       if(!isfile || fin!=stdin) {
5031         if(sc.retcode!=0) {
5032           fprintf(stderr,"Errors encountered reading %s\n",file_name);
5033         }
5034         if(isfile) {
5035           fclose(fin);
5036         }
5037       }
5038     }
5039     file_name=*argv++;
5040   } while(file_name!=0);
5041   if(argc==1) {
5042     scheme_load_named_file(&sc,stdin,0);
5043   }
5044   retcode=sc.retcode;
5045   scheme_deinit(&sc);
5046
5047   return retcode;
5048 }
5049
5050 #endif
5051
5052 /*
5053 Local variables:
5054 c-file-style: "k&r"
5055 End:
5056 */