src/scheme.c

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