microscheme/scheme.c

/*
 * µscheme
 *
 * Copyright (C) 2015 Marc Alexander Lehmann <uscheme@schmorp.de>
 *                 do as you want with this, attribution appreciated.
 *
 *   Based opn tinyscheme-1.41 (original credits follow)
 *   Dimitrios Souflis (dsouflis@acm.org)
 *   Based on MiniScheme (original credits follow)
 * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)
 * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
 * (MINISCM) This version has been modified by R.C. Secrist.
 * (MINISCM)
 * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
 * (MINISCM)
 * (MINISCM) This is a revised and modified version by Akira KIDA.
 * (MINISCM)    current version is 0.85k4 (15 May 1994)
 *
 */

#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
#include "malloc.c"

#define SCHEME_SOURCE
#include "scheme-private.h"
#ifndef WIN32
# include <unistd.h>
#endif
#if USE_MATH
# include <math.h>
#endif

#include "ecb.h"

#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>

#if !USE_ERROR_CHECKING
# define NDEBUG
#endif

#include <assert.h>
#include <stdlib.h>
#include <string.h>

#include <limits.h>
#include <inttypes.h>
#include <float.h>
//#include <ctype.h>

#if '1' != '0' + 1 \
 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
 || 'f' != 'a' + 5
# error "execution character set digits not consecutive"
#endif

enum {
  TOK_EOF,
  TOK_LPAREN,
  TOK_RPAREN,
  TOK_DOT,
  TOK_ATOM,
  TOK_DOTATOM, /* atom name starting with '.' */
  TOK_STRATOM, /* atom name enclosed in | */
  TOK_QUOTE,
  TOK_DQUOTE,
  TOK_BQUOTE,
  TOK_COMMA,
  TOK_ATMARK,
  TOK_SHARP,
  TOK_SHARP_CONST,
  TOK_VEC
};

#define BACKQUOTE '`'
#define DELIMITERS  "()\";\f\t\v\n\r "

#define NIL    (&SCHEME_V->xNIL) //TODO: make this 0?
#define S_T    (&SCHEME_V->xT)   //TODO: magic ptr value?
#define S_F    (&SCHEME_V->xF)   //TODO: magic ptr value?
#define S_SINK (&SCHEME_V->xsink)
#define S_EOF  (&SCHEME_V->xEOF_OBJ)

#if !USE_MULTIPLICITY
static scheme sc;
#endif

static void
xbase (char *s, long n, int base)
{
  if (n < 0)
    {
      *s++ = '-';
      n = -n;
    }

  char *p = s;

  do {
    *p++ = '0' + n % base;
    n /= base;
  } while (n);

  *p-- = 0;

  while (p > s)
    {
      char x = *s; *s = *p; *p = x;
      --p; ++s;
    }
}

static void
xnum (char *s, long n)
{
  xbase (s, n, 10);
}

static void
xwrstr (const char *s)
{
  write (1, s, strlen (s));
}

static void
xwrnum (long n)
{
  char buf[64];

  xnum (buf, n);
  xwrstr (buf);
}

static char
xtoupper (char c)
{
  if (c >= 'a' && c <= 'z')
    c -= 'a' - 'A';

  return c;
}

static char
xtolower (char c)
{
  if (c >= 'A' && c <= 'Z')
    c += 'a' - 'A';

  return c;
}

static int
xisdigit (char c)
{
  return c >= '0' && c <= '9';
}

#define toupper(c) xtoupper (c)
#define tolower(c) xtolower (c)
#define isdigit(c) xisdigit (c)

#if USE_IGNORECASE
static const char *
xstrlwr (char *s)
{
  const char *p = s;

  while (*s)
    {
      *s = tolower (*s);
      s++;
    }

  return p;
}

#define stricmp(a,b) strcasecmp (a, b)
#define strlwr(s) xstrlwr (s)

#else
# define stricmp(a,b) strcmp (a, b)
# define strlwr(s) (s)
#endif

#ifndef prompt
# define prompt "ts> "
#endif

#ifndef InitFile
# define InitFile "init.scm"
#endif

#ifndef FIRST_CELLSEGS
# define FIRST_CELLSEGS 3
#endif

enum scheme_types
{
  T_INTEGER,
  T_REAL,
  T_STRING,
  T_SYMBOL,
  T_PROC,
  T_PAIR, /* also used for free cells */
  T_CLOSURE,
  T_CONTINUATION,
  T_FOREIGN,
  T_CHARACTER,
  T_PORT,
  T_VECTOR,
  T_MACRO,
  T_PROMISE,
  T_ENVIRONMENT,
  /* one more... */
  T_NUM_SYSTEM_TYPES
};

#define T_MASKTYPE   0x000f
#define T_SYNTAX     0x0010
#define T_IMMUTABLE  0x0020
#define T_ATOM       0x0040 /* only for gc */
#define T_MARK       0x0080 /* only for gc */

/* num, for generic arithmetic */
struct num
{
  IVALUE ivalue;
#if USE_REAL
  RVALUE rvalue;
  char is_fixnum;
#endif
};

#if USE_REAL
# define num_is_fixnum(n)    (n).is_fixnum
# define num_set_fixnum(n,f) (n).is_fixnum = (f)
# define num_ivalue(n)       (n).ivalue
# define num_rvalue(n)       (n).rvalue
# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i)
# define num_set_rvalue(n,r) (n).rvalue = (r)
#else
# define num_is_fixnum(n)    1
# define num_set_fixnum(n,f) 0
# define num_ivalue(n)       (n).ivalue
# define num_rvalue(n)       (n).ivalue
# define num_set_ivalue(n,i) (n).ivalue = (i)
# define num_set_rvalue(n,r) (n).ivalue = (r)
#endif

enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };

static num num_op (enum num_op op, num a, num b);
static num num_intdiv (num a, num b);
static num num_rem (num a, num b);
static num num_mod (num a, num b);

#if USE_MATH
static double round_per_R5RS (double x);
#endif
static int is_zero_rvalue (RVALUE x);

static num num_zero;
static num num_one;

/* macros for cell operations */
#define typeflag(p)       ((p)->flag + 0)
#define set_typeflag(p,v) ((p)->flag = (v))
#define type(p)           (typeflag (p) & T_MASKTYPE)

INTERFACE int
is_string (pointer p)
{
  return type (p) == T_STRING;
}

#define strvalue(p)      ((p)->object.string.svalue)
#define strlength(p)     ((p)->object.string.length)

INTERFACE int
is_vector (pointer p)
{
  return type (p) == T_VECTOR;
}

#define vecvalue(p)     ((p)->object.vector.vvalue)
#define veclength(p)    ((p)->object.vector.length)
INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);

INTERFACE int
is_integer (pointer p)
{
  return type (p) == T_INTEGER;
}

/* not the same as in scheme, where integers are (correctly :) reals */
INTERFACE int
is_real (pointer p)
{
  return type (p) == T_REAL;
}

INTERFACE int
is_number (pointer p)
{
  return is_integer (p) || is_real (p);
}

INTERFACE int
is_character (pointer p)
{
  return type (p) == T_CHARACTER;
}

INTERFACE char *
string_value (pointer p)
{
  return strvalue (p);
}

#define ivalue_unchecked(p) (p)->object.ivalue
#define set_ivalue(p,v)     (p)->object.ivalue = (v)

#if USE_REAL
#define rvalue_unchecked(p) (p)->object.rvalue
#define set_rvalue(p,v)     (p)->object.rvalue = (v)
#else
#define rvalue_unchecked(p) (p)->object.ivalue
#define set_rvalue(p,v)     (p)->object.ivalue = (v)
#endif

INTERFACE long
charvalue (pointer p)
{
  return ivalue_unchecked (p);
}

INTERFACE int
is_port (pointer p)
{
  return type (p) == T_PORT;
}

INTERFACE int
is_inport (pointer p)
{
  return is_port (p) && p->object.port->kind & port_input;
}

INTERFACE int
is_outport (pointer p)
{
  return is_port (p) && p->object.port->kind & port_output;
}

INTERFACE int
is_pair (pointer p)
{
  return type (p) == T_PAIR;
}

#define car(p)           ((p)->object.cons.car + 0)
#define cdr(p)           ((p)->object.cons.cdr + 0)

static pointer caar (pointer p) { return car (car (p)); }
static pointer cadr (pointer p) { return car (cdr (p)); }
static pointer cdar (pointer p) { return cdr (car (p)); }
static pointer cddr (pointer p) { return cdr (cdr (p)); }

static pointer cadar (pointer p) { return car (cdr (car (p))); }
static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
static pointer cdaar (pointer p) { return cdr (car (car (p))); }

INTERFACE void
set_car (pointer p, pointer q)
{
  p->object.cons.car = q;
}

INTERFACE void
set_cdr (pointer p, pointer q)
{
  p->object.cons.cdr = q;
}

INTERFACE pointer
pair_car (pointer p)
{
  return car (p);
}

INTERFACE pointer
pair_cdr (pointer p)
{
  return cdr (p);
}

INTERFACE int
is_symbol (pointer p)
{
  return type (p) == T_SYMBOL;
}

INTERFACE char *
symname (pointer p)
{
  return strvalue (car (p));
}

#if USE_PLIST
SCHEME_EXPORT int
hasprop (pointer p)
{
  return typeflag (p) & T_SYMBOL;
}

# define symprop(p)       cdr(p)
#endif

INTERFACE int
is_syntax (pointer p)
{
  return typeflag (p) & T_SYNTAX;
}

INTERFACE int
is_proc (pointer p)
{
  return type (p) == T_PROC;
}

INTERFACE int
is_foreign (pointer p)
{
  return type (p) == T_FOREIGN;
}

INTERFACE char *
syntaxname (pointer p)
{
  return strvalue (car (p));
}

#define procnum(p)       ivalue_unchecked (p)
static const char *procname (pointer x);

INTERFACE int
is_closure (pointer p)
{
  return type (p) == T_CLOSURE;
}

INTERFACE int
is_macro (pointer p)
{
  return type (p) == T_MACRO;
}

INTERFACE pointer
closure_code (pointer p)
{
  return car (p);
}

INTERFACE pointer
closure_env (pointer p)
{
  return cdr (p);
}

INTERFACE int
is_continuation (pointer p)
{
  return type (p) == T_CONTINUATION;
}

#define cont_dump(p)       cdr (p)
#define set_cont_dump(p,v) set_cdr ((p), (v))

/* To do: promise should be forced ONCE only */
INTERFACE int
is_promise (pointer p)
{
  return type (p) == T_PROMISE;
}

INTERFACE int
is_environment (pointer p)
{
  return type (p) == T_ENVIRONMENT;
}

#define setenvironment(p)    set_typeflag ((p), T_ENVIRONMENT)

#define is_atom(p)       (typeflag (p) & T_ATOM)
#define setatom(p)       set_typeflag ((p), typeflag (p) | T_ATOM)
#define clratom(p)       set_typeflag ((p), typeflag (p) & ~T_ATOM)

#define is_mark(p)       (typeflag (p) & T_MARK)
#define setmark(p)       set_typeflag ((p), typeflag (p) | T_MARK)
#define clrmark(p)       set_typeflag ((p), typeflag (p) & ~T_MARK)

INTERFACE int
is_immutable (pointer p)
{
  return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
}

INTERFACE void
setimmutable (pointer p)
{
#if USE_ERROR_CHECKING
  set_typeflag (p, typeflag (p) | T_IMMUTABLE);
#endif
}

/* Result is:
   proper list: length
   circular list: -1
   not even a pair: -2
   dotted list: -2 minus length before dot
*/
INTERFACE int
list_length (SCHEME_P_ pointer a)
{
  int i = 0;
  pointer slow, fast;

  slow = fast = a;

  while (1)
    {
      if (fast == NIL)
        return i;

      if (!is_pair (fast))
        return -2 - i;

      fast = cdr (fast);
      ++i;

      if (fast == NIL)
        return i;

      if (!is_pair (fast))
        return -2 - i;

      ++i;
      fast = cdr (fast);

      /* Safe because we would have already returned if `fast'
         encountered a non-pair. */
      slow = cdr (slow);

      if (fast == slow)
        {
          /* the fast pointer has looped back around and caught up
             with the slow pointer, hence the structure is circular,
             not of finite length, and therefore not a list */
          return -1;
        }
    }
}

INTERFACE int
is_list (SCHEME_P_ pointer a)
{
  return list_length (SCHEME_A_ a) >= 0;
}

#if USE_CHAR_CLASSIFIERS
ecb_inline int
Cisalpha (int c)
{
  return isascii (c) && isalpha (c);
}

ecb_inline int
Cisdigit (int c)
{
  return isascii (c) && isdigit (c);
}

ecb_inline int
Cisspace (int c)
{
  return isascii (c) && isspace (c);
}

ecb_inline int
Cisupper (int c)
{
  return isascii (c) && isupper (c);
}

ecb_inline int
Cislower (int c)
{
  return isascii (c) && islower (c);
}
#endif

#if USE_ASCII_NAMES
static const char *charnames[32] = {
  "nul",
  "soh",
  "stx",
  "etx",
  "eot",
  "enq",
  "ack",
  "bel",
  "bs",
  "ht",
  "lf",
  "vt",
  "ff",
  "cr",
  "so",
  "si",
  "dle",
  "dc1",
  "dc2",
  "dc3",
  "dc4",
  "nak",
  "syn",
  "etb",
  "can",
  "em",
  "sub",
  "esc",
  "fs",
  "gs",
  "rs",
  "us"
};

static int
is_ascii_name (const char *name, int *pc)
{
  int i;

  for (i = 0; i < 32; i++)
    {
      if (stricmp (name, charnames[i]) == 0)
        {
          *pc = i;
          return 1;
        }
    }

  if (stricmp (name, "del") == 0)
    {
      *pc = 127;
      return 1;
    }

  return 0;
}

#endif

static int file_push (SCHEME_P_ const char *fname);
static void file_pop (SCHEME_P);
static int file_interactive (SCHEME_P);
ecb_inline int is_one_of (const char *s, int c);
static int alloc_cellseg (SCHEME_P_ int n);
ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
static void finalize_cell (SCHEME_P_ pointer a);
static int count_consecutive_cells (pointer x, int needed);
static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
static pointer mk_number (SCHEME_P_ const num n);
static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
static pointer mk_vector (SCHEME_P_ uint32_t len);
static pointer mk_atom (SCHEME_P_ char *q);
static pointer mk_sharp_const (SCHEME_P_ char *name);

#if USE_PORTS
static pointer mk_port (SCHEME_P_ port *p);
static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
static pointer port_from_file (SCHEME_P_ int, int prop);
static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
static port *port_rep_from_file (SCHEME_P_ int, int prop);
static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
static void port_close (SCHEME_P_ pointer p, int flag);
#endif
static void mark (pointer a);
static void gc (SCHEME_P_ pointer a, pointer b);
static int basic_inchar (port *pt);
static int inchar (SCHEME_P);
static void backchar (SCHEME_P_ int c);
static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
static pointer readstrexp (SCHEME_P_ char delim);
ecb_inline int skipspace (SCHEME_P);
static int token (SCHEME_P);
static void printslashstring (SCHEME_P_ char *s, int len);
static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
static void printatom (SCHEME_P_ pointer l, int f);
static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
static pointer mk_closure (SCHEME_P_ pointer c, pointer e);
static pointer mk_continuation (SCHEME_P_ pointer d);
static pointer reverse (SCHEME_P_ pointer a);
static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
static pointer revappend (SCHEME_P_ pointer a, pointer b);
static pointer ss_get_cont (SCHEME_P);
static void ss_set_cont (SCHEME_P_ pointer cont);
static void dump_stack_mark (SCHEME_P);
static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
static void assign_syntax (SCHEME_P_ const char *name);
static int syntaxnum (pointer p);
static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);

static IVALUE
ivalue (pointer x)
{
  return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
}

static RVALUE
rvalue (pointer x)
{
  return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
}

INTERFACE num
nvalue (pointer x)
{
  num n;

  num_set_fixnum (n, is_integer (x));

  if (num_is_fixnum (n))
    num_set_ivalue (n, ivalue_unchecked (x));
  else
    num_set_rvalue (n, rvalue_unchecked (x));

  return n;
}

static num
num_op (enum num_op op, num a, num b)
{
  num ret;

  num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));

  if (num_is_fixnum (ret))
    {
      switch (op)
        {
          case NUM_ADD:    a.ivalue += b.ivalue; break;
          case NUM_SUB:    a.ivalue -= b.ivalue; break;
          case NUM_MUL:    a.ivalue *= b.ivalue; break;
          case NUM_INTDIV: a.ivalue /= b.ivalue; break;
        }

      num_set_ivalue (ret, a.ivalue);
    }
#if USE_REAL
  else
    {
      switch (op)
        {
          case NUM_ADD:    a.rvalue += b.rvalue; break;
          case NUM_SUB:    a.rvalue -= b.rvalue; break;
          case NUM_MUL:    a.rvalue *= b.rvalue; break;
          case NUM_INTDIV: a.rvalue /= b.rvalue; break;
        }

      num_set_rvalue (ret, a.rvalue);
    }
#endif

  return ret;
}

static num
num_div (num a, num b)
{
  num ret;

  num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0);

  if (num_is_fixnum (ret))
    num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b));
  else
    num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b));

  return ret;
}

static num
num_rem (num a, num b)
{
  num ret;
  long e1, e2, res;

  num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
  e1 = num_ivalue (a);
  e2 = num_ivalue (b);
  res = e1 % e2;

  /* remainder should have same sign as second operand */
  if (res > 0)
    {
      if (e1 < 0)
        res -= labs (e2);
    }
  else if (res < 0)
    {
      if (e1 > 0)
        res += labs (e2);
    }

  num_set_ivalue (ret, res);
  return ret;
}

static num
num_mod (num a, num b)
{
  num ret;
  long e1, e2, res;

  num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
  e1 = num_ivalue (a);
  e2 = num_ivalue (b);
  res = e1 % e2;

  /* modulo should have same sign as second operand */
  if (res * e2 < 0)
    res += e2;

  num_set_ivalue (ret, res);
  return ret;
}

/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
static int
num_cmp (num a, num b)
{
  int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
  int ret;

  if (is_fixnum)
    {
      IVALUE av = num_ivalue (a);
      IVALUE bv = num_ivalue (b);

      ret = av == bv ? 0 : av < bv ? -1 : +1;
    }
  else
    {
      RVALUE av = num_rvalue (a);
      RVALUE bv = num_rvalue (b);

      ret = av == bv ? 0 : av < bv ? -1 : +1;
    }

  return ret;
}

#if USE_MATH

/* Round to nearest. Round to even if midway */
static double
round_per_R5RS (double x)
{
  double fl = floor (x);
  double ce = ceil (x);
  double dfl = x - fl;
  double dce = ce - x;

  if (dfl > dce)
    return ce;
  else if (dfl < dce)
    return fl;
  else
    {
      if (fmod (fl, 2) == 0)        /* I imagine this holds */
        return fl;
      else
        return ce;
    }
}
#endif

static int
is_zero_rvalue (RVALUE x)
{
  return x == 0;
#if 0
#if USE_REAL
  return x < DBL_MIN && x > -DBL_MIN;   /* why the hate of denormals? this should be == 0. */
#else
  return x == 0;
#endif
#endif
}

/* allocate new cell segment */
static int
alloc_cellseg (SCHEME_P_ int n)
{
  pointer newp;
  pointer last;
  pointer p;
  char *cp;
  long i;
  int k;

  static int segsize = CELL_SEGSIZE >> 1;
  segsize <<= 1;

  for (k = 0; k < n; k++)
    {
      if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
        return k;

      cp = malloc (segsize * sizeof (struct cell));

      if (!cp && USE_ERROR_CHECKING)
        return k;

      i = ++SCHEME_V->last_cell_seg;
      SCHEME_V->alloc_seg[i] = cp;

      newp = (pointer)cp;
      SCHEME_V->cell_seg[i] = newp;
      SCHEME_V->cell_segsize[i] = segsize;
      SCHEME_V->fcells += segsize;
      last = newp + segsize - 1;

      for (p = newp; p <= last; p++)
        {
          set_typeflag (p, T_PAIR);
          set_car (p, NIL);
          set_cdr (p, p + 1);
        }

      set_cdr (last, SCHEME_V->free_cell);
      SCHEME_V->free_cell = newp;
    }

  return n;
}

/* get new cell. parameter a, b is marked by gc. */
ecb_inline pointer
get_cell_x (SCHEME_P_ pointer a, pointer b)
{
  if (ecb_expect_false (SCHEME_V->free_cell == NIL))
    {
      if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
        return S_SINK;

      if (SCHEME_V->free_cell == NIL)
        {
          const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8;

          gc (SCHEME_A_ a, b);

          if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
            {
              /* if only a few recovered, get more to avoid fruitless gc's */
              if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL)
                {
#if USE_ERROR_CHECKING
                  SCHEME_V->no_memory = 1;
                  return S_SINK;
#endif
                }
            }
        }
    }

  {
    pointer x = SCHEME_V->free_cell;

    SCHEME_V->free_cell = cdr (x);
    --SCHEME_V->fcells;
    return x;
  }
}

/* To retain recent allocs before interpreter knows about them -
   Tehom */

static void
push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
{
  pointer holder = get_cell_x (SCHEME_A_ recent, extra);

  set_typeflag (holder, T_PAIR);
  setimmutable (holder);
  set_car (holder, recent);
  set_cdr (holder, car (S_SINK));
  set_car (S_SINK, holder);
}

static pointer
get_cell (SCHEME_P_ pointer a, pointer b)
{
  pointer cell = get_cell_x (SCHEME_A_ a, b);

  /* For right now, include "a" and "b" in "cell" so that gc doesn't
     think they are garbage. */
  /* Tentatively record it as a pair so gc understands it. */
  set_typeflag (cell, T_PAIR);
  set_car (cell, a);
  set_cdr (cell, b);
  push_recent_alloc (SCHEME_A_ cell, NIL);

  return cell;
}

static pointer
get_vector_object (SCHEME_P_ uint32_t len, pointer init)
{
  pointer v = get_cell_x (SCHEME_A_ 0, 0);
  pointer *e = malloc (len * sizeof (pointer));

  if (!e && USE_ERROR_CHECKING)
    return S_SINK;

  /* Record it as a vector so that gc understands it. */
  set_typeflag (v, T_VECTOR | T_ATOM);

  v->object.vector.vvalue = e;
  v->object.vector.length = len;
  fill_vector (v, 0, init);
  push_recent_alloc (SCHEME_A_ v, NIL);

  return v;
}

ecb_inline void
ok_to_freely_gc (SCHEME_P)
{
  set_car (S_SINK, NIL);
}

#if defined TSGRIND
static void
check_cell_alloced (pointer p, int expect_alloced)
{
  /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
  if (typeflag (p) & !expect_alloced)
    xwrstr ("Cell is already allocated!\n");

  if (!(typeflag (p)) & expect_alloced)
    xwrstr ("Cell is not allocated!\n");
}

static void
check_range_alloced (pointer p, int n, int expect_alloced)
{
  int i;

  for (i = 0; i < n; i++)
    check_cell_alloced (p + i, expect_alloced);
}
#endif

/* Medium level cell allocation */

/* get new cons cell */
pointer
xcons (SCHEME_P_ pointer a, pointer b, int immutable)
{
  pointer x = get_cell (SCHEME_A_ a, b);

  set_typeflag (x, T_PAIR);

  if (immutable)
    setimmutable (x);

  set_car (x, a);
  set_cdr (x, b);

  return x;
}

/* ========== oblist implementation  ========== */

static pointer
generate_symbol (SCHEME_P_ const char *name)
{
  pointer x = mk_string (SCHEME_A_ name);
  setimmutable (x);
  x = immutable_cons (x, NIL);
  set_typeflag (x, T_SYMBOL);
  return x;
}

#ifndef USE_OBJECT_LIST

static int
hash_fn (const char *key, int table_size)
{
  const unsigned char *p = key;
  uint32_t hash = 2166136261;

  while (*p)
    hash = (hash ^ *p++) * 16777619;

  return hash % table_size;
}

static pointer
oblist_initial_value (SCHEME_P)
{
  return mk_vector (SCHEME_A_ 461);     /* probably should be bigger */
}

/* returns the new symbol */
static pointer
oblist_add_by_name (SCHEME_P_ const char *name)
{
  pointer x = generate_symbol (SCHEME_A_ name);
  int location = hash_fn (name, veclength (SCHEME_V->oblist));
  vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
  return x;
}

ecb_inline pointer
oblist_find_by_name (SCHEME_P_ const char *name)
{
  int location;
  pointer x;
  char *s;

  location = hash_fn (name, veclength (SCHEME_V->oblist));

  for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
    {
      s = symname (car (x));

      /* case-insensitive, per R5RS section 2 */
      if (stricmp (name, s) == 0)
        return car (x);
    }

  return NIL;
}

static pointer
oblist_all_symbols (SCHEME_P)
{
  int i;
  pointer x;
  pointer ob_list = NIL;

  for (i = 0; i < veclength (SCHEME_V->oblist); i++)
    for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
       ob_list = cons (x, ob_list);

  return ob_list;
}

#else

static pointer
oblist_initial_value (SCHEME_P)
{
  return NIL;
}

ecb_inline pointer
oblist_find_by_name (SCHEME_P_ const char *name)
{
  pointer x;
  char *s;

  for (x = SCHEME_V->oblist; x != NIL; x = cdr (x))
    {
      s = symname (car (x));

      /* case-insensitive, per R5RS section 2 */
      if (stricmp (name, s) == 0)
        return car (x);
    }

  return NIL;
}

/* returns the new symbol */
static pointer
oblist_add_by_name (SCHEME_P_ const char *name)
{
  pointer x = mk_string (SCHEME_A_ name);
  set_typeflag (x, T_SYMBOL);
  setimmutable (x);
  SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
  return x;
}

static pointer
oblist_all_symbols (SCHEME_P)
{
  return SCHEME_V->oblist;
}

#endif

#if USE_PORTS
static pointer
mk_port (SCHEME_P_ port *p)
{
  pointer x = get_cell (SCHEME_A_ NIL, NIL);

  set_typeflag (x, T_PORT | T_ATOM);
  x->object.port = p;

  return x;
}
#endif

pointer
mk_foreign_func (SCHEME_P_ foreign_func f)
{
  pointer x = get_cell (SCHEME_A_ NIL, NIL);

  set_typeflag (x, (T_FOREIGN | T_ATOM));
  x->object.ff = f;

  return x;
}

INTERFACE pointer
mk_character (SCHEME_P_ int c)
{
  pointer x = get_cell (SCHEME_A_ NIL, NIL);

  set_typeflag (x, (T_CHARACTER | T_ATOM));
  set_ivalue (x, c & 0xff);

  return x;
}

/* get number atom (integer) */
INTERFACE pointer
mk_integer (SCHEME_P_ long n)
{
  pointer x = get_cell (SCHEME_A_ NIL, NIL);

  set_typeflag (x, (T_INTEGER | T_ATOM));
  set_ivalue (x, n);

  return x;
}

INTERFACE pointer
mk_real (SCHEME_P_ RVALUE n)
{
#if USE_REAL
  pointer x = get_cell (SCHEME_A_ NIL, NIL);

  set_typeflag (x, (T_REAL | T_ATOM));
  set_rvalue (x, n);

  return x;
#else
  return mk_integer (SCHEME_A_ n);
#endif
}

static pointer
mk_number (SCHEME_P_ const num n)
{
#if USE_REAL
  return num_is_fixnum (n)
      ? mk_integer (SCHEME_A_ num_ivalue (n))
      : mk_real    (SCHEME_A_ num_rvalue (n));
#else
  return mk_integer (SCHEME_A_ num_ivalue (n));
#endif
}

/* allocate name to string area */
static char *
store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
{
  char *q = malloc (len_str + 1);

  if (q == 0 && USE_ERROR_CHECKING)
    {
      SCHEME_V->no_memory = 1;
      return SCHEME_V->strbuff;
    }

  if (str)
    memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
  else
    memset (q, fill, len_str);

  q[len_str] = 0;

  return q;
}

INTERFACE pointer
mk_empty_string (SCHEME_P_ uint32_t len, char fill)
{
  pointer x = get_cell (SCHEME_A_ NIL, NIL);

  set_typeflag (x, T_STRING | T_ATOM);
  strvalue (x) = store_string (SCHEME_A_ len, 0, fill);
  strlength (x) = len;
  return x;
}

INTERFACE pointer
mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
{
  pointer x = get_cell (SCHEME_A_ NIL, NIL);

  set_typeflag (x, T_STRING | T_ATOM);
  strvalue (x) = store_string (SCHEME_A_ len, str, 0);
  strlength (x) = len;

  return x;
}

INTERFACE pointer
mk_string (SCHEME_P_ const char *str)
{
  return mk_counted_string (SCHEME_A_ str, strlen (str));
}

INTERFACE pointer
mk_vector (SCHEME_P_ uint32_t len)
{
  return get_vector_object (SCHEME_A_ len, NIL);
}

INTERFACE void
fill_vector (pointer vec, uint32_t start, pointer obj)
{
  int i;

  for (i = start; i < veclength (vec); i++)
    vecvalue (vec)[i] = obj;
}

INTERFACE void
vector_resize (pointer vec, uint32_t newsize, pointer fill)
{
  uint32_t oldsize = veclength (vec);
  vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
  veclength (vec) = newsize;
  fill_vector (vec, oldsize, fill);
}

INTERFACE pointer
vector_get (pointer vec, uint32_t ielem)
{
  return vecvalue(vec)[ielem];
}

INTERFACE void
vector_set (pointer vec, uint32_t ielem, pointer a)
{
  vecvalue(vec)[ielem] = a;
}

/* get new symbol */
INTERFACE pointer
mk_symbol (SCHEME_P_ const char *name)
{
  /* first check oblist */
  pointer x = oblist_find_by_name (SCHEME_A_ name);

  if (x == NIL)
    x = oblist_add_by_name (SCHEME_A_ name);

  return x;
}

INTERFACE pointer
gensym (SCHEME_P)
{
  pointer x;
  char name[40] = "gensym-";
  xnum (name + 7, SCHEME_V->gensym_cnt);

  return generate_symbol (SCHEME_A_ name);
}

/* make symbol or number atom from string */
static pointer
mk_atom (SCHEME_P_ char *q)
{
  char c, *p;
  int has_dec_point = 0;
  int has_fp_exp = 0;

#if USE_COLON_HOOK
  if ((p = strstr (q, "::")) != 0)
    {
      *p = 0;
      return cons (SCHEME_V->COLON_HOOK,
                   cons (cons (SCHEME_V->QUOTE,
                               cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
    }
#endif

  p = q;
  c = *p++;

  if ((c == '+') || (c == '-'))
    {
      c = *p++;

      if (c == '.')
        {
          has_dec_point = 1;
          c = *p++;
        }

      if (!isdigit (c))
        return mk_symbol (SCHEME_A_ strlwr (q));
    }
  else if (c == '.')
    {
      has_dec_point = 1;
      c = *p++;

      if (!isdigit (c))
        return mk_symbol (SCHEME_A_ strlwr (q));
    }
  else if (!isdigit (c))
    return mk_symbol (SCHEME_A_ strlwr (q));

  for (; (c = *p) != 0; ++p)
    {
      if (!isdigit (c))
        {
          if (c == '.')
            {
              if (!has_dec_point)
                {
                  has_dec_point = 1;
                  continue;
                }
            }
          else if ((c == 'e') || (c == 'E'))
            {
              if (!has_fp_exp)
                {
                  has_dec_point = 1;    /* decimal point illegal from now on */
                  p++;

                  if ((*p == '-') || (*p == '+') || isdigit (*p))
                    continue;
                }
            }

          return mk_symbol (SCHEME_A_ strlwr (q));
        }
    }

#if USE_REAL
  if (has_dec_point)
    return mk_real (SCHEME_A_ atof (q));
#endif

  return mk_integer (SCHEME_A_ strtol (q, 0, 10));
}

/* make constant */
static pointer
mk_sharp_const (SCHEME_P_ char *name)
{
  if (!strcmp (name, "t"))
    return S_T;
  else if (!strcmp (name, "f"))
    return S_F;
  else if (*name == '\\')       /* #\w (character) */
    {
      int c;

      if (stricmp (name + 1, "space") == 0)
        c = ' ';
      else if (stricmp (name + 1, "newline") == 0)
        c = '\n';
      else if (stricmp (name + 1, "return") == 0)
        c = '\r';
      else if (stricmp (name + 1, "tab") == 0)
        c = '\t';
      else if (name[1] == 'x' && name[2] != 0)
        {
          long c1 = strtol (name + 2, 0, 16);

          if (0 <= c1 && c1 <= UCHAR_MAX)
            c = c1;
          else
            return NIL;
        }
#if USE_ASCII_NAMES
      else if (is_ascii_name (name + 1, &c))
        /* nothing */;
#endif
      else if (name[2] == 0)
        c = name[1];
      else
        return NIL;

      return mk_character (SCHEME_A_ c);
    }
  else
    {
      /* identify base by string index */
      const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
      char *base = strchr (baseidx, *name);

      if (base)
        return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));

      return NIL;
    }
}

/* ========== garbage collector ========== */

/*--
 *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
 *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
 *  for marking.
 *
 *  The exception is vectors - vectors are currently marked recursively,
 *  which is inherited form tinyscheme and could be fixed by having another
 *  word of context in the vector
 */
static void
mark (pointer a)
{
  pointer t, q, p;

  t = 0;
  p = a;
E2:
  setmark (p);

  if (ecb_expect_false (is_vector (p)))
    {
      int i;

      for (i = 0; i < veclength (p); i++)
        mark (vecvalue (p)[i]);
    }

  if (is_atom (p))
    goto E6;

  /* E4: down car */
  q = car (p);

  if (q && !is_mark (q))
    {
      setatom (p);              /* a note that we have moved car */
      set_car (p, t);
      t = p;
      p = q;
      goto E2;
    }

E5:
  q = cdr (p);                  /* down cdr */

  if (q && !is_mark (q))
    {
      set_cdr (p, t);
      t = p;
      p = q;
      goto E2;
    }

E6:                            /* up.  Undo the link switching from steps E4 and E5. */
  if (!t)
    return;

  q = t;

  if (is_atom (q))
    {
      clratom (q);
      t = car (q);
      set_car (q, p);
      p = q;
      goto E5;
    }
  else
    {
      t = cdr (q);
      set_cdr (q, p);
      p = q;
      goto E6;
    }
}

/* garbage collection. parameter a, b is marked. */
static void
gc (SCHEME_P_ pointer a, pointer b)
{
  pointer p;
  int i;

  if (SCHEME_V->gc_verbose)
    putstr (SCHEME_A_ "gc...");

  /* mark system globals */
  mark (SCHEME_V->oblist);
  mark (SCHEME_V->global_env);

  /* mark current registers */
  mark (SCHEME_V->args);
  mark (SCHEME_V->envir);
  mark (SCHEME_V->code);
  dump_stack_mark (SCHEME_A);
  mark (SCHEME_V->value);
  mark (SCHEME_V->inport);
  mark (SCHEME_V->save_inport);
  mark (SCHEME_V->outport);
  mark (SCHEME_V->loadport);

  /* Mark recent objects the interpreter doesn't know about yet. */
  mark (car (S_SINK));
  /* Mark any older stuff above nested C calls */
  mark (SCHEME_V->c_nest);

  /* mark variables a, b */
  mark (a);
  mark (b);

  /* garbage collect */
  clrmark (NIL);
  SCHEME_V->fcells = 0;
  SCHEME_V->free_cell = NIL;

  /* free-list is kept sorted by address so as to maintain consecutive
     ranges, if possible, for use with vectors. Here we scan the cells
     (which are also kept sorted by address) downwards to build the
     free-list in sorted order.
   */
  for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
    {
      p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];

      while (--p >= SCHEME_V->cell_seg[i])
        {
          if (is_mark (p))
            clrmark (p);
          else
            {
              /* reclaim cell */
              if (typeflag (p) != T_PAIR)
                {
                  finalize_cell (SCHEME_A_ p);
                  set_typeflag (p, T_PAIR);
                  set_car (p, NIL);
                }

              ++SCHEME_V->fcells;
              set_cdr (p, SCHEME_V->free_cell);
              SCHEME_V->free_cell = p;
            }
        }
    }

  if (SCHEME_V->gc_verbose)
    {
      xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
    }
}

static void
finalize_cell (SCHEME_P_ pointer a)
{
  /* TODO, fast bitmap check? */
  if (is_string (a))
    free (strvalue (a));
  else if (is_vector (a))
    free (vecvalue (a));
#if USE_PORTS
  else if (is_port (a))
    {
      if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
        port_close (SCHEME_A_ a, port_input | port_output);

      free (a->object.port);
    }
#endif
}

/* ========== Routines for Reading ========== */

static int
file_push (SCHEME_P_ const char *fname)
{
#if USE_PORTS
  int fin;

  if (SCHEME_V->file_i == MAXFIL - 1)
    return 0;

  fin = open (fname, O_RDONLY);

  if (fin >= 0)
    {
      SCHEME_V->file_i++;
      SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
      SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
      SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
      SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
      SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
      SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i;

#if SHOW_ERROR_LINE
      SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;

      if (fname)
        SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
#endif
    }

  return fin >= 0;

#else
  return 1;
#endif
}

static void
file_pop (SCHEME_P)
{
  if (SCHEME_V->file_i != 0)
    {
      SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
#if USE_PORTS
      port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
#endif
      SCHEME_V->file_i--;
      SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i;
    }
}

static int
file_interactive (SCHEME_P)
{
#if USE_PORTS
  return SCHEME_V->file_i == 0
      && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
      && (SCHEME_V->inport->object.port->kind & port_file);
#else
  return 0;
#endif
}

#if USE_PORTS
static port *
port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
{
  int fd;
  int flags;
  char *rw;
  port *pt;

  if (prop == (port_input | port_output))
    flags = O_RDWR | O_APPEND | O_CREAT;
  else if (prop == port_output)
    flags = O_WRONLY | O_TRUNC | O_CREAT;
  else
    flags = O_RDONLY;

  fd = open (fn, flags, 0666);

  if (fd < 0)
    return 0;

  pt = port_rep_from_file (SCHEME_A_ fd, prop);
  pt->rep.stdio.closeit = 1;

# if SHOW_ERROR_LINE
  if (fn)
    pt->rep.stdio.filename = store_string (SCHEME_A_ strlen (fn), fn, 0);

  pt->rep.stdio.curr_line = 0;
# endif

  return pt;
}

static pointer
port_from_filename (SCHEME_P_ const char *fn, int prop)
{
  port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

static port *
port_rep_from_file (SCHEME_P_ int f, int prop)
{
  port *pt = malloc (sizeof *pt);

  if (!pt && USE_ERROR_CHECKING)
    return NULL;

  pt->unget = -1;
  pt->kind = port_file | prop;
  pt->rep.stdio.file = f;
  pt->rep.stdio.closeit = 0;
  return pt;
}

static pointer
port_from_file (SCHEME_P_ int f, int prop)
{
  port *pt = port_rep_from_file (SCHEME_A_ f, prop);

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

static port *
port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
{
  port *pt = malloc (sizeof (port));

  if (!pt && USE_ERROR_CHECKING)
    return 0;

  pt->unget = -1;
  pt->kind = port_string | prop;
  pt->rep.string.start = start;
  pt->rep.string.curr = start;
  pt->rep.string.past_the_end = past_the_end;
  return pt;
}

static pointer
port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
{
  port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

# define BLOCK_SIZE 256

static port *
port_rep_from_scratch (SCHEME_P)
{
  char *start;
  port *pt = malloc (sizeof (port));

  if (!pt && USE_ERROR_CHECKING)
    return 0;

  start = malloc (BLOCK_SIZE);

  if (start == 0)
    return 0;

  memset (start, ' ', BLOCK_SIZE - 1);
  start[BLOCK_SIZE - 1] = '\0';
  pt->unget = -1;
  pt->kind = port_string | port_output | port_srfi6;
  pt->rep.string.start = start;
  pt->rep.string.curr = start;
  pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
  return pt;
}

static pointer
port_from_scratch (SCHEME_P)
{
  port *pt = port_rep_from_scratch (SCHEME_A);

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

static void
port_close (SCHEME_P_ pointer p, int flag)
{
  port *pt = p->object.port;

  pt->kind &= ~flag;

  if ((pt->kind & (port_input | port_output)) == 0)
    {
      if (pt->kind & port_file)
        {

# if SHOW_ERROR_LINE
          /* Cleanup is here so (close-*-port) functions could work too */
          pt->rep.stdio.curr_line = 0;

          if (pt->rep.stdio.filename)
            free (pt->rep.stdio.filename);

# endif

          close (pt->rep.stdio.file);
        }

      pt->kind = port_free;
    }
}
#endif

/* get new character from input file */
static int
inchar (SCHEME_P)
{
  int c;
  port *pt;

  pt = SCHEME_V->inport->object.port;

  if (pt->kind & port_saw_EOF)
    return EOF;

  c = basic_inchar (pt);

  if (c == EOF && SCHEME_V->inport == SCHEME_V->loadport)
    {
      /* Instead, set port_saw_EOF */
      pt->kind |= port_saw_EOF;

      /* file_pop(SCHEME_A); */
      return EOF;
      /* NOTREACHED */
    }

  return c;
}

static int ungot = -1;

static int
basic_inchar (port *pt)
{
#if USE_PORTS
  if (pt->unget != -1)
    {
      int r = pt->unget;
      pt->unget = -1;
      return r;
    }

  if (pt->kind & port_file)
    {
      char c;

      if (!read (pt->rep.stdio.file, &c, 1))
        return EOF;

      return c;
    }
  else
    {
      if (*pt->rep.string.curr == 0 || pt->rep.string.curr == pt->rep.string.past_the_end)
        return EOF;
      else
        return *pt->rep.string.curr++;
    }
#else
  if (ungot == -1)
    {
      char c;
      if (!read (0, &c, 1))
        return EOF;

      ungot = c;
    }

  {
    int r = ungot;
    ungot = -1;
    return r;
  }
#endif
}

/* back character to input buffer */
static void
backchar (SCHEME_P_ int c)
{
#if USE_PORTS
  port *pt;

  if (c == EOF)
    return;

  pt = SCHEME_V->inport->object.port;
  pt->unget = c;
#else
  if (c == EOF)
    return;

  ungot = c;
#endif
}

#if USE_PORTS
static int
realloc_port_string (SCHEME_P_ port *p)
{
  char *start = p->rep.string.start;
  size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
  char *str = malloc (new_size);

  if (str)
    {
      memset (str, ' ', new_size - 1);
      str[new_size - 1] = '\0';
      strcpy (str, start);
      p->rep.string.start = str;
      p->rep.string.past_the_end = str + new_size - 1;
      p->rep.string.curr -= start - str;
      free (start);
      return 1;
    }
  else
    return 0;
}
#endif

INTERFACE void
putstr (SCHEME_P_ const char *s)
{
#if USE_PORTS
  port *pt = SCHEME_V->outport->object.port;

  if (pt->kind & port_file)
    write (pt->rep.stdio.file, s, strlen (s));
  else
    for (; *s; s++)
      if (pt->rep.string.curr != pt->rep.string.past_the_end)
        *pt->rep.string.curr++ = *s;
      else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
        *pt->rep.string.curr++ = *s;

#else
  xwrstr (s);
#endif
}

static void
putchars (SCHEME_P_ const char *s, int len)
{
#if USE_PORTS
  port *pt = SCHEME_V->outport->object.port;

  if (pt->kind & port_file)
    write (pt->rep.stdio.file, s, len);
  else
    {
      for (; len; len--)
        {
          if (pt->rep.string.curr != pt->rep.string.past_the_end)
            *pt->rep.string.curr++ = *s++;
          else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
            *pt->rep.string.curr++ = *s++;
        }
    }

#else
  write (1, s, len);
#endif
}

INTERFACE void
putcharacter (SCHEME_P_ int c)
{
#if USE_PORTS
  port *pt = SCHEME_V->outport->object.port;

  if (pt->kind & port_file)
    {
      char cc = c;
      write (pt->rep.stdio.file, &cc, 1);
    }
  else
    {
      if (pt->rep.string.curr != pt->rep.string.past_the_end)
        *pt->rep.string.curr++ = c;
      else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
        *pt->rep.string.curr++ = c;
    }

#else
  char cc = c;
  write (1, &c, 1);
#endif
}

/* read characters up to delimiter, but cater to character constants */
static char *
readstr_upto (SCHEME_P_ int skip, const char *delim)
{
  char *p = SCHEME_V->strbuff + skip;

  while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));

  if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
    *p = 0;
  else
    {
      backchar (SCHEME_A_ p[-1]);
      *--p = '\0';
    }

  return SCHEME_V->strbuff;
}

/* read string expression "xxx...xxx" */
static pointer
readstrexp (SCHEME_P_ char delim)
{
  char *p = SCHEME_V->strbuff;
  int c;
  int c1 = 0;
  enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;

  for (;;)
    {
      c = inchar (SCHEME_A);

      if (c == EOF || p - SCHEME_V->strbuff > sizeof (SCHEME_V->strbuff) - 1)
        return S_F;

      switch (state)
        {
          case st_ok:
            if (ecb_expect_false (c == delim))
              return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);

            if (ecb_expect_false (c == '\\'))
              state = st_bsl;
            else
              *p++ = c;

            break;

          case st_bsl:
            switch (c)
              {
                case '0':
                case '1':
                case '2':
                case '3':
                case '4':
                case '5':
                case '6':
                case '7':
                  state = st_oct1;
                  c1 = c - '0';
                  break;

                case 'x':
                case 'X':
                  state = st_x1;
                  c1 = 0;
                  break;

                case 'n':
                  *p++ = '\n';
                  state = st_ok;
                  break;

                case 't':
                  *p++ = '\t';
                  state = st_ok;
                  break;

                case 'r':
                  *p++ = '\r';
                  state = st_ok;
                  break;

                default:
                  *p++ = c;
                  state = st_ok;
                  break;
              }

            break;

          case st_x1:
          case st_x2:
            c = tolower (c);

            if (c >= '0' && c <= '9')
              c1 = (c1 << 4) + c - '0';
            else if (c >= 'a' && c <= 'f')
              c1 = (c1 << 4) + c - 'a' + 10;
            else
              return S_F;

            if (state == st_x1)
              state = st_x2;
            else
              {
                *p++ = c1;
                state = st_ok;
              }

            break;

          case st_oct1:
          case st_oct2:
            if (c < '0' || c > '7')
              {
                *p++ = c1;
                backchar (SCHEME_A_ c);
                state = st_ok;
              }
            else
              {
                if (state == st_oct2 && c1 >= ' ')
                  return S_F;

                c1 = (c1 << 3) + (c - '0');

                if (state == st_oct1)
                  state = st_oct2;
                else
                  {
                    *p++ = c1;
                    state = st_ok;
                  }
              }

            break;
        }
    }
}

/* check c is in chars */
ecb_inline int
is_one_of (const char *s, int c)
{
  if (c == EOF)
    return 1;

  return !!strchr (s, c);
}

/* skip white characters */
ecb_inline int
skipspace (SCHEME_P)
{
  int c, curr_line = 0;

  do
    {
      c = inchar (SCHEME_A);
#if SHOW_ERROR_LINE
      if (c == '\n')
        curr_line++;
#endif
    }
  while (c == ' ' || c == '\n' || c == '\r' || c == '\t');

  /* record it */
#if SHOW_ERROR_LINE
  if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
    SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
#endif

  if (c != EOF)
    {
      backchar (SCHEME_A_ c);
      return 1;
    }
  else
    return EOF;
}

/* get token */
static int
token (SCHEME_P)
{
  int c = skipspace (SCHEME_A);

  if (c == EOF)
    return TOK_EOF;

  switch ((c = inchar (SCHEME_A)))
    {
      case EOF:
        return TOK_EOF;

      case '(':
        return TOK_LPAREN;

      case ')':
        return TOK_RPAREN;

      case '.':
        c = inchar (SCHEME_A);

        if (is_one_of (" \n\t", c))
          return TOK_DOT;
        else
          {
            backchar (SCHEME_A_ c);
            return TOK_DOTATOM;
          }

      case '|':
        return TOK_STRATOM;

      case '\'':
        return TOK_QUOTE;

      case ';':
        while ((c = inchar (SCHEME_A)) != '\n' && c != EOF)
          ;

#if SHOW_ERROR_LINE

        if (c == '\n' && SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
          SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++;

#endif

        if (c == EOF)
          return TOK_EOF;
        else
          return token (SCHEME_A);

      case '"':
        return TOK_DQUOTE;

      case BACKQUOTE:
        return TOK_BQUOTE;

      case ',':
        if ((c = inchar (SCHEME_A)) == '@')
          return TOK_ATMARK;
        else
          {
            backchar (SCHEME_A_ c);
            return TOK_COMMA;
          }

      case '#':
        c = inchar (SCHEME_A);

        if (c == '(')
          return TOK_VEC;
        else if (c == '!')
          {
            while ((c = inchar (SCHEME_A)) != '\n' && c != EOF)
              ;

#if SHOW_ERROR_LINE

            if (c == '\n' && SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
              SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++;

#endif

            if (c == EOF)
              return TOK_EOF;
            else
              return token (SCHEME_A);
          }
        else
          {
            backchar (SCHEME_A_ c);

            if (is_one_of (" tfodxb\\", c))
              return TOK_SHARP_CONST;
            else
              return TOK_SHARP;
          }

      default:
        backchar (SCHEME_A_ c);
        return TOK_ATOM;
    }
}

/* ========== Routines for Printing ========== */
#define   ok_abbrev(x)   (is_pair(x) && cdr(x) == NIL)

static void
printslashstring (SCHEME_P_ char *p, int len)
{
  int i;
  unsigned char *s = (unsigned char *) p;

  putcharacter (SCHEME_A_ '"');

  for (i = 0; i < len; i++)
    {
      if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\')
        {
          putcharacter (SCHEME_A_ '\\');

          switch (*s)
            {
              case '"':
                putcharacter (SCHEME_A_ '"');
                break;

              case '\n':
                putcharacter (SCHEME_A_ 'n');
                break;

              case '\t':
                putcharacter (SCHEME_A_ 't');
                break;

              case '\r':
                putcharacter (SCHEME_A_ 'r');
                break;

              case '\\':
                putcharacter (SCHEME_A_ '\\');
                break;

              default:
                {
                  int d = *s / 16;

                  putcharacter (SCHEME_A_ 'x');

                  if (d < 10)
                    putcharacter (SCHEME_A_ d + '0');
                  else
                    putcharacter (SCHEME_A_ d - 10 + 'A');

                  d = *s % 16;

                  if (d < 10)
                    putcharacter (SCHEME_A_ d + '0');
                  else
                    putcharacter (SCHEME_A_ d - 10 + 'A');
                }
            }
        }
      else
        putcharacter (SCHEME_A_ * s);

      s++;
    }

  putcharacter (SCHEME_A_ '"');
}


/* print atoms */
static void
printatom (SCHEME_P_ pointer l, int f)
{
  char *p;
  int len;

  atom2str (SCHEME_A_ l, f, &p, &len);
  putchars (SCHEME_A_ p, len);
}


/* Uses internal buffer unless string pointer is already available */
static void
atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
{
  char *p;

  if (l == NIL)
    p = "()";
  else if (l == S_T)
    p = "#t";
  else if (l == S_F)
    p = "#f";
  else if (l == S_EOF)
    p = "#<EOF>";
  else if (is_port (l))
    p = "#<PORT>";
  else if (is_number (l))
    {
      p = SCHEME_V->strbuff;

      if (f <= 1 || f == 10)    /* f is the base for numbers if > 1 */
        {
          if (is_integer (l))
            xnum (p, ivalue_unchecked (l));
#if USE_REAL
          else
            {
              snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
              /* r5rs says there must be a '.' (unless 'e'?) */
              f = strcspn (p, ".e");

              if (p[f] == 0)
                {
                  p[f] = '.';   /* not found, so add '.0' at the end */
                  p[f + 1] = '0';
                  p[f + 2] = 0;
                }
            }
#endif
        }
      else
        {
          long v = ivalue (l);

          if (f == 16)
            xbase (p, v, 16);
          else if (f == 8)
            xbase (p, v, 8);
          else if (f == 2)
            {
              unsigned long b = (v < 0) ? -v : v;

              p = &p[STRBUFFSIZE - 1];
              *p = 0;

              do
                {
                  *--p = (b & 1) ? '1' : '0';
                  b >>= 1;
                }
              while (b != 0);

              if (v < 0)
                *--p = '-';
            }
        }
    }
  else if (is_string (l))
    {
      if (!f)
        p = strvalue (l);
      else                      /* Hack, uses the fact that printing is needed */
        {
          *pp = SCHEME_V->strbuff;
          *plen = 0;
          printslashstring (SCHEME_A_ strvalue (l), strlength (l));
          return;
        }
    }
  else if (is_character (l))
    {
      int c = charvalue (l);

      p = SCHEME_V->strbuff;

      if (!f)
        {
          p[0] = c;
          p[1] = 0;
        }
      else
        {
          switch (c)
            {
              case ' ':
                p ="#\\space";
                break;

              case '\n':
                p ="#\\newline";
                break;

              case '\r':
                p ="#\\return";
                break;

              case '\t':
                p ="#\\tab";
                break;

              default:
#if USE_ASCII_NAMES
                if (c == 127)
                  {
                    strcpy (p, "#\\del");
                    break;
                  }
                else if (c < 32)
                  {
                    strcpy (p, "#\\");
                    strcpy (p + 2, charnames[c]);
                    break;
                  }

#else

                if (c < 32)
                  {
                    strcpy (p, "#\\x");
                    xbase (p + 3, c, 16);
                    break;
                  }

#endif
                strcpy (p, "#\\%");
                p[2] = c;
                break;
            }
        }
    }
  else if (is_symbol (l))
    p = symname (l);
  else if (is_proc (l))
    {
#if USE_PRINTF
      p = SCHEME_V->strbuff;
      snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l));
#else
      p = "#<PROCEDURE>";
#endif
    }
  else if (is_macro (l))
    p = "#<MACRO>";
  else if (is_closure (l))
    p = "#<CLOSURE>";
  else if (is_promise (l))
    p = "#<PROMISE>";
  else if (is_foreign (l))
    {
#if USE_PRINTF
      p = SCHEME_V->strbuff;
      snprintf (p, STRBUFFSIZE, "#<FOREIGN PROCEDURE %ld>", procnum (l));
#else
      p = "#<FOREIGN PROCEDURE>";
#endif
    }
  else if (is_continuation (l))
    p = "#<CONTINUATION>";
  else
    p = "#<ERROR>";

  *pp = p;
  *plen = strlen (p);
}

/* ========== Routines for Evaluation Cycle ========== */

/* make closure. c is code. e is environment */
static pointer
mk_closure (SCHEME_P_ pointer c, pointer e)
{
  pointer x = get_cell (SCHEME_A_ c, e);

  set_typeflag (x, T_CLOSURE);
  set_car (x, c);
  set_cdr (x, e);
  return x;
}

/* make continuation. */
static pointer
mk_continuation (SCHEME_P_ pointer d)
{
  pointer x = get_cell (SCHEME_A_ NIL, d);

  set_typeflag (x, T_CONTINUATION);
  set_cont_dump (x, d);
  return x;
}

static pointer
list_star (SCHEME_P_ pointer d)
{
  pointer p, q;

  if (cdr (d) == NIL)
    return car (d);

  p = cons (car (d), cdr (d));
  q = p;

  while (cdr (cdr (p)) != NIL)
    {
      d = cons (car (p), cdr (p));

      if (cdr (cdr (p)) != NIL)
        p = cdr (d);
    }

  set_cdr (p, car (cdr (p)));
  return q;
}

/* reverse list -- produce new list */
static pointer
reverse (SCHEME_P_ pointer a)
{
  /* a must be checked by gc */
  pointer p = NIL;

  for (; is_pair (a); a = cdr (a))
    p = cons (car (a), p);

  return p;
}

/* reverse list --- in-place */
static pointer
reverse_in_place (SCHEME_P_ pointer term, pointer list)
{
  pointer result = term;
  pointer p = list;

  while (p != NIL)
    {
      pointer q = cdr (p);
      set_cdr (p, result);
      result = p;
      p = q;
    }

  return result;
}

/* append list -- produce new list (in reverse order) */
static pointer
revappend (SCHEME_P_ pointer a, pointer b)
{
  pointer result = a;
  pointer p = b;

  while (is_pair (p))
    {
      result = cons (car (p), result);
      p = cdr (p);
    }

  if (p == NIL)
    return result;

  return S_F;           /* signal an error */
}

/* equivalence of atoms */
int
eqv (pointer a, pointer b)
{
  if (is_string (a))
    {
      if (is_string (b))
        return strvalue (a) == strvalue (b);
      else
        return 0;
    }
  else if (is_number (a))
    {
      if (is_number (b))
        return num_cmp (nvalue (a), nvalue (b)) == 0;

      return 0;
    }
  else if (is_character (a))
    {
      if (is_character (b))
        return charvalue (a) == charvalue (b);
      else
        return 0;
    }
  else if (is_port (a))
    {
      if (is_port (b))
        return a == b;
      else
        return 0;
    }
  else if (is_proc (a))
    {
      if (is_proc (b))
        return procnum (a) == procnum (b);
      else
        return 0;
    }
  else
    return a == b;
}

/* true or false value macro */

/* () is #t in R5RS */
#define is_true(p)       ((p) != S_F)
#define is_false(p)      ((p) == S_F)

/* ========== Environment implementation  ========== */

#ifndef USE_ALIST_ENV

/*
 * In this implementation, each frame of the environment may be
 * a hash table: a vector of alists hashed by variable name.
 * In practice, we use a vector only for the initial frame;
 * subsequent frames are too small and transient for the lookup
 * speed to out-weigh the cost of making a new vector.
 */

static void
new_frame_in_env (SCHEME_P_ pointer old_env)
{
  pointer new_frame;

  /* The interaction-environment has about 300 variables in it. */
  if (old_env == NIL)
    new_frame = mk_vector (SCHEME_A_ 461);
  else
    new_frame = NIL;

  SCHEME_V->envir = immutable_cons (new_frame, old_env);
  setenvironment (SCHEME_V->envir);
}

static uint32_t
sym_hash (pointer sym, uint32_t size)
{
  uintptr_t ptr = (uintptr_t)sym;

#if 0
  /* table size is prime, so why mix */
  ptr += ptr >> 32;
  ptr += ptr >> 16;
  ptr += ptr >>  8;
#endif

  return ptr % size;
}

ecb_inline void
new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
{
  pointer slot = immutable_cons (variable, value);

  if (is_vector (car (env)))
    {
      int location = sym_hash (variable, veclength (car (env)));
      vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
    }
  else
    set_car (env, immutable_cons (slot, car (env)));
}

static pointer
find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
{
  pointer x, y;

  for (x = env; x != NIL; x = cdr (x))
    {
      if (is_vector (car (x)))
        {
          int location = sym_hash (hdl, veclength (car (x)));
          y = vector_get (car (x), location);
        }
      else
        y = car (x);

      for (; y != NIL; y = cdr (y))
        if (caar (y) == hdl)
          break;

      if (y != NIL)
        return car (y);

      if (!all)
        break;
    }

  return NIL;
}

#else /* USE_ALIST_ENV */

ecb_inline void
new_frame_in_env (SCHEME_P_ pointer old_env)
{
  SCHEME_V->envir = immutable_cons (NIL, old_env);
  setenvironment (SCHEME_V->envir);
}

ecb_inline void
new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
{
  set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
}

static pointer
find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
{
  pointer x, y;

  for (x = env; x != NIL; x = cdr (x))
    {
      for (y = car (x); y != NIL; y = cdr (y))
        if (caar (y) == hdl)
          break;

      if (y != NIL)
        return car (y);
        break;

      if (!all)
        break;
    }

  return NIL;
}

#endif /* USE_ALIST_ENV else */

ecb_inline void
new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
{
  new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
}

ecb_inline void
set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
{
  set_cdr (slot, value);
}

ecb_inline pointer
slot_value_in_env (pointer slot)
{
  return cdr (slot);
}

/* ========== Evaluation Cycle ========== */

static int
xError_1 (SCHEME_P_ const char *s, pointer a)
{
#if USE_ERROR_HOOK
  pointer x;
  pointer hdl = SCHEME_V->ERROR_HOOK;
#endif

#if USE_PRINTF
#if SHOW_ERROR_LINE
  char sbuf[STRBUFFSIZE];

  /* make sure error is not in REPL */
  if ((SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) && SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file != STDIN_FILENO)
    {
      int ln = SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line;
      const char *fname = SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename;

      /* should never happen */
      if (!fname)
        fname = "<unknown>";

      /* we started from 0 */
      ln++;
      snprintf (sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);

      s = sbuf;
    }
#endif
#endif

#if USE_ERROR_HOOK
  x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);

  if (x != NIL)
    {
      pointer code = a
         ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
         : NIL;

      code = cons (mk_string (SCHEME_A_ s), code);
      setimmutable (car (code));
      SCHEME_V->code = cons (slot_value_in_env (x), code);
      SCHEME_V->op = OP_EVAL;

      return 0;
    }
#endif

  if (a)
    SCHEME_V->args = cons (a, NIL);
  else
    SCHEME_V->args = NIL;

  SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
  setimmutable (car (SCHEME_V->args));
  SCHEME_V->op = OP_ERR0;

  return 0;
}

#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
#define Error_0(s)    Error_1 (s, 0)

/* Too small to turn into function */
#define  BEGIN do {
#define  END   } while (0)
#define s_goto(a) BEGIN                                    \
    SCHEME_V->op = a;                                      \
    return 0; END

#define s_return(a) return xs_return (SCHEME_A_ a)

#ifndef USE_SCHEME_STACK

/* this structure holds all the interpreter's registers */
struct dump_stack_frame
{
  enum scheme_opcodes op;
  pointer args;
  pointer envir;
  pointer code;
};

# define STACK_GROWTH 3

static void
s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
{
  int nframes = (uintptr_t)SCHEME_V->dump;
  struct dump_stack_frame *next_frame;

  /* enough room for the next frame? */
  if (nframes >= SCHEME_V->dump_size)
    {
      SCHEME_V->dump_size += STACK_GROWTH;
      SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
    }

  next_frame = SCHEME_V->dump_base + nframes;

  next_frame->op    = op;
  next_frame->args  = args;
  next_frame->envir = SCHEME_V->envir;
  next_frame->code  = code;

  SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
}

static int
xs_return (SCHEME_P_ pointer a)
{
  int nframes = (uintptr_t)SCHEME_V->dump;
  struct dump_stack_frame *frame;

  SCHEME_V->value = a;

  if (nframes <= 0)
    return -1;

  frame = &SCHEME_V->dump_base[--nframes];
  SCHEME_V->op    = frame->op;
  SCHEME_V->args  = frame->args;
  SCHEME_V->envir = frame->envir;
  SCHEME_V->code  = frame->code;
  SCHEME_V->dump  = (pointer)(uintptr_t)nframes;

  return 0;
}

ecb_inline void
dump_stack_reset (SCHEME_P)
{
  /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
  SCHEME_V->dump = (pointer)+0;
}

ecb_inline void
dump_stack_initialize (SCHEME_P)
{
  SCHEME_V->dump_size = 0;
  SCHEME_V->dump_base = 0;
  dump_stack_reset (SCHEME_A);
}

static void
dump_stack_free (SCHEME_P)
{
  free (SCHEME_V->dump_base);
  SCHEME_V->dump_base = 0;
  SCHEME_V->dump = (pointer)0;
  SCHEME_V->dump_size = 0;
}

static void
dump_stack_mark (SCHEME_P)
{
  int nframes = (uintptr_t)SCHEME_V->dump;
  int i;

  for (i = 0; i < nframes; i++)
    {
      struct dump_stack_frame *frame = SCHEME_V->dump_base + i;

      mark (frame->args);
      mark (frame->envir);
      mark (frame->code);
    }
}

static pointer
ss_get_cont (SCHEME_P)
{
  int nframes = (uintptr_t)SCHEME_V->dump;
  int i;

  pointer cont = NIL;

  for (i = nframes; i--; )
    {
      struct dump_stack_frame *frame = SCHEME_V->dump_base + i;

      cont = cons (mk_integer (SCHEME_A_ frame->op),
             cons (frame->args,
             cons (frame->envir,
             cons (frame->code,
               cont))));
    }

  return cont;
}

static void
ss_set_cont (SCHEME_P_ pointer cont)
{
  int i = 0;
  struct dump_stack_frame *frame = SCHEME_V->dump_base;

  while (cont != NIL)
    {
      frame->op    = ivalue_unchecked (car (cont)); cont = cdr (cont);
      frame->args  =                   car (cont) ; cont = cdr (cont);
      frame->envir =                   car (cont) ; cont = cdr (cont);
      frame->code  =                   car (cont) ; cont = cdr (cont);

      ++frame;
      ++i;
    }

  SCHEME_V->dump = (pointer)(uintptr_t)i;
}

#else

ecb_inline void
dump_stack_reset (SCHEME_P)
{
  SCHEME_V->dump = NIL;
}

ecb_inline void
dump_stack_initialize (SCHEME_P)
{
  dump_stack_reset (SCHEME_A);
}

static void
dump_stack_free (SCHEME_P)
{
  SCHEME_V->dump = NIL;
}

static int
xs_return (SCHEME_P_ pointer a)
{
  pointer dump = SCHEME_V->dump;

  SCHEME_V->value = a;

  if (dump == NIL)
    return -1;

  SCHEME_V->op    = ivalue_unchecked (car (dump)); dump = cdr (dump);
  SCHEME_V->args  =                   car (dump) ; dump = cdr (dump);
  SCHEME_V->envir =                   car (dump) ; dump = cdr (dump);
  SCHEME_V->code  =                   car (dump) ; dump = cdr (dump);

  SCHEME_V->dump = dump;

  return 0;
}

static void
s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
{
  SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
                   cons (args,
                   cons (SCHEME_V->envir,
                   cons (code,
                     SCHEME_V->dump))));
}

static void
dump_stack_mark (SCHEME_P)
{
  mark (SCHEME_V->dump);
}

static pointer
ss_get_cont (SCHEME_P)
{
  return SCHEME_V->dump;
}

static void
ss_set_cont (SCHEME_P_ pointer cont)
{
  SCHEME_V->dump = cont;
}

#endif

#define s_retbool(tf)    s_return ((tf) ? S_T : S_F)

static int
opexe_0 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer args = SCHEME_V->args;
  pointer x, y;

  switch (op)
    {
      case OP_LOAD:            /* load */
        if (file_interactive (SCHEME_A))
          {
            xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
            //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
          }

        if (!file_push (SCHEME_A_ strvalue (car (args))))
          Error_1 ("unable to open", car (args));
        else
          {
            SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
            s_goto (OP_T0LVL);
          }

      case OP_T0LVL:           /* top level */

        /* If we reached the end of file, this loop is done. */
        if (SCHEME_V->loadport->object.port->kind & port_saw_EOF)
          {
            if (SCHEME_V->file_i == 0)
              {
                SCHEME_V->args = NIL;
                s_goto (OP_QUIT);
              }
            else
              {
                file_pop (SCHEME_A);
                s_return (SCHEME_V->value);
              }

            /* NOTREACHED */
          }

        /* If interactive, be nice to user. */
        if (file_interactive (SCHEME_A))
          {
            SCHEME_V->envir = SCHEME_V->global_env;
            dump_stack_reset (SCHEME_A);
            putstr (SCHEME_A_ "\n");
            putstr (SCHEME_A_ prompt);
          }

        /* Set up another iteration of REPL */
        SCHEME_V->nesting = 0;
        SCHEME_V->save_inport = SCHEME_V->inport;
        SCHEME_V->inport = SCHEME_V->loadport;
        s_save (SCHEME_A_ OP_T0LVL, NIL, NIL);
        s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
        s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
        s_goto (OP_READ_INTERNAL);

      case OP_T1LVL:           /* top level */
        SCHEME_V->code   = SCHEME_V->value;
        SCHEME_V->inport = SCHEME_V->save_inport;
        s_goto (OP_EVAL);

      case OP_READ_INTERNAL:   /* internal read */
        SCHEME_V->tok = token (SCHEME_A);

        if (SCHEME_V->tok == TOK_EOF)
          s_return (S_EOF);

        s_goto (OP_RDSEXPR);

      case OP_GENSYM:
        s_return (gensym (SCHEME_A));

      case OP_VALUEPRINT:      /* print evaluation result */

        /* OP_VALUEPRINT is always pushed, because when changing from
           non-interactive to interactive mode, it needs to be
           already on the stack */
#if USE_TRACING
        if (SCHEME_V->tracing)
          putstr (SCHEME_A_ "\nGives: ");
#endif

        if (file_interactive (SCHEME_A))
          {
            SCHEME_V->print_flag = 1;
            SCHEME_V->args = SCHEME_V->value;
            s_goto (OP_P0LIST);
          }
        else
          s_return (SCHEME_V->value);

      case OP_EVAL:            /* main part of evaluation */
#if USE_TRACING
        if (SCHEME_V->tracing)
          {
            /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */
            s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code);
            SCHEME_V->args = SCHEME_V->code;
            putstr (SCHEME_A_ "\nEval: ");
            s_goto (OP_P0LIST);
          }

        /* fall through */

      case OP_REAL_EVAL:
#endif
        if (is_symbol (SCHEME_V->code)) /* symbol */
          {
            x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);

            if (x != NIL)
              s_return (slot_value_in_env (x));
            else
              Error_1 ("eval: unbound variable:", SCHEME_V->code);
          }
        else if (is_pair (SCHEME_V->code))
          {
            x = car (SCHEME_V->code);

            if (is_syntax (x))   /* SYNTAX */
              {
                SCHEME_V->code = cdr (SCHEME_V->code);
                s_goto (syntaxnum (x));
              }
            else                /* first, eval top element and eval arguments */
              {
                s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
                /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
                SCHEME_V->code = x;
                s_goto (OP_EVAL);
              }
          }
        else
          s_return (SCHEME_V->code);

      case OP_E0ARGS:          /* eval arguments */
        if (is_macro (SCHEME_V->value)) /* macro expansion */
          {
            s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
            SCHEME_V->args = cons (SCHEME_V->code, NIL);
            SCHEME_V->code = SCHEME_V->value;
            s_goto (OP_APPLY);
          }
        else
          {
            SCHEME_V->code = cdr (SCHEME_V->code);
            s_goto (OP_E1ARGS);
          }

      case OP_E1ARGS:          /* eval arguments */
        args = cons (SCHEME_V->value, args);

        if (is_pair (SCHEME_V->code))   /* continue */
          {
            s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code));
            SCHEME_V->code = car (SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_EVAL);
          }
        else                    /* end */
          {
            args = reverse_in_place (SCHEME_A_ NIL, args);
            SCHEME_V->code = car (args);
            SCHEME_V->args = cdr (args);
            s_goto (OP_APPLY);
          }

#if USE_TRACING

      case OP_TRACING:
        {
          int tr = SCHEME_V->tracing;

          SCHEME_V->tracing = ivalue_unchecked (car (args));
          s_return (mk_integer (SCHEME_A_ tr));
        }

#endif

      case OP_APPLY:           /* apply 'code' to 'args' */
#if USE_TRACING
        if (SCHEME_V->tracing)
          {
            s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code);
            SCHEME_V->print_flag = 1;
            /*  args=cons(SCHEME_V->code,args); */
            putstr (SCHEME_A_ "\nApply to: ");
            s_goto (OP_P0LIST);
          }

        /* fall through */

      case OP_REAL_APPLY:
#endif
        if (is_proc (SCHEME_V->code))
          s_goto (procnum (SCHEME_V->code));  /* PROCEDURE */
        else if (is_foreign (SCHEME_V->code))
          {
            /* Keep nested calls from GC'ing the arglist */
            push_recent_alloc (SCHEME_A_ args, NIL);
            x = SCHEME_V->code->object.ff (SCHEME_A_ args);

            s_return (x);
          }
        else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code))       /* CLOSURE */
          {
            /* Should not accept promise */
            /* make environment */
            new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));

            for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y))
              {
                if (y == NIL)
                  Error_0 ("not enough arguments");
                else
                  new_slot_in_env (SCHEME_A_ car (x), car (y));
              }

            if (x == NIL)
              {
                /*--
                 * if (y != NIL) {
                 *   Error_0("too many arguments");
                 * }
                 */
              }
            else if (is_symbol (x))
              new_slot_in_env (SCHEME_A_ x, y);
            else
              Error_1 ("syntax error in closure: not a symbol:", x);

            SCHEME_V->code = cdr (closure_code (SCHEME_V->code));
            SCHEME_V->args = NIL;
            s_goto (OP_BEGIN);
          }
        else if (is_continuation (SCHEME_V->code))      /* CONTINUATION */
          {
            ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
            s_return (args != NIL ? car (args) : NIL);
          }
        else
          Error_0 ("illegal function");

      case OP_DOMACRO:         /* do macro */
        SCHEME_V->code = SCHEME_V->value;
        s_goto (OP_EVAL);

#if 1

      case OP_LAMBDA:          /* lambda */
        /* If the hook is defined, apply it to SCHEME_V->code, otherwise
           set SCHEME_V->value fall thru */
        {
          pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);

          if (f != NIL)
            {
              s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code);
              SCHEME_V->args = cons (SCHEME_V->code, NIL);
              SCHEME_V->code = slot_value_in_env (f);
              s_goto (OP_APPLY);
            }

            SCHEME_V->value = SCHEME_V->code;
            /* Fallthru */
        }

      case OP_LAMBDA1:
        s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));

#else

      case OP_LAMBDA:          /* lambda */
        s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));

#endif

      case OP_MKCLOSURE:       /* make-closure */
        x = car (args);

        if (car (x) == SCHEME_V->LAMBDA)
          x = cdr (x);

        if (cdr (args) == NIL)
          y = SCHEME_V->envir;
        else
          y = cadr (args);

        s_return (mk_closure (SCHEME_A_ x, y));

      case OP_QUOTE:           /* quote */
        s_return (car (SCHEME_V->code));

      case OP_DEF0:            /* define */
        if (is_immutable (car (SCHEME_V->code)))
          Error_1 ("define: unable to alter immutable", car (SCHEME_V->code));

        if (is_pair (car (SCHEME_V->code)))
          {
            x = caar (SCHEME_V->code);
            SCHEME_V->code = cons (SCHEME_V->LAMBDA, cons (cdar (SCHEME_V->code), cdr (SCHEME_V->code)));
          }
        else
          {
            x = car (SCHEME_V->code);
            SCHEME_V->code = cadr (SCHEME_V->code);
          }

        if (!is_symbol (x))
          Error_0 ("variable is not a symbol");

        s_save (SCHEME_A_ OP_DEF1, NIL, x);
        s_goto (OP_EVAL);

      case OP_DEF1:            /* define */
        x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0);

        if (x != NIL)
          set_slot_in_env (SCHEME_A_ x, SCHEME_V->value);
        else
          new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);

        s_return (SCHEME_V->code);


      case OP_DEFP:            /* defined? */
        x = SCHEME_V->envir;

        if (cdr (args) != NIL)
          x = cadr (args);

        s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL);

      case OP_SET0:            /* set! */
        if (is_immutable (car (SCHEME_V->code)))
          Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code));

        s_save (SCHEME_A_ OP_SET1, NIL, car (SCHEME_V->code));
        SCHEME_V->code = cadr (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_SET1:            /* set! */
        y = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);

        if (y != NIL)
          {
            set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
            s_return (SCHEME_V->value);
          }
        else
          Error_1 ("set!: unbound variable:", SCHEME_V->code);


      case OP_BEGIN:           /* begin */
        if (!is_pair (SCHEME_V->code))
          s_return (SCHEME_V->code);

        if (cdr (SCHEME_V->code) != NIL)
          s_save (SCHEME_A_ OP_BEGIN, NIL, cdr (SCHEME_V->code));

        SCHEME_V->code = car (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_IF0:             /* if */
        s_save (SCHEME_A_ OP_IF1, NIL, cdr (SCHEME_V->code));
        SCHEME_V->code = car (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_IF1:             /* if */
        if (is_true (SCHEME_V->value))
          SCHEME_V->code = car (SCHEME_V->code);
        else
          SCHEME_V->code = cadr (SCHEME_V->code);       /* (if #f 1) ==> () because * car(NIL) = NIL */
        s_goto (OP_EVAL);

      case OP_LET0:            /* let */
        SCHEME_V->args = NIL;
        SCHEME_V->value = SCHEME_V->code;
        SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
        s_goto (OP_LET1);

      case OP_LET1:            /* let (calculate parameters) */
        args = cons (SCHEME_V->value, args);

        if (is_pair (SCHEME_V->code))   /* continue */
          {
            if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
              Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));

            s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));
            SCHEME_V->code = cadar (SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_EVAL);
          }
        else                    /* end */
          {
            args = reverse_in_place (SCHEME_A_ NIL, args);
            SCHEME_V->code = car (args);
            SCHEME_V->args = cdr (args);
            s_goto (OP_LET2);
          }

      case OP_LET2:            /* let */
        new_frame_in_env (SCHEME_A_ SCHEME_V->envir);

        for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
             y != NIL; x = cdr (x), y = cdr (y))
          new_slot_in_env (SCHEME_A_ caar (x), car (y));

        if (is_symbol (car (SCHEME_V->code)))   /* named let */
          {
            for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
              {
                if (!is_pair (x))
                  Error_1 ("Bad syntax of binding in let :", x);

                if (!is_list (SCHEME_A_ car (x)))
                  Error_1 ("Bad syntax of binding in let :", car (x));

                args = cons (caar (x), args);
              }

            x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
                            SCHEME_V->envir);
            new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x);
            SCHEME_V->code = cddr (SCHEME_V->code);
          }
        else
          {
            SCHEME_V->code = cdr (SCHEME_V->code);
          }

        SCHEME_V->args = NIL;
        s_goto (OP_BEGIN);

      case OP_LET0AST:         /* let* */
        if (car (SCHEME_V->code) == NIL)
          {
            new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
            SCHEME_V->code = cdr (SCHEME_V->code);
            s_goto (OP_BEGIN);
          }

        if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
          Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code));

        s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
        SCHEME_V->code = car (cdaar (SCHEME_V->code));
        s_goto (OP_EVAL);

      case OP_LET1AST:         /* let* (make new frame) */
        new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
        s_goto (OP_LET2AST);

      case OP_LET2AST:         /* let* (calculate parameters) */
        new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value);
        SCHEME_V->code = cdr (SCHEME_V->code);

        if (is_pair (SCHEME_V->code))   /* continue */
          {
            s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
            SCHEME_V->code = cadar (SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_EVAL);
          }
        else                    /* end */
          {
            SCHEME_V->code = args;
            SCHEME_V->args = NIL;
            s_goto (OP_BEGIN);
          }

      case OP_LET0REC:         /* letrec */
        new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
        SCHEME_V->args = NIL;
        SCHEME_V->value = SCHEME_V->code;
        SCHEME_V->code = car (SCHEME_V->code);
        s_goto (OP_LET1REC);

      case OP_LET1REC:         /* letrec (calculate parameters) */
        args = cons (SCHEME_V->value, args);

        if (is_pair (SCHEME_V->code))   /* continue */
          {
            if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
              Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));

            s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
            SCHEME_V->code = cadar (SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_EVAL);
          }
        else                    /* end */
          {
            args = reverse_in_place (SCHEME_A_ NIL, args);
            SCHEME_V->code = car (args);
            SCHEME_V->args = cdr (args);
            s_goto (OP_LET2REC);
          }

      case OP_LET2REC:         /* letrec */
        for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
          new_slot_in_env (SCHEME_A_ caar (x), car (y));

        SCHEME_V->code = cdr (SCHEME_V->code);
        SCHEME_V->args = NIL;
        s_goto (OP_BEGIN);

      case OP_COND0:           /* cond */
        if (!is_pair (SCHEME_V->code))
          Error_0 ("syntax error in cond");

        s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
        SCHEME_V->code = caar (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_COND1:           /* cond */
        if (is_true (SCHEME_V->value))
          {
            if ((SCHEME_V->code = cdar (SCHEME_V->code)) == NIL)
              s_return (SCHEME_V->value);

            if (car (SCHEME_V->code) == SCHEME_V->FEED_TO)
              {
                if (!is_pair (cdr (SCHEME_V->code)))
                  Error_0 ("syntax error in cond");

                x = cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL));
                SCHEME_V->code = cons (cadr (SCHEME_V->code), cons (x, NIL));
                s_goto (OP_EVAL);
              }

            s_goto (OP_BEGIN);
          }
        else
          {
            if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
              s_return (NIL);
            else
              {
                s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
                SCHEME_V->code = caar (SCHEME_V->code);
                s_goto (OP_EVAL);
              }
          }

      case OP_DELAY:           /* delay */
        x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
        set_typeflag (x, T_PROMISE);
        s_return (x);

      case OP_AND0:            /* and */
        if (SCHEME_V->code == NIL)
          s_return (S_T);

        s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
        SCHEME_V->code = car (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_AND1:            /* and */
        if (is_false (SCHEME_V->value))
          s_return (SCHEME_V->value);
        else if (SCHEME_V->code == NIL)
          s_return (SCHEME_V->value);
        else
          {
            s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
            SCHEME_V->code = car (SCHEME_V->code);
            s_goto (OP_EVAL);
          }

      case OP_OR0:             /* or */
        if (SCHEME_V->code == NIL)
          s_return (S_F);

        s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
        SCHEME_V->code = car (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_OR1:             /* or */
        if (is_true (SCHEME_V->value))
          s_return (SCHEME_V->value);
        else if (SCHEME_V->code == NIL)
          s_return (SCHEME_V->value);
        else
          {
            s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
            SCHEME_V->code = car (SCHEME_V->code);
            s_goto (OP_EVAL);
          }

      case OP_C0STREAM:        /* cons-stream */
        s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
        SCHEME_V->code = car (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_C1STREAM:        /* cons-stream */
        SCHEME_V->args = SCHEME_V->value;       /* save SCHEME_V->value to register args for gc */
        x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
        set_typeflag (x, T_PROMISE);
        s_return (cons (args, x));

      case OP_MACRO0:          /* macro */
        if (is_pair (car (SCHEME_V->code)))
          {
            x = caar (SCHEME_V->code);
            SCHEME_V->code = cons (SCHEME_V->LAMBDA, cons (cdar (SCHEME_V->code), cdr (SCHEME_V->code)));
          }
        else
          {
            x = car (SCHEME_V->code);
            SCHEME_V->code = cadr (SCHEME_V->code);
          }

        if (!is_symbol (x))
          Error_0 ("variable is not a symbol");

        s_save (SCHEME_A_ OP_MACRO1, NIL, x);
        s_goto (OP_EVAL);

      case OP_MACRO1:          /* macro */
        set_typeflag (SCHEME_V->value, T_MACRO);
        x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 0);

        if (x != NIL)
          set_slot_in_env (SCHEME_A_ x, SCHEME_V->value);
        else
          new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);

        s_return (SCHEME_V->code);

      case OP_CASE0:           /* case */
        s_save (SCHEME_A_ OP_CASE1, NIL, cdr (SCHEME_V->code));
        SCHEME_V->code = car (SCHEME_V->code);
        s_goto (OP_EVAL);

      case OP_CASE1:           /* case */
        for (x = SCHEME_V->code; x != NIL; x = cdr (x))
          {
            if (!is_pair (y = caar (x)))
              break;

            for (; y != NIL; y = cdr (y))
              if (eqv (car (y), SCHEME_V->value))
                  break;

            if (y != NIL)
              break;
          }

        if (x != NIL)
          {
            if (is_pair (caar (x)))
              {
                SCHEME_V->code = cdar (x);
                s_goto (OP_BEGIN);
              }
            else                /* else */
              {
                s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
                SCHEME_V->code = caar (x);
                s_goto (OP_EVAL);
              }
          }
        else
          s_return (NIL);

      case OP_CASE2:           /* case */
        if (is_true (SCHEME_V->value))
          s_goto (OP_BEGIN);
        else
          s_return (NIL);

      case OP_PAPPLY:          /* apply */
        SCHEME_V->code = car (args);
        SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
        /*SCHEME_V->args = cadr(args); */
        s_goto (OP_APPLY);

      case OP_PEVAL:           /* eval */
        if (cdr (args) != NIL)
          SCHEME_V->envir = cadr (args);

        SCHEME_V->code = car (args);
        s_goto (OP_EVAL);

      case OP_CONTINUATION:    /* call-with-current-continuation */
        SCHEME_V->code = car (args);
        SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
        s_goto (OP_APPLY);
    }

  if (USE_ERROR_CHECKING) abort ();
}

static int
opexe_1 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer args = SCHEME_V->args;
  pointer x = car (args);
  num v;

  switch (op)
    {
#if USE_MATH
      case OP_INEX2EX:         /* inexact->exact */
        {
          if (is_integer (x))
            s_return (x);

          RVALUE r = rvalue_unchecked (x);

          if (r == (RVALUE)(IVALUE)r)
            s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));
          else
            Error_1 ("inexact->exact: not integral:", x);
        }

      case OP_EXP:  s_return (mk_real (SCHEME_A_ exp  (rvalue (x))));
      case OP_LOG:  s_return (mk_real (SCHEME_A_ log  (rvalue (x))));
      case OP_SIN:  s_return (mk_real (SCHEME_A_ sin  (rvalue (x))));
      case OP_COS:  s_return (mk_real (SCHEME_A_ cos  (rvalue (x))));
      case OP_TAN:  s_return (mk_real (SCHEME_A_ tan  (rvalue (x))));
      case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
      case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));

      case OP_ATAN:
        if (cdr (args) == NIL)
          s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
        else
          {
            pointer y = cadr (args);
            s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
          }

      case OP_SQRT:
        s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));

      case OP_EXPT:
        {
          RVALUE result;
          int real_result = 1;
          pointer y = cadr (args);

          if (is_integer (x) && is_integer (y))
            real_result = 0;

          /* This 'if' is an R5RS compatibility fix. */
          /* NOTE: Remove this 'if' fix for R6RS.    */
          if (rvalue (x) == 0 && rvalue (y) < 0)
            result = 0;
          else
            result = pow (rvalue (x), rvalue (y));

          /* Before returning integer result make sure we can. */
          /* If the test fails, result is too big for integer. */
          if (!real_result)
            {
              long result_as_long = result;

              if (result != result_as_long)
                real_result = 1;
            }

          if (real_result)
            s_return (mk_real (SCHEME_A_ result));
          else
            s_return (mk_integer (SCHEME_A_ result));
        }

      case OP_FLOOR:   s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
      case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil  (rvalue (x))));

      case OP_TRUNCATE:
        {
          RVALUE n = rvalue (x);
          s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
        }

      case OP_ROUND:
        if (is_integer (x))
          s_return (x);

        s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
#endif

      case OP_ADD:             /* + */
        v = num_zero;

        for (x = args; x != NIL; x = cdr (x))
          v = num_op (NUM_ADD, v, nvalue (car (x)));

        s_return (mk_number (SCHEME_A_ v));

      case OP_MUL:             /* * */
        v = num_one;

        for (x = args; x != NIL; x = cdr (x))
          v = num_op (NUM_MUL, v, nvalue (car (x)));

        s_return (mk_number (SCHEME_A_ v));

      case OP_SUB:             /* - */
        if (cdr (args) == NIL)
          {
            x = args;
            v = num_zero;
          }
        else
          {
            x = cdr (args);
            v = nvalue (car (args));
          }

        for (; x != NIL; x = cdr (x))
          v = num_op (NUM_SUB, v, nvalue (car (x)));

        s_return (mk_number (SCHEME_A_ v));

      case OP_DIV:             /* / */
        if (cdr (args) == NIL)
          {
            x = args;
            v = num_one;
          }
        else
          {
            x = cdr (args);
            v = nvalue (car (args));
          }

        for (; x != NIL; x = cdr (x))
          if (!is_zero_rvalue (rvalue (car (x))))
            v = num_div (v, nvalue (car (x)));
          else
            Error_0 ("/: division by zero");

        s_return (mk_number (SCHEME_A_ v));

      case OP_INTDIV:          /* quotient */
        if (cdr (args) == NIL)
          {
            x = args;
            v = num_one;
          }
        else
          {
            x = cdr (args);
            v = nvalue (car (args));
          }

        for (; x != NIL; x = cdr (x))
          {
            if (ivalue (car (x)) != 0)
              v = num_op (NUM_INTDIV, v, nvalue (car (x)));
            else
              Error_0 ("quotient: division by zero");
          }

        s_return (mk_number (SCHEME_A_ v));

      case OP_REM:             /* remainder */
        v = nvalue (x);

        if (ivalue (cadr (args)) != 0)
          v = num_rem (v, nvalue (cadr (args)));
        else
          Error_0 ("remainder: division by zero");

        s_return (mk_number (SCHEME_A_ v));

      case OP_MOD:             /* modulo */
        v = nvalue (x);

        if (ivalue (cadr (args)) != 0)
          v = num_mod (v, nvalue (cadr (args)));
        else
          Error_0 ("modulo: division by zero");

        s_return (mk_number (SCHEME_A_ v));

      case OP_CAR:             /* car */
        s_return (caar (args));

      case OP_CDR:             /* cdr */
        s_return (cdar (args));

      case OP_CONS:            /* cons */
        set_cdr (args, cadr (args));
        s_return (args);

      case OP_SETCAR:          /* set-car! */
        if (!is_immutable (x))
          {
            set_car (x, cadr (args));
            s_return (car (args));
          }
        else
          Error_0 ("set-car!: unable to alter immutable pair");

      case OP_SETCDR:          /* set-cdr! */
        if (!is_immutable (x))
          {
            set_cdr (x, cadr (args));
            s_return (car (args));
          }
        else
          Error_0 ("set-cdr!: unable to alter immutable pair");

      case OP_CHAR2INT:        /* char->integer */
        s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));

      case OP_INT2CHAR:        /* integer->char */
        s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));

      case OP_CHARUPCASE:
        {
          unsigned char c = ivalue_unchecked (x);
          c = toupper (c);
          s_return (mk_character (SCHEME_A_ c));
        }

      case OP_CHARDNCASE:
        {
          unsigned char c = ivalue_unchecked (x);
          c = tolower (c);
          s_return (mk_character (SCHEME_A_ c));
        }

      case OP_STR2SYM:         /* string->symbol */
        s_return (mk_symbol (SCHEME_A_ strvalue (x)));

      case OP_STR2ATOM:        /* string->atom */
        {
          char *s = strvalue (x);
          long pf = 0;

          if (cdr (args) != NIL)
            {
              /* we know cadr(args) is a natural number */
              /* see if it is 2, 8, 10, or 16, or error */
              pf = ivalue_unchecked (cadr (args));

              if (pf == 16 || pf == 10 || pf == 8 || pf == 2)
                {
                  /* base is OK */
                }
              else
                pf = -1;
            }

          if (pf < 0)
            Error_1 ("string->atom: bad base:", cadr (args));
          else if (*s == '#')   /* no use of base! */
            s_return (mk_sharp_const (SCHEME_A_ s + 1));
          else
            {
              if (pf == 0 || pf == 10)
                s_return (mk_atom (SCHEME_A_ s));
              else
                {
                  char *ep;
                  long iv = strtol (s, &ep, (int) pf);

                  if (*ep == 0)
                    s_return (mk_integer (SCHEME_A_ iv));
                  else
                    s_return (S_F);
                }
            }
        }

      case OP_SYM2STR:         /* symbol->string */
        x = mk_string (SCHEME_A_ symname (x));
        setimmutable (x);
        s_return (x);

      case OP_ATOM2STR:        /* atom->string */
        {
          long pf = 0;

          if (cdr (args) != NIL)
            {
              /* we know cadr(args) is a natural number */
              /* see if it is 2, 8, 10, or 16, or error */
              pf = ivalue_unchecked (cadr (args));

              if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))
                {
                  /* base is OK */
                }
              else
                pf = -1;
            }

          if (pf < 0)
            Error_1 ("atom->string: bad base:", cadr (args));
          else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))
            {
              char *p;
              int len;

              atom2str (SCHEME_A_ x, pf, &p, &len);
              s_return (mk_counted_string (SCHEME_A_ p, len));
            }
          else
            Error_1 ("atom->string: not an atom:", x);
        }

      case OP_MKSTRING:        /* make-string */
        {
          int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
          int len = ivalue_unchecked (x);

          s_return (mk_empty_string (SCHEME_A_ len, fill));
        }

      case OP_STRLEN:          /* string-length */
        s_return (mk_integer (SCHEME_A_ strlength (x)));

      case OP_STRREF:          /* string-ref */
        {
          char *str = strvalue (x);
          int index = ivalue_unchecked (cadr (args));

          if (index >= strlength (x))
            Error_1 ("string-ref: out of bounds:", cadr (args));

          s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
        }

      case OP_STRSET:          /* string-set! */
        {
          char *str = strvalue (x);
          int index = ivalue_unchecked (cadr (args));
          int c;

          if (is_immutable (x))
            Error_1 ("string-set!: unable to alter immutable string:", x);

          if (index >= strlength (x))
            Error_1 ("string-set!: out of bounds:", cadr (args));

          c = charvalue (caddr (args));

          str[index] = c;
          s_return (car (args));
        }

      case OP_STRAPPEND:       /* string-append */
        {
          /* in 1.29 string-append was in Scheme in init.scm but was too slow */
          int len = 0;
          pointer newstr;
          char *pos;

          /* compute needed length for new string */
          for (x = args; x != NIL; x = cdr (x))
            len += strlength (car (x));

          newstr = mk_empty_string (SCHEME_A_ len, ' ');

          /* store the contents of the argument strings into the new string */
          for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x))
            memcpy (pos, strvalue (car (x)), strlength (car (x)));

          s_return (newstr);
        }

      case OP_SUBSTR:          /* substring */
        {
          char *str = strvalue (x);
          int index0 = ivalue_unchecked (cadr (args));
          int index1;
          int len;

          if (index0 > strlength (x))
            Error_1 ("substring: start out of bounds:", cadr (args));

          if (cddr (args) != NIL)
            {
              index1 = ivalue_unchecked (caddr (args));

              if (index1 > strlength (x) || index1 < index0)
                Error_1 ("substring: end out of bounds:", caddr (args));
            }
          else
            index1 = strlength (x);

          len = index1 - index0;
          x = mk_empty_string (SCHEME_A_ len, ' ');
          memcpy (strvalue (x), str + index0, len);
          strvalue (x)[len] = 0;

          s_return (x);
        }

      case OP_VECTOR:          /* vector */
        {
          int i;
          pointer vec;
          int len = list_length (SCHEME_A_ args);

          if (len < 0)
            Error_1 ("vector: not a proper list:", args);

          vec = mk_vector (SCHEME_A_ len);

#if USE_ERROR_CHECKING
          if (SCHEME_V->no_memory)
            s_return (S_SINK);
#endif

          for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
            vector_set (vec, i, car (x));

          s_return (vec);
        }

      case OP_MKVECTOR:        /* make-vector */
        {
          pointer fill = NIL;
          pointer vec;
          int len = ivalue_unchecked (x);

          if (cdr (args) != NIL)
            fill = cadr (args);

          vec = mk_vector (SCHEME_A_ len);

#if USE_ERROR_CHECKING
          if (SCHEME_V->no_memory)
            s_return (S_SINK);
#endif

          if (fill != NIL)
            fill_vector (vec, 0, fill);

          s_return (vec);
        }

      case OP_VECLEN:          /* vector-length */
        s_return (mk_integer (SCHEME_A_ veclength (x)));

      case OP_VECRESIZE:
        vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
        s_return (x);

      case OP_VECREF:          /* vector-ref */
        {
          int index = ivalue_unchecked (cadr (args));

          if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
            Error_1 ("vector-ref: out of bounds:", cadr (args));

          s_return (vector_get (x, index));
        }

      case OP_VECSET:          /* vector-set! */
        {
          int index = ivalue_unchecked (cadr (args));

          if (is_immutable (x))
            Error_1 ("vector-set!: unable to alter immutable vector:", x);

          if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
            Error_1 ("vector-set!: out of bounds:", cadr (args));

          vector_set (x, index, caddr (args));
          s_return (x);
        }
    }

  if (USE_ERROR_CHECKING) abort ();
}

static int
opexe_2 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer x = SCHEME_V->args;

  for (;;)
    {
      num v = nvalue (car (x));
      x = cdr (x);

      if (x == NIL)
        break;

      int r = num_cmp (v, nvalue (car (x)));

      switch (op)
        {
          case OP_NUMEQ: r = r == 0; break;
          case OP_LESS:  r = r <  0; break;
          case OP_GRE:   r = r >  0; break;
          case OP_LEQ:   r = r <= 0; break;
          case OP_GEQ:   r = r >= 0; break;
        }

      if (!r)
        s_return (S_F);
    }

  s_return (S_T);
}

static int
opexe_3 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer args = SCHEME_V->args;
  pointer a = car (args);
  pointer d = cdr (args);
  int r;

  switch (op)
    {
      case OP_NOT:             /* not */          r = is_false (a)        ; break;
      case OP_BOOLP:           /* boolean? */     r = a == S_F || a == S_T; break;
      case OP_EOFOBJP:         /* eof-object? */  r = a == S_EOF          ; break;
      case OP_NULLP:           /* null? */        r = a == NIL            ; break;
      case OP_SYMBOLP:         /* symbol? */      r = is_symbol (a)       ; break;
      case OP_NUMBERP:         /* number? */      r = is_number (a)       ; break;
      case OP_STRINGP:         /* string? */      r = is_string (a)       ; break;
      case OP_INTEGERP:        /* integer? */     r = is_integer (a)      ; break;
      case OP_REALP:           /* real? */        r = is_number (a)       ; break; /* all numbers are real */
      case OP_CHARP:           /* char? */        r = is_character (a)    ; break;

#if USE_CHAR_CLASSIFIERS
      case OP_CHARAP:          /* char-alphabetic? */  r = Cisalpha (ivalue_unchecked (a)); break;
      case OP_CHARNP:          /* char-numeric? */     r = Cisdigit (ivalue_unchecked (a)); break;
      case OP_CHARWP:          /* char-whitespace? */  r = Cisspace (ivalue_unchecked (a)); break;
      case OP_CHARUP:          /* char-upper-case? */  r = Cisupper (ivalue_unchecked (a)); break;
      case OP_CHARLP:          /* char-lower-case? */  r = Cislower (ivalue_unchecked (a)); break;
#endif

#if USE_PORTS
      case OP_PORTP:           /* port? */         r = is_port (a)   ; break;
      case OP_INPORTP:         /* input-port? */   r = is_inport (a) ; break;
      case OP_OUTPORTP:        /* output-port? */  r = is_outport (a); break;
#endif

      case OP_PROCP:           /* procedure? */

        /*--
         * continuation should be procedure by the example
         * (call-with-current-continuation procedure?) ==> #t
         * in R^3 report sec. 6.9
         */
        r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a);
        break;

      case OP_PAIRP:           /* pair? */         r = is_pair (a)                   ; break;
      case OP_LISTP:           /* list? */         r = list_length (SCHEME_A_ a) >= 0; break;
      case OP_ENVP:            /* environment? */  r = is_environment (a)            ; break;
      case OP_VECTORP:         /* vector? */       r = is_vector (a)                 ; break;
      case OP_EQ:              /* eq? */           r = a == cadr (args)              ; break;
      case OP_EQV:             /* eqv? */          r = eqv (a, cadr (args))          ; break;
    }

  s_retbool (r);
}

static int
opexe_4 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer args = SCHEME_V->args;
  pointer a = car (args);
  pointer x, y;

  switch (op)
    {
      case OP_FORCE:           /* force */
        SCHEME_V->code = a;

        if (is_promise (SCHEME_V->code))
          {
            /* Should change type to closure here */
            s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_APPLY);
          }
        else
          s_return (SCHEME_V->code);

      case OP_SAVE_FORCED:     /* Save forced value replacing promise */
        memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell));
        s_return (SCHEME_V->value);

#if USE_PORTS

      case OP_WRITE:           /* write */
      case OP_DISPLAY:         /* display */
      case OP_WRITE_CHAR:      /* write-char */
        if (is_pair (cdr (SCHEME_V->args)))
          {
            if (cadr (SCHEME_V->args) != SCHEME_V->outport)
              {
                x = cons (SCHEME_V->outport, NIL);
                s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
                SCHEME_V->outport = cadr (SCHEME_V->args);
              }
          }

        SCHEME_V->args = a;

        if (op == OP_WRITE)
          SCHEME_V->print_flag = 1;
        else
          SCHEME_V->print_flag = 0;

        s_goto (OP_P0LIST);

      case OP_NEWLINE:         /* newline */
        if (is_pair (args))
          {
            if (a != SCHEME_V->outport)
              {
                x = cons (SCHEME_V->outport, NIL);
                s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
                SCHEME_V->outport = a;
              }
          }

        putstr (SCHEME_A_ "\n");
        s_return (S_T);
#endif

      case OP_ERR0:            /* error */
        SCHEME_V->retcode = -1;

        if (!is_string (a))
          {
            args = cons (mk_string (SCHEME_A_ " -- "), args);
            setimmutable (car (args));
          }

        putstr (SCHEME_A_ "Error: ");
        putstr (SCHEME_A_ strvalue (car (args)));
        SCHEME_V->args = cdr (args);
        s_goto (OP_ERR1);

      case OP_ERR1:            /* error */
        putstr (SCHEME_A_ " ");

        if (args != NIL)
          {
            s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
            SCHEME_V->args = a;
            SCHEME_V->print_flag = 1;
            s_goto (OP_P0LIST);
          }
        else
          {
            putstr (SCHEME_A_ "\n");

            if (SCHEME_V->interactive_repl)
              s_goto (OP_T0LVL);
            else
              return -1;
          }

      case OP_REVERSE:         /* reverse */
        s_return (reverse (SCHEME_A_ a));

      case OP_LIST_STAR:       /* list* */
        s_return (list_star (SCHEME_A_ SCHEME_V->args));

      case OP_APPEND:          /* append */
        x = NIL;
        y = args;

        if (y == x)
          s_return (x);

        /* cdr() in the while condition is not a typo. If car() */
        /* is used (append '() 'a) will return the wrong result. */
        while (cdr (y) != NIL)
          {
            x = revappend (SCHEME_A_ x, car (y));
            y = cdr (y);

            if (x == S_F)
              Error_0 ("non-list argument to append");
          }

        s_return (reverse_in_place (SCHEME_A_ car (y), x));

#if USE_PLIST

      case OP_PUT:             /* put */
        if (!hasprop (a) || !hasprop (cadr (args)))
          Error_0 ("illegal use of put");

        for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
          {
            if (caar (x) == y)
              break;
          }

        if (x != NIL)
          cdar (x) = caddr (args);
        else
          symprop (a) = cons (cons (y, caddr (args)), symprop (a));

        s_return (S_T);

      case OP_GET:             /* get */
        if (!hasprop (a) || !hasprop (cadr (args)))
          Error_0 ("illegal use of get");

        for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
          if (caar (x) == y)
            break;

        if (x != NIL)
          s_return (cdar (x));
        else
          s_return (NIL);

#endif /* USE_PLIST */

      case OP_QUIT:            /* quit */
        if (is_pair (args))
          SCHEME_V->retcode = ivalue (a);

        return -1;

      case OP_GC:              /* gc */
        gc (SCHEME_A_ NIL, NIL);
        s_return (S_T);

      case OP_GCVERB:          /* gc-verbose */
        {
          int was = SCHEME_V->gc_verbose;

          SCHEME_V->gc_verbose = (a != S_F);
          s_retbool (was);
        }

      case OP_NEWSEGMENT:      /* new-segment */
        if (!is_pair (args) || !is_number (a))
          Error_0 ("new-segment: argument must be a number");

        alloc_cellseg (SCHEME_A_ ivalue (a));

        s_return (S_T);

      case OP_OBLIST:          /* oblist */
        s_return (oblist_all_symbols (SCHEME_A));

#if USE_PORTS

      case OP_CURR_INPORT:     /* current-input-port */
        s_return (SCHEME_V->inport);

      case OP_CURR_OUTPORT:    /* current-output-port */
        s_return (SCHEME_V->outport);

      case OP_OPEN_INFILE:     /* open-input-file */
      case OP_OPEN_OUTFILE:    /* open-output-file */
      case OP_OPEN_INOUTFILE:  /* open-input-output-file */
        {
          int prop = 0;
          pointer p;

          switch (op)
            {
              case OP_OPEN_INFILE:
                prop = port_input;
                break;

              case OP_OPEN_OUTFILE:
                prop = port_output;
                break;

              case OP_OPEN_INOUTFILE:
                prop = port_input | port_output;
                break;
            }

          p = port_from_filename (SCHEME_A_ strvalue (a), prop);

          s_return (p == NIL ? S_F : p);
        }

# if USE_STRING_PORTS

      case OP_OPEN_INSTRING:   /* open-input-string */
      case OP_OPEN_INOUTSTRING:        /* open-input-output-string */
        {
          int prop = 0;
          pointer p;

          switch (op)
            {
              case OP_OPEN_INSTRING:
                prop = port_input;
                break;

              case OP_OPEN_INOUTSTRING:
                prop = port_input | port_output;
                break;
            }

          p = port_from_string (SCHEME_A_ strvalue (a),
                                strvalue (a) + strlength (a), prop);

          s_return (p == NIL ? S_F : p);
        }

      case OP_OPEN_OUTSTRING:  /* open-output-string */
        {
          pointer p;

          if (a == NIL)
            p = port_from_scratch (SCHEME_A);
          else
            p = port_from_string (SCHEME_A_ strvalue (a),
                                  strvalue (a) + strlength (a), port_output);

          s_return (p == NIL ? S_F : p);
        }

      case OP_GET_OUTSTRING:   /* get-output-string */
        {
          port *p;

          if ((p = a->object.port)->kind & port_string)
            {
              off_t size;
              char *str;

              size = p->rep.string.curr - p->rep.string.start + 1;
              str = malloc (size);

              if (str != NULL)
                {
                  pointer s;

                  memcpy (str, p->rep.string.start, size - 1);
                  str[size - 1] = '\0';
                  s = mk_string (SCHEME_A_ str);
                  free (str);
                  s_return (s);
                }
            }

          s_return (S_F);
        }

# endif

      case OP_CLOSE_INPORT:    /* close-input-port */
        port_close (SCHEME_A_ a, port_input);
        s_return (S_T);

      case OP_CLOSE_OUTPORT:   /* close-output-port */
        port_close (SCHEME_A_ a, port_output);
        s_return (S_T);
#endif

      case OP_INT_ENV:         /* interaction-environment */
        s_return (SCHEME_V->global_env);

      case OP_CURR_ENV:        /* current-environment */
        s_return (SCHEME_V->envir);

    }

  if (USE_ERROR_CHECKING) abort ();
}

static int
opexe_5 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer args = SCHEME_V->args;
  pointer x;

  if (SCHEME_V->nesting != 0)
    {
      int n = SCHEME_V->nesting;

      SCHEME_V->nesting = 0;
      SCHEME_V->retcode = -1;
      Error_1 ("unmatched parentheses:", mk_integer (SCHEME_A_ n));
    }

  switch (op)
    {
        /* ========== reading part ========== */
#if USE_PORTS
      case OP_READ:
        if (!is_pair (args))
          s_goto (OP_READ_INTERNAL);

        if (!is_inport (car (args)))
          Error_1 ("read: not an input port:", car (args));

        if (car (args) == SCHEME_V->inport)
          s_goto (OP_READ_INTERNAL);

        x = SCHEME_V->inport;
        SCHEME_V->inport = car (args);
        x = cons (x, NIL);
        s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
        s_goto (OP_READ_INTERNAL);

      case OP_READ_CHAR:       /* read-char */
      case OP_PEEK_CHAR:       /* peek-char */
        {
          int c;

          if (is_pair (args))
            {
              if (car (args) != SCHEME_V->inport)
                {
                  x = SCHEME_V->inport;
                  x = cons (x, NIL);
                  s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
                  SCHEME_V->inport = car (args);
                }
            }

          c = inchar (SCHEME_A);

          if (c == EOF)
            s_return (S_EOF);

          if (SCHEME_V->op == OP_PEEK_CHAR)
            backchar (SCHEME_A_ c);

          s_return (mk_character (SCHEME_A_ c));
        }

      case OP_CHAR_READY:      /* char-ready? */
        {
          pointer p = SCHEME_V->inport;
          int res;

          if (is_pair (args))
            p = car (args);

          res = p->object.port->kind & port_string;

          s_retbool (res);
        }

      case OP_SET_INPORT:      /* set-input-port */
        SCHEME_V->inport = car (args);
        s_return (SCHEME_V->value);

      case OP_SET_OUTPORT:     /* set-output-port */
        SCHEME_V->outport = car (args);
        s_return (SCHEME_V->value);
#endif

      case OP_RDSEXPR:
        switch (SCHEME_V->tok)
          {
            case TOK_EOF:
              s_return (S_EOF);
              /* NOTREACHED */

            case TOK_VEC:
              s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
              /* fall through */

            case TOK_LPAREN:
              SCHEME_V->tok = token (SCHEME_A);

              if (SCHEME_V->tok == TOK_RPAREN)
                s_return (NIL);
              else if (SCHEME_V->tok == TOK_DOT)
                Error_0 ("syntax error: illegal dot expression");
              else
                {
                  SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
                  s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
                  s_goto (OP_RDSEXPR);
                }

            case TOK_QUOTE:
              s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
              SCHEME_V->tok = token (SCHEME_A);
              s_goto (OP_RDSEXPR);

            case TOK_BQUOTE:
              SCHEME_V->tok = token (SCHEME_A);

              if (SCHEME_V->tok == TOK_VEC)
                {
                  s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
                  SCHEME_V->tok = TOK_LPAREN;
                  s_goto (OP_RDSEXPR);
                }
              else
                s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);

              s_goto (OP_RDSEXPR);

            case TOK_COMMA:
              s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
              SCHEME_V->tok = token (SCHEME_A);
              s_goto (OP_RDSEXPR);

            case TOK_ATMARK:
              s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
              SCHEME_V->tok = token (SCHEME_A);
              s_goto (OP_RDSEXPR);

            case TOK_ATOM:
              s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));

            case TOK_DOTATOM:
              SCHEME_V->strbuff[0] = '.';
              s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));

            case TOK_STRATOM:
              x = readstrexp (SCHEME_A_ '|');
              //TODO: haven't checked whether the garbage collector could interfere
              s_return (mk_atom (SCHEME_A_ strvalue (x)));

            case TOK_DQUOTE:
              x = readstrexp (SCHEME_A_ '"');

              if (x == S_F)
                Error_0 ("Error reading string");

              setimmutable (x);
              s_return (x);

            case TOK_SHARP:
              {
                pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);

                if (f == NIL)
                  Error_0 ("undefined sharp expression");
                else
                  {
                    SCHEME_V->code = cons (slot_value_in_env (f), NIL);
                    s_goto (OP_EVAL);
                  }
              }

            case TOK_SHARP_CONST:
              if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
                Error_0 ("undefined sharp expression");
              else
                s_return (x);

            default:
              Error_0 ("syntax error: illegal token");
          }

        break;

      case OP_RDLIST:
        SCHEME_V->args = cons (SCHEME_V->value, args);
        SCHEME_V->tok = token (SCHEME_A);

        switch (SCHEME_V->tok)
          {
            case TOK_EOF:
              s_return (S_EOF);

            case TOK_RPAREN:
              {
                int c = inchar (SCHEME_A);

                if (c != '\n')
                  backchar (SCHEME_A_ c);
#if SHOW_ERROR_LINE
                else if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
                  SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line++;
#endif

                SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
                s_return (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args));
              }

            case TOK_DOT:
              s_save (SCHEME_A_ OP_RDDOT, SCHEME_V->args, NIL);
              SCHEME_V->tok = token (SCHEME_A);
              s_goto (OP_RDSEXPR);

            default:
              s_save (SCHEME_A_ OP_RDLIST, SCHEME_V->args, NIL);
              s_goto (OP_RDSEXPR);
          }

      case OP_RDDOT:
        if (token (SCHEME_A) != TOK_RPAREN)
          Error_0 ("syntax error: illegal dot expression");

        SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
        s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));

      case OP_RDQUOTE:
        s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));

      case OP_RDQQUOTE:
        s_return (cons (SCHEME_V->QQUOTE, cons (SCHEME_V->value, NIL)));

      case OP_RDQQUOTEVEC:
        s_return (cons (mk_symbol (SCHEME_A_ "apply"),
                        cons (mk_symbol (SCHEME_A_ "vector"),
                              cons (cons (SCHEME_V->QQUOTE, cons (SCHEME_V->value, NIL)), NIL))));

      case OP_RDUNQUOTE:
        s_return (cons (SCHEME_V->UNQUOTE, cons (SCHEME_V->value, NIL)));

      case OP_RDUQTSP:
        s_return (cons (SCHEME_V->UNQUOTESP, cons (SCHEME_V->value, NIL)));

      case OP_RDVEC:
        /*SCHEME_V->code=cons(mk_proc(SCHEME_A_ OP_VECTOR),SCHEME_V->value);
           s_goto(OP_EVAL); Cannot be quoted */
        /*x=cons(mk_proc(SCHEME_A_ OP_VECTOR),SCHEME_V->value);
           s_return(x); Cannot be part of pairs */
        /*SCHEME_V->code=mk_proc(SCHEME_A_ OP_VECTOR);
           SCHEME_V->args=SCHEME_V->value;
           s_goto(OP_APPLY); */
        SCHEME_V->args = SCHEME_V->value;
        s_goto (OP_VECTOR);

        /* ========== printing part ========== */
      case OP_P0LIST:
        if (is_vector (args))
          {
            putstr (SCHEME_A_ "#(");
            SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
            s_goto (OP_PVECFROM);
          }
        else if (is_environment (args))
          {
            putstr (SCHEME_A_ "#<ENVIRONMENT>");
            s_return (S_T);
          }
        else if (!is_pair (args))
          {
            printatom (SCHEME_A_ args, SCHEME_V->print_flag);
            s_return (S_T);
          }
        else
          {
            pointer a = car (args);
            pointer b = cdr (args);
            int ok_abbr = ok_abbrev (b);
            SCHEME_V->args = car (b);

            if (a == SCHEME_V->QUOTE && ok_abbr)
              putstr (SCHEME_A_ "'");
            else if (a == SCHEME_V->QQUOTE && ok_abbr)
              putstr (SCHEME_A_ "`");
            else if (a == SCHEME_V->UNQUOTE && ok_abbr)
              putstr (SCHEME_A_ ",");
            else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
              putstr (SCHEME_A_ ",@");
            else
              {
                putstr (SCHEME_A_ "(");
                s_save (SCHEME_A_ OP_P1LIST, b, NIL);
                SCHEME_V->args = a;
              }

            s_goto (OP_P0LIST);
          }

      case OP_P1LIST:
        if (is_pair (args))
          {
            s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
            putstr (SCHEME_A_ " ");
            SCHEME_V->args = car (args);
            s_goto (OP_P0LIST);
          }
        else if (is_vector (args))
          {
            s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
            putstr (SCHEME_A_ " . ");
            s_goto (OP_P0LIST);
          }
        else
          {
            if (args != NIL)
              {
                putstr (SCHEME_A_ " . ");
                printatom (SCHEME_A_ args, SCHEME_V->print_flag);
              }

            putstr (SCHEME_A_ ")");
            s_return (S_T);
          }

      case OP_PVECFROM:
        {
          int i = ivalue_unchecked (cdr (args));
          pointer vec = car (args);
          int len = veclength (vec);

          if (i == len)
            {
              putstr (SCHEME_A_ ")");
              s_return (S_T);
            }
          else
            {
              pointer elem = vector_get (vec, i);

              ivalue_unchecked (cdr (args)) = i + 1;
              s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
              SCHEME_V->args = elem;

              if (i > 0)
                putstr (SCHEME_A_ " ");

              s_goto (OP_P0LIST);
            }
        }
    }

  if (USE_ERROR_CHECKING) abort ();
}

static int
opexe_6 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer args = SCHEME_V->args;
  pointer a = car (args);
  pointer x, y;

  switch (op)
    {
      case OP_LIST_LENGTH:     /* length *//* a.k */
        {
          long v = list_length (SCHEME_A_ a);

          if (v < 0)
            Error_1 ("length: not a list:", a);

          s_return (mk_integer (SCHEME_A_ v));
        }

      case OP_ASSQ:            /* assq *//* a.k */
        x = a;

        for (y = cadr (args); is_pair (y); y = cdr (y))
          {
            if (!is_pair (car (y)))
              Error_0 ("unable to handle non pair element");

            if (x == caar (y))
              break;
          }

        if (is_pair (y))
          s_return (car (y));
        else
          s_return (S_F);


      case OP_GET_CLOSURE:     /* get-closure-code *//* a.k */
        SCHEME_V->args = a;

        if (SCHEME_V->args == NIL)
          s_return (S_F);
        else if (is_closure (SCHEME_V->args))
          s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
        else if (is_macro (SCHEME_V->args))
          s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
        else
          s_return (S_F);

      case OP_CLOSUREP:        /* closure? */
        /*
         * Note, macro object is also a closure.
         * Therefore, (closure? <#MACRO>) ==> #t
         */
        s_retbool (is_closure (a));

      case OP_MACROP:          /* macro? */
        s_retbool (is_macro (a));
    }

  if (USE_ERROR_CHECKING) abort ();
}

/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);

typedef int (*test_predicate)(pointer);
static int
tst_any (pointer p)
{
  return 1;
}

static int
tst_inonneg (pointer p)
{
  return is_integer (p) && ivalue_unchecked (p) >= 0;
}

static int
tst_is_list (SCHEME_P_ pointer p)
{
  return p == NIL || is_pair (p);
}

/* Correspond carefully with following defines! */
static struct
{
  test_predicate fct;
  const char *kind;
} tests[] = {
  { tst_any       , 0                      },
  { is_string     , "string"               },
  { is_symbol     , "symbol"               },
  { is_port       , "port"                 },
  { is_inport     , "input port"           },
  { is_outport    , "output port"          },
  { is_environment, "environment"          },
  { is_pair       , "pair"                 },
  { 0             , "pair or '()"          },
  { is_character  , "character"            },
  { is_vector     , "vector"               },
  { is_number     , "number"               },
  { is_integer    , "integer"              },
  { tst_inonneg   , "non-negative integer" }
};

#define TST_NONE        0 /* TST_NONE used for built-ins, 0 for internal ops */
#define TST_ANY         "\001"
#define TST_STRING      "\002"
#define TST_SYMBOL      "\003"
#define TST_PORT        "\004"
#define TST_INPORT      "\005"
#define TST_OUTPORT     "\006"
#define TST_ENVIRONMENT "\007"
#define TST_PAIR        "\010"
#define TST_LIST        "\011"
#define TST_CHAR        "\012"
#define TST_VECTOR      "\013"
#define TST_NUMBER      "\014"
#define TST_INTEGER     "\015"
#define TST_NATURAL     "\016"

#define INF_ARG 0xff
#define UNNAMED_OP ""

static const char opnames[] =
#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
#include "opdefines.h"
#undef OP_DEF
;

static const char *
opname (int idx)
{
  const char *name = opnames;

  /* should do this at compile time, but would require external program, right? */
  while (idx--)
    name += strlen (name) + 1;

  return *name ? name : "ILLEGAL";
}

static const char *
procname (pointer x)
{
  return opname (procnum (x));
}

typedef struct
{
  uint8_t func;
  /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
  uint8_t builtin;
#if USE_ERROR_CHECKING
  uint8_t min_arity;
  uint8_t max_arity;
  char arg_tests_encoding[3];
#endif
} op_code_info;

static const op_code_info dispatch_table[] = {
#if USE_ERROR_CHECKING
#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
#else
#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
#endif
#include "opdefines.h"
#undef OP_DEF
  {0}
};

/* kernel of this interpreter */
static void ecb_hot
Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
{
  SCHEME_V->op = op;

  for (;;)
    {
      const op_code_info *pcd = dispatch_table + SCHEME_V->op;

#if USE_ERROR_CHECKING
      if (pcd->builtin)       /* if built-in function, check arguments */
        {
          char msg[STRBUFFSIZE];
          int n = list_length (SCHEME_A_ SCHEME_V->args);

          /* Check number of arguments */
          if (ecb_expect_false (n < pcd->min_arity))
            {
              snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
                        opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
              xError_1 (SCHEME_A_ msg, 0);
              continue;
            }
          else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
            {
              snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
                        opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
              xError_1 (SCHEME_A_ msg, 0);
              continue;
            }
          else
            {
              if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
                {
                  int i = 0;
                  int j;
                  const char *t = pcd->arg_tests_encoding;
                  pointer arglist = SCHEME_V->args;

                  do
                    {
                      pointer arg = car (arglist);

                      j = t[0];

                      /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
                      if (j == TST_LIST[0])
                        {
                          if (!tst_is_list (SCHEME_A_ arg))
                            break;
                        }
                      else
                        {
                          if (!tests[j - 1].fct (arg))
                            break;
                        }

                      if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1])    /* last test is replicated as necessary */
                        t++;

                      arglist = cdr (arglist);
                      i++;
                    }
                  while (i < n);

                  if (i < n)
                    {
                      snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
                      xError_1 (SCHEME_A_ msg, 0);
                      continue;
                    }
                }
            }
        }
#endif

      ok_to_freely_gc (SCHEME_A);

      static const dispatch_func dispatch_funcs[] = {
        opexe_0,
        opexe_1,
        opexe_2,
        opexe_3,
        opexe_4,
        opexe_5,
        opexe_6,
      };

      if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
        return;

      if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
        {
          xwrstr ("No memory!\n");
          return;
        }
    }
}

/* ========== Initialization of internal keywords ========== */

static void
assign_syntax (SCHEME_P_ const char *name)
{
  pointer x = oblist_add_by_name (SCHEME_A_ name);
  set_typeflag (x, typeflag (x) | T_SYNTAX);
}

static void
assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
{
  pointer x = mk_symbol (SCHEME_A_ name);
  pointer y = mk_proc (SCHEME_A_ op);
  new_slot_in_env (SCHEME_A_ x, y);
}

static pointer
mk_proc (SCHEME_P_ enum scheme_opcodes op)
{
  pointer y = get_cell (SCHEME_A_ NIL, NIL);
  set_typeflag (y, (T_PROC | T_ATOM));
  ivalue_unchecked (y) = op;
  return y;
}

/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
static int
syntaxnum (pointer p)
{
  const char *s = strvalue (car (p));

  switch (strlength (car (p)))
    {
      case 2:
        if (s[0] == 'i')
          return OP_IF0;        /* if */
        else
          return OP_OR0;        /* or */

      case 3:
        if (s[0] == 'a')
          return OP_AND0;       /* and */
        else
          return OP_LET0;       /* let */

      case 4:
        switch (s[3])
          {
            case 'e':
              return OP_CASE0;  /* case */

            case 'd':
              return OP_COND0;  /* cond */

            case '*':
              return OP_LET0AST;/* let* */

            default:
              return OP_SET0;   /* set! */
          }

      case 5:
        switch (s[2])
          {
            case 'g':
              return OP_BEGIN;  /* begin */

            case 'l':
              return OP_DELAY;  /* delay */

            case 'c':
              return OP_MACRO0; /* macro */

            default:
              return OP_QUOTE;  /* quote */
          }

      case 6:
        switch (s[2])
          {
            case 'm':
              return OP_LAMBDA; /* lambda */

            case 'f':
              return OP_DEF0;   /* define */

            default:
              return OP_LET0REC;/* letrec */
          }

      default:
        return OP_C0STREAM;     /* cons-stream */
    }
}

#if USE_MULTIPLICITY
ecb_cold scheme *
scheme_init_new ()
{
  scheme *sc = malloc (sizeof (scheme));

  if (!scheme_init (SCHEME_A))
    {
      free (SCHEME_A);
      return 0;
    }
  else
    return sc;
}
#endif

ecb_cold int
scheme_init (SCHEME_P)
{
  int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
  pointer x;

  num_set_fixnum (num_zero, 1);
  num_set_ivalue (num_zero, 0);
  num_set_fixnum (num_one, 1);
  num_set_ivalue (num_one, 1);

#if USE_INTERFACE
  SCHEME_V->vptr = &vtbl;
#endif
  SCHEME_V->gensym_cnt = 0;
  SCHEME_V->last_cell_seg = -1;
  SCHEME_V->free_cell = NIL;
  SCHEME_V->fcells = 0;
  SCHEME_V->no_memory = 0;
  SCHEME_V->inport = NIL;
  SCHEME_V->outport = NIL;
  SCHEME_V->save_inport = NIL;
  SCHEME_V->loadport = NIL;
  SCHEME_V->nesting = 0;
  SCHEME_V->interactive_repl = 0;

  if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS)
    {
#if USE_ERROR_CHECKING
      SCHEME_V->no_memory = 1;
      return 0;
#endif
    }

  SCHEME_V->gc_verbose = 0;
  dump_stack_initialize (SCHEME_A);
  SCHEME_V->code = NIL;
  SCHEME_V->args = NIL;
  SCHEME_V->envir = NIL;
  SCHEME_V->tracing = 0;

  /* init NIL */
  set_typeflag (NIL, T_ATOM | T_MARK);
  set_car (NIL, NIL);
  set_cdr (NIL, NIL);
  /* init T */
  set_typeflag (S_T, T_ATOM | T_MARK);
  set_car (S_T, S_T);
  set_cdr (S_T, S_T);
  /* init F */
  set_typeflag (S_F, T_ATOM | T_MARK);
  set_car (S_F, S_F);
  set_cdr (S_F, S_F);
  /* init EOF_OBJ */
  set_typeflag (S_EOF, T_ATOM | T_MARK);
  set_car (S_EOF, S_EOF);
  set_cdr (S_EOF, S_EOF);
  /* init sink */
  set_typeflag (S_SINK, T_PAIR | T_MARK);
  set_car (S_SINK, NIL);

  /* init c_nest */
  SCHEME_V->c_nest = NIL;

  SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
  /* init global_env */
  new_frame_in_env (SCHEME_A_ NIL);
  SCHEME_V->global_env = SCHEME_V->envir;
  /* init else */
  x = mk_symbol (SCHEME_A_ "else");
  new_slot_in_env (SCHEME_A_ x, S_T);

  {
    static const char *syntax_names[] = {
      "lambda", "quote", "define", "if", "begin", "set!",
      "let", "let*", "letrec", "cond", "delay", "and",
      "or", "cons-stream", "macro", "case"
    };

    for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
      assign_syntax (SCHEME_A_ syntax_names[i]);
  }

  // TODO: should iterate via strlen, to avoid n² complexity
  for (i = 0; i < n; i++)
    if (dispatch_table[i].builtin)
      assign_proc (SCHEME_A_ i, opname (i));

  /* initialization of global pointers to special symbols */
  SCHEME_V->LAMBDA       = mk_symbol (SCHEME_A_ "lambda");
  SCHEME_V->QUOTE        = mk_symbol (SCHEME_A_ "quote");
  SCHEME_V->QQUOTE       = mk_symbol (SCHEME_A_ "quasiquote");
  SCHEME_V->UNQUOTE      = mk_symbol (SCHEME_A_ "unquote");
  SCHEME_V->UNQUOTESP    = mk_symbol (SCHEME_A_ "unquote-splicing");
  SCHEME_V->FEED_TO      = mk_symbol (SCHEME_A_ "=>");
  SCHEME_V->COLON_HOOK   = mk_symbol (SCHEME_A_ "*colon-hook*");
  SCHEME_V->ERROR_HOOK   = mk_symbol (SCHEME_A_ "*error-hook*");
  SCHEME_V->SHARP_HOOK   = mk_symbol (SCHEME_A_ "*sharp-hook*");
  SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");

  return !SCHEME_V->no_memory;
}

#if USE_PORTS
void
scheme_set_input_port_file (SCHEME_P_ int fin)
{
  SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
}

void
scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
{
  SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
}

void
scheme_set_output_port_file (SCHEME_P_ int fout)
{
  SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
}

void
scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
{
  SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
}
#endif

void
scheme_set_external_data (SCHEME_P_ void *p)
{
  SCHEME_V->ext_data = p;
}

ecb_cold void
scheme_deinit (SCHEME_P)
{
  int i;

#if SHOW_ERROR_LINE
  char *fname;
#endif

  SCHEME_V->oblist = NIL;
  SCHEME_V->global_env = NIL;
  dump_stack_free (SCHEME_A);
  SCHEME_V->envir = NIL;
  SCHEME_V->code = NIL;
  SCHEME_V->args = NIL;
  SCHEME_V->value = NIL;

  if (is_port (SCHEME_V->inport))
    set_typeflag (SCHEME_V->inport, T_ATOM);

  SCHEME_V->inport = NIL;
  SCHEME_V->outport = NIL;

  if (is_port (SCHEME_V->save_inport))
    set_typeflag (SCHEME_V->save_inport, T_ATOM);

  SCHEME_V->save_inport = NIL;

  if (is_port (SCHEME_V->loadport))
    set_typeflag (SCHEME_V->loadport, T_ATOM);

  SCHEME_V->loadport = NIL;
  SCHEME_V->gc_verbose = 0;
  gc (SCHEME_A_ NIL, NIL);

  for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
    free (SCHEME_V->alloc_seg[i]);

#if SHOW_ERROR_LINE
  for (i = 0; i <= SCHEME_V->file_i; i++)
    {
      if (SCHEME_V->load_stack[i].kind & port_file)
        {
          fname = SCHEME_V->load_stack[i].rep.stdio.filename;

          if (fname)
            free (fname);
        }
    }
#endif
}

void
scheme_load_file (SCHEME_P_ int fin)
{
  scheme_load_named_file (SCHEME_A_ fin, 0);
}

void
scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
{
  dump_stack_reset (SCHEME_A);
  SCHEME_V->envir = SCHEME_V->global_env;
  SCHEME_V->file_i = 0;
  SCHEME_V->load_stack[0].unget = -1;
  SCHEME_V->load_stack[0].kind = port_input | port_file;
  SCHEME_V->load_stack[0].rep.stdio.file = fin;
#if USE_PORTS
  SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
#endif
  SCHEME_V->retcode = 0;

#if USE_PORTS
  if (fin == STDIN_FILENO)
    SCHEME_V->interactive_repl = 1;
#endif

#if USE_PORTS
#if SHOW_ERROR_LINE
  SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;

  if (fin != STDIN_FILENO && filename)
    SCHEME_V->load_stack[0].rep.stdio.filename = store_string (SCHEME_A_ strlen (filename), filename, 0);
#endif
#endif

  SCHEME_V->inport = SCHEME_V->loadport;
  SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
  Eval_Cycle (SCHEME_A_ OP_T0LVL);
  set_typeflag (SCHEME_V->loadport, T_ATOM);

  if (SCHEME_V->retcode == 0)
    SCHEME_V->retcode = SCHEME_V->nesting != 0;
}

void
scheme_load_string (SCHEME_P_ const char *cmd)
{
  dump_stack_reset (SCHEME_A);
  SCHEME_V->envir = SCHEME_V->global_env;
  SCHEME_V->file_i = 0;
  SCHEME_V->load_stack[0].kind = port_input | port_string;
  SCHEME_V->load_stack[0].rep.string.start = (char *)cmd;      /* This func respects const */
  SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
  SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
#if USE_PORTS
  SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
#endif
  SCHEME_V->retcode = 0;
  SCHEME_V->interactive_repl = 0;
  SCHEME_V->inport = SCHEME_V->loadport;
  SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
  Eval_Cycle (SCHEME_A_ OP_T0LVL);
  set_typeflag (SCHEME_V->loadport, T_ATOM);

  if (SCHEME_V->retcode == 0)
    SCHEME_V->retcode = SCHEME_V->nesting != 0;
}

void
scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
{
  pointer x;

  x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);

  if (x != NIL)
    set_slot_in_env (SCHEME_A_ x, value);
  else
    new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
}

#if !STANDALONE

void
scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
{
  scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
}

void
scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
{
  int i;

  for (i = 0; i < count; i++)
    scheme_register_foreign_func (SCHEME_A_ list + i);
}

pointer
scheme_apply0 (SCHEME_P_ const char *procname)
{
  return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
}

void
save_from_C_call (SCHEME_P)
{
  pointer saved_data = cons (car (S_SINK),
                             cons (SCHEME_V->envir,
                                   SCHEME_V->dump));

  /* Push */
  SCHEME_V->c_nest = cons (saved_data, SCHEME_V->c_nest);
  /* Truncate the dump stack so TS will return here when done, not
     directly resume pre-C-call operations. */
  dump_stack_reset (SCHEME_A);
}

void
restore_from_C_call (SCHEME_P)
{
  set_car (S_SINK, caar (SCHEME_V->c_nest));
  SCHEME_V->envir = cadar (SCHEME_V->c_nest);
  SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
  /* Pop */
  SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
}

/* "func" and "args" are assumed to be already eval'ed. */
pointer
scheme_call (SCHEME_P_ pointer func, pointer args)
{
  int old_repl = SCHEME_V->interactive_repl;

  SCHEME_V->interactive_repl = 0;
  save_from_C_call (SCHEME_A);
  SCHEME_V->envir = SCHEME_V->global_env;
  SCHEME_V->args = args;
  SCHEME_V->code = func;
  SCHEME_V->retcode = 0;
  Eval_Cycle (SCHEME_A_ OP_APPLY);
  SCHEME_V->interactive_repl = old_repl;
  restore_from_C_call (SCHEME_A);
  return SCHEME_V->value;
}

pointer
scheme_eval (SCHEME_P_ pointer obj)
{
  int old_repl = SCHEME_V->interactive_repl;

  SCHEME_V->interactive_repl = 0;
  save_from_C_call (SCHEME_A);
  SCHEME_V->args = NIL;
  SCHEME_V->code = obj;
  SCHEME_V->retcode = 0;
  Eval_Cycle (SCHEME_A_ OP_EVAL);
  SCHEME_V->interactive_repl = old_repl;
  restore_from_C_call (SCHEME_A);
  return SCHEME_V->value;
}

#endif

/* ========== Main ========== */

#if STANDALONE

int
main (int argc, char **argv)
{
# if USE_MULTIPLICITY
  scheme ssc;
  scheme *const SCHEME_V = &ssc;
# else
# endif
  int fin;
  char *file_name = InitFile;
  int retcode;
  int isfile = 1;

  if (argc == 2 && strcmp (argv[1], "-?") == 0)
    {
      xwrstr ("Usage: tinyscheme -?\n");
      xwrstr ("or:    tinyscheme [<file1> <file2> ...]\n");
      xwrstr ("followed by\n");
      xwrstr ("          -1 <file> [<arg1> <arg2> ...]\n");
      xwrstr ("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
      xwrstr ("assuming that the executable is named tinyscheme.\n");
      xwrstr ("Use - as filename for stdin.\n");
      return 1;
    }

  if (!scheme_init (SCHEME_A))
    {
      xwrstr ("Could not initialize!\n");
      return 2;
    }

# if USE_PORTS
  scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
  scheme_set_output_port_file (SCHEME_A_ STDOUT_FILENO);
# endif

  argv++;

#if 0
  if (access (file_name, 0) != 0)
    {
      char *p = getenv ("TINYSCHEMEINIT");

      if (p != 0)
        file_name = p;
    }
#endif

  do
    {
#if USE_PORTS
      if (strcmp (file_name, "-") == 0)
        fin = STDIN_FILENO;
      else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
        {
          pointer args = NIL;

          isfile = file_name[1] == '1';
          file_name = *argv++;

          if (strcmp (file_name, "-") == 0)
            fin = STDIN_FILENO;
          else if (isfile)
            fin = open (file_name, O_RDONLY);

          for (; *argv; argv++)
            {
              pointer value = mk_string (SCHEME_A_ * argv);

              args = cons (value, args);
            }

          args = reverse_in_place (SCHEME_A_ NIL, args);
          scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);

        }
      else
        fin = open (file_name, O_RDONLY);
#endif

      if (isfile && fin < 0)
        {
          xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n");
        }
      else
        {
          if (isfile)
            scheme_load_named_file (SCHEME_A_ fin, file_name);
          else
            scheme_load_string (SCHEME_A_ file_name);

#if USE_PORTS
          if (!isfile || fin != STDIN_FILENO)
            {
              if (SCHEME_V->retcode != 0)
                {
                  xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n");
                }

              if (isfile)
                close (fin);
            }
#endif
        }

      file_name = *argv++;
    }
  while (file_name != 0);

  if (argc == 1)
    scheme_load_named_file (SCHEME_A_ STDIN_FILENO, 0);

  retcode = SCHEME_V->retcode;
  scheme_deinit (SCHEME_A);

  return retcode;
}

#endif

/*
Local variables:
c-file-style: "k&r"
End:
*/
Revision:	1.37
Committed:	Sun Nov 29 05:09:24 2015 UTC (8 years, 6 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.36:	+13 -0 lines
Log Message:	* empty log message *