cvsroot/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 EXPERIMENT 1

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

#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 WHITESPACE " \t\r\n\v\f"
#define DELIMITERS  "()\";" WHITESPACE

#define NIL    POINTER (&SCHEME_V->xNIL)
#define S_T    POINTER (&SCHEME_V->xT)
#define S_F    POINTER (&SCHEME_V->xF)
#define S_SINK POINTER (&SCHEME_V->xsink)
#define S_EOF  POINTER (&SCHEME_V->xEOF_OBJ)

#if !USE_MULTIPLICITY
static scheme sc;
#endif

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

  char *p = s;

  do {
    *p++ = "0123456789abcdef"[n % base];
    n /= base;
  } while (n);

  *p-- = 0;

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

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

ecb_cold static void
putnum (SCHEME_P_ long n)
{
  char buf[64];

  xnum (buf, n);
  putstr (SCHEME_A_ buf);
}

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

  return c;
}

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

  return c;
}

ecb_cold 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
ecb_cold 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

enum scheme_types
{
  T_INTEGER,
  T_CHARACTER,
  T_REAL,
  T_STRING,
  T_SYMBOL,
  T_PROC,
  T_PAIR, /* also used for free cells */
  T_CLOSURE,
  T_MACRO,
  T_CONTINUATION,
  T_FOREIGN,
  T_PORT,
  T_VECTOR,
  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);

static int is_zero_rvalue (RVALUE x);

static num num_zero;
static num num_one;

/* convert "pointer" to cell* / cell* to pointer */
#define CELL(p) ((struct cell *)(p) + 0)
#define POINTER(c) ((void *)((c) - 0))

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

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

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

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

#define vecvalue(p)     (CELL(p)->object.vector.vvalue)
#define veclength(p)    (CELL(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) CELL(p)->object.ivalue
#define set_ivalue(p,v)     CELL(p)->object.ivalue = (v)

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

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

#define port(p)             CELL(p)->object.port
#define set_port(p,v)       port(p) = (v)
INTERFACE int
is_port (pointer p)
{
  return type (p) == T_PORT;
}

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

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

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

#define car(p)           (POINTER (CELL(p)->object.cons.car))
#define cdr(p)           (POINTER (CELL(p)->object.cons.cdr))

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)
{
  CELL(p)->object.cons.car = CELL (q);
}

INTERFACE void
set_cdr (pointer p, pointer q)
{
  CELL(p)->object.cons.cdr = CELL (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 (p);
}

#if USE_PLIST
#error plists are broken because symbols are no longer pairs
#define symprop(p)       cdr(p)
SCHEME_EXPORT int
hasprop (pointer p)
{
  return typeflag (p) & T_SYMBOL;
}
#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 (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
*/
ecb_hot 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"
};

ecb_cold 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);
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;
}

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 */
ecb_cold static int
alloc_cellseg (SCHEME_P)
{
  struct cell *newp;
  struct cell *last;
  struct cell *p;
  char *cp;
  long i;
  int k;

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

  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 = (struct cell *)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++)
    {
      pointer cp = POINTER (p);
      set_typeflag (cp, T_PAIR);
      set_car (cp, NIL);
      set_cdr (cp, POINTER (p + 1));
    }

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

  return 1;
}

/* 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->cell_segsize [SCHEME_V->last_cell_seg] >> 1;

          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) && 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 */
ecb_hot 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);
}

ecb_hot 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_ NIL, NIL);
  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);

  CELL(v)->object.vector.vvalue = e;
  CELL(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)
    putstr (SCHEME_A_ "Cell is already allocated!\n");

  if (!(typeflag (p)) & expect_alloced)
    putstr (SCHEME_A_ "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 */
ecb_hot 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;
}

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

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

#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;
}

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

/* returns the new symbol */
ecb_cold 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_cold static 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;
}

ecb_cold 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

ecb_cold static pointer
oblist_initial_value (SCHEME_P)
{
  return NIL;
}

ecb_cold static 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 */
ecb_cold static pointer
oblist_add_by_name (SCHEME_P_ const char *name)
{
  pointer x = generate_symbol (SCHEME_A_ name);
  SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
  return x;
}

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

#endif

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

  set_typeflag (x, T_PORT | T_ATOM);
  set_port (x, p);

  return x;
}
#endif

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

  set_typeflag (x, T_FOREIGN | T_ATOM);
  CELL(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 p = 0;
  pointer *pp = &p;

#if USE_INTCACHE
  if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
    pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
#endif

  if (!*pp)
    {
      pointer x = get_cell (SCHEME_A_ NIL, NIL);

      set_typeflag (x, T_INTEGER | T_ATOM);
      setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
      set_ivalue (x, n);

      *pp = x;
    }

  return *pp;
}

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;
}

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

  return generate_symbol (SCHEME_A_ name);
}

static int
is_gensym (SCHEME_P_ pointer x)
{
  return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
}

/* make symbol or number atom from string */
ecb_cold 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 */
ecb_cold 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;

      // TODO: optimise
      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 (stricmp (name + 1, "alarm") == 0)
        c = 0x07;
      else if (stricmp (name + 1, "backspace") == 0)
        c = 0x08;
      else if (stricmp (name + 1, "escape") == 0)
        c = 0x1b;
      else if (stricmp (name + 1, "delete") == 0)
        c = 0x7f;
      else if (stricmp (name + 1, "null") == 0)
        c = 0;
      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 ========== */

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

      free (port (a));
    }
#endif
}

/*--
 *  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
 */
ecb_hot 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;
    }
}

ecb_hot static void
gc_free (SCHEME_P)
{
  int i;
  uint32_t total = 0;

  /* Here we scan the cells to build the free-list. */
  for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
    {
      struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
      struct cell *p;
      total += SCHEME_V->cell_segsize [i];

      for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
        {
          pointer c = POINTER (p);

          if (is_mark (c))
            clrmark (c);
          else
            {
              /* reclaim cell */
              if (typeflag (c) != T_PAIR)
                {
                  finalize_cell (SCHEME_A_ c);
                  set_typeflag (c, T_PAIR);
                  set_car (c, NIL);
                }

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

  if (SCHEME_V->gc_verbose)
    {
      putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
    }
}

/* garbage collection. parameter a, b is marked. */
ecb_cold static void
gc (SCHEME_P_ pointer a, pointer b)
{
  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);

#if USE_INTCACHE
  /* mark intcache */
  for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
    if (SCHEME_V->intcache[i - INTCACHE_MIN])
      mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
#endif

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

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

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

  gc_free (SCHEME_A);
}

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

ecb_cold 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;
      set_port (SCHEME_V->loadport, 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
}

ecb_cold 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--;
      set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
    }
}

ecb_cold 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
      && (port (SCHEME_V->inport)->kind & port_file);
#else
  return 0;
#endif
}

#if USE_PORTS
ecb_cold 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;
}

ecb_cold 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);
}

ecb_cold 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;
}

ecb_cold 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);
}

ecb_cold 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;
}

ecb_cold 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

ecb_cold 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;
}

ecb_cold 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);
}

ecb_cold static void
port_close (SCHEME_P_ pointer p, int flag)
{
  port *pt = port (p);

  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 = port (SCHEME_V->inport);

  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 = port (SCHEME_V->inport);
  pt->unget = c;
#else
  if (c == EOF)
    return;

  ungot = c;
#endif
}

#if USE_PORTS
ecb_cold 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

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

  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
  write (pt->rep.stdio.file, s, strlen (s));
#endif
}

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

  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
}

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

  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 */
ecb_cold 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" */
ecb_cold 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 'a': *p++ = '\a'; state = st_ok; break;
                case 'n': *p++ = '\n'; state = st_ok; break;
                case 'r': *p++ = '\r'; state = st_ok; break;
                case 't': *p++ = '\t'; state = st_ok; break;

                //TODO: \whitespace eol whitespace

                //TODO: x should end in ;, not two-digit hex
                case 'x':
                case 'X':
                  state = st_x1;
                  c1 = 0;
                  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_cold int
is_one_of (const char *s, int c)
{
  return c == EOF || !!strchr (s, c);
}

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

  do
    {
      c = inchar (SCHEME_A);

#if SHOW_ERROR_LINE
      if (ecb_expect_false (c == '\n'))
        curr_line++;
#endif

      if (ecb_expect_false (c == EOF))
        return c;
    }
  while (is_one_of (WHITESPACE, c));

  /* 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

  backchar (SCHEME_A_ c);
  return 1;
}

/* get token */
ecb_cold 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 (WHITESPACE, 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)

ecb_cold 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 */
ecb_cold 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 */
ecb_cold 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
    {
#if USE_PRINTF
      p = SCHEME_V->strbuff;
      snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
#else
      p = "#<ERROR>";
#endif
    }

  *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 (cddr (p) != NIL)
    {
      d = cons (car (p), cdr (p));

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

  set_cdr (p, cadr (p));
  return q;
}

/* reverse list -- produce new list */
ecb_hot 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 */
ecb_hot 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) */
ecb_hot 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 */
ecb_hot 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)));
}

ecb_hot 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 */

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

static 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)));
}

ecb_hot 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 */

static void
new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
{
  assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
  new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
}

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

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

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

ecb_cold 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

ecb_hot 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 (ecb_expect_false (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 ecb_hot 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_cold 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_cold void
dump_stack_initialize (SCHEME_P)
{
  SCHEME_V->dump_size = 0;
  SCHEME_V->dump_base = 0;
  dump_stack_reset (SCHEME_A);
}

ecb_cold 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;
}

ecb_cold 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);
    }
}

ecb_cold 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;
}

ecb_cold 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_cold void
dump_stack_reset (SCHEME_P)
{
  SCHEME_V->dump = NIL;
}

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

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

ecb_hot 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;
}

ecb_hot 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))));
}

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

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

ecb_cold 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)

#if EXPERIMENT
static int
debug (SCHEME_P_ int indent, pointer x)
{
  int c;

  if (is_syntax (x))
    {
      printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
      return 8 + 8;
    }

  if (x == NIL)
    {
      printf ("%*sNIL\n", indent, "");
      return 3;
    }

  switch (type (x))
    {
      case T_INTEGER:
        printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
        return 32+8;

      case T_SYMBOL:
        printf ("%*sS<%s>\n", indent, "", symname (x));
        return 24+8;

      case T_CLOSURE:
        printf ("%*sS<%s>\n", indent, "", "closure");
        debug (SCHEME_A_ indent + 3, cdr(x));
        return 32 + debug (SCHEME_A_ indent + 3, car (x));

      case T_PAIR:
        printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
        c = debug (SCHEME_A_ indent + 3, car (x));
        c += debug (SCHEME_A_ indent + 3, cdr (x));
        return c + 1;

      case T_PORT:
        printf ("%*sS<%s>\n", indent, "", "port");
        return 24+8;

      case T_VECTOR:
        printf ("%*sS<%s>\n", indent, "", "vector");
        return 24+8;

      case T_ENVIRONMENT:
        printf ("%*sS<%s>\n", indent, "", "environment");
        return 0 + debug (SCHEME_A_ indent + 3, car (x));

      default:
        printf ("unhandled type %d\n", type (x));
        break;
    }
}
#endif

/* syntax, eval, core, ... */
ecb_hot static int
opexe_0 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer args = SCHEME_V->args;
  pointer x, y;

  switch (op)
    {
#if EXPERIMENT //D
      case OP_DEBUG:
        printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
        printf ("\n");
        s_return (S_T);
#endif
      case OP_LOAD:            /* load */
        if (file_interactive (SCHEME_A))
          {
            putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
            //D fprintf (port (SCHEME_V->outport)->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 (port (SCHEME_V->loadport)->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)
              Error_1 ("eval: unbound variable:", SCHEME_V->code);

            s_return (slot_value_in_env (x));
          }
        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 (ecb_expect_false (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 = CELL(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);

      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));

      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 ();
}

/* math, cxr */
ecb_hot 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))
          {
            RVALUE r = rvalue_unchecked (x);

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

        s_return (x);

      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: s_return (mk_real (SCHEME_A_ trunc     (rvalue (x))));
      case OP_ROUND:    s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));

      case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (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))
                                                 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
      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:
        s_return (mk_real (SCHEME_A_
           cdr (args) == NIL
             ? atan (rvalue (x))
             : atan2 (rvalue (x), rvalue (cadr (args)))));

      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));
        }
#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));

      /* the compiler will optimize this mess... */
      case OP_CAR:    op_car:   s_return (car (x));
      case OP_CDR:    op_cdr:   s_return (cdr (x));
      case OP_CAAR:   op_caar:  x = car (x); goto op_car;
      case OP_CADR:   op_cadr:  x = cdr (x); goto op_car;
      case OP_CDAR:   op_cdar:  x = car (x); goto op_cdr;
      case OP_CDDR:   op_cddr:  x = cdr (x); goto op_cdr;
      case OP_CAAAR:  op_caaar: x = car (x); goto op_caar;
      case OP_CAADR:  op_caadr: x = cdr (x); goto op_caar;
      case OP_CADAR:  op_cadar: x = car (x); goto op_cadr;
      case OP_CADDR:  op_caddr: x = cdr (x); goto op_cadr;
      case OP_CDAAR:  op_cdaar: x = car (x); goto op_cdar;
      case OP_CDADR:  op_cdadr: x = cdr (x); goto op_cdar;
      case OP_CDDAR:  op_cddar: x = car (x); goto op_cddr;
      case OP_CDDDR:  op_cdddr: x = cdr (x); goto op_cddr;
      case OP_CAAAAR:           x = car (x); goto op_caaar;
      case OP_CAAADR:           x = cdr (x); goto op_caaar;
      case OP_CAADAR:           x = car (x); goto op_caadr;
      case OP_CAADDR:           x = cdr (x); goto op_caadr;
      case OP_CADAAR:           x = car (x); goto op_cadar;
      case OP_CADADR:           x = cdr (x); goto op_cadar;
      case OP_CADDAR:           x = car (x); goto op_caddr;
      case OP_CADDDR:           x = cdr (x); goto op_caddr;
      case OP_CDAAAR:           x = car (x); goto op_cdaar;
      case OP_CDAADR:           x = cdr (x); goto op_cdaar;
      case OP_CDADAR:           x = car (x); goto op_cdadr;
      case OP_CDADDR:           x = cdr (x); goto op_cdadr;
      case OP_CDDAAR:           x = car (x); goto op_cddar;
      case OP_CDDADR:           x = cdr (x); goto op_cddar;
      case OP_CDDDAR:           x = car (x); goto op_cdddr;
      case OP_CDDDDR:           x = cdr (x); goto op_cdddr;

      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_STRING_COPY:          /* substring/string-copy */
        {
          char *str = strvalue (x);
          int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
          int index1;
          int len;

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

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

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

          len = index1 - index0;
          x = mk_counted_string (SCHEME_A_ str + index0, len);

          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 ();
}

/* relational ops */
ecb_hot 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);
}

/* predicates */
ecb_hot 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_GENSYMP:         /* gensym? */      r = is_gensym (SCHEME_A_ 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);
}

/* promises, list ops, ports */
ecb_hot 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 */
        *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
        s_return (SCHEME_V->value);

#if USE_PORTS

      case OP_EOF_OBJECT:      /* eof-object */
        s_return (S_EOF);

      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 0
        if (!is_pair (args) || !is_number (a))
          Error_0 ("new-segment: argument must be a number");
#endif
        s_retbool (alloc_cellseg (SCHEME_A));

      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 = port (a);

          if (p->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 ();
}

/* reading */
ecb_cold 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 = port (p)->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 ();
}

/* list ops */
ecb_hot 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
         * (schmorp) well, obviously not, fix? TODO
         */
        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);

ecb_hot static int
tst_any (pointer p)
{
  return 1;
}

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

ecb_hot 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
;

ecb_cold 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";
}

ecb_cold 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 */
ecb_hot static void
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)
        {
          putstr (SCHEME_A_ "No memory!\n");
          return;
        }
    }
}

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

ecb_cold 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);
}

ecb_cold 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! */
ecb_hot static int
syntaxnum (pointer p)
{
  const char *s = strvalue (p);

  switch (strlength (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;

  /* this memset is not strictly correct, as we assume (intcache)
   * that memset 0 will also set pointers to 0, but memset does
   * of course not guarantee that. screw such systems.
   */
  memset (SCHEME_V, 0, sizeof (*SCHEME_V));

  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))
    {
#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
ecb_cold void
scheme_set_input_port_file (SCHEME_P_ int fin)
{
  SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
}

ecb_cold 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);
}

ecb_cold void
scheme_set_output_port_file (SCHEME_P_ int fout)
{
  SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
}

ecb_cold 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

ecb_cold 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
}

ecb_cold void
scheme_load_file (SCHEME_P_ int fin)
{
  scheme_load_named_file (SCHEME_A_ fin, 0);
}

ecb_cold 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;
}

ecb_cold 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;
}

ecb_cold 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

ecb_cold 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));
}

ecb_cold 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);
}

ecb_cold pointer
scheme_apply0 (SCHEME_P_ const char *procname)
{
  return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
}

ecb_cold 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);
}

ecb_cold 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. */
ecb_cold 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;
}

ecb_cold 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

ecb_cold 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;
  system ("ps v $PPID");//D

  if (argc == 2 && strcmp (argv[1], "-?") == 0)
    {
      putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
      putstr (SCHEME_A_ "or:    tinyscheme [<file1> <file2> ...]\n");
      putstr (SCHEME_A_ "followed by\n");
      putstr (SCHEME_A_ "          -1 <file> [<arg1> <arg2> ...]\n");
      putstr (SCHEME_A_ "          -c <Scheme commands> [<arg1> <arg2> ...]\n");
      putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
      putstr (SCHEME_A_ "Use - as filename for stdin.\n");
      return 1;
    }

  if (!scheme_init (SCHEME_A))
    {
      putstr (SCHEME_A_ "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)
        {
          putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\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)
                {
                  putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\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.60
Committed:	Wed Dec 2 02:59:36 2015 UTC (8 years, 7 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.59:	+187 -172 lines
Log Message:	hot cold