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 PAGE_SIZE 4096 /* does not work on sparc/alpha */
#include "malloc.c"

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

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

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

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

enum {
  TOK_EOF,
  TOK_LPAREN,
  TOK_RPAREN,
  TOK_DOT,
  TOK_ATOM,
  TOK_QUOTE,
  TOK_DQUOTE,
  TOK_BQUOTE,
  TOK_COMMA,
  TOK_ATMARK,
  TOK_SHARP,
  TOK_SHARP_CONST,
  TOK_VEC
};

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

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

#if !USE_MULTIPLICITY
static scheme sc;
#endif

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

  char *p = s;

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

  *p-- = 0;

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

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

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

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

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

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

  return c;
}

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

  return c;
}

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

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

#if USE_STRLWR
static const char *
strlwr (char *s)
{
  const char *p = s;

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

  return p;
}
#endif

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

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

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

#ifndef FIRST_CELLSEGS
# define FIRST_CELLSEGS 3
#endif

enum scheme_types
{
  T_FREE,
  T_STRING,
  T_NUMBER,
  T_SYMBOL,
  T_PROC,
  T_PAIR,
  T_CLOSURE,
  T_CONTINUATION,
  T_FOREIGN,
  T_CHARACTER,
  T_PORT,
  T_VECTOR,
  T_MACRO,
  T_PROMISE,
  T_ENVIRONMENT,
  /* one more... */
  T_NUM_SYSTEM_TYPES
};

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

static num num_add (num a, num b);
static num num_mul (num a, num b);
static num num_div (num a, num b);
static num num_intdiv (num a, num b);
static num num_sub (num a, num b);
static num num_rem (num a, num b);
static num num_mod (num a, num b);
static int num_eq (num a, num b);
static int num_gt (num a, num b);
static int num_ge (num a, num b);
static int num_lt (num a, num b);
static int num_le (num a, num b);

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

static INLINE int
num_is_integer (pointer p)
{
  return num_is_fixnum (p->object.number);
}

static num num_zero;
static num num_one;

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

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

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

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

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

INTERFACE uint32_t
vector_length (pointer vec)
{
  return vec->object.vector.length;
}

INTERFACE INLINE int
is_number (pointer p)
{
  return type (p) == T_NUMBER;
}

INTERFACE INLINE int
is_integer (pointer p)
{
  if (!is_number (p))
    return 0;

  if (num_is_integer (p) || ivalue (p) == rvalue (p))
    return 1;

  return 0;
}

INTERFACE INLINE int
is_real (pointer p)
{
  return is_number (p) && !num_is_fixnum (p->object.number);
}

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

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

INLINE num
nvalue (pointer p)
{
  return (p)->object.number;
}

static IVALUE
num_get_ivalue (const num n)
{
  return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
}

static RVALUE
num_get_rvalue (const num n)
{
  return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
}

INTERFACE IVALUE
ivalue (pointer p)
{
  return num_get_ivalue (p->object.number);
}

INTERFACE RVALUE
rvalue (pointer p)
{
  return num_get_rvalue (p->object.number);
}

#define ivalue_unchecked(p)  ((p)->object.number.value.ivalue)
#if USE_REAL
# define rvalue_unchecked(p)  ((p)->object.number.value.rvalue)
# define set_num_integer(p)   (p)->object.number.is_fixnum=1;
# define set_num_real(p)      (p)->object.number.is_fixnum=0;
#else
# define rvalue_unchecked(p)  ((p)->object.number.value.ivalue)
# define set_num_integer(p)   0
# define set_num_real(p)      0
#endif
INTERFACE long
charvalue (pointer p)
{
  return ivalue_unchecked (p);
}

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

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

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

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

#define car(p)           ((p)->object.cons.car + 0)
#define cdr(p)           ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */

#define caar(p)          car (car (p))
#define cadr(p)          car (cdr (p))
#define cdar(p)          cdr (car (p))
#define cddr(p)          cdr (cdr (p))

#define cadar(p)         car (cdr (car (p)))
#define caddr(p)         car (cdr (cdr (p)))
#define cdaar(p)         cdr (car (car (p)))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

INTERFACE INLINE 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 INLINE int
is_promise (pointer p)
{
  return type (p) == T_PROMISE;
}

INTERFACE INLINE 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 INLINE int
is_immutable (pointer p)
{
  return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
}

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

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

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

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

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

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

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

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

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

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

  return 0;
}

#endif

static int file_push (SCHEME_P_ const char *fname);
static void file_pop (SCHEME_P);
static int file_interactive (SCHEME_P);
static INLINE int is_one_of (char *s, int c);
static int alloc_cellseg (SCHEME_P_ int n);
static 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_ char *delim);
static pointer readstrexp (SCHEME_P);
static 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 pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);
static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);
static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);
static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);
static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);
static pointer 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 num
num_add (num a, num b)
{
  num ret;

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

  if (num_is_fixnum (ret))
    num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b));
  else
    num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b));

  return ret;
}

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

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

  if (num_is_fixnum (ret))
    num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
  else
    num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));

  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_get_ivalue (a) % num_get_ivalue (b) == 0);

  if (num_is_fixnum (ret))
    num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
  else
    num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));

  return ret;
}

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

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

  if (num_is_fixnum (ret))
    num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
  else
    num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));

  return ret;
}

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

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

  if (num_is_fixnum (ret))
    num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
  else
    num_set_rvalue (ret, num_get_rvalue (a) - num_get_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_get_ivalue (a);
  e2 = num_get_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_get_ivalue (a);
  e2 = num_get_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;
}

static int
num_eq (num a, num b)
{
  int ret;
  int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);

  if (is_fixnum)
    ret = num_get_ivalue (a) == num_get_ivalue (b);
  else
    ret = num_get_rvalue (a) == num_get_rvalue (b);

  return ret;
}


static int
num_gt (num a, num b)
{
  int ret;
  int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);

  if (is_fixnum)
    ret = num_get_ivalue (a) > num_get_ivalue (b);
  else
    ret = num_get_rvalue (a) > num_get_rvalue (b);

  return ret;
}

static int
num_ge (num a, num b)
{
  return !num_lt (a, b);
}

static int
num_lt (num a, num b)
{
  int ret;
  int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);

  if (is_fixnum)
    ret = num_get_ivalue (a) < num_get_ivalue (b);
  else
    ret = num_get_rvalue (a) < num_get_rvalue (b);

  return ret;
}

static int
num_le (num a, num b)
{
  return !num_gt (a, b);
}

#if USE_MATH

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

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

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

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

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

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

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

      if (!cp && USE_ERROR_CHECKING)
        return k;

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

      /* insert new segment in address order */
      newp = (pointer)cp;
      SCHEME_V->cell_seg[i] = newp;
      SCHEME_V->cell_segsize[i] = segsize;

      //TODO: insert, not swap
      while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
        {
          p = SCHEME_V->cell_seg[i];
          SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
          SCHEME_V->cell_seg[i - 1] = p;

          k = SCHEME_V->cell_segsize[i];
          SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
          SCHEME_V->cell_segsize[i - 1] = k;

          --i;
        }

      SCHEME_V->fcells += segsize;
      last = newp + segsize - 1;

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

      /* insert new cells in address order on free list */
      if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
        {
          set_cdr (last, SCHEME_V->free_cell);
          SCHEME_V->free_cell = newp;
        }
      else
        {
          p = SCHEME_V->free_cell;

          while (cdr (p) != NIL && newp > cdr (p))
            p = cdr (p);

          set_cdr (last, cdr (p));
          set_cdr (p, newp);
        }
    }

  return n;
}

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

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

          gc (SCHEME_A_ a, b);

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

  {
    pointer x = SCHEME_V->free_cell;

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

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

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

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

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

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

  return cell;
}

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

  if (!e && USE_ERROR_CHECKING)
    return S_SINK;

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

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

  return v;
}

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

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

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

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

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

/* Medium level cell allocation */

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

  set_typeflag (x, T_PAIR);

  if (immutable)
    setimmutable (x);

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

  return x;
}

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

#ifndef USE_OBJECT_LIST

static int hash_fn (const char *key, int table_size);

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

/* returns the new symbol */
static pointer
oblist_add_by_name (SCHEME_P_ const char *name)
{
  int location;

  pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
  set_typeflag (x, T_SYMBOL);
  setimmutable (car (x));

  location = hash_fn (name, veclength (SCHEME_V->oblist));
  set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
  return x;
}

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

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

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

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

  return NIL;
}

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

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

  return ob_list;
}

#else

static pointer
oblist_initial_value (SCHEME_P)
{
  return NIL;
}

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

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

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

  return NIL;
}

/* returns the new symbol */
static pointer
oblist_add_by_name (SCHEME_P_ const char *name)
{
  pointer x;

  x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
  set_typeflag (x, T_SYMBOL);
  setimmutable (car (x));
  SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
  return x;
}

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

#endif

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

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

  return x;
}
#endif

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

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

  return x;
}

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

  set_typeflag (x, (T_CHARACTER | T_ATOM));
  ivalue_unchecked (x) = c & 0xff;
  set_num_integer (x);
  return x;
}

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

  set_typeflag (x, (T_NUMBER | T_ATOM));
  ivalue_unchecked (x) = num;
  set_num_integer (x);
  return x;
}

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

  set_typeflag (x, (T_NUMBER | T_ATOM));
  rvalue_unchecked (x) = n;
  set_num_real (x);
  return x;
}

static pointer
mk_number (SCHEME_P_ const num n)
{
  if (num_is_fixnum (n))
    return mk_integer (SCHEME_A_ num_get_ivalue (n));
  else
    return mk_real (SCHEME_A_ num_get_rvalue (n));
}

/* 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)
    {
      int l = strlen (str);

      if (l > len_str)
        l = len_str;

      memcpy (q, str, l);
      q[l] = 0;
    }
  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, pointer obj)
{
  int i;

  for (i = 0; i < vec->object.vector.length; i++)
    vecvalue (vec)[i] = obj;
}

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

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

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

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

  return x;
}

INTERFACE pointer
gensym (SCHEME_P)
{
  pointer x;

  for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
    {
      char name[40] = "gensym-";
      xnum (name + 7, SCHEME_V->gensym_cnt);

      /* first check oblist */
      x = oblist_find_by_name (SCHEME_A_ name);

      if (x == NIL)
        {
          x = oblist_add_by_name (SCHEME_A_ name);
          return x;
        }
    }

  return NIL;
}

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

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

  p = q;
  c = *p++;

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

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

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

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

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

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

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

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

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

/* make constant */
static pointer
mk_sharp_const (SCHEME_P_ char *name)
{
  long x;
  char tmp[STRBUFFSIZE];

  if (!strcmp (name, "t"))
    return S_T;
  else if (!strcmp (name, "f"))
    return S_F;
  else if (*name == '\\')       /* #\w (character) */
    {
      int c = 0;

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

          if (c1 <= UCHAR_MAX)
            c = c1;
          else
            return NIL;

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

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

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

      return NIL;
    }
}

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

/*--
 *  We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
 *  sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
 *  for marking.
 */
static void
mark (pointer a)
{
  pointer t, q, p;

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

  if (is_vector (p))
    {
      int i;

      for (i = 0; i < p->object.vector.length; i++)
        mark (vecvalue (p)[i]);
    }

  if (is_atom (p))
    goto E6;

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

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

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

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

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

  q = t;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  fin = open (fname, O_RDONLY);

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

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

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

  return fin >= 0;

#else
  return 1;
#endif
}

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

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

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

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

  fd = open (fn, flags, 0666);

  if (fd < 0)
    return 0;

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

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

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

  return pt;
}

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

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

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

  if (!pt && USE_ERROR_CHECKING)
    return NULL;

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

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

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

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

  if (!pt && USE_ERROR_CHECKING)
    return 0;

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

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

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

# define BLOCK_SIZE 256

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

  if (!pt && USE_ERROR_CHECKING)
    return 0;

  start = malloc (BLOCK_SIZE);

  if (start == 0)
    return 0;

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

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

  if (!pt && USE_ERROR_CHECKING)
    return NIL;

  return mk_port (SCHEME_A_ pt);
}

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

  pt->kind &= ~flag;

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

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

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

# endif

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

      pt->kind = port_free;
    }
}
#endif

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

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

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

  c = basic_inchar (pt);

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

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

  return c;
}

static int ungot = -1;

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

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

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

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

      ungot = c;
    }

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

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

  if (c == EOF)
    return;

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

  ungot = c;
#endif
}

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

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

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

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

#else
  xwrstr (s);
#endif
}

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

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

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

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

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

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

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

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

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

  return SCHEME_V->strbuff;
}

/* read string expression "xxx...xxx" */
static pointer
readstrexp (SCHEME_P)
{
  char *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:
            switch (c)
              {
                case '\\':
                  state = st_bsl;
                  break;

                case '"':
                  *p = 0;
                  return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);

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

            break;

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

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

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

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

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

                case '"':
                  *p++ = '"';
                  state = st_ok;
                  break;

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

            break;

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

            if (c >= '0' && c <= 'F')
              {
                if (c <= '9')
                  c1 = (c1 << 4) + c - '0';
                else
                  c1 = (c1 << 4) + c - 'A' + 10;

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

            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 >= 32)
                  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 */
static INLINE int
is_one_of (char *s, int c)
{
  if (c == EOF)
    return 1;

  return !!strchr (s, c);
}

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

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

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

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

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

  if (c == EOF)
    return TOK_EOF;

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

      case '(':
        return TOK_LPAREN;

      case ')':
        return TOK_RPAREN;

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

        if (is_one_of (" \n\t", c))
          return TOK_DOT;
        else
          {
            //TODO: ungetc twice in a row is not supported in C
            backchar (SCHEME_A_ c);
            backchar (SCHEME_A_ '.');
            return TOK_ATOM;
          }

      case '\'':
        return TOK_QUOTE;

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

#if SHOW_ERROR_LINE

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

#endif

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

      case '"':
        return TOK_DQUOTE;

      case BACKQUOTE:
        return TOK_BQUOTE;

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

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

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

#if SHOW_ERROR_LINE

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

#endif

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

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

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

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

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

  putcharacter (SCHEME_A_ '"');

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

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

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

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

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

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

              default:
                {
                  int d = *s / 16;

                  putcharacter (SCHEME_A_ 'x');

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

                  d = *s % 16;

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

      s++;
    }

  putcharacter (SCHEME_A_ '"');
}


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

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


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

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

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

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

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

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

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

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

      p = SCHEME_V->strbuff;

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

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

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

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

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

#else

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  return p;
}

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

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

  return result;
}

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

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

  if (p == NIL)
    return result;

  return S_F;           /* signal an error */
}

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

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

#if !defined(USE_ALIST_ENV) || !defined(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;
}
#endif

#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 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 = hash_fn (symname (variable), veclength (car (env)));

      set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));
    }
  else
    set_car (env, immutable_cons (slot, car (env)));
}

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

  for (x = env; x != NIL; x = cdr (x))
    {
      if (is_vector (car (x)))
        {
          location = hash_fn (symname (hdl), veclength (car (x)));
          y = vector_elem (car (x), location);
        }
      else
        y = car (x);

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

      if (y != NIL)
        break;

      if (!all)
        return NIL;
    }

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

  return NIL;
}

#else /* USE_ALIST_ENV */

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

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

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

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

      if (y != NIL)
        break;

      if (!all)
        return NIL;
    }

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

  return NIL;
}

#endif /* USE_ALIST_ENV else */

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

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

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

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

static pointer
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 S_T;
    }
#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 S_T;
}

#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 S_T; END

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

#ifndef USE_SCHEME_STACK

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

# define STACK_GROWTH 3

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

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

  next_frame = SCHEME_V->dump_base + nframes;

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

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

static pointer
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 NIL;

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

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

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

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

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

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

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

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

  pointer cont = NIL;

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

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

  return cont;
}

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

  while (cont != NIL)
    {
      frame->op    = ivalue (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

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

static INLINE void
dump_stack_initialize (SCHEME_P)
{
  dump_stack_reset (SCHEME_A);
}

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

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

  SCHEME_V->value = a;

  if (dump == NIL)
    return NIL;

  SCHEME_V->op    = ivalue (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 S_T;
}

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

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

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

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

#endif

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

static pointer
opexe_0 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer x, y;

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

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

      case OP_T0LVL:           /* top level */

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

            /* NOTREACHED */
          }

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

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

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

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

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

        s_goto (OP_RDSEXPR);

      case OP_GENSYM:
        s_return (gensym (SCHEME_A));

      case OP_VALUEPRINT:      /* print evaluation result */

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

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

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

        /* fall through */

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

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

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

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

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

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

#if USE_TRACING

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

          SCHEME_V->tracing = ivalue (car (SCHEME_V->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, SCHEME_V->args, SCHEME_V->code);
            SCHEME_V->print_flag = 1;
            /*  SCHEME_V->args=cons(SCHEME_V->code,SCHEME_V->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_ SCHEME_V->args, NIL);
            x = SCHEME_V->code->object.ff (SCHEME_A_ SCHEME_V->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 = SCHEME_V->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 (SCHEME_V->args != NIL ? car (SCHEME_V->args) : NIL);
          }
        else
          Error_0 ("illegal function");

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

#if 1

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

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

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

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

#else

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

#endif

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

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

        if (cdr (SCHEME_V->args) == NIL)
          y = SCHEME_V->envir;
        else
          y = cadr (SCHEME_V->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 (SCHEME_V->args) != NIL)
          x = cadr (SCHEME_V->args);

        s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->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) */
        SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->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, SCHEME_V->args, cdr (SCHEME_V->code));
            SCHEME_V->code = cadar (SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_EVAL);
          }
        else                    /* end */
          {
            SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args);
            SCHEME_V->code = car (SCHEME_V->args);
            SCHEME_V->args = cdr (SCHEME_V->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 = SCHEME_V->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), SCHEME_V->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));

                SCHEME_V->args = cons (caar (x), SCHEME_V->args);
              }

            x =
              mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->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);
            SCHEME_V->args = NIL;
          }
        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, SCHEME_V->args, SCHEME_V->code);
            SCHEME_V->code = cadar (SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_EVAL);
          }
        else                    /* end */
          {
            SCHEME_V->code = SCHEME_V->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) */
        SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->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, SCHEME_V->args, cdr (SCHEME_V->code));
            SCHEME_V->code = cadar (SCHEME_V->code);
            SCHEME_V->args = NIL;
            s_goto (OP_EVAL);
          }
        else                    /* end */
          {
            SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args);
            SCHEME_V->code = car (SCHEME_V->args);
            SCHEME_V->args = cdr (SCHEME_V->args);
            s_goto (OP_LET2REC);
          }

      case OP_LET2REC:         /* letrec */
        for (x = car (SCHEME_V->code), y = SCHEME_V->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 SCHEME_V->args for gc */
        x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
        set_typeflag (x, T_PROMISE);
        s_return (cons (SCHEME_V->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 (SCHEME_V->args);
        SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args));
        /*SCHEME_V->args = cadr(SCHEME_V->args); */
        s_goto (OP_APPLY);

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

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

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

  return S_T;
}

static pointer
opexe_2 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer x;
  num v;

#if USE_MATH
  RVALUE dd;
#endif

  switch (op)
    {
#if USE_MATH

      case OP_INEX2EX:         /* inexact->exact */
        x = car (SCHEME_V->args);

        if (num_is_integer (x))
          s_return (x);
        else if (modf (rvalue_unchecked (x), &dd) == 0.0)
          s_return (mk_integer (SCHEME_A_ ivalue (x)));
        else
          Error_1 ("inexact->exact: not integral:", x);

      case OP_EXP:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ exp (rvalue (x))));

      case OP_LOG:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ log (rvalue (x))));

      case OP_SIN:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ sin (rvalue (x))));

      case OP_COS:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ cos (rvalue (x))));

      case OP_TAN:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ tan (rvalue (x))));

      case OP_ASIN:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ asin (rvalue (x))));

      case OP_ACOS:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ acos (rvalue (x))));

      case OP_ATAN:
        x = car (SCHEME_V->args);

        if (cdr (SCHEME_V->args) == NIL)
          s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
        else
          {
            pointer y = cadr (SCHEME_V->args);

            s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
          }

      case OP_SQRT:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));

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

          x = car (SCHEME_V->args);

          if (num_is_integer (x) && num_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.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 = (long) result;

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

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

      case OP_FLOOR:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ floor (rvalue (x))));

      case OP_CEILING:
        x = car (SCHEME_V->args);
        s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));

      case OP_TRUNCATE:
        {
          RVALUE rvalue_of_x;

          x = car (SCHEME_V->args);
          rvalue_of_x = rvalue (x);

          if (rvalue_of_x > 0)
            s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));
          else
            s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
        }

      case OP_ROUND:
        x = car (SCHEME_V->args);

        if (num_is_integer (x))
          s_return (x);

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

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

        for (x = SCHEME_V->args; x != NIL; x = cdr (x))
          v = num_add (v, nvalue (car (x)));

        s_return (mk_number (SCHEME_A_ v));

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

        for (x = SCHEME_V->args; x != NIL; x = cdr (x))
          v = num_mul (v, nvalue (car (x)));

        s_return (mk_number (SCHEME_A_ v));

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

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

        s_return (mk_number (SCHEME_A_ v));

      case OP_DIV:             /* / */
        if (cdr (SCHEME_V->args) == NIL)
          {
            x = SCHEME_V->args;
            v = num_one;
          }
        else
          {
            x = cdr (SCHEME_V->args);
            v = nvalue (car (SCHEME_V->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 (SCHEME_V->args) == NIL)
          {
            x = SCHEME_V->args;
            v = num_one;
          }
        else
          {
            x = cdr (SCHEME_V->args);
            v = nvalue (car (SCHEME_V->args));
          }

        for (; x != NIL; x = cdr (x))
          {
            if (ivalue (car (x)) != 0)
              v = 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 (car (SCHEME_V->args));

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

        s_return (mk_number (SCHEME_A_ v));

      case OP_MOD:             /* modulo */
        v = nvalue (car (SCHEME_V->args));

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

        s_return (mk_number (SCHEME_A_ v));

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

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

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

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

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

      case OP_CHAR2INT:        /* char->integer */
        s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args))));

      case OP_INT2CHAR:        /* integer->char */
        s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args))));

      case OP_CHARUPCASE:
        {
          unsigned char c = ivalue (car (SCHEME_V->args));
          c = toupper (c);
          s_return (mk_character (SCHEME_A_ c));
        }

      case OP_CHARDNCASE:
        {
          unsigned char c = ivalue (car (SCHEME_V->args));
          c = tolower (c);
          s_return (mk_character (SCHEME_A_ c));
        }

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

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

          if (cdr (SCHEME_V->args) != NIL)
            {
              /* we know cadr(SCHEME_V->args) is a natural number */
              /* see if it is 2, 8, 10, or 16, or error */
              pf = ivalue_unchecked (cadr (SCHEME_V->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 (SCHEME_V->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 (car (SCHEME_V->args)));
        setimmutable (x);
        s_return (x);

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

          x = car (SCHEME_V->args);

          if (cdr (SCHEME_V->args) != NIL)
            {
              /* we know cadr(SCHEME_V->args) is a natural number */
              /* see if it is 2, 8, 10, or 16, or error */
              pf = ivalue_unchecked (cadr (SCHEME_V->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 (SCHEME_V->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 = ' ';
          int len;

          len = ivalue (car (SCHEME_V->args));

          if (cdr (SCHEME_V->args) != NIL)
            fill = charvalue (cadr (SCHEME_V->args));

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

      case OP_STRLEN:          /* string-length */
        s_return (mk_integer (SCHEME_A_ strlength (car (SCHEME_V->args))));

      case OP_STRREF:          /* string-ref */
        {
          char *str;
          int index;

          str = strvalue (car (SCHEME_V->args));

          index = ivalue (cadr (SCHEME_V->args));

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

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

      case OP_STRSET:          /* string-set! */
        {
          char *str;
          int index;
          int c;

          if (is_immutable (car (SCHEME_V->args)))
            Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args));

          str = strvalue (car (SCHEME_V->args));

          index = ivalue (cadr (SCHEME_V->args));

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

          c = charvalue (caddr (SCHEME_V->args));

          str[index] = (char) c;
          s_return (car (SCHEME_V->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 = SCHEME_V->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 = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x))
            memcpy (pos, strvalue (car (x)), strlength (car (x)));

          s_return (newstr);
        }

      case OP_SUBSTR:          /* substring */
        {
          char *str;
          int index0;
          int index1;
          int len;

          str = strvalue (car (SCHEME_V->args));

          index0 = ivalue (cadr (SCHEME_V->args));

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

          if (cddr (SCHEME_V->args) != NIL)
            {
              index1 = ivalue (caddr (SCHEME_V->args));

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

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

          s_return (x);
        }

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

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

          vec = mk_vector (SCHEME_A_ len);

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

          for (x = SCHEME_V->args, i = 0; is_pair (x); x = cdr (x), i++)
            set_vector_elem (vec, i, car (x));

          s_return (vec);
        }

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

          len = ivalue (car (SCHEME_V->args));

          if (cdr (SCHEME_V->args) != NIL)
            fill = cadr (SCHEME_V->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, fill);

          s_return (vec);
        }

      case OP_VECLEN:          /* vector-length */
        s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));

      case OP_VECREF:          /* vector-ref */
        {
          int index;

          index = ivalue (cadr (SCHEME_V->args));

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

          s_return (vector_elem (car (SCHEME_V->args), index));
        }

      case OP_VECSET:          /* vector-set! */
        {
          int index;

          if (is_immutable (car (SCHEME_V->args)))
            Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));

          index = ivalue (cadr (SCHEME_V->args));

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

          set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));
          s_return (car (SCHEME_V->args));
        }
    }

  return S_T;
}

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

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

  slow = fast = a;

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

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

      fast = cdr (fast);
      ++i;

      if (fast == NIL)
        return i;

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

      ++i;
      fast = cdr (fast);

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

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

static pointer
opexe_3 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer x;
  num v;
  int (*comp_func) (num, num);

  switch (op)
    {
      case OP_NOT:             /* not */
        s_retbool (is_false (car (SCHEME_V->args)));

      case OP_BOOLP:           /* boolean? */
        s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T);

      case OP_EOFOBJP:         /* boolean? */
        s_retbool (car (SCHEME_V->args) == S_EOF);

      case OP_NULLP:           /* null? */
        s_retbool (car (SCHEME_V->args) == NIL);

      case OP_NUMEQ:           /* = */
      case OP_LESS:            /* < */
      case OP_GRE:             /* > */
      case OP_LEQ:             /* <= */
      case OP_GEQ:             /* >= */
        switch (op)
          {
            case OP_NUMEQ:
              comp_func = num_eq;
              break;

            case OP_LESS:
              comp_func = num_lt;
              break;

            case OP_GRE:
              comp_func = num_gt;
              break;

            case OP_LEQ:
              comp_func = num_le;
              break;

            case OP_GEQ:
              comp_func = num_ge;
              break;
          }

        x = SCHEME_V->args;
        v = nvalue (car (x));
        x = cdr (x);

        for (; x != NIL; x = cdr (x))
          {
            if (!comp_func (v, nvalue (car (x))))
              s_retbool (0);

            v = nvalue (car (x));
          }

        s_retbool (1);

      case OP_SYMBOLP:         /* symbol? */
        s_retbool (is_symbol (car (SCHEME_V->args)));

      case OP_NUMBERP:         /* number? */
        s_retbool (is_number (car (SCHEME_V->args)));

      case OP_STRINGP:         /* string? */
        s_retbool (is_string (car (SCHEME_V->args)));

      case OP_INTEGERP:        /* integer? */
        s_retbool (is_integer (car (SCHEME_V->args)));

      case OP_REALP:           /* real? */
        s_retbool (is_number (car (SCHEME_V->args)));   /* All numbers are real */

      case OP_CHARP:           /* char? */
        s_retbool (is_character (car (SCHEME_V->args)));
#if USE_CHAR_CLASSIFIERS

      case OP_CHARAP:          /* char-alphabetic? */
        s_retbool (Cisalpha (ivalue (car (SCHEME_V->args))));

      case OP_CHARNP:          /* char-numeric? */
        s_retbool (Cisdigit (ivalue (car (SCHEME_V->args))));

      case OP_CHARWP:          /* char-whitespace? */
        s_retbool (Cisspace (ivalue (car (SCHEME_V->args))));

      case OP_CHARUP:          /* char-upper-case? */
        s_retbool (Cisupper (ivalue (car (SCHEME_V->args))));

      case OP_CHARLP:          /* char-lower-case? */
        s_retbool (Cislower (ivalue (car (SCHEME_V->args))));
#endif
#if USE_PORTS

      case OP_PORTP:           /* port? */
        s_retbool (is_port (car (SCHEME_V->args)));

      case OP_INPORTP:         /* input-port? */
        s_retbool (is_inport (car (SCHEME_V->args)));

      case OP_OUTPORTP:        /* output-port? */
        s_retbool (is_outport (car (SCHEME_V->args)));
#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
          */
        s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args))
                   || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args)));

      case OP_PAIRP:           /* pair? */
        s_retbool (is_pair (car (SCHEME_V->args)));

      case OP_LISTP:           /* list? */
        s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0);

      case OP_ENVP:            /* environment? */
        s_retbool (is_environment (car (SCHEME_V->args)));

      case OP_VECTORP:         /* vector? */
        s_retbool (is_vector (car (SCHEME_V->args)));

      case OP_EQ:              /* eq? */
        s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args));

      case OP_EQV:             /* eqv? */
        s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args)));
    }

  return S_T;
}

static pointer
opexe_4 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer x, y;

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

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

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

#if USE_PORTS

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

        SCHEME_V->args = car (SCHEME_V->args);

        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 (SCHEME_V->args))
          {
            if (car (SCHEME_V->args) != SCHEME_V->outport)
              {
                x = cons (SCHEME_V->outport, NIL);
                s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
                SCHEME_V->outport = car (SCHEME_V->args);
              }
          }

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

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

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

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

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

        if (SCHEME_V->args != NIL)
          {
            s_save (SCHEME_A_ OP_ERR1, cdr (SCHEME_V->args), NIL);
            SCHEME_V->args = car (SCHEME_V->args);
            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 NIL;
          }

      case OP_REVERSE:         /* reverse */
        s_return (reverse (SCHEME_A_ car (SCHEME_V->args)));

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

      case OP_APPEND:          /* append */
        x = NIL;
        y = SCHEME_V->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 (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args)))
          Error_0 ("illegal use of put");

        for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x))
          {
            if (caar (x) == y)
              break;
          }

        if (x != NIL)
          cdar (x) = caddr (SCHEME_V->args);
        else
          symprop (car (SCHEME_V->args)) = cons (cons (y, caddr (SCHEME_V->args)), symprop (car (SCHEME_V->args)));

        s_return (S_T);

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

        for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->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 (SCHEME_V->args))
          SCHEME_V->retcode = ivalue (car (SCHEME_V->args));

        return NIL;

      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 = (car (SCHEME_V->args) != S_F);
          s_retbool (was);
        }

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

        alloc_cellseg (SCHEME_A_ (int)ivalue (car (SCHEME_V->args)));

        s_return (S_T);

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

#if USE_PORTS

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

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

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

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

              case OP_OPEN_OUTFILE:
                prop = port_output;
                break;

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

          p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop);

          if (p == NIL)
            s_return (S_F);

          s_return (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 (car (SCHEME_V->args)),
                                strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop);

          if (p == NIL)
            s_return (S_F);

          s_return (p);
        }

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

          if (car (SCHEME_V->args) == NIL)
            {
              p = port_from_scratch (SCHEME_A);

              if (p == NIL)
                s_return (S_F);
            }
          else
            {
              p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)),
                                    strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output);

              if (p == NIL)
                s_return (S_F);
            }

          s_return (p);
        }

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

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

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

              if (str != NULL)
                {
                  pointer s;

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

          s_return (S_F);
        }

# endif

      case OP_CLOSE_INPORT:    /* close-input-port */
        port_close (SCHEME_A_ car (SCHEME_V->args), port_input);
        s_return (S_T);

      case OP_CLOSE_OUTPORT:   /* close-output-port */
        port_close (SCHEME_A_ car (SCHEME_V->args), 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);

    }

  return S_T;
}

static pointer
opexe_5 (SCHEME_P_ enum scheme_opcodes op)
{
  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 (SCHEME_V->args))
          s_goto (OP_READ_INTERNAL);

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

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

        x = SCHEME_V->inport;
        SCHEME_V->inport = car (SCHEME_V->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 (SCHEME_V->args))
            {
              if (car (SCHEME_V->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 (SCHEME_V->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 (SCHEME_V->args))
            p = car (SCHEME_V->args);

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

          s_retbool (res);
        }

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

      case OP_SET_OUTPORT:     /* set-output-port */
        SCHEME_V->outport = car (SCHEME_V->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_ DELIMITERS)));

            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_ 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, SCHEME_V->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, SCHEME_V->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 (SCHEME_V->args))
          {
            putstr (SCHEME_A_ "#(");
            SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0));
            s_goto (OP_PVECFROM);
          }
        else if (is_environment (SCHEME_V->args))
          {
            putstr (SCHEME_A_ "#<ENVIRONMENT>");
            s_return (S_T);
          }
        else if (!is_pair (SCHEME_V->args))
          {
            printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag);
            s_return (S_T);
          }
        else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args)))
          {
            putstr (SCHEME_A_ "'");
            SCHEME_V->args = cadr (SCHEME_V->args);
            s_goto (OP_P0LIST);
          }
        else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args)))
          {
            putstr (SCHEME_A_ "`");
            SCHEME_V->args = cadr (SCHEME_V->args);
            s_goto (OP_P0LIST);
          }
        else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args)))
          {
            putstr (SCHEME_A_ ",");
            SCHEME_V->args = cadr (SCHEME_V->args);
            s_goto (OP_P0LIST);
          }
        else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args)))
          {
            putstr (SCHEME_A_ ",@");
            SCHEME_V->args = cadr (SCHEME_V->args);
            s_goto (OP_P0LIST);
          }
        else
          {
            putstr (SCHEME_A_ "(");
            s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
            SCHEME_V->args = car (SCHEME_V->args);
            s_goto (OP_P0LIST);
          }

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

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

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

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

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

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

              s_goto (OP_P0LIST);
            }
        }
    }

  return S_T;
}

static pointer
opexe_6 (SCHEME_P_ enum scheme_opcodes op)
{
  pointer x, y;

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

          if (v < 0)
            Error_1 ("length: not a list:", car (SCHEME_V->args));

          s_return (mk_integer (SCHEME_A_ v));
        }

      case OP_ASSQ:            /* assq *//* a.k */
        x = car (SCHEME_V->args);

        for (y = cadr (SCHEME_V->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 = car (SCHEME_V->args);

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

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

      case OP_MACROP:          /* macro? */
        s_retbool (is_macro (car (SCHEME_V->args)));
    }

  return S_T;           /* NOTREACHED */
}

typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);

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

static int
is_nonneg (pointer p)
{
  return ivalue (p) >= 0 && is_integer (p);
}

/* Correspond carefully with following defines! */
static struct
{
  test_predicate fct;
  const char *kind;
} tests[] =
{
  { 0, 0},                        /* unused */
  { is_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" },
  { is_nonneg, "non-negative integer" }
};

#define TST_NONE 0
#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"

typedef struct
{
  dispatch_func func;
  char *name;
  int min_arity;
  int max_arity;
  char *arg_tests_encoding;
} op_code_info;

#define INF_ARG 0xffff

static op_code_info dispatch_table[] = {
#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
#include "opdefines.h"
  {0}
};

static const char *
procname (pointer x)
{
  int n = procnum (x);
  const char *name = dispatch_table[n].name;

  if (name == 0)
    name = "ILLEGAL!";

  return name;
}

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

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

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

          /* Check number of arguments */
          if (n < pcd->min_arity)
            {
              ok = 0;
              snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
                        pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
            }

          if (ok && n > pcd->max_arity)
            {
              ok = 0;
              snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
                        pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
            }

          if (ok)
            {
              if (pcd->arg_tests_encoding)
                {
                  int i = 0;
                  int j;
                  const char *t = pcd->arg_tests_encoding;
                  pointer arglist = SCHEME_V->args;

                  do
                    {
                      pointer arg = car (arglist);

                      j = (int) t[0];

                      if (j == TST_LIST[0])
                        {
                          if (arg != NIL && !is_pair (arg))
                            break;
                        }
                      else
                        {
                          if (!tests[j].fct (arg))
                            break;
                        }

                      if (t[1] != 0)    /* last test is replicated as necessary */
                        t++;

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

                  if (i < n)
                    {
                      ok = 0;
                      snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);
                    }
                }
            }

          if (!ok)
            {
              if (xError_1 (SCHEME_A_ msg, 0) == NIL)
                return;

              pcd = dispatch_table + SCHEME_V->op;
            }
        }
#endif

      ok_to_freely_gc (SCHEME_A);

      if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)
        return;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

            default:
              return OP_QUOTE;  /* quote */
          }

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

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

            default:
              return OP_LET0REC;        /* letrec */
          }

      default:
        return OP_C0STREAM;     /* cons-stream */
    }
}

#if USE_MULTIPLICITY
scheme *
scheme_init_new ()
{
  scheme *sc = malloc (sizeof (scheme));

  if (!scheme_init (SCHEME_A))
    {
      free (SCHEME_A);
      return 0;
    }
  else
    return sc;
}
#endif

int
scheme_init (SCHEME_P)
{
  int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
  pointer x;

  num_set_fixnum (num_zero, 1);
  num_set_ivalue (num_zero, 0);
  num_set_fixnum (num_one, 1);
  num_set_ivalue (num_one, 1);

#if USE_INTERFACE
  SCHEME_V->vptr = &vtbl;
#endif
  SCHEME_V->gensym_cnt = 0;
  SCHEME_V->last_cell_seg = -1;
  SCHEME_V->free_cell = NIL;
  SCHEME_V->fcells = 0;
  SCHEME_V->no_memory = 0;
  SCHEME_V->inport = NIL;
  SCHEME_V->outport = NIL;
  SCHEME_V->save_inport = NIL;
  SCHEME_V->loadport = NIL;
  SCHEME_V->nesting = 0;
  SCHEME_V->interactive_repl = 0;

  if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS)
    {
#if USE_ERROR_CHECKING
      SCHEME_V->no_memory = 1;
      return 0;
#endif
    }

  SCHEME_V->gc_verbose = 0;
  dump_stack_initialize (SCHEME_A);
  SCHEME_V->code = NIL;
  SCHEME_V->args = NIL;
  SCHEME_V->envir = NIL;
  SCHEME_V->tracing = 0;

  /* init NIL */
  set_typeflag (NIL, T_ATOM | T_MARK);
  set_car (NIL, NIL);
  set_cdr (NIL, NIL);
  /* init T */
  set_typeflag (S_T, T_ATOM | T_MARK);
  set_car (S_T, S_T);
  set_cdr (S_T, S_T);
  /* init F */
  set_typeflag (S_F, T_ATOM | T_MARK);
  set_car (S_F, S_F);
  set_cdr (S_F, S_F);
  /* init EOF_OBJ */
  set_typeflag (S_EOF, T_ATOM | T_MARK);
  set_car (S_EOF, S_EOF);
  set_cdr (S_EOF, S_EOF);
  /* init sink */
  set_typeflag (S_SINK, T_PAIR | T_MARK);
  set_car (S_SINK, NIL);

  /* init c_nest */
  SCHEME_V->c_nest = NIL;

  SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
  /* init global_env */
  new_frame_in_env (SCHEME_A_ NIL);
  SCHEME_V->global_env = SCHEME_V->envir;
  /* init else */
  x = mk_symbol (SCHEME_A_ "else");
  new_slot_in_env (SCHEME_A_ x, S_T);

  {
    static const char *syntax_names[] = {
      "lambda", "quote", "define", "if", "begin", "set!",
      "let", "let*", "letrec", "cond", "delay", "and",
      "or", "cons-stream", "macro", "case"
    };

    for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
      assign_syntax (SCHEME_A_ syntax_names[i]);
  }

  for (i = 0; i < n; i++)
    if (dispatch_table[i].name != 0)
      assign_proc (SCHEME_A_ i, dispatch_table[i].name);

  /* initialization of global pointers to special symbols */
  SCHEME_V->LAMBDA       = mk_symbol (SCHEME_A_ "lambda");
  SCHEME_V->QUOTE        = mk_symbol (SCHEME_A_ "quote");
  SCHEME_V->QQUOTE       = mk_symbol (SCHEME_A_ "quasiquote");
  SCHEME_V->UNQUOTE      = mk_symbol (SCHEME_A_ "unquote");
  SCHEME_V->UNQUOTESP    = mk_symbol (SCHEME_A_ "unquote-splicing");
  SCHEME_V->FEED_TO      = mk_symbol (SCHEME_A_ "=>");
  SCHEME_V->COLON_HOOK   = mk_symbol (SCHEME_A_ "*colon-hook*");
  SCHEME_V->ERROR_HOOK   = mk_symbol (SCHEME_A_ "*error-hook*");
  SCHEME_V->SHARP_HOOK   = mk_symbol (SCHEME_A_ "*sharp-hook*");
  SCHEME_V->COMPILE_HOOK = mk_symbol (SCHEME_A_ "*compile-hook*");

  return !SCHEME_V->no_memory;
}

#if USE_PORTS
void
scheme_set_input_port_file (SCHEME_P_ int fin)
{
  SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
}

void
scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
{
  SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
}

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

void
scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
{
  SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
}
#endif

void
scheme_set_external_data (SCHEME_P_ void *p)
{
  SCHEME_V->ext_data = p;
}

void
scheme_deinit (SCHEME_P)
{
  int i;

#if SHOW_ERROR_LINE
  char *fname;
#endif

  SCHEME_V->oblist = NIL;
  SCHEME_V->global_env = NIL;
  dump_stack_free (SCHEME_A);
  SCHEME_V->envir = NIL;
  SCHEME_V->code = NIL;
  SCHEME_V->args = NIL;
  SCHEME_V->value = NIL;

  if (is_port (SCHEME_V->inport))
    set_typeflag (SCHEME_V->inport, T_ATOM);

  SCHEME_V->inport = NIL;
  SCHEME_V->outport = NIL;

  if (is_port (SCHEME_V->save_inport))
    set_typeflag (SCHEME_V->save_inport, T_ATOM);

  SCHEME_V->save_inport = NIL;

  if (is_port (SCHEME_V->loadport))
    set_typeflag (SCHEME_V->loadport, T_ATOM);

  SCHEME_V->loadport = NIL;
  SCHEME_V->gc_verbose = 0;
  gc (SCHEME_A_ NIL, NIL);

  for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
    free (SCHEME_V->alloc_seg[i]);

#if SHOW_ERROR_LINE
  for (i = 0; i <= SCHEME_V->file_i; i++)
    {
      if (SCHEME_V->load_stack[i].kind & port_file)
        {
          fname = SCHEME_V->load_stack[i].rep.stdio.filename;

          if (fname)
            free (fname);
        }
    }
#endif
}

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

void
scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
{
  dump_stack_reset (SCHEME_A);
  SCHEME_V->envir = SCHEME_V->global_env;
  SCHEME_V->file_i = 0;
  SCHEME_V->load_stack[0].unget = -1;
  SCHEME_V->load_stack[0].kind = port_input | port_file;
  SCHEME_V->load_stack[0].rep.stdio.file = fin;
#if USE_PORTS
  SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
#endif
  SCHEME_V->retcode = 0;

#if USE_PORTS
  if (fin == STDIN_FILENO)
    SCHEME_V->interactive_repl = 1;
#endif

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

  if (fin != STDIN_FILENO && filename)
    SCHEME_V->load_stack[0].rep.stdio.filename = store_string (SCHEME_A_ strlen (filename), filename, 0);
#endif
#endif

  SCHEME_V->inport = SCHEME_V->loadport;
  SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
  Eval_Cycle (SCHEME_A_ OP_T0LVL);
  set_typeflag (SCHEME_V->loadport, T_ATOM);

  if (SCHEME_V->retcode == 0)
    SCHEME_V->retcode = SCHEME_V->nesting != 0;
}

void
scheme_load_string (SCHEME_P_ const char *cmd)
{
  dump_stack_reset (SCHEME_A);
  SCHEME_V->envir = SCHEME_V->global_env;
  SCHEME_V->file_i = 0;
  SCHEME_V->load_stack[0].kind = port_input | port_string;
  SCHEME_V->load_stack[0].rep.string.start = (char *) cmd;      /* This func respects const */
  SCHEME_V->load_stack[0].rep.string.past_the_end = (char *) cmd + strlen (cmd);
  SCHEME_V->load_stack[0].rep.string.curr = (char *) cmd;
#if USE_PORTS
  SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
#endif
  SCHEME_V->retcode = 0;
  SCHEME_V->interactive_repl = 0;
  SCHEME_V->inport = SCHEME_V->loadport;
  SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
  Eval_Cycle (SCHEME_A_ OP_T0LVL);
  set_typeflag (SCHEME_V->loadport, T_ATOM);

  if (SCHEME_V->retcode == 0)
    SCHEME_V->retcode = SCHEME_V->nesting != 0;
}

void
scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
{
  pointer x;

  x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);

  if (x != NIL)
    set_slot_in_env (SCHEME_A_ x, value);
  else
    new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
}

#if !STANDALONE

void
scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
{
  scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
}

void
scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
{
  int i;

  for (i = 0; i < count; i++)
    scheme_register_foreign_func (SCHEME_A_ list + i);
}

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

void
save_from_C_call (SCHEME_P)
{
  pointer saved_data = cons (car (S_SINK),
                             cons (SCHEME_V->envir,
                                   SCHEME_V->dump));

  /* Push */
  SCHEME_V->c_nest = cons (saved_data, SCHEME_V->c_nest);
  /* Truncate the dump stack so TS will return here when done, not
     directly resume pre-C-call operations. */
  dump_stack_reset (SCHEME_A);
}

void
restore_from_C_call (SCHEME_P)
{
  set_car (S_SINK, caar (SCHEME_V->c_nest));
  SCHEME_V->envir = cadar (SCHEME_V->c_nest);
  SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
  /* Pop */
  SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
}

/* "func" and "args" are assumed to be already eval'ed. */
pointer
scheme_call (SCHEME_P_ pointer func, pointer args)
{
  int old_repl = SCHEME_V->interactive_repl;

  SCHEME_V->interactive_repl = 0;
  save_from_C_call (SCHEME_A);
  SCHEME_V->envir = SCHEME_V->global_env;
  SCHEME_V->args = args;
  SCHEME_V->code = func;
  SCHEME_V->retcode = 0;
  Eval_Cycle (SCHEME_A_ OP_APPLY);
  SCHEME_V->interactive_repl = old_repl;
  restore_from_C_call (SCHEME_A);
  return SCHEME_V->value;
}

pointer
scheme_eval (SCHEME_P_ pointer obj)
{
  int old_repl = SCHEME_V->interactive_repl;

  SCHEME_V->interactive_repl = 0;
  save_from_C_call (SCHEME_A);
  SCHEME_V->args = NIL;
  SCHEME_V->code = obj;
  SCHEME_V->retcode = 0;
  Eval_Cycle (SCHEME_A_ OP_EVAL);
  SCHEME_V->interactive_repl = old_repl;
  restore_from_C_call (SCHEME_A);
  return SCHEME_V->value;
}

#endif

/* ========== Main ========== */

#if STANDALONE

int
main (int argc, char **argv)
{
# if USE_MULTIPLICITY
  scheme ssc;
  scheme *const SCHEME_V = &ssc;
# else
# endif
  int fin;
  char *file_name = InitFile;
  int retcode;
  int isfile = 1;

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

  if (!scheme_init (SCHEME_A))
    {
      xwrstr ("Could not initialize!\n");
      return 2;
    }

# if USE_PORTS
  scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
  scheme_set_output_port_file (SCHEME_A_ STDOUT_FILENO);
# endif

  argv++;

#if 0
  if (access (file_name, 0) != 0)
    {
      char *p = getenv ("TINYSCHEMEINIT");

      if (p != 0)
        file_name = p;
    }
#endif

  do
    {
#if USE_PORTS
      if (strcmp (file_name, "-") == 0)
        fin = STDIN_FILENO;
      else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
        {
          pointer args = NIL;

          isfile = file_name[1] == '1';
          file_name = *argv++;

          if (strcmp (file_name, "-") == 0)
            fin = STDIN_FILENO;
          else if (isfile)
            fin = open (file_name, O_RDONLY);

          for (; *argv; argv++)
            {
              pointer value = mk_string (SCHEME_A_ * argv);

              args = cons (value, args);
            }

          args = reverse_in_place (SCHEME_A_ NIL, args);
          scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);

        }
      else
        fin = open (file_name, O_RDONLY);
#endif

      if (isfile && fin < 0)
        {
          xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n");
        }
      else
        {
          if (isfile)
            scheme_load_named_file (SCHEME_A_ fin, file_name);
          else
            scheme_load_string (SCHEME_A_ file_name);

#if USE_PORTS
          if (!isfile || fin != STDIN_FILENO)
            {
              if (SCHEME_V->retcode != 0)
                {
                  xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n");
                }

              if (isfile)
                close (fin);
            }
#endif
        }

      file_name = *argv++;
    }
  while (file_name != 0);

  if (argc == 1)
    scheme_load_named_file (SCHEME_A_ STDIN_FILENO, 0);

  retcode = SCHEME_V->retcode;
  scheme_deinit (SCHEME_A);

  return retcode;
}

#endif

/*
Local variables:
c-file-style: "k&r"
End:
*/
Revision:	1.8
Committed:	Wed Nov 25 22:36:25 2015 UTC (8 years, 7 months ago) by root
Content type:	text/plain
Branch:	MAIN
Changes since 1.7:	+21 -54 lines
Log Message:	* empty log message *