/* This version of TinyScheme was branched at 1.42 from
 * https://sourceforge.net/p/tinyscheme
 * There was reference to authors of MiniScheme from which TinyScheme
 * was created long ago, but nowadays it is somewhat misleading.
 * Many people put efforts to this thing, so please look at the
 * comprehensive list of contributors here:
 * http://tinyscheme.sourceforge.net/credits.html
 */

#define _SCHEME_SOURCE
#ifndef WIN32
#include <unistd.h>
#endif
#ifdef WIN32
#define snprintf _snprintf
#endif
#if USE_DL
#include "dynload.h"
#endif
#if USE_MATH
#include <math.h>
#endif

#include <limits.h>
#include <float.h>
#include <ctype.h>
#include <time.h>
#include <stdbool.h>
#include <iso646.h>
#define isnt !=
#define is ==
#define eq ==

// nullptr
#include <stddef.h>
#ifdef __cplusplus
// nullptr is included since C++11, and everyone uses that?
#elif __STDC_VERSION__ >= 202311L
// nullptr is available in C23
#else
// Just alias it to NULL when unavailable
#define nullptr NULL
#endif

enum token_type {
	TOK_EOF = -1,
	TOK_LPAREN,
	TOK_RPAREN,
	TOK_DOT,
	TOK_ATOM,
	TOK_QUOTE,
	TOK_COMMENT,
	TOK_DQUOTE,
	TOK_BQUOTE,
	TOK_COMMA,
	TOK_ATMARK,
	TOK_SHARP,
	TOK_SHARP_CONST,
	TOK_VEC,
	TOK_BVEC,
};

#define DELIMITERS  "[]()\";\f\t\v\n\r "

/*
 *  Basic memory allocation units
 */

#define OBJ_LIST_SIZE 461

#define VERSION "Teeny Scheme (Come As You Are)"

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

#define str_eq_to_lower(X,Y) (!strcmp((X),(Y)))
#define str_eq(X,Y) (!strcmp((X),(Y)))
#define str_to_maybe_lower(X) (X)

#ifndef PROMPT
#define PROMPT "ts> "
#endif

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

#ifndef LIBDIR
#define LIBDIR "/usr/local/lib/teenyscheme"
#endif

#ifndef FIRST_CELLSEGS
#define FIRST_CELLSEGS 3
#endif

enum scheme_types {
	T_STRING = 1,
	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,
	T_BYTEVECTOR,
	T_STRUCT,
};

/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
#define ADJ 32
#define TYPE_BITS 5
#define T_MASKTYPE      31	/* 0000000000011111 */
#define T_SYNTAX      4096	/* 0001000000000000 */
#define T_IMMUTABLE   8192	/* 0010000000000000 */
#define T_ATOM       16384    /* 0100000000000000 */	/* only for gc */
#define CLRATOM      49151    /* 1011111111111111 */	/* only for gc */
#define MARK         32768	/* 1000000000000000 */
#define UNMARK       32767	/* 0111111111111111 */

// these may be overriden by env properties
static int cell_segsize = CELL_SEGSIZE;
static int cell_nsegment = CELL_NSEGMENT;
static long evalcnt = 0;
#ifdef EVAL_LIMIT
static long eval_limit;
#endif
static char *libdir = LIBDIR;

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_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 inline int
num_is_integer(pointer p)
{
	return ((p)->_object._number.is_fixnum);
}

static num num_zero;
static num num_one;

/* macros for cell operations */
#define typeflag(p)      ((p)->_flag)
#define type(p)          (typeflag(p) & T_MASKTYPE)

INTERFACE bool
is_string(pointer p)
{
	return (type(p) is T_STRING);
}

#define strvalue(p)         ((p)->_object._string._svalue)
#define strlength(p)        ((p)->_object._string._length)

// TODO: Eradicate it in as many places as humanly possible
INTERFACE char *
str2C(char_t *str)
{
#if USE_UNICODE
	size_t length = 0;
	for (size_t i = 0; str[i] != 0; ++i)
		length++;
	length++;
	uint8_t *buff = (uint8_t *) malloc(length * 4), *p = buff;
	for (size_t i = 0; i < length; ++i)
		p += utf8proc_encode_char(str[i], p);
	length = p - buff;
	buff = (uint8_t *) realloc(buff, length + 1);
	buff[length] = '\0';
	return (char *)buff;
#else
	return (char *)str;
#endif
}

#define bvecbytes(p)        ((p)->_object._bvector._bytes)
#define bveclength(p)       ((p)->_object._bvector._length)

#define structlength(p)     ((p)->_object._struct._length)
#define structdata(p)       ((p)->_object._struct._data)
#define structname(p)       ((p)->_object._struct._name)

#define veclength(p)        ((p)->_object._vector._length)
#define vecelems(p)         ((p)->_object._vector._elems)

#define _INTERFACE(RETTYPE, NAME, REAL_NAME, ...)	\
	RETTYPE REAL_NAME(__VA_ARGS__);
#include "interface.h"

INTERFACE bool
is_vector(pointer p)
{
	return (type(p) is T_VECTOR);
}

INTERFACE bool
is_bvector(pointer p)
{
	return (type(p) is T_BYTEVECTOR);
}

INTERFACE uint8_t
bvector_elem(pointer bvec, int ielem)
{
	return bvecbytes(bvec)[ielem];
}

INTERFACE void
set_bvector_elem(pointer bvec, int ielem, uint8_t a)
{
	bvecbytes(bvec)[ielem] = a;
}

INTERFACE bool
is_number(pointer p)
{
	return (type(p) is T_NUMBER);
}

INTERFACE bool
is_integer(pointer p)
{
	if (not is_number(p))
		return 0;
	if (num_is_integer(p) or((double)ivalue(p) == rvalue(p)))
		return 1;
	return 0;
}

INTERFACE bool
is_real(pointer p)
{
	return is_number(p) and not(p)->_object._number.is_fixnum;
}

INTERFACE bool
is_character(pointer p)
{
	return (type(p) is T_CHARACTER);
}

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

inline num
nvalue(pointer p)
{
	return ((p)->_object._number);
}

INTERFACE long long
ivalue(pointer p)
{
	return (num_is_integer(p) ? (p)->_object._number.
		value.ivalue : (long)(p)->_object._number.value.rvalue);
}

INTERFACE double
rvalue(pointer p)
{
	return (not num_is_integer(p) ? (p)->_object._number.
		value.rvalue : (double)(p)->_object._number.value.ivalue);
}

#define ivalue_unchecked(p)       ((p)->_object._number.value.ivalue)
#define rvalue_unchecked(p)       ((p)->_object._number.value.rvalue)
#define set_num_integer(p)   (p)->_object._number.is_fixnum = true;
#define set_num_real(p)      (p)->_object._number.is_fixnum = false;

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

INTERFACE bool
is_port(pointer p)
{
	return (type(p) is T_PORT);
}

INTERFACE bool
is_inport(pointer p)
{
	return is_port(p) and p->_object._port->kind & PORT_INPUT;
}

INTERFACE bool
is_outport(pointer p)
{
	return is_port(p) and p->_object._port->kind & PORT_OUTPUT;
}

INTERFACE bool
is_pair(pointer p)
{
	return (type(p) is T_PAIR);
}

#define car(p)           ((p)->_object._cons._car)
#define cdr(p)           ((p)->_object._cons._cdr)
INTERFACE pointer
pair_car(pointer p)
{
	return car(p);
}

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

INTERFACE pointer
set_car(pointer p, pointer q)
{
	return car(p) = q;
}

INTERFACE pointer
set_cdr(pointer p, pointer q)
{
	return cdr(p) = q;
}

INTERFACE bool
is_symbol(pointer p)
{
	return (type(p) is T_SYMBOL);
}

INTERFACE inline char *
symname(pointer p)
{
	return str2C(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 bool
is_syntax(pointer p)
{
	return (typeflag(p) & T_SYNTAX);
}

INTERFACE bool
is_proc(pointer p)
{
	return (type(p) is T_PROC);
}

INTERFACE bool
is_foreign(pointer p)
{
	return (type(p) is T_FOREIGN);
}

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

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

INTERFACE bool
is_closure(pointer p)
{
	return (type(p) is T_CLOSURE);
}

INTERFACE bool
is_macro(pointer p)
{
	return (type(p) is T_MACRO);
}

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

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

INTERFACE bool
is_continuation(pointer p)
{
	return (type(p) is T_CONTINUATION);
}

#define cont_dump(p)     cdr(p)

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

INTERFACE bool
is_environment(pointer p)
{
	return (type(p) is T_ENVIRONMENT);
}

#define setenvironment(p)    typeflag(p) = T_ENVIRONMENT

#define is_atom(p)       (typeflag(p)&T_ATOM)
#define setatom(p)       typeflag(p) |= T_ATOM
#define clratom(p)       typeflag(p) &= CLRATOM

#define is_mark(p)       (typeflag(p)&MARK)
#define setmark(p)       typeflag(p) |= MARK
#define clrmark(p)       typeflag(p) &= UNMARK

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

/*#define setimmutable(p)  typeflag(p) |= T_IMMUTABLE*/
INTERFACE void
setimmutable(pointer p)
{
	typeflag(p) |= T_IMMUTABLE;
}

#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)))
#define cadaar(p)        car(cdr(car(car(p))))
#define cadddr(p)        car(cdr(cdr(cdr(p))))
#define cddddr(p)        cdr(cdr(cdr(cdr(p))))

#define IS_ASCII(C) (((C) & ~0x7F) == 0)

static int file_push(scheme * sc, const char *fname);
static void file_pop(scheme * sc);
static int file_interactive(scheme * sc);
static inline bool is_one_of(char *s, int c);
static int alloc_cellseg(scheme * sc, int n);
static inline pointer get_cell(scheme * sc, pointer a, pointer b);
static pointer _get_cell(scheme * sc, pointer a, pointer b);
static void finalize_cell(scheme * sc, pointer a);
static pointer find_slot_in_env(scheme * sc, pointer env, pointer sym, int all);
static pointer mk_number(scheme * sc, num n);
static pointer mk_atom(scheme * sc, char *q);
static pointer mk_sharp_const(scheme * sc, char *name);
static pointer mk_port(scheme * sc, port * p);
static pointer port_from_filename(scheme * sc, const char *fn, int prop);
static pointer port_from_file(scheme * sc, FILE *, int prop);
static pointer port_from_string(scheme * sc, char *start, char *past_the_end,
				int prop);
static port *port_rep_from_filename(scheme * sc, const char *fn, int prop);
static port *port_rep_from_file(scheme * sc, FILE *, int prop);
static port *port_rep_from_string(scheme * sc, char *start,
				  char *past_the_end, int prop);
static void port_close(scheme * sc, pointer p, int flag);
static void mark(pointer a);
static void gc(scheme * sc, pointer a, pointer b);
static int basic_inchar(port * pt);
static int inchar(scheme * sc);
static void backchar(scheme * sc, int c);
static char *readstr_upto(scheme * sc, const char *delim);
static pointer readstrexp(scheme * sc);
static inline int skipspace(scheme * sc);
static enum token_type token(scheme * sc);
static void atom2str(scheme * sc, pointer l, int f, char **pp, int *plen);
static void printatom(scheme * sc, pointer l, int f);
static pointer mk_proc(scheme * sc, enum scheme_opcode op);
static pointer mk_closure(scheme * sc, pointer c, pointer e);
static pointer mk_continuation(scheme * sc, pointer d);
static pointer reverse(scheme * sc, pointer a);
static pointer reverse_in_place(scheme * sc, pointer term, pointer list);
static pointer revappend(scheme * sc, pointer a, pointer b);
static void dump_stack_mark(scheme *);
static void eval_cycle(scheme * sc, enum scheme_opcode op);
static void assign_syntax(scheme * sc, const char *name);
static int syntaxnum(pointer p);
static void assign_proc(scheme * sc, enum scheme_opcode, const char *name);

#define num_ivalue(n)       (n.is_fixnum ? (n).value.ivalue : (long)(n).value.rvalue)
#define num_rvalue(n)       (not n.is_fixnum ? (n).value.rvalue : (double)(n).value.ivalue)

static num
num_add(num a, num b)
{
	num ret;
	ret.is_fixnum = a.is_fixnum and b.is_fixnum;
	if (ret.is_fixnum)
		ret.value.ivalue = a.value.ivalue + b.value.ivalue;
	else
		ret.value.rvalue = num_rvalue(a) + num_rvalue(b);
	return ret;
}

static num
num_mul(num a, num b)
{
	num ret;
	ret.is_fixnum = a.is_fixnum and b.is_fixnum;
	if (ret.is_fixnum)
		ret.value.ivalue = a.value.ivalue * b.value.ivalue;
	else
		ret.value.rvalue = num_rvalue(a) * num_rvalue(b);
	return ret;
}

static num
num_div(num a, num b)
{
	num ret;
	ret.is_fixnum =
	    a.is_fixnum and b.is_fixnum
	    and b.value.ivalue != 0 and a.value.ivalue % b.value.ivalue == 0;
	if (ret.is_fixnum)
		ret.value.ivalue = a.value.ivalue / b.value.ivalue;
	else
		ret.value.rvalue = num_rvalue(a) / num_rvalue(b);
	return ret;
}

static num
num_sub(num a, num b)
{
	num ret;
	ret.is_fixnum = a.is_fixnum and b.is_fixnum;
	if (ret.is_fixnum)
		ret.value.ivalue = a.value.ivalue - b.value.ivalue;
	else
		ret.value.rvalue = num_rvalue(a) - num_rvalue(b);
	return ret;
}

static num
num_rem(num a, num b)
{
	num ret;
	long e1, e2, res;
	ret.is_fixnum = a.is_fixnum and b.is_fixnum;
	e1 = num_ivalue(a);
	e2 = num_ivalue(b);
	res = e1 % e2;
	/* remainder should have same sign as first operand */
	if (res > 0) {
		if (e1 < 0) {
			res -= labs(e2);
		}
	} else if (res < 0) {
		if (e1 > 0) {
			res += labs(e2);
		}
	}
	if (ret.is_fixnum)
		ret.value.ivalue = res;
	else
		ret.value.rvalue = res;
	return ret;
}

static num
num_mod(num a, num b)
{
	num ret;
	long e1, e2, res;
	ret.is_fixnum = a.is_fixnum and b.is_fixnum;
	e1 = num_ivalue(a);
	e2 = num_ivalue(b);
	res = e1 % e2;
	/* modulo should have same sign as second operand */
	if ((res < 0) != (e2 < 0) and res) {
		res += e2;
	}
	if (ret.is_fixnum) {
		ret.value.ivalue = res;
	} else {
		ret.value.rvalue = res;
	}
	return ret;
}

static int
num_eq(num a, num b)
{
	int ret;
	int is_fixnum = a.is_fixnum and b.is_fixnum;
	if (is_fixnum) {
		ret = a.value.ivalue == b.value.ivalue;
	} else {
		ret = num_rvalue(a) == num_rvalue(b);
	}
	return ret;
}

static int
num_gt(num a, num b)
{
	int ret;
	int is_fixnum = a.is_fixnum and b.is_fixnum;
	if (is_fixnum) {
		ret = a.value.ivalue > b.value.ivalue;
	} else {
		ret = num_rvalue(a) > num_rvalue(b);
	}
	return ret;
}

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

static int
num_lt(num a, num b)
{
	int ret;
	int is_fixnum = a.is_fixnum and b.is_fixnum;
	if (is_fixnum) {
		ret = a.value.ivalue < b.value.ivalue;
	} else {
		ret = num_rvalue(a) < num_rvalue(b);
	}
	return ret;
}

static int
num_le(num a, num b)
{
	return not 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

/* allocate new cell segment */
static int
alloc_cellseg(scheme *sc, int n)
{
	pointer newp;
	pointer last;
	pointer p;
	char *cp;
	long i;
	size_t adj = ADJ;

	if (adj < sizeof(struct cell))
		adj = sizeof(struct cell);
	for (int k = 0; k < n; k++) {
		if (sc->last_cell_seg >= cell_nsegment - 1)
			return k;
		cp = (char *)sc->malloc(cell_segsize * sizeof(struct cell) +
					adj);
		if (cp is nullptr)
			return k;
		i = ++sc->last_cell_seg;
		sc->alloc_seg[i] = cp;
		/* adjust in TYPE_BITS-bit boundary */
		if (((uintptr_t) cp) % adj != 0) {
			cp = (char *)(adj * ((uintptr_t) cp / adj + 1));
		}
		/* insert new segment in address order */
		newp = (pointer) cp;
		sc->cell_seg[i] = newp;
		while (i > 0 and sc->cell_seg[i - 1] > sc->cell_seg[i]) {
			p = sc->cell_seg[i];
			sc->cell_seg[i] = sc->cell_seg[i - 1];
			sc->cell_seg[--i] = p;
		}
		sc->fcells += cell_segsize;
		last = newp + cell_segsize - 1;
		for (p = newp; p <= last; p++) {
			typeflag(p) = 0;
			cdr(p) = p + 1;
			car(p) = sc->NIL;
		}
		/* insert new cells in address order on free list */
		if (sc->free_cell is sc->NIL or p < sc->free_cell) {
			cdr(last) = sc->free_cell;
			sc->free_cell = newp;
		} else {
			p = sc->free_cell;
			while (cdr(p) isnt sc->NIL and newp > cdr(p))
				p = cdr(p);
			cdr(last) = cdr(p);
			cdr(p) = newp;
		}
	}
	return n;
}

static inline pointer
get_cell_x(scheme *sc, pointer a, pointer b)
{
	if (sc->free_cell isnt sc->NIL) {
		pointer x = sc->free_cell;
		sc->free_cell = cdr(x);
		--sc->fcells;
		return (x);
	}
	return _get_cell(sc, a, b);
}

/* get new cell.  parameter a, b is marked by gc. */
static pointer
_get_cell(scheme *sc, pointer a, pointer b)
{
	if (sc->no_memory)
		return sc->sink;

	if (sc->free_cell is sc->NIL) {
		const int min_to_be_recovered = sc->last_cell_seg * 8;
		gc(sc, a, b);
		if (sc->fcells < min_to_be_recovered
		    or sc->free_cell is sc->NIL) {
			/* if only a few recovered, get more to avoid fruitless gc's */
			if (not alloc_cellseg(sc, 1) and sc->
			    free_cell is sc->NIL) {
				sc->no_memory = true;
				return sc->sink;
			}
		}
	}
	pointer x = sc->free_cell;
	sc->free_cell = cdr(x);
	--sc->fcells;
	return (x);
}

#if USE_INTERFACE
/* make sure that there is a given number of cells free */
INTERFACE pointer
reserve_cells(scheme *sc, int n)
{
	if (sc->no_memory)
		return sc->NIL;

	/* Are there enough cells available? */
	if (sc->fcells < n) {
		/* If not, try gc'ing some */
		gc(sc, sc->NIL, sc->NIL);
		if (sc->fcells < n) {
			/* If there still aren't, try getting more heap */
			if (not alloc_cellseg(sc, 1)) {
				sc->no_memory = true;
				return sc->NIL;
			}
		}
		if (sc->fcells < n) {
			/* If all fail, report failure */
			sc->no_memory = true;
			return sc->NIL;
		}
	}
	return (sc->T);
}
#endif

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

static void
push_recent_alloc(scheme *sc, pointer recent, pointer extra)
{
	pointer holder = get_cell_x(sc, recent, extra);
	typeflag(holder) = T_PAIR | T_IMMUTABLE;
	car(holder) = recent;
	cdr(holder) = car(sc->sink);
	car(sc->sink) = holder;
}

static pointer
get_cell(scheme *sc, pointer a, pointer b)
{
	pointer cell = get_cell_x(sc, 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. */
	typeflag(cell) = T_PAIR;
	car(cell) = a;
	cdr(cell) = b;
	push_recent_alloc(sc, cell, sc->NIL);
	return cell;
}

static inline void
ok_to_freely_gc(scheme *sc)
{
	car(sc->sink) = sc->NIL;
}

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

}

static void
check_range_alloced(pointer p, int n, int expect_alloced)
{
	for (int i = 0; i < n; i++)
		(void)check_cell_alloced(p + i, expect_alloced);
}

#endif

/* Medium level cell allocation */

/* get new cons cell */
pointer
_cons(scheme *sc, pointer a, pointer b, bool immutable)
{
	pointer x = get_cell(sc, a, b);

	typeflag(x) = T_PAIR;
	if (immutable)
		setimmutable(x);
	car(x) = a;
	cdr(x) = b;
	return (x);
}

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

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

static pointer
oblist_initial_value(scheme *sc)
{
	return mk_vector(sc, OBJ_LIST_SIZE);
}

/* returns the new symbol */
static pointer
oblist_add_by_name(scheme *sc, const char *name)
{
	pointer x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
	typeflag(x) = T_SYMBOL;
	setimmutable(car(x));

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

static inline pointer
oblist_find_by_name(scheme *sc, const char *name)
{
	char *s;
	int location = hash_fn(name, veclength(sc->oblist));
	for (pointer x = vector_elem(sc->oblist, location); x isnt sc->NIL;
	     x = cdr(x)) {
		s = symname(car(x));
		if (str_eq_to_lower(name, s))
			return car(x);
	}
	return sc->NIL;
}

static pointer
oblist_all_symbols(scheme *sc)
{
	pointer ob_list = sc->NIL;

	for (size_t i = 0; i < veclength(sc->oblist); i++) {
		for (pointer x = vector_elem(sc->oblist, i); x isnt sc->NIL;
		     x = cdr(x)) {
			ob_list = cons(sc, x, ob_list);
		}
	}
	return ob_list;
}

static pointer
mk_port(scheme *sc, port *p)
{
	pointer x = get_cell(sc, sc->NIL, sc->NIL);

	typeflag(x) = T_PORT | T_ATOM;
	x->_object._port = p;
	return (x);
}

pointer
mk_foreign_func(scheme *sc, foreign_func f)
{
	pointer x = get_cell(sc, sc->NIL, sc->NIL);

	typeflag(x) = (T_FOREIGN | T_ATOM);
	x->_object._ff = f;
	return (x);
}

INTERFACE pointer
mk_character(scheme *sc, int c)
{
	pointer x = get_cell(sc, sc->NIL, sc->NIL);

	typeflag(x) = (T_CHARACTER | T_ATOM);
	ivalue_unchecked(x) = c;
	set_num_integer(x);
	return (x);
}

/* get number atom (integer) */
INTERFACE pointer
mk_integer(scheme *sc, long long num)
{
	pointer x = get_cell(sc, sc->NIL, sc->NIL);

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

INTERFACE pointer
mk_real(scheme *sc, double n)
{
	pointer x = get_cell(sc, sc->NIL, sc->NIL);

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

static pointer
mk_number(scheme *sc, num n)
{
	if (n.is_fixnum)
		return mk_integer(sc, n.value.ivalue);
	else
		return mk_real(sc, n.value.rvalue);
}

/* allocate name to string area */
#if USE_UNICODE
static char_t *
store_string(scheme *sc, size_t len_str, const char *str, int fill)
{
	if (str isnt nullptr) {
		utf8proc_int32_t dummy[1] = { 0 };
		utf8proc_ssize_t size =
		    utf8proc_decompose((utf8proc_uint8_t *) str, len_str, dummy,
				       0, (utf8proc_option_t)0);
		if (size < 0) {
			fprintf(stderr,
				"Unrecognized codepoints in string \"%s\"\n",
				str);
			return nullptr;
		}
		char_t *q = (char_t *)sc->malloc((size + 1) * sizeof(char_t));
		if (q is nullptr)
			return sc->no_memory = true, nullptr;
		utf8proc_decompose((utf8proc_uint8_t *) str, len_str, q, size,
				   (utf8proc_option_t)0);
		q[size] = 0;
		return q;
	} else {
		char_t *q = (char_t *) sc->malloc(len_str * sizeof(char_t));
		if (q is nullptr)
			return sc->no_memory = true, nullptr;
		for (size_t i = 0; i < len_str; ++i)
			q[i] = fill;
		return q;
	}
}
static size_t
store_strlen(UNUSED scheme *sc, size_t len_str, const char *str, UNUSED int fill)
{
	if (str isnt nullptr) {
		utf8proc_int32_t dummy[1] = { 0 };
		utf8proc_ssize_t size =
		    utf8proc_decompose((utf8proc_uint8_t *) str, len_str, dummy,
				       0, (utf8proc_option_t) 0);
		if (size < 0) {
			fprintf(stderr,
				"Unrecognized codepoints in string \"%s\"\n",
				str);
			return 0;
		}
		return size;
	} else {
		return len_str;
	}
}
#else
static char *
store_string(scheme *sc, size_t len_str, const char *str, int fill)
{
	char *q = (char *)sc->malloc(len_str + 1);
	if (q is nullptr) {
		sc->no_memory = 1;
		return sc->strbuff;
	}
	if (str isnt nullptr) {
		snprintf(q, len_str + 1, "%s", str);
	} else {
		memset(q, fill, len_str);
		q[len_str] = 0;
	}
	return (q);
}
static size_t
store_strlen(UNUSED scheme *sc, size_t len_str, UNUSED const char *str, UNUSED int fill)
{
	return len_str;
}
#endif

/* get new string */
INTERFACE pointer
mk_string(scheme *sc, const char *str)
{
	return mk_counted_string(sc, str, strlen(str));
}

INTERFACE pointer
mk_counted_string(scheme *sc, const char *str, size_t len)
{
	pointer x = get_cell(sc, sc->NIL, sc->NIL);
	typeflag(x) = (T_STRING | T_ATOM);
	strvalue(x) = store_string(sc, len, str, ' ');
	strlength(x) = store_strlen(sc, len, str, ' ');
	return (x);
}

INTERFACE pointer
mk_vector(scheme *sc, size_t len)
{
	pointer vec = get_cell(sc, sc->NIL, sc->NIL);
	pointer *elems = (pointer *) sc->malloc(len * sizeof(pointer));
	for (size_t i = 0; i < len; ++i)
		elems[i] = sc->NIL;
	typeflag(vec) = (T_VECTOR | T_ATOM);
	vecelems(vec) = elems;
	veclength(vec) = len;
	return vec;
}

INTERFACE size_t
vector_length(pointer vec)
{
	return veclength(vec);
}

INTERFACE void
fill_vector(pointer vec, pointer obj)
{
	int i;
	int len = veclength(vec);
	for (i = 0; i < len; i++)
		vecelems(vec)[i] = obj;
}

INTERFACE pointer
vector_elem(pointer vec, int ielem)
{
	return vecelems(vec)[ielem];
}

INTERFACE pointer
set_vector_elem(pointer vec, int ielem, pointer a)
{
	return vecelems(vec)[ielem] = a;
}

INTERFACE bool
is_struct(pointer p)
{
	return (type(p) is T_STRUCT);
}

INTERFACE pointer
mk_struct(scheme *sc, pointer sym, size_t len)
{
	pointer *data;
	pointer x = get_cell(sc, sc->NIL, sc->NIL);
	typeflag(x) = (T_STRUCT | T_ATOM);
	structlength(x) = len;
	structname(x) = sym;
	data = (pointer *) sc->malloc(sizeof(pointer) * len);
	for (size_t i = 0; i < len; ++i)
		data[i] = sc->F;
	structdata(x) = data;
	return x;
}

INTERFACE pointer
struct_elem(pointer strct, int ielem)
{
	return structdata(strct)[ielem];
}

INTERFACE void
set_struct_elem(pointer strct, int ielem, pointer a)
{
	structdata(strct)[ielem] = a;
}

INTERFACE pointer
mk_bvector(scheme *sc, size_t len, uint8_t val)
{
	uint8_t *s;
	pointer x = get_cell(sc, sc->NIL, sc->NIL);
	typeflag(x) = (T_BYTEVECTOR | T_ATOM);
	s = (uint8_t *) sc->malloc(len);
	// This used to contain an ominous "if (val >= 0)" check. Why?
	memset(s, val, len);
	bvecbytes(x) = s;
	bveclength(x) = len;
	return x;
}

/* get new symbol */
INTERFACE pointer
mk_symbol(scheme *sc, const char *name)
{
	/* first check oblist */
	pointer x = oblist_find_by_name(sc, name);
	if (x is sc->NIL)
		x = oblist_add_by_name(sc, name);
	return x;
}

INTERFACE pointer
gensym(scheme *sc, char_t *pattern)
{
	pointer x;
	char name[40];

	for (; sc->gensym_cnt < LONG_MAX; sc->gensym_cnt++) {
		snprintf(name, 40, "%s-%ld", (pattern ? str2C(pattern) : "gensym"), sc->gensym_cnt);

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

		if (x isnt sc->NIL) {
			continue;
		} else {
			x = oblist_add_by_name(sc, name);
			return (x);
		}
	}

	return sc->NIL;
}

/* make symbol or number atom from string */
static pointer
mk_atom(scheme *sc, char *q)
{
	char c, *p;
	bool has_dec_point = false;
	bool has_fp_exp = false;

#if USE_COLON_HOOK
	if ((p = strstr(q, "::")) isnt nullptr) {
		*p = 0;
		return cons(sc, sc->COLON_HOOK,
			    cons(sc,
				 cons(sc,
				      sc->QUOTE,
				      cons(sc, mk_atom(sc, p + 2), sc->NIL)),
				 cons(sc, mk_symbol(sc, str_to_maybe_lower(q)),
				      sc->NIL)));
	}
#endif

	p = q;
	c = *p++;
	if ((c is '+') or(c is '-')) {
		if (str_eq(p, "inf.0"))
			return mk_real(sc, (c is '+' ? 1 : -1) / 0.0);
		else if (str_eq(p, "nan.0"))
			return mk_real(sc, 0 / 0.0);
		c = *p++;
		if (c is '.') {
			has_dec_point = true;
			c = *p++;
		}
		if (not isdigit(c)) {
			return (mk_symbol(sc, str_to_maybe_lower(q)));
		}
	} else if (c is '.') {
		has_dec_point = true;
		c = *p++;
		if (not isdigit(c)) {
			return (mk_symbol(sc, str_to_maybe_lower(q)));
		}
	} else if (not isdigit(c)) {
		return (mk_symbol(sc, str_to_maybe_lower(q)));
	}

	for (; (c = *p) != 0; ++p) {
		if (not isdigit(c)) {
			if (c is '.') {
				if (not has_dec_point) {
					has_dec_point = true;
					continue;
				}
			} else if ((c is 'e') or(c is 'E')) {
				if (not has_fp_exp) {
					has_fp_exp = true;
					has_dec_point = true;	/* decimal point illegal further */
					p++;
					if (*p is '-' or * p is '+'
					    or isdigit(*p)) {
						continue;
					}
				}
			}
			return (mk_symbol(sc, str_to_maybe_lower(q)));
		}
	}
	if (has_dec_point) {
		return mk_real(sc, atof(q));
	}
	// Yes, this converts the number twice, but such is the price
	// of precision.
	if (atof(q) > (double)LLONG_MAX)
		return mk_real(sc, atof(q));
	else
		return (mk_integer(sc, atoll(q)));
}

static pointer
mk_sharp_const(scheme *sc, char *name)
{
	if (str_eq_to_lower(name, "t")) {
		return (sc->T);
	} else if (str_eq_to_lower(name, "f")) {
		return (sc->F);
	} else if (*name is '\\') {	/* #\w (character) */
		int c = 0;
		if (str_eq_to_lower(name + 1, "space")) {
			c = ' ';
		} else if (str_eq_to_lower(name + 1, "newline")) {
			c = '\n';
		} else if (str_eq_to_lower(name + 1, "return")) {
			c = '\r';
		} else if (str_eq_to_lower(name + 1, "tab")) {
			c = '\t';
		} else if (name[1] is 'x' and name[2] != 0) {
			int c1 = 0;
			if (sscanf(name + 2, "%x", (unsigned int *)&c1) is 1) {
				c = c1;
			} else {
				return sc->NIL;
			}
		} else if (name[2] == 0) {
			c = name[1];
		} else {
#if USE_UNICODE
			utf8proc_int32_t buf[1] = { 0 };
			utf8proc_decompose((utf8proc_uint8_t *) name + 1,
					   strlen(name + 1), buf, 1,
					   UTF8PROC_NULLTERM);
			c = buf[0];
#else
			return sc->NIL;
#endif
		}
		return mk_character(sc, c);
	} else if (*name is 'x') {	/* #x (hex) */
		return (mk_integer(sc, strtoll(name + 1, nullptr, 16)));
	} else if (*name is 'b') {	/* #b (bin) */
		return (mk_integer(sc, strtoll(name + 1, nullptr, 2)));
	} else if (*name is 'o') {	/* #o (oct) */
		return (mk_integer(sc, strtoll(name + 1, nullptr, 8)));
	} else if (*name is 'd') {	/* #d (dec) */
		return (mk_integer(sc, strtoll(name + 1, nullptr, 10)));
	} else {
		return (sc->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 = (pointer) nullptr, q, p = a;

 E2:	setmark(p);
	if (is_vector(p)) {
		size_t len = veclength(p);
		for (size_t i = 0; i < len; i++) {
			/* Vector cells will be treated like ordinary cells */
			mark(vecelems(p)[i]);
		}
	}
	if (is_atom(p))
		goto E6;
	/* E4: down car */
	q = car(p);
	if (q and not is_mark(q)) {
		setatom(p);	/* a note that we have moved car */
		car(p) = t;
		t = p;
		p = q;
		goto E2;
	}
 E5:	q = cdr(p);		/* down cdr */
	if (q and not is_mark(q)) {
		cdr(p) = t;
		t = p;
		p = q;
		goto E2;
	}
 E6:				/* up.  Undo the link switching from steps E4 and E5. */
	if (not t)
		return;
	q = t;
	if (is_atom(q)) {
		clratom(q);
		t = car(q);
		car(q) = p;
		p = q;
		goto E5;
	} else {
		t = cdr(q);
		cdr(q) = p;
		p = q;
		goto E6;
	}
}

/* garbage collection. parameter a, b is marked. */
static void
gc(scheme *sc, pointer a, pointer b)
{
	if (sc->gc_verbose)
		putstr(sc, "gc...");

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

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

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

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

	/* garbage collect */
	clrmark(sc->NIL);
	sc->fcells = 0;
	sc->free_cell = sc->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 (int i = sc->last_cell_seg; i >= 0; i--) {
		pointer p = sc->cell_seg[i] + cell_segsize;
		while (--p >= sc->cell_seg[i]) {
			if (is_mark(p)) {
				clrmark(p);
			} else {
				/* reclaim cell */
				if (typeflag(p) != 0) {
					finalize_cell(sc, p);
					typeflag(p) = 0;
					car(p) = sc->NIL;
				}
				++sc->fcells;
				cdr(p) = sc->free_cell;
				sc->free_cell = p;
			}
		}
	}

	if (sc->gc_verbose) {
		char msg[80];
		sprintf(msg, "done: %ld cells were recovered.\n", sc->fcells);
		putstr(sc, msg);
	}
}

static void
finalize_cell(scheme *sc, pointer a)
{
	if (is_string(a)) {
		sc->free(strvalue(a));
	} else if (is_vector(a)) {
		for (size_t i = 0; i < veclength(a); ++i)
			finalize_cell(sc, vecelems(a)[i]);
		sc->free(vecelems(a));
	} else if (is_port(a)) {
		if (a->_object._port->kind & PORT_FILE
		    and a->_object._port->rep.stdio.closeit) {
			port_close(sc, a, PORT_INPUT | PORT_OUTPUT);
		}
		sc->free(a->_object._port);
	}
}

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

static int
file_push(scheme *sc, const char *fname)
{
	FILE *fin = nullptr;

	if (sc->file_i == MAXFIL - 1)
		return 0;
	fin = fopen(fname, "r");
	if (fin isnt nullptr) {
		sc->file_i++;
		sc->load_stack[sc->file_i].kind = PORT_FILE | PORT_INPUT;
		sc->load_stack[sc->file_i].rep.stdio.file = fin;
		sc->load_stack[sc->file_i].rep.stdio.closeit = 1;
		sc->nesting_stack[sc->file_i] = 0;
		sc->loadport->_object._port = sc->load_stack + sc->file_i;

#if SHOW_ERROR_LINE
		sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
		if (fname)
			sc->load_stack[sc->file_i].rep.stdio.filename =
			    str2C(store_string(sc, strlen(fname), fname, 0));
#endif
	}
	return fin isnt nullptr;
}

static void
file_pop(scheme *sc)
{
	if (sc->file_i != 0) {
		sc->nesting = sc->nesting_stack[sc->file_i];
		port_close(sc, sc->loadport, PORT_INPUT);
		sc->file_i--;
		sc->loadport->_object._port = sc->load_stack + sc->file_i;
	}
}

static int
file_interactive(scheme *sc)
{
	return sc->interactive_repl
	    and sc->file_i == 0 and sc->load_stack[0].rep.stdio.file is stdin
	    and sc->inport->_object._port->kind & PORT_FILE;
}

static port *
port_rep_from_filename(scheme *sc, const char *fn, int prop)
{
	FILE *f;
	const char *rw;
	port *pt;
	if (prop == (PORT_INPUT | PORT_OUTPUT)) {
		rw = "a+";
	} else if (prop == PORT_OUTPUT) {
		rw = "w";
	} else {
		rw = "r";
	}
	f = fopen(fn, rw);
	if (f is nullptr)
		return nullptr;
	pt = port_rep_from_file(sc, f, prop);
	pt->rep.stdio.closeit = 1;

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

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

static pointer
port_from_filename(scheme *sc, const char *fn, int prop)
{
	port *pt;
	pt = port_rep_from_filename(sc, fn, prop);
	if (pt is nullptr)
		return sc->NIL;
	return mk_port(sc, pt);
}

static port *
port_rep_from_file(scheme *sc, FILE *f, int prop)
{
	port *pt;

	pt = (port *) sc->malloc(sizeof *pt);
	if (pt is nullptr)
		return nullptr;
	pt->kind = PORT_FILE | prop;
	pt->rep.stdio.file = f;
	pt->rep.stdio.closeit = 0;
	return pt;
}

static pointer
port_from_file(scheme *sc, FILE *f, int prop)
{
	port *pt;
	pt = port_rep_from_file(sc, f, prop);
	if (pt is nullptr)
		return sc->NIL;
	return mk_port(sc, pt);
}

static port *
port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop)
{
	port *pt;
	pt = (port *) sc->malloc(sizeof(port));
	if (pt is nullptr)
		return nullptr;
	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 *sc, char *start, char *past_the_end, int prop)
{
	port *pt;
	pt = port_rep_from_string(sc, start, past_the_end, prop);
	if (pt is nullptr)
		return sc->NIL;
	return mk_port(sc, pt);
}

#define BLOCK_SIZE 256

static port *
port_rep_from_scratch(scheme *sc)
{
	port *pt;
	char *start;
	pt = (port *) sc->malloc(sizeof(port));
	if (pt is nullptr)
		return nullptr;
	start = (char *)sc->malloc(BLOCK_SIZE);
	if (start is nullptr)
		return nullptr;
	memset(start, ' ', BLOCK_SIZE - 1);
	start[BLOCK_SIZE - 1] = '\0';
	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 *sc)
{
	port *pt;
	pt = port_rep_from_scratch(sc);
	if (pt is nullptr)
		return sc->NIL;
	return mk_port(sc, pt);
}

static void
port_close(scheme *sc, 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)
				sc->free(pt->rep.stdio.filename);
#endif

			fclose(pt->rep.stdio.file);
		}
		pt->kind = PORT_FREE;
	}
}

/* get new character from input file */
static int
inchar(scheme *sc)
{
	int c;
	port *pt;
	if (sc->backchar >= 0) {
		c = sc->backchar;
		sc->backchar = -1;
		return c;
	}
	pt = sc->inport->_object._port;
	if (pt->kind & PORT_SAW_EOF)
		return EOF;
	c = basic_inchar(pt);
	if (c is EOF and sc->inport is sc->loadport) {
		/* Instead, set PORT_SAW_EOF */
		pt->kind |= PORT_SAW_EOF;
		return EOF;
	}
	return c;
}

static int
inchar8(scheme *sc)
{
	int c;
	port *pt;
	if (sc->backchar >= 0) {
		c = sc->backchar;
		sc->backchar = -1;
		return c;
	}
	pt = sc->inport->_object._port;
	if (pt->kind & PORT_SAW_EOF)
		return EOF;
	c = basic_inchar(pt);
	if (c is EOF and sc->inport is sc->loadport) {
		/* Instead, set PORT_SAW_EOF */
		pt->kind |= PORT_SAW_EOF;
		return EOF;
	}
	return c;
}

static int
basic_inchar(port *pt)
{
	if (pt->kind & PORT_FILE) {
		return fgetc(pt->rep.stdio.file);
	} else {
		if (*pt->rep.string.curr == 0 or
		    pt->rep.string.curr is pt->rep.string.past_the_end) {
			return EOF;
		} else {
			return *pt->rep.string.curr++;
		}
	}
}

/* back character to input buffer */
static void
backchar(scheme *sc, int c)
{
	if (c is EOF)
		return;
	sc->backchar = c;
}

static int
realloc_port_string(scheme *sc, port *p)
{
	char *start = p->rep.string.start;
	size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
	char *str = (char *)sc->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;
		sc->free(start);
		return 1;
	} else {
		return 0;
	}
}

INTERFACE void
putstr(scheme *sc, const char *s)
{
	port *pt = sc->outport->_object._port;
	if (pt->kind & PORT_FILE) {
		fputs(s, pt->rep.stdio.file);
	} else {
		for (; *s; s++) {
			if (pt->rep.string.curr isnt pt->rep.
			    string.past_the_end) {
				*pt->rep.string.curr++ = *s;
			} else if (pt->kind & PORT_SRFI6
				   and realloc_port_string(sc, pt)) {
				*pt->rep.string.curr++ = *s;
			}
		}
	}
}

static void
putchars(scheme *sc, const char *s, int len)
{
	port *pt = sc->outport->_object._port;
	if (pt->kind & PORT_FILE) {
		fwrite(s, 1, len, pt->rep.stdio.file);
	} else {
		for (; len; len--) {
			if (pt->rep.string.curr isnt pt->rep.
			    string.past_the_end) {
				*pt->rep.string.curr++ = *s++;
			} else if (pt->kind & PORT_SRFI6
				   and realloc_port_string(sc, pt)) {
				*pt->rep.string.curr++ = *s++;
			}
		}
	}
}

INTERFACE void
putcharacter(scheme *sc, int c)
{
	port *pt = sc->outport->_object._port;
	if (pt->kind & PORT_FILE) {
		fputc(c, pt->rep.stdio.file);
	} else {
		if (pt->rep.string.curr isnt pt->rep.string.past_the_end) {
			*pt->rep.string.curr++ = c;
		} else if (pt->kind & PORT_SRFI6 and
			   realloc_port_string(sc, pt)) {
			*pt->rep.string.curr++ = c;
		}
	}
}

static int
check_strbuff_size(scheme *sc, char **p)
{
	int len = *p - sc->strbuff;
	if (len + 1 < sc->strbuff_size)
		return 1;
	sc->strbuff_size *= 2;
	if (sc->strbuff_size >= STRBUFF_MAX_SIZE) {
		sc->strbuff_size /= 2;
		return 0;
	}
	char *t = (char *)sc->malloc(sc->strbuff_size);
	memcpy(t, sc->strbuff, len);
	*p = t + len;
	sc->free(sc->strbuff);
	sc->strbuff = t;
	return 1;
}

/* read characters up to delimiter, but cater to character constants */
static char *
readstr_upto(scheme *sc, const char *delim)
{
	char *p = sc->strbuff;
	int c;

	while (1) {
		c = inchar(sc);
		check_strbuff_size(sc, &p);
		*p++ = c;
		if (is_one_of((char *)delim, c)) {
			break;
		}
	}

	if (p == sc->strbuff + 2 and p[-2] is '\\') {
		*p = 0;
	} else {
		backchar(sc, p[-1]);
		*--p = '\0';
	}
	return sc->strbuff;
}

/* read string expression "xxx...xxx" */
static pointer
readstrexp(scheme *sc)
{
	char *p = sc->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(sc);
		if (c is EOF or not check_strbuff_size(sc, &p)) {
			return sc->F;
		}
		switch (state) {
		case st_ok:
			switch (c) {
			case '\\':
				state = st_bsl;
				break;
			case '"':
				*p = 0;
				return mk_counted_string(sc, sc->strbuff,
							 p - sc->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' and c <= 'F') {
				if (c <= '9') {
					c1 = (c1 << 4) + c - '0';
				} else {
					c1 = (c1 << 4) + c - 'A' + 10;
				}
				if (state is st_x1) {
					state = st_x2;
				} else {
					*p++ = c1;
					state = st_ok;
				}
			} else {
				return sc->F;
			}
			break;
		case st_oct1:
		case st_oct2:
			if (c < '0' or c > '7') {
				*p++ = c1;
				backchar(sc, c);
				state = st_ok;
			} else {
				if (state is st_oct2 and c1 >= 32)
					return sc->F;

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

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

		}
	}
}

/* check c is in chars */
static inline bool
is_one_of(char *s, int c)
{
	if (c is EOF)
		return true;
	while (*s)
		if (*s++ is c)
			return true;
	return false;
}

/* skip white characters */
static inline int
skipspace(scheme *sc)
{
	int c = 0, curr_line = 0;

	do {
		c = inchar(sc);
#if SHOW_ERROR_LINE
		if (c is '\n')
			curr_line++;
#endif
	} while (isspace(c));

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

	if (c isnt EOF) {
		backchar(sc, c);
		return 1;
	} else {
		return EOF;
	}
}

/* get token */
static enum token_type
token(scheme *sc)
{
	int c = skipspace(sc);
	if (c is EOF) {
		return (TOK_EOF);
	}
	switch (c = inchar(sc)) {
	case EOF:
		return (TOK_EOF);
	case '(':
	case '[':
		return (TOK_LPAREN);
	case ')':
	case ']':
		return (TOK_RPAREN);
	case '.':
		c = inchar(sc);
		if (is_one_of((char *)" \n\t", c)) {
			return (TOK_DOT);
		} else {
			backchar(sc, c);
			backchar(sc, '.');
			return TOK_ATOM;
		}
	case '\'':
		return (TOK_QUOTE);
	case ';':
		while ((c = inchar(sc)) isnt '\n' and c isnt EOF) {
		}

#if SHOW_ERROR_LINE
		if (c is '\n' and sc->load_stack[sc->file_i].kind & PORT_FILE)
			sc->load_stack[sc->file_i].rep.stdio.curr_line++;
#endif

		if (c is EOF) {
			return (TOK_EOF);
		} else {
			return (token(sc));
		}
	case '"':
		return (TOK_DQUOTE);
	case '`':
		return (TOK_BQUOTE);
	case ',':
		if ((c = inchar(sc)) is '@') {
			return (TOK_ATMARK);
		} else {
			backchar(sc, c);
			return (TOK_COMMA);
		}
	case '#':
		c = inchar(sc);
		if (c is '(' or c is '[') {
			return (TOK_VEC);
		} else if (c is 'u') {
			if (((c = inchar(sc)) is '8' and(c = inchar(sc)) is '(')
			    or c is '[') {
				return TOK_BVEC;
			} else {
				return (TOK_SHARP);
			}
		} else if (c is '!') {
			while ((c = inchar(sc)) isnt '\n' and c isnt EOF) {
			}

#if SHOW_ERROR_LINE
			if (c is '\n'
			    and sc->load_stack[sc->file_i].kind & PORT_FILE)
				sc->load_stack[sc->file_i].rep.
				    stdio.curr_line++;
#endif

			if (c is EOF) {
				return (TOK_EOF);
			} else {
				return (token(sc));
			}
		} else {
			backchar(sc, c);
			if (is_one_of((char *)" tfodxb\\", c)) {
				return TOK_SHARP_CONST;
			} else {
				return (TOK_SHARP);
			}
		}
	default:
		backchar(sc, c);
		return (TOK_ATOM);
	}
}

/* ========== Routines for Printing ========== */
#define   ok_abbrev(x)   (is_pair(x) and cdr(x) is sc->NIL)

void
llong_to_str(long long v, char *s, int base)
{
	if (base == 10) {
		sprintf(s, "%lld", v);
	} else if (base == 16 and v >= 0) {
		sprintf(s, "%llx", v);
	} else if (base == 8 and v >= 0) {
		sprintf(s, "%llo", v);
#if __STDC_VERSION__ >= 202311L
	} else if (base == 2 and v >= 0) {
		sprintf(s, "%llb", v);
#endif
	}
	char *p;
	char c;
	if (v < 0) {
		*s++ = '-';
		v = -v;
	}
	p = s;
	if (v == 0) {
		*s++ = '0';
	}
	while (v > 0) {
		c = (char)(v % base);
		v /= base;
		if (c < 10)
			c += '0';
		else
			c += 'A' - 10;
		*s++ = c;
	}
	*s-- = '\0';
	while (s > p) {
		// Yes, this can be rewritten as
		// c = *p++ = *s-- = c;
		// No, I’m not doing this
		c = *p;
		*p++ = *s;
		*s-- = c;
	}
}

static void
printslashstring(scheme *sc, char_t *p, size_t len)
{
	char_t c;
	char_t *s = p;
	putcharacter(sc, '"');
	for (size_t i = 0; i < len; ++i) {
		c = *s++;
		// printf("%i\n", c);
		if (c is '"' or c < ' ' or c > 255 or c is '\\') {
			putcharacter(sc, '\\');
			switch (c) {
			case '"':
				putcharacter(sc, '"');
				break;
			case '\n':
				putcharacter(sc, 'n');
				break;
			case '\t':
				putcharacter(sc, 't');
				break;
			case '\r':
				putcharacter(sc, 'r');
				break;
			case '\\':
				putcharacter(sc, '\\');
				break;
			default:{
					int digits[4] = {
						(c & 0xF000) >> 12,
						(c & 0x0F00) >> 8,
						(c & 0x00F0) >> 4,
						(c & 0x000F) >> 0,
					};
					putcharacter(sc, 'x');
					// printf("Digits are [%i %i %i %i]\n", digits[0], digits[1], digits[2], digits[3]);
					for (size_t i = 0; i < 4; ++i) {
						if (digits[i] < 10)
							putcharacter(sc,
								     digits[i] +
								     '0');
						else
							putcharacter(sc,
								     digits[i] -
								     10 + 'A');
					}
					putcharacter(sc, ';');
				}
			}
		} else {
			putcharacter(sc, c);
		}
	}
	putcharacter(sc, '"');
}

/* print atoms */
static void
printatom(scheme *sc, pointer l, int f)
{
	char *p;
	int len;
	atom2str(sc, l, f, &p, &len);
	putchars(sc, p, len);
}

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

	*plen = -1;
	if (l is sc->NIL) {
		p = (char *)"()";
	} else if (l is sc->T) {
		p = (char *)"#t";
	} else if (l is sc->F) {
		p = (char *)"#f";
	} else if (l is sc->EOF_OBJ) {
		p = (char *)"#<eof>";
	} else if (is_port(l)) {
		p = (char *)((l->_object._port->kind & PORT_INPUT) ?
			     "#<input-port>" : "#<output-port>");
	} else if (is_number(l)) {
		p = sc->strbuff;
		if (f <= 1 or f == 10) {	/* f is the base for numbers if > 1 */
			if (num_is_integer(l)) {
				sprintf(p, "%lld", ivalue_unchecked(l));
			} else {
				if (rvalue_unchecked(l) * 0.0 != 0.0) {	// is +/-inf or nan
					if (rvalue_unchecked(l) > 0) {
						strcpy(p, "+inf");
					} else if (rvalue_unchecked(l) < 0) {
						strcpy(p, "-inf");
					} else {
						strcpy(p, "+nan");
					}
				} else {
					sprintf(p, "%.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;
				}
			}
		} else {
			long long v = ivalue(l);
			if (f >= 2 and f <= 36) {
				llong_to_str(v, p, f);
			} else {
				*p = '\0';
			}
		}
	} else if (is_string(l)) {
		if (not f) {
			p = str2C(strvalue(l));
			*plen = strlen(p);
		} else {	/* Hack, uses the fact that printing is needed */
			*pp = sc->strbuff;
			*plen = 0;
			printslashstring(sc, strvalue(l), strlength(l));
			return;
		}
	} else if (is_character(l)) {
		char_t c = charvalue(l);
		p = sc->strbuff;
		if (not f) {
			if (c < 32 or c >= 0x80) {
				sprintf(p, "%s", str2C(&(char_t) {
						       c}
					));
			} else {
				sprintf(p, "%c", c);
			}
		} else {
			switch (c) {
			case ' ':
				p = (char *)"#\\space";
				break;
			case '\n':
				p = (char *)"#\\newline";
				break;
			case '\r':
				p = (char *)"#\\return";
				break;
			case '\t':
				p = (char *)"#\\tab";
				break;
			default:
				if (c < 32 or c >= 0x80) {
					sprintf(p, "#\\x%x", c);
					break;
				}
				sprintf(p, "#\\%c", c);
				break;
			}
		}
	} else if (is_symbol(l)) {
		p = symname(l);
	} else if (is_proc(l)) {
		p = sc->strbuff;
		snprintf(p, sc->strbuff_size, "#<procedure %s(%llx) %ud%s>",
			 procname(l), procnum(l), procminarity(l),
			 (procminarity(l) != procmaxarity(l) ? "+" : ""));
	} else if (is_macro(l)) {
		p = (char *)"#<macro>";
	} else if (is_closure(l)) {
		pointer arglist = car(closure_code(l));
		int len = list_length(sc, arglist);
		p = sc->strbuff;
		snprintf(p, sc->strbuff_size, "#<closure %d%s>",
			 (len < 0 ? -len - 2 : len), (len < 0 ? "+" : ""));
	} else if (is_promise(l)) {
		p = (char *)"#<promise>";
	} else if (is_foreign(l)) {
		p = sc->strbuff;
		snprintf(p, sc->strbuff_size, "#<foreign-procedure %lld>",
			 procnum(l));
	} else if (is_continuation(l)) {
		p = (char *)"#<continuation>";
	} else if (is_struct(l)) {
		p = sc->strbuff;
		snprintf(p, sc->strbuff_size, "#<struct %s>",
			 symname(structname(l)));
	} else {
		p = (char *)"#<error>";
	}
	*pp = p;
	if (*plen < 0) {
		*plen = strlen(p);
	}
}

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

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

	typeflag(x) = T_CLOSURE;
	car(x) = c;
	cdr(x) = e;
	return (x);
}

/* make continuation. */
static pointer
mk_continuation(scheme *sc, pointer d)
{
	pointer x = get_cell(sc, sc->NIL, d);

	typeflag(x) = T_CONTINUATION;
	cont_dump(x) = d;
	return (x);
}

static pointer
list_star(scheme *sc, pointer d)
{
	pointer p, q;
	if (cdr(d) is sc->NIL)
		return car(d);
	p = cons(sc, car(d), cdr(d));
	q = p;
	while (cdr(cdr(p)) isnt sc->NIL) {
		d = cons(sc, car(p), cdr(p));
		if (cdr(cdr(p)) isnt sc->NIL) {
			p = cdr(d);
		}
	}
	cdr(p) = car(cdr(p));
	return q;
}

/* reverse list -- produce new list */
static pointer
reverse(scheme *sc, pointer a)
{
/* a must be checked by gc */
	pointer p = sc->NIL;
	for (; is_pair(a); a = cdr(a))
		p = cons(sc, car(a), p);
	return (p);
}

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

	while (p isnt sc->NIL) {
		q = cdr(p);
		cdr(p) = result;
		result = p;
		p = q;
	}
	return (result);
}

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

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

	if (p is sc->NIL)
		return result;

	return sc->F;		/* signal an error */
}

/* equivalence of atoms */
bool
eqv(pointer a, pointer b)
{
	if (is_string(a)) {
		if (is_string(b))
			return (strvalue(a) eq strvalue(b));
		else
			return (0);
	} else if (is_number(a)) {
		if (is_number(b)) {
			if (num_is_integer(a) eq num_is_integer(b))
				return num_eq(nvalue(a), nvalue(b));
		}
		return false;
	} else if (is_character(a)) {
		if (is_character(b)) {
			return charvalue(a) eq charvalue(b);
		} else {
			return false;
		}
	} else if (is_port(a)) {
		if (is_port(b)) {
			return a eq b;
		} else {
			return false;
		}
	} else if (is_proc(a)) {
		if (is_proc(b)) {
			return procnum(a) eq procnum(b);
		} else {
			return false;
		}
	} else {
		return (a is b);
	}
}

/* true or false value macro */
/* () is #t in R5RS */
#define is_true(p)       ((p) isnt sc->F)
#define is_false(p)      ((p) is sc->F)

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

#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)

static int
hash_fn(const char *key, int table_size)
{
	unsigned int hashed = 0;
	const char *c;
	int bits_per_int = sizeof(unsigned int) * 8;

	for (c = key; *c; c++) {
		/* letters have about 5 bits in them */
		hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
		hashed ^= *c;
	}
	return hashed % 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 *sc, pointer old_env)
{
	pointer new_frame;

	/* The interaction-environment has about 300 variables in it. */
	if (old_env is sc->NIL) {
		new_frame = mk_vector(sc, 461);
	} else {
		new_frame = sc->NIL;
	}

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

static inline void
new_slot_spec_in_env(scheme *sc, pointer env, pointer variable, pointer value)
{
	pointer slot = immutable_cons(sc, variable, value);

	if (is_vector(car(env))) {
		int location = hash_fn(symname(variable), veclength(car(env)));

		set_vector_elem(car(env), location,
				immutable_cons(sc, slot,
					       vector_elem(car(env),
							   location)));
	} else {
		car(env) = immutable_cons(sc, slot, car(env));
	}
}

static pointer
find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
{
	pointer x, symbols;
	int location;

	for (x = env; x isnt sc->NIL; x = cdr(x)) {
		if (is_vector(car(x))) {
			location = hash_fn(symname(hdl), veclength(car(x)));
			symbols = vector_elem(car(x), location);
		} else {
			symbols = car(x);
		}
		for (; symbols isnt sc->NIL; symbols = cdr(symbols))
			if (caar(symbols) is hdl)
				break;
		if (symbols isnt sc->NIL)
			break;
		if (not all)
			return sc->NIL;
	}
	if (x isnt sc->NIL)
		return car(symbols);
	return sc->NIL;
}

#else				/* USE_ALIST_ENV */

static inline void
new_frame_in_env(scheme *sc, pointer old_env)
{
	sc->envir = immutable_cons(sc, sc->NIL, old_env);
	setenvironment(sc->envir);
}

static inline void
new_slot_spec_in_env(scheme *sc, pointer env, pointer variable, pointer value)
{
	car(env) =
	    immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
}

static pointer
find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
{
	pointer x, y;
	for (x = env; x isnt sc->NIL; x = cdr(x)) {
		for (y = car(x); y isnt sc->NIL; y = cdr(y))
			if (caar(y) is hdl)
				break;
		if (y isnt sc->NIL)
			break;
		if (not all)
			return sc->NIL;
	}
	if (x isnt sc->NIL)
		return car(y);
	return sc->NIL;
}

#endif				/* USE_ALIST_ENV else */

static inline void
new_slot_in_env(scheme *sc, pointer variable, pointer value)
{
	new_slot_spec_in_env(sc, sc->envir, variable, value);
}

static inline void
set_slot_in_env(pointer slot, pointer value)
{
	cdr(slot) = value;
}

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

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

static const char *opcode_names[] = {
#define _OP_DEF(NAME, MINARITY, MAXARITY, TYPES, OP)	\
	[OP] = NAME,
#include "scheme-ops.h"
};

enum scheme_opcode __opcode__ = (enum scheme_opcode)0;

static pointer
error_(scheme *sc, const char *s, pointer a)
{
	const char *str = s;
#if USE_ERROR_HOOK
	pointer x;
	pointer hdl = sc->ERROR_HOOK;
#endif

#if SHOW_ERROR_LINE
	char sbuf[AUXBUFF_SIZE];

	/* make sure error is not in REPL */
	if (sc->load_stack[sc->file_i].kind & PORT_FILE and
	    sc->load_stack[sc->file_i].rep.stdio.file isnt stdin) {
		int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
		const char *fname =
		    sc->load_stack[sc->file_i].rep.stdio.filename;

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

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

		str = (const char *)sbuf;
	}
#endif

#if USE_ERROR_HOOK
	x = find_slot_in_env(sc, sc->envir, hdl, 1);
	if (x isnt sc->NIL) {
		if (a isnt nullptr) {
			sc->code =
			    cons(sc,
				 cons(sc, sc->QUOTE, cons(sc, (a), sc->NIL)),
				 sc->NIL);
		} else {
			sc->code = sc->NIL;
		}
		sc->code = cons(sc, mk_string(sc, str), sc->code);
		setimmutable(car(sc->code));
		sc->code = cons(sc, slot_value_in_env(x), sc->code);
		sc->op = (int)OP_EVAL;
		return sc->T;
	}
#endif

	if (a isnt nullptr)
		sc->args = cons(sc, (a), sc->NIL);
	else
		sc->args = sc->NIL;
	sc->args = cons(sc, mk_string(sc, str), sc->args);
	setimmutable(car(sc->args));
	sc->op = (int)OP_ERR0;
	return sc->T;
}

static pointer
error_named_(scheme *sc, const char *name, const char *s, pointer a)
{
	char msg[AUXBUFF_SIZE];
	snprintf(msg, AUXBUFF_SIZE, "%s: %s", name, s);
	return error_(sc, msg, a);
}

#define error_1(sc, s, a)  return error_named_(sc, __func__, s, a)
#define error_0(sc, s)     return error_named_(sc, __func__, s, nullptr)
#define error_named_1(sc, s, a)					\
	return error_named_(sc, opcode_names[__opcode__], s, a)
#define error_named_0(sc, s)						\
	return error_named_(sc, opcode_names[__opcode__], s, nullptr)

/* Too small to turn into function */
#define s_goto(sc,a) return (sc->op = (int)(a), sc->T)

#define s_return(sc, value) return _s_return(sc, value, sc->NIL)
#define s_return_values(sc, first, other) return _s_return(sc, first, other)

#ifndef USE_SCHEME_STACK

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

#define STACK_GROWTH 3

static void
s_save(scheme *sc, enum scheme_opcode op, pointer args, pointer code)
{
	int nframes = (int)sc->dump;
	struct dump_stack_frame *next_frame;

	/* enough room for the next frame? */
	if (nframes >= sc->dump_size) {
		sc->dump_size += STACK_GROWTH;
		/* alas there is no sc->realloc */
		sc->dump_base = realloc(sc->dump_base,
					sizeof(struct dump_stack_frame) *
					sc->dump_size);
	}
	next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
	next_frame->op = op;
	next_frame->args = args;
	next_frame->envir = sc->envir;
	next_frame->code = code;
	sc->dump = (pointer) (nframes + 1);
}

static pointer
_s_return(scheme *sc, pointer value, pointer other_values)
{
	int nframes = (int)sc->dump;
	struct dump_stack_frame *frame;

	sc->value = value;
	sc->other_values = other_values;
	if (nframes <= 0)
		return sc->NIL;
	nframes--;
	frame = (struct dump_stack_frame *)sc->dump_base + nframes;
	sc->op = frame->op;
	sc->args = frame->args;
	sc->envir = frame->envir;
	sc->code = frame->code;
	sc->dump = (pointer) nframes;
	return sc->T;
}

static inline void
dump_stack_reset(scheme *sc)
{
	/* in this implementation, sc->dump is the number of frames on the stack */
	sc->dump = (pointer) nullptr;
}

static inline void
dump_stack_initialize(scheme *sc)
{
	sc->dump_size = 0;
	sc->dump_base = nullptr;
	dump_stack_reset(sc);
}

static void
dump_stack_free(scheme *sc)
{
	free(sc->dump_base);
	sc->dump_base = nullptr;
	sc->dump = (pointer) 0;
	sc->dump_size = 0;
}

static inline void
dump_stack_mark(scheme *sc)
{
	int nframes = (int)sc->dump;
	for (int i = 0; i < nframes; i++) {
		struct dump_stack_frame *frame;
		frame = (struct dump_stack_frame *)sc->dump_base + i;
		mark(frame->args);
		mark(frame->envir);
		mark(frame->code);
	}
}

#else

static inline void
dump_stack_reset(scheme *sc)
{
	sc->dump = sc->NIL;
}

static inline void
dump_stack_initialize(scheme *sc)
{
	dump_stack_reset(sc);
}

static void
dump_stack_free(scheme *sc)
{
	sc->dump = sc->NIL;
}

static pointer
_s_return(scheme *sc, pointer value, pointer other_values)
{
	sc->value = value;
	sc->other_values = other_values;
	if (sc->dump is sc->NIL)
		return sc->NIL;
	sc->op = ivalue(car(sc->dump));
	sc->args = cadr(sc->dump);
	sc->envir = caddr(sc->dump);
	sc->code = cadddr(sc->dump);
	sc->dump = cddddr(sc->dump);
	return sc->T;
}

static void
s_save(scheme *sc, enum scheme_opcode op, pointer args, pointer code)
{
	sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
	sc->dump = cons(sc, (args), sc->dump);
	sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
}

static inline void
dump_stack_mark(scheme *sc)
{
	mark(sc->dump);
}
#endif

#define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)

#define check_immutable(x, message) if (is_immutable((x))) error_1(sc, message, x);
#define check_immutable_named(x, message) if (is_immutable((x))) error_named_1(sc, message, x);

#define DEFHANDLER(op, scmname, ...)    \
	static pointer DO_##op(__VA_ARGS__)

DEFHANDLER(OP_LOAD, "load", scheme *sc)
{
	if (file_interactive(sc)) {
		fprintf(sc->outport->_object._port->rep.stdio.file,
			"Loading %s\n", str2C(strvalue(car(sc->args))));
	}
	if (not file_push(sc, str2C(strvalue(car(sc->args))))) {
		error_1(sc, "unable to open", car(sc->args));
	} else {
		sc->args = mk_integer(sc, sc->file_i);
		s_goto(sc, OP_T0LVL);
	}
}

DEFHANDLER(OP_T0LVL, "top level", scheme *sc)
{
	/* If we reached the end of file, this loop is done. */
	if (sc->loadport->_object._port->kind & PORT_SAW_EOF) {
		if (sc->file_i == 0) {
			sc->args = sc->NIL;
			s_goto(sc, OP_QUIT);
		} else {
			file_pop(sc);
			s_return(sc, sc->value);
		}
	}

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

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

DEFHANDLER(OP_T1LVL, "top level", scheme *sc)
{
	sc->code = sc->value;
	sc->inport = sc->save_inport;
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_READ_INTERNAL, "internal read", scheme *sc)
{
	sc->tok = token(sc);
	if (sc->tok is TOK_EOF)
		s_return(sc, sc->EOF_OBJ);
	s_goto(sc, OP_RDSEXPR);
}

DEFHANDLER(OP_VALUEPRINT, "print evaluation result", scheme *sc)
{
	/* OP_VALUEPRINT is always pushed, because when changing from
	   non-interactive to interactive mode, it needs to be
	   already on the stack */
	if (file_interactive(sc)) {
		sc->print_flag = true;
		sc->args = sc->value;
		s_save(sc, OP_VALUEPRINT1, sc->other_values, sc->NIL);
		s_goto(sc, OP_P0LIST);
	} else {
		s_return(sc, sc->value);
	}
}

DEFHANDLER(OP_VALUEPRINT1, "print evaluation results beyond first value",
	   scheme *sc)
{
	if (sc->args is sc->NIL)
		s_return(sc, sc->F);
	putstr(sc, "\n");
	s_save(sc, OP_VALUEPRINT1, cdr(sc->args), sc->NIL);
	sc->value = car(sc->args);
	s_goto(sc, OP_VALUEPRINT);
}

DEFHANDLER(OP_EVAL, "main part of evaluation", scheme *sc)
{

	evalcnt += 1;
#ifdef EVAL_LIMIT
	if (evalcnt >= eval_limit) {
		fprintf(stderr, "Eval steps limit reached: %ld\n", evalcnt);
		exit(7);
	}
#endif
	if (is_symbol(sc->code)) {	/* symbol */
		pointer cell = find_slot_in_env(sc, sc->envir, sc->code, 1);
		if (cell isnt sc->NIL) {
			s_return(sc, slot_value_in_env(cell));
		} else {
			error_1(sc, "eval: unbound variable:", sc->code);
		}
	} else if (is_pair(sc->code)) {
		pointer name;
		if (is_syntax(name = car(sc->code))) {	/* SYNTAX */
			sc->code = cdr(sc->code);
			s_goto(sc, syntaxnum(name));
		} else {	/* first, eval top element and eval arguments */
			s_save(sc, OP_E0ARGS, sc->NIL, sc->code);
			/* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code)); */
			sc->code = car(sc->code);
			s_goto(sc, OP_EVAL);
		}
	} else {
		s_return(sc, sc->code);
	}
}

DEFHANDLER(OP_E0ARGS, "eval arguments", scheme *sc)
{
	if (is_macro(sc->value)) {	/* macro expansion */
		s_save(sc, OP_DOMACRO, sc->NIL, sc->NIL);
		sc->args = cons(sc, sc->code, sc->NIL);
		sc->code = sc->value;
		s_goto(sc, OP_APPLY);
	} else {
		sc->code = cdr(sc->code);
		s_goto(sc, OP_E1ARGS);
	}
}

DEFHANDLER(OP_E1ARGS, "eval arguments", scheme *sc)
{
	sc->args = cons(sc, sc->value, sc->args);
	if (is_pair(sc->code)) {	/* continue */
		s_save(sc, OP_E1ARGS, sc->args, cdr(sc->code));
		sc->code = car(sc->code);
		sc->args = sc->NIL;
		s_goto(sc, OP_EVAL);
	} else {		/* end */
		sc->args = reverse_in_place(sc, sc->NIL, sc->args);
		sc->code = car(sc->args);
		sc->args = cdr(sc->args);
		s_goto(sc, OP_APPLY);
	}
}

DEFHANDLER(OP_APPLY, "apply 'code' to 'args'", scheme *sc)
{
	if (is_proc(sc->code)) {
		s_goto(sc, procnum(sc->code));	/* PROCEDURE */
	} else if (is_foreign(sc->code)) {
		/* Keep nested calls from GC'ing the arglist */
		push_recent_alloc(sc, sc->args, sc->NIL);
		pointer result = sc->code->_object._ff(sc, sc->args);
		s_return(sc, result);
	} else if (is_closure(sc->code) or is_macro(sc->code)
		   or is_promise(sc->code)) {	/* CLOSURE */
		/* Should not accept promise */
		/* make environment */
		new_frame_in_env(sc, closure_env(sc->code));
		pointer initial_params, params, args;
		for (initial_params = params =
		     car(closure_code(sc->code)), args = sc->args;
		     is_pair(params); params = cdr(params)
		     , args = cdr(args)) {
			if (args is sc->NIL) {
				error_1(sc, "not enough arguments for arglist",
					initial_params);
			} else {
				new_slot_in_env(sc, car(params), car(args));
			}
		}
		if (params is sc->NIL) {
			if (args isnt sc->NIL) {
				error_1(sc, "too many arguments for arglist",
					initial_params);
			}
		} else if (is_symbol(params))
			new_slot_in_env(sc, params, args);
		else {
			error_1(sc,
				"syntax error in closure: not a symbol:",
				params);
		}
		sc->code = cdr(closure_code(sc->code));
		sc->args = sc->NIL;
		s_goto(sc, OP_BEGIN);
	} else if (is_continuation(sc->code)) {	/* CONTINUATION */
		sc->dump = cont_dump(sc->code);
		s_return(sc, sc->args isnt sc->NIL ? car(sc->args) : sc->NIL);
	} else {
		error_1(sc, "illegal function", sc->code);
	}
}

DEFHANDLER(OP_DOMACRO, "do macro", scheme *sc)
{
	sc->code = sc->value;
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_LAMBDA, "lambda", scheme *sc)
{

/* If the hook is defined, apply it to sc->code, otherwise
   set sc->value fall thru */
	pointer f = find_slot_in_env(sc, sc->envir, sc->COMPILE_HOOK,
				     1);
	if (f is sc->NIL) {
		sc->value = sc->code;
		s_goto(sc, OP_LAMBDA1);
	} else {
		s_save(sc, OP_LAMBDA1, sc->args, sc->code);
		sc->args = cons(sc, sc->code, sc->NIL);
		sc->code = slot_value_in_env(f);
		s_goto(sc, OP_APPLY);
	}
}

DEFHANDLER(OP_MKCLOSURE, "make-closure", scheme *sc)
{
	pointer env, body = car(sc->args);
	if (car(body) is sc->LAMBDA) {
		body = cdr(body);
	}
	if (cdr(sc->args) is sc->NIL) {
		env = sc->envir;
	} else {
		env = cadr(sc->args);
	}
	s_return(sc, mk_closure(sc, body, env));
}

DEFHANDLER(OP_DEF0, "define", scheme *sc)
{
	check_immutable(car(sc->code), "define: unable to alter immutable");
	pointer name;
	if (is_pair(car(sc->code))) {
		name = caar(sc->code);
		sc->code =
		    cons(sc, sc->LAMBDA,
			 cons(sc, cdar(sc->code), cdr(sc->code)));
	} else {
		name = car(sc->code);
		sc->code = cadr(sc->code);
	}
	if (not is_symbol(name)) {
		error_0(sc, "variable is not a symbol");
	}
	s_save(sc, OP_DEF1, sc->NIL, name);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_DEF1, "define", scheme *sc)
{
	pointer cell = find_slot_in_env(sc, sc->envir, sc->code, 0);
	if (cell isnt sc->NIL)
		set_slot_in_env(cell, sc->value);
	else
		new_slot_in_env(sc, sc->code, sc->value);
	s_return(sc, sc->code);
}

DEFHANDLER(OP_DEFP, "defined?", scheme *sc)
{
	pointer env = sc->envir;
	if (cdr(sc->args) isnt sc->NIL)
		env = cadr(sc->args);
	s_retbool(find_slot_in_env(sc, env, car(sc->args), 1) isnt sc->NIL);
}

DEFHANDLER(OP_SET0, "set!", scheme *sc)
{
	check_immutable(car(sc->code),
			"set!: unable to alter immutable variable");
	s_save(sc, OP_SET1, sc->NIL, car(sc->code));
	sc->code = cadr(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_SET1, "set!", scheme *sc)
{

	pointer cell = find_slot_in_env(sc, sc->envir, sc->code, 1);
	if (cell isnt sc->NIL) {
		set_slot_in_env(cell, sc->value);
		s_return(sc, sc->value);
	} else {
		error_1(sc, "set!: unbound variable:", sc->code);
	}
}

DEFHANDLER(OP_BEGIN, "begin", scheme *sc)
{
	if (not is_pair(sc->code))
		s_return(sc, sc->code);
	if (cdr(sc->code) isnt sc->NIL)
		s_save(sc, OP_BEGIN, sc->NIL, cdr(sc->code));
	sc->code = car(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_IF0, "if", scheme *sc)
{
	s_save(sc, OP_IF1, sc->NIL, cdr(sc->code));
	sc->code = car(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_IF1, "if", scheme *sc)
{
	if (is_true(sc->value))
		sc->code = car(sc->code);
	else
		sc->code = cadr(sc->code);	/* (if #f 1) ==> () because
						 * car(sc->NIL) = sc->NIL */
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_LET0, "let", scheme *sc)
{
	sc->args = sc->NIL;
	sc->value = sc->code;
	sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
	s_goto(sc, OP_LET1);
}

DEFHANDLER(OP_LET1, "let (calculate parameters)", scheme *sc)
{
	sc->args = cons(sc, sc->value, sc->args);
	if (is_pair(sc->code)) {	/* continue */
		if (not is_pair(car(sc->code)) or not is_pair(cdar(sc->code))) {
			error_1(sc,
				"Bad syntax of binding spec in let :",
				car(sc->code));
		}
		s_save(sc, OP_LET1, sc->args, cdr(sc->code));
		sc->code = cadar(sc->code);
		sc->args = sc->NIL;
		s_goto(sc, OP_EVAL);
	} else {		/* end */
		sc->args = reverse_in_place(sc, sc->NIL, sc->args);
		sc->code = car(sc->args);
		sc->args = cdr(sc->args);
		s_goto(sc, OP_LET2);
	}
}

DEFHANDLER(OP_LET2, "let", scheme *sc)
{
	new_frame_in_env(sc, sc->envir);
	for (pointer bindings =
	     is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code),
	     args = sc->args; args isnt sc->NIL;
	     bindings = cdr(bindings), args = cdr(args)) {
		new_slot_in_env(sc, caar(bindings), car(args));
	}
	if (is_symbol(car(sc->code))) {	/* named let */
		pointer bindings, closure;
		for (bindings = cadr(sc->code), sc->args = sc->NIL;
		     bindings isnt sc->NIL; bindings = cdr(bindings)) {
			if (not is_pair(bindings))
				error_1(sc,
					"Bad syntax of binding in let :",
					bindings);
			if (not is_list(sc, car(bindings)))
				error_1(sc,
					"Bad syntax of binding in let :",
					car(bindings));
			sc->args = cons(sc, caar(bindings), sc->args);
		}
		closure = mk_closure(sc,
				     cons(sc,
					  reverse_in_place(sc, sc->NIL,
							   sc->args),
					  cddr(sc->code)), sc->envir);
		new_slot_in_env(sc, car(sc->code), closure);
		sc->code = cddr(sc->code);
		sc->args = sc->NIL;
	} else {
		sc->code = cdr(sc->code);
		sc->args = sc->NIL;
	}
	s_goto(sc, OP_BEGIN);
}

DEFHANDLER(OP_LET0AST, "let*", scheme *sc)
{
	if (car(sc->code) is sc->NIL) {
		new_frame_in_env(sc, sc->envir);
		sc->code = cdr(sc->code);
		s_goto(sc, OP_BEGIN);
	}
	if (not is_pair(car(sc->code)) or not is_pair(caar(sc->code))
	    or not is_pair(cdaar(sc->code))) {
		error_1(sc, "Bad syntax of binding spec in let* :",
			car(sc->code));
	}
	s_save(sc, OP_LET1AST, cdr(sc->code), car(sc->code));
	sc->code = cadaar(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_LET1AST, "let* (make new frame)", scheme *sc)
{
	new_frame_in_env(sc, sc->envir);
	s_goto(sc, OP_LET2AST);
}

DEFHANDLER(OP_LET2AST, "let* (calculate parameters)", scheme *sc)
{
	new_slot_in_env(sc, caar(sc->code), sc->value);
	sc->code = cdr(sc->code);
	if (is_pair(sc->code)) {	/* continue */
		s_save(sc, OP_LET2AST, sc->args, sc->code);
		sc->code = cadar(sc->code);
		sc->args = sc->NIL;
		s_goto(sc, OP_EVAL);
	} else {		/* end */
		sc->code = sc->args;
		sc->args = sc->NIL;
		s_goto(sc, OP_BEGIN);
	}
}

DEFHANDLER(OP_LET0REC, "letrec", scheme *sc)
{
	new_frame_in_env(sc, sc->envir);
	sc->args = sc->NIL;
	sc->value = sc->code;
	sc->code = car(sc->code);
	s_goto(sc, OP_LET1REC);
}

DEFHANDLER(OP_LET1REC, "letrec (calculate parameters)", scheme *sc)
{
	sc->args = cons(sc, sc->value, sc->args);
	if (is_pair(sc->code)) {	/* continue */
		if (not is_pair(car(sc->code)) or not is_pair(cdar(sc->code)))
			error_1(sc,
				"Bad syntax of binding spec in letrec:",
				car(sc->code));
		s_save(sc, OP_LET1REC, sc->args, cdr(sc->code));
		sc->code = cadar(sc->code);
		sc->args = sc->NIL;
		s_goto(sc, OP_EVAL);
	} else {		/* end */
		sc->args = reverse_in_place(sc, sc->NIL, sc->args);
		sc->code = car(sc->args);
		sc->args = cdr(sc->args);
		s_goto(sc, OP_LET2REC);
	}
}

DEFHANDLER(OP_LET2REC, "letrec", scheme *sc)
{
	for (pointer bindings = car(sc->code), args = sc->args;
	     args isnt sc->NIL; bindings = cdr(bindings), args = cdr(args)) {
		new_slot_in_env(sc, caar(bindings), car(args));
	}
	sc->code = cdr(sc->code);
	sc->args = sc->NIL;
	s_goto(sc, OP_BEGIN);
}

DEFHANDLER(OP_COND0, "cond", scheme *sc)
{
	if (not is_pair(sc->code))
		error_0(sc, "syntax error in cond");
	s_save(sc, OP_COND1, sc->NIL, sc->code);
	sc->code = caar(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_COND1, "cond", scheme *sc)
{
	if (is_true(sc->value)) {
		if ((sc->code = cdar(sc->code)) is sc->NIL)
			s_return(sc, sc->value);
		if (not sc->code or car(sc->code) is sc->FEED_TO) {
			if (not is_pair(cdr(sc->code))) {
				error_0(sc, "syntax error in cond");
			}
			pointer expr = cons(sc, sc->QUOTE,
					    cons(sc, sc->value, sc->NIL));
			sc->code =
			    cons(sc, cadr(sc->code), cons(sc, expr, sc->NIL));
			s_goto(sc, OP_EVAL);
		}
		s_goto(sc, OP_BEGIN);
	} else {
		if ((sc->code = cdr(sc->code)) is sc->NIL) {
			s_return(sc, sc->NIL);
		} else {
			s_save(sc, OP_COND1, sc->NIL, sc->code);
			sc->code = caar(sc->code);
			s_goto(sc, OP_EVAL);
		}
	}
}

DEFHANDLER(OP_DELAY, "delay", scheme *sc)
{
	pointer closure =
	    mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
	typeflag(closure) = T_PROMISE;
	s_return(sc, closure);
}

DEFHANDLER(OP_AND0, "and", scheme *sc)
{
	if (sc->code is sc->NIL)
		s_return(sc, sc->T);
	s_save(sc, OP_AND1, sc->NIL, cdr(sc->code));
	sc->code = car(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_AND1, "and", scheme *sc)
{
	if (is_false(sc->value)) {
		s_return(sc, sc->value);
	} else if (sc->code is sc->NIL) {
		s_return(sc, sc->value);
	} else {
		s_save(sc, OP_AND1, sc->NIL, cdr(sc->code));
		sc->code = car(sc->code);
		s_goto(sc, OP_EVAL);
	}
}

DEFHANDLER(OP_OR0, "or", scheme *sc)
{
	if (sc->code is sc->NIL)
		s_return(sc, sc->F);
	s_save(sc, OP_OR1, sc->NIL, cdr(sc->code));
	sc->code = car(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_OR1, "or", scheme *sc)
{
	if (is_true(sc->value)) {
		s_return(sc, sc->value);
	} else if (sc->code is sc->NIL) {
		s_return(sc, sc->value);
	} else {
		s_save(sc, OP_OR1, sc->NIL, cdr(sc->code));
		sc->code = car(sc->code);
		s_goto(sc, OP_EVAL);
	}
}

DEFHANDLER(OP_C0STREAM, "cons-stream", scheme *sc)
{
	s_save(sc, OP_C1STREAM, sc->NIL, cdr(sc->code));
	sc->code = car(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_C1STREAM, "cons-stream", scheme *sc)
{
	sc->args = sc->value;	/* save sc->value to register sc->args for gc */
	pointer closure =
	    mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
	typeflag(closure) = T_PROMISE;
	s_return(sc, cons(sc, sc->args, closure));
}

DEFHANDLER(OP_MACRO0, "macro", scheme *sc)
{
	pointer name;
	if (is_pair(car(sc->code))) {
		name = caar(sc->code);
		sc->code =
		    cons(sc, sc->LAMBDA,
			 cons(sc, cdar(sc->code), cdr(sc->code)));
	} else {
		name = car(sc->code);
		sc->code = cadr(sc->code);
	}
	if (not is_symbol(name))
		error_0(sc, "variable is not a symbol");
	s_save(sc, OP_MACRO1, sc->NIL, name);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_MACRO1, "macro", scheme *sc)
{
	typeflag(sc->value) = T_MACRO;
	pointer cell = find_slot_in_env(sc, sc->envir, sc->code, 0);
	if (cell isnt sc->NIL) {
		set_slot_in_env(cell, sc->value);
	} else {
		new_slot_in_env(sc, sc->code, sc->value);
	}
	s_return(sc, sc->code);
}

DEFHANDLER(OP_CASE0, "case", scheme *sc)
{
	s_save(sc, OP_CASE1, sc->NIL, cdr(sc->code));
	sc->code = car(sc->code);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_CASE1, "case", scheme *sc)
{
	pointer body, clause;
	for (body = sc->code; body isnt sc->NIL; body = cdr(body)) {
		if (not is_pair(clause = caar(body))) {
			break;
		}
		for (; clause isnt sc->NIL; clause = cdr(clause)) {
			if (eqv(car(clause), sc->value))
				break;
		}
		if (clause isnt sc->NIL)
			break;
	}
	if (body isnt sc->NIL) {
		if (is_pair(caar(body))) {
			sc->code = cdar(body);
			s_goto(sc, OP_BEGIN);
		} else {	/* else */
			s_save(sc, OP_CASE2, sc->NIL, cdar(body));
			sc->code = caar(body);
			s_goto(sc, OP_EVAL);
		}
	} else {
		s_return(sc, sc->NIL);
	}
}

DEFHANDLER(OP_CASE2, "case", scheme *sc)
{
	if (is_true(sc->value)) {
		s_goto(sc, OP_BEGIN);
	} else {
		s_return(sc, sc->NIL);
	}
}

DEFHANDLER(OP_PAPPLY, "apply", scheme *sc)
{
	sc->code = car(sc->args);
	sc->args = list_star(sc, cdr(sc->args));
	/*sc->args = cadr(sc->args); */
	s_goto(sc, OP_APPLY);
}

DEFHANDLER(OP_PEVAL, "eval", scheme *sc)
{
	if (cdr(sc->args) isnt sc->NIL)
		sc->envir = cadr(sc->args);
	sc->code = car(sc->args);
	s_goto(sc, OP_EVAL);
}

DEFHANDLER(OP_CONTINUATION, "call-with-current-continuation", scheme *sc)
{
	sc->code = car(sc->args);
	sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
	s_goto(sc, OP_APPLY);
}

DEFHANDLER(OP_VALUES, "values", scheme *sc)
{
	s_return_values(sc, car(sc->args), cdr(sc->args));
}

DEFHANDLER(OP_CALLWV0, "call-with-values (entry)", scheme *sc)
{
	s_save(sc, OP_CALLWV1, sc->NIL, cadr(sc->args));
	sc->code = car(sc->args);
	sc->args = sc->NIL;
	s_goto(sc, OP_APPLY);
}

DEFHANDLER(OP_CALLWV1, "call-with-values (apply the second procedure)",
	   scheme *sc)
{
	sc->args = cons(sc, sc->value, sc->other_values);
	s_goto(sc, OP_APPLY);
}

DEFHANDLER(OP_ADD, "+", scheme *sc)
{
	num v = num_zero;
	for (pointer x = sc->args; x isnt sc->NIL; x = cdr(x))
		v = num_add(v, nvalue(car(x)));
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_MUL, "*", scheme *sc)
{
	num v = num_one;
	for (pointer x = sc->args; x isnt sc->NIL; x = cdr(x))
		v = num_mul(v, nvalue(car(x)));
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_SUB, "-", scheme *sc)
{
	pointer x;
	num v;
	// Single argument: subtract from zero
	if (cdr(sc->args) is sc->NIL) {
		x = sc->args;
		v = num_zero;
	} else {		// Regular args: prepare loop
		x = cdr(sc->args);
		v = nvalue(car(sc->args));
	}
	for (; x isnt sc->NIL; x = cdr(x)) {
		v = num_sub(v, nvalue(car(x)));
	}
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_DIV, "/", scheme *sc)
{
	pointer x;
	num v;
	// Singe arg: reciprocal (1 / x)
	if (cdr(sc->args) is sc->NIL) {
		x = sc->args;
		v = num_one;
	} else {		// Regular division
		x = cdr(sc->args);
		v = nvalue(car(sc->args));
	}
	for (; x isnt sc->NIL; x = cdr(x)) {
		v = num_div(v, nvalue(car(x)));
	}
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_REM, "remainder", scheme *sc)
{
	num v = nvalue(car(sc->args));
	pointer x = cadr(sc->args);
	if (ivalue(x) != 0)
		v = num_rem(v, nvalue(x));
	else
		error_named_0(sc, "division by zero");
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_MOD, "modulo", scheme *sc)
{
	num v = nvalue(car(sc->args));
	pointer x = cadr(sc->args);
	if (ivalue(x) != 0)
		v = num_mod(v, nvalue(x));
	else
		error_named_0(sc, "division by zero");
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_CONS, "cons", scheme *sc)
{
	// Something utterly wrong happens here
	cdr(sc->args) = cadr(sc->args);
	s_return(sc, sc->args);
}

DEFHANDLER(OP_SETCAR, "set-car!", scheme *sc)
{
	check_immutable_named(car(sc->args), "unable to alter immutable pair");
	caar(sc->args) = cadr(sc->args);
	s_return(sc, car(sc->args));
}

DEFHANDLER(OP_SETCDR, "set-cdr!", scheme *sc)
{
	check_immutable_named(car(sc->args), "unable to alter immutable pair");
	cdar(sc->args) = cadr(sc->args);
	s_return(sc, car(sc->args));
}

DEFHANDLER(OP_LIST_LENGTH, "length", scheme *sc)
{
	int len = list_length(sc, car(sc->args));
	if (len < 0)
		error_named_1(sc, "not a list:", car(sc->args));
	s_return(sc, mk_integer(sc, len));
}

DEFHANDLER(OP_APPEND, "append", scheme *sc)
{
	pointer x = sc->NIL;
	pointer y = sc->args;
	if (y is x)
		s_return(sc, x);

	/* cdr() in the while condition is not a typo. If car() */
	/* is used (append '() 'a) will return the wrong result. */
	while (cdr(y) isnt sc->NIL) {
		x = revappend(sc, x, car(y));
		y = cdr(y);
		if (x is sc->F)
			error_named_0(sc, "non-list argument");
	}

	s_return(sc, reverse_in_place(sc, car(y), x));
}

#if USE_PLIST
DEFHANDLER(OP_PUT, "put", scheme *sc)
{
	pointer x;
	if (not hasprop(car(sc->args)) or not hasprop(cadr(sc->args))) {
		error_0(sc, "illegal use of put");
	}
	for (x = symprop(car(sc->args)), y = cadr(sc->args);
	     x isnt sc->NIL; x = cdr(x)) {
		if (caar(x) is y)
			break;
	}
	if (x isnt sc->NIL)
		cdar(x) = caddr(sc->args);
	else
		symprop(car(sc->args)) =
		    cons(sc, cons(sc, y, caddr(sc->args)),
			 symprop(car(sc->args)));
	s_return(sc, sc->T);
}

DEFHANDLER(OP_GET, "get", scheme *sc)
{
	pointer x;
	if (not hasprop(car(sc->args)) or not hasprop(cadr(sc->args))) {
		error_0(sc, "illegal use of get");
	}
	for (x = symprop(car(sc->args)), y = cadr(sc->args);
	     x isnt sc->NIL; x = cdr(x)) {
		if (caar(x) is y)
			break;
	}
	if (x isnt sc->NIL) {
		s_return(sc, cdar(x));
	} else {
		s_return(sc, sc->NIL);
	}
}
#endif				/* USE_PLIST */
DEFHANDLER(OP_CHAR2INT, "char->integer", scheme *sc)
{
	char_t c = charvalue(car(sc->args));
	s_return(sc, mk_integer(sc, c));
}

DEFHANDLER(OP_INT2CHAR, "integer->char", scheme *sc)
{
	char_t c = ivalue(car(sc->args));
	s_return(sc, mk_character(sc, c));
}

DEFHANDLER(OP_CHARUPCASE, "char-upcase", scheme *sc)
{
	char_t c = charvalue(car(sc->args));
#if USE_UNICODE
	s_return(sc, mk_character(sc, utf8proc_toupper(c)));
#else
	s_return(sc, mk_character(sc, toupper(c)));
#endif
}

DEFHANDLER(OP_CHARDNCASE, "char-downcase", scheme *sc)
{
	char_t c = charvalue(car(sc->args));
#if USE_UNICODE
	s_return(sc, mk_character(sc, utf8proc_tolower(c)));
#else
	s_return(sc, mk_character(sc, tolower(c)));
#endif
}

DEFHANDLER(OP_STR2SYM, string->symbol, scheme *sc)
{
	s_return(sc, mk_symbol(sc, str2C(strvalue(car(sc->args)))));
}

DEFHANDLER(OP_STR2ATOM, string->atom, scheme *sc)
{
	char *s = str2C(strvalue(car(sc->args)));
	long pf = 0;
	if (cdr(sc->args) isnt sc->NIL) {
		/* we know cadr(sc->args) is a natural number */
		/* see if it is 2, 8, 10, or 16, or error */
		pf = ivalue_unchecked(cadr(sc->args));
		if (pf < 2 or pf > 36) {
			pf = -1;
		}
	}
	if (pf < 0) {
		error_1(sc, "string->atom: bad base:", cadr(sc->args));
	} else if (*s is '#') {	/* no use of base! */
		s_return(sc, mk_sharp_const(sc, s + 1));
	} else {
		if (pf == 0 or pf == 10) {
			s_return(sc, mk_atom(sc, s));
		} else {
			char *ep;
			long iv = strtoll(s, &ep, (int)pf);
			if (*ep == 0) {
				s_return(sc, mk_integer(sc, iv));
			} else {
				s_return(sc, sc->F);
			}
		}
	}
}

DEFHANDLER(OP_SYM2STR, symbol->string, scheme *sc)
{
	pointer x = mk_string(sc, symname(car(sc->args)));
	setimmutable(x);
	s_return(sc, x);
}

DEFHANDLER(OP_ATOM2STR, "atom->string", scheme *sc)
{
	long pf = 0;
	pointer x = car(sc->args);
	pointer y = cdr(sc->args);
	if (y isnt sc->NIL) {
		/* we know cadr(sc->args) is a natural number */
		/* see if it is 2, 8, 10, or 16, or error */
		y = car(y);
		pf = ivalue_unchecked(y);
		if (not is_number(x) or pf < 2 or pf > 36) {
			pf = -1;
		}
	}
	if (pf < 0) {
		error_named_1(sc, "bad base:", y);
	} else if (is_number(x) or is_character(x)
		   or is_string(x)
		   or is_symbol(x)) {
		char *p;
		int len;
		atom2str(sc, x, (int)pf, &p, &len);
		s_return(sc, mk_counted_string(sc, p, len));
	} else {
		error_named_1(sc, "not an atom:", x);
	}
}

DEFHANDLER(OP_MKSTRING, "make-string", scheme *sc)
{
	char_t fill = ' ';
	size_t len = ivalue(car(sc->args));

	if (cdr(sc->args) isnt sc->NIL)
		fill = charvalue(cadr(sc->args));
	pointer p = mk_counted_string(sc, "", len);
	char_t *s = strvalue(p);
	for (size_t i = 0; i < len; ++i)
		s[i] = fill;
	s[len] = '\0';
	s_return(sc, p);
}

DEFHANDLER(OP_STRREF, "string-ref", scheme *sc)
{
	char_t *str = strvalue(car(sc->args));
	pointer x = cadr(sc->args);

	if (not is_integer(x))
		error_named_1(sc, "index must be exact:", x);

	size_t index = ivalue(x);
	if (index >= strlength(car(sc->args)))
		error_named_1(sc, "out of bounds:", x);

	s_return(sc, mk_character(sc, str[index]));
}

DEFHANDLER(OP_STRSET, "string-set!", scheme *sc)
{
	pointer x = car(sc->args);
	check_immutable_named(x, "unable to alter immutable string:");
	char_t *str = strvalue(x);

	pointer y = cadr(sc->args);
	if (not is_integer(y))
		error_named_1(sc, "index must be exact:", y);

	size_t index = ivalue(y);
	if (index >= strlength(x))
		error_named_1(sc, "out of bounds:", y);

	int c = charvalue(caddr(sc->args));

	str[index] = (char)c;
	s_return(sc, x);
}

DEFHANDLER(OP_STRAPPEND, "string-append", scheme *sc)
{
	size_t len = 0;
	for (pointer args = sc->args; args isnt sc->NIL; args = cdr(args))
		len += strlength(car(args));
	pointer newstr = mk_counted_string(sc, "", len);
	char_t *data = strvalue(newstr);
	// store the contents of the argument strings into the new string
	for (pointer args = sc->args; args isnt sc->NIL; args = cdr(args)) {
		size_t arg1len = strlength(car(args));
		memcpy(data, strvalue(car(args)), arg1len * sizeof(char_t));
		data += arg1len;
	}
	s_return(sc, newstr);
}

DEFHANDLER(OP_SUBSTR, "substring", scheme *sc)
{
	char_t *str = strvalue(car(sc->args));
	size_t index0 = ivalue(cadr(sc->args));
	size_t index1;

	if (index0 > strlength(car(sc->args))) {
		error_named_1(sc, "start out of bounds:", cadr(sc->args));
	}

	if (cddr(sc->args) isnt sc->NIL) {
		index1 = ivalue(caddr(sc->args));
		if (index1 > strlength(car(sc->args))
		    or index1 < index0) {
			error_named_1(sc,
				      "end out of bounds:", caddr(sc->args));
		}
	} else {
		index1 = strlength(car(sc->args));
	}

	size_t len = index1 - index0;
	pointer x = mk_counted_string(sc, "", len);

	memcpy(strvalue(x), str + index0, len * sizeof(char_t));
	strvalue(x)[len] = '\0';

	s_return(sc, x);
}

DEFHANDLER(OP_VECTOR, "vector", scheme *sc)
{
	int i;
	pointer vec;
	pointer x;
	int len = list_length(sc, sc->args);
	if (len < 0) {
		error_named_1(sc, "not a proper list:", sc->args);
	}
	vec = mk_vector(sc, len);
	if (sc->no_memory) {
		s_return(sc, sc->sink);
	}
	for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
		set_vector_elem(vec, i, car(x));
	}
	s_return(sc, vec);
}

DEFHANDLER(OP_MKVECTOR, "make-vector", scheme *sc)
{
	pointer fill = sc->NIL;
	pointer vec;

	int len = ivalue(car(sc->args));

	if (cdr(sc->args) isnt sc->NIL)
		fill = cadr(sc->args);
	vec = mk_vector(sc, len);
	if (sc->no_memory)
		s_return(sc, sc->sink);
	if (fill isnt sc->NIL)
		fill_vector(vec, fill);
	s_return(sc, vec);
}

DEFHANDLER(OP_VECREF, "vector-ref", scheme *sc)
{
	pointer x = cadr(sc->args);
	if (not is_integer(x))
		error_named_1(sc, "index must be exact:", x);
	size_t index = ivalue(x);

	if (index >= veclength(car(sc->args)))
		error_named_1(sc, "out of bounds:", x);

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

DEFHANDLER(OP_VECSET, "vector-set!", scheme *sc)
{
	check_immutable_named(car(sc->args),
			      "unable to alter immutable vector:");

	pointer x = cadr(sc->args);
	if (not is_integer(x))
		error_named_1(sc, "index must be exact:", x);

	int index = ivalue(x);
	if (index >= ivalue(car(sc->args)))
		error_named_1(sc, "out of bounds:", x);

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

DEFHANDLER(OP_BVECTOR, "bytevector", scheme *sc)
{
	int i;
	pointer bvec, x;
	int len = list_length(sc, sc->args);
	if (len < 0)
		error_named_1(sc, "not a proper list:", sc->args);
	bvec = mk_bvector(sc, len, 0);
	if (sc->no_memory)
		s_return(sc, sc->sink);
	for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++)
		set_bvector_elem(bvec, i, ivalue(car(x)));
	s_return(sc, bvec);
}

DEFHANDLER(OP_MKBVECTOR, "make-bytevector", scheme *sc)
{
	uint8_t fill = 0;
	pointer vec;
	size_t len = ivalue(car(sc->args));

	if (cdr(sc->args) isnt sc->NIL)
		fill = ivalue(cadr(sc->args));
	vec = mk_bvector(sc, len, fill);
	if (sc->no_memory)
		s_return(sc, sc->sink);
	s_return(sc, vec);
}

DEFHANDLER(OP_BVECREF, "bytevector-u8-ref", scheme *sc)
{
	pointer x = cadr(sc->args);
	if (not is_integer(x))
		error_named_1(sc, "index must be exact:", x);
	size_t index = ivalue(x);

	if (index >= (size_t)ivalue(car(sc->args)))
		error_named_1(sc, "out of bounds:", x);

	s_return(sc, mk_integer(sc, bvector_elem(car(sc->args), index)));
}

DEFHANDLER(OP_BVECSET, "bytevector-u8-set!", scheme *sc)
{
	pointer x = car(sc->args);
	check_immutable(x, "unable to alter immutable data:");
	pointer y = cadr(sc->args);
	if (not is_integer(y))
		error_named_1(sc, "index must be exact:", y);

	size_t index = ivalue(y);
	if (index >= bveclength(x))
		error_named_1(sc, "out of bounds:", y);

	set_bvector_elem(x, index, ivalue(caddr(sc->args)));
	s_return(sc, x);
}

DEFHANDLER(OP_BVECLEN, "bytevector-length", scheme *sc)
{
	s_return(sc, mk_integer(sc, bveclength(car(sc->args))));
}

DEFHANDLER(OP_STRUCT, "struct", scheme *sc)
{
	int i;
	pointer x, name = car(sc->args);
	int len = list_length(sc, cdr(sc->args));
	if (len < 0)
		error_named_1(sc, "not a proper list:", sc->args);
	pointer strct = mk_struct(sc, name, len);
	if (sc->no_memory)
		s_return(sc, sc->sink);
	for (x = cdr(sc->args), i = 0; is_pair(x); x = cdr(x), i++)
		set_struct_elem(strct, i, car(x));
	s_return(sc, strct);
}

DEFHANDLER(OP_MKSTRUCT, "make-struct", scheme *sc)
{
	// TODO: fill?
	pointer name = car(sc->args);
	int len = ivalue(cadr(sc->args));
	pointer strct = mk_struct(sc, name, len);
	if (sc->no_memory)
		s_return(sc, sc->sink);
	s_return(sc, strct);
}

DEFHANDLER(OP_STRUCTREF, "struct-ref", scheme *sc)
{
	pointer x = cadr(sc->args);
	if (not is_integer(x))
		error_named_1(sc, "index must be exact:", x);
	size_t index = ivalue(x);

	if (index >= structlength(car(sc->args)))
		error_named_1(sc, "out of bounds:", x);

	s_return(sc, struct_elem(car(sc->args), index));
}

DEFHANDLER(OP_STRUCTSET, "struct-set!", scheme *sc)
{
	check_immutable_named(car(sc->args),
			      "unable to alter immutable struct:");
	pointer x = cadr(sc->args);
	if (not is_integer(x))
		error_named_1(sc, "index must be exact:", x);

	int index = ivalue(x);
	if (index >= ivalue(car(sc->args)))
		error_named_1(sc, "out of bounds:", x);

	set_struct_elem(car(sc->args), index, caddr(sc->args));
	s_return(sc, car(sc->args));
}

#if USE_MATH
DEFHANDLER(OP_INEX2EX, "exact", scheme *sc)
{
	pointer x = car(sc->args);
	if (num_is_integer(x)) {
		s_return(sc, x);
	} else if (modf(rvalue_unchecked(x), &(double) { 0.0 }) == 0.0) {
		s_return(sc, mk_integer(sc, ivalue(x)));
	} else {
		error_1(sc, "argument not integral:", x);
	}
	// Just to shut up the compiler
	return nullptr;
}

DEFHANDLER(OP_ATAN, "atan", scheme *sc)
{
	pointer x = car(sc->args);
	if (cdr(sc->args) is sc->NIL) {
		s_return(sc, mk_real(sc, atan(rvalue(x))));
	} else {
		pointer y = cadr(sc->args);
		s_return(sc, mk_real(sc, atan2(rvalue(x), rvalue(y))));
	}
}

DEFHANDLER(OP_EXPT, "expt", scheme *sc)
{
	double result;
	int real_result = 1;
	pointer x = car(sc->args);
	pointer y = cadr(sc->args);
	if (num_is_integer(x) and num_is_integer(y))
		real_result = 0;
	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 (not real_result) {
		long result_as_long = (long)result;
		if (result != (double)result_as_long)
			real_result = 1;
	}
	if (real_result)
		s_return(sc, mk_real(sc, result));
	else
		s_return(sc, mk_integer(sc, (long long)result));
}

DEFHANDLER(OP_ROUND, "round", scheme *sc)
{
	pointer x = car(sc->args);
	if (num_is_integer(x))
		s_return(sc, x);
	s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
}
#endif

bool
is_list(scheme *sc, pointer a)
{
	return list_length(sc, a) >= 0;
}

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

	slow = fast = a;
	while (1) {
		if (fast is sc->NIL)
			return i;
		if (not is_pair(fast))
			return -2 - i;
		fast = cdr(fast);
		++i;
		if (fast is sc->NIL)
			return i;
		if (not 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 is 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;
		}
	}
}

DEFHANDLER(OP_NOT, "not", scheme *sc)
{
	s_retbool(is_false(car(sc->args)));
}

DEFHANDLER(OP_BOOLP, "boolean?", scheme *sc)
{
	s_retbool(car(sc->args) is sc->F or car(sc->args) is sc->T);
}

DEFHANDLER(OP_EOFOBJP, "eof-object?", scheme *sc)
{
	s_retbool(car(sc->args) is sc->EOF_OBJ);
}

DEFHANDLER(OP_NULLP, "null?", scheme *sc)
{
	s_retbool(car(sc->args) is sc->NIL);
}

pointer
help_compare(scheme *sc, int (*comp_func)(num, num))
{
	pointer x = sc->args;
	num v = nvalue(car(x));
	x = cdr(x);

	for (; x isnt sc->NIL; x = cdr(x)) {
		if (not comp_func(v, nvalue(car(x))))
			s_retbool(false);
		v = nvalue(car(x));
	}
	s_retbool(true);
}

DEFHANDLER(OP_NUMEQ, "=", scheme *sc)
{
	return help_compare(sc, num_eq);
}

DEFHANDLER(OP_LESS, "<", scheme *sc)
{
	return help_compare(sc, num_lt);
}

DEFHANDLER(OP_GRE, ">", scheme *sc)
{
	return help_compare(sc, num_gt);
}

DEFHANDLER(OP_LEQ, "<=", scheme *sc)
{
	return help_compare(sc, num_le);
}

DEFHANDLER(OP_GEQ, ">=", scheme *sc)
{
	return help_compare(sc, num_ge);
}

DEFHANDLER(OP_SYMBOLP, "symbol?", scheme *sc)
{
	s_retbool(is_symbol(car(sc->args)));
}

DEFHANDLER(OP_NUMBERP, "number?", scheme *sc)
{
	s_retbool(is_number(car(sc->args)));
}

DEFHANDLER(OP_STRINGP, "string?", scheme *sc)
{
	s_retbool(is_string(car(sc->args)));
}

DEFHANDLER(OP_INTEGERP, "integer?", scheme *sc)
{
	s_retbool(is_integer(car(sc->args)));
}

DEFHANDLER(OP_REALP, "real?", scheme *sc)
{
	s_retbool(is_number(car(sc->args)));	/* All numbers are real */
}

DEFHANDLER(OP_CHARP, "char?", scheme *sc)
{
	s_retbool(is_character(car(sc->args)));
}

#if USE_CHAR_CLASSIFIERS
DEFHANDLER(OP_CHARAP, "char-alphabetic?", scheme *sc)
{
#if USE_UNICODE
	utf8proc_category_t category =
	    utf8proc_category(charvalue(car(sc->args)));
	s_retbool(category is UTF8PROC_CATEGORY_LU or category is
		  UTF8PROC_CATEGORY_LL or category is UTF8PROC_CATEGORY_LT or
		  category is UTF8PROC_CATEGORY_LM or category is
		  UTF8PROC_CATEGORY_LO);
#else
	s_retbool(isalpha(charvalue(car(sc->args))));
#endif
}

DEFHANDLER(OP_CHARNP, "char-numeric?", scheme *sc)
{
#if USE_UNICODE
	s_retbool(utf8proc_category(charvalue(car(sc->args))) is
		  UTF8PROC_CATEGORY_ND);
#else
	s_retbool(isdigit(charvalue(car(sc->args))));
#endif
}

// TODO: Move to Unicode
DEFHANDLER(OP_CHARWP, "char-whitespace?", scheme *sc)
{
#if USE_UNICODE
	s_retbool(utf8proc_category(charvalue(car(sc->args))) is
		  UTF8PROC_CATEGORY_ZS);
#else
	s_retbool(isspace(charvalue(car(sc->args))));
#endif
}

DEFHANDLER(OP_CHARUP, "char-upper-case?", scheme *sc)
{
#if USE_UNICODE
	s_retbool(utf8proc_category(charvalue(car(sc->args))) is
		  UTF8PROC_CATEGORY_LU);
#else
	s_retbool(isupper(charvalue(car(sc->args))));
#endif
}

DEFHANDLER(OP_CHARLP, "char-lower-case?", scheme *sc)
{
#if USE_UNICODE
	s_retbool(utf8proc_category(charvalue(car(sc->args))) is
		  UTF8PROC_CATEGORY_LL);
#else
	s_retbool(islower(charvalue(car(sc->args))));
#endif
}
#endif
DEFHANDLER(OP_PORTP, "port?", scheme *sc)
{
	s_retbool(is_port(car(sc->args)));
}

DEFHANDLER(OP_INPORTP, "input-port?", scheme *sc)
{
	s_retbool(is_inport(car(sc->args)));
}

DEFHANDLER(OP_OUTPORTP, "output-port?", scheme *sc)
{
	s_retbool(is_outport(car(sc->args)));
}

INTERFACE bool
is_procedure(pointer p)
{
	return is_proc(p) or is_closure(p) or is_foreign(p) or
	    is_continuation(p);
}

DEFHANDLER(OP_PROCP, "procedure?", scheme *sc)
{
	  /*--
              * continuation should be procedure by the example
              * (call-with-current-continuation procedure?) ==> #t
                 * in R^3 report sec. 6.9
              */
	s_retbool(is_procedure(car(sc->args)));
}

DEFHANDLER(OP_PAIRP, "pair?", scheme *sc)
{
	s_retbool(is_pair(car(sc->args)));
}

DEFHANDLER(OP_LISTP, "list?", scheme *sc)
{
	s_retbool(list_length(sc, car(sc->args)) >= 0);
}

DEFHANDLER(OP_ENVP, "environment?", scheme *sc)
{
	s_retbool(is_environment(car(sc->args)));
}

DEFHANDLER(OP_VECTORP, "vector?", scheme *sc)
{
	s_retbool(is_vector(car(sc->args)));
}

DEFHANDLER(OP_BVECTORP, "bytevector?", scheme *sc)
{
	s_retbool(is_bvector(car(sc->args)));
}

DEFHANDLER(OP_STRUCTP, "struct?", scheme *sc)
{
	s_retbool(is_struct(car(sc->args)));
}

DEFHANDLER(OP_EQ, "eq?", scheme *sc)
{
	s_retbool(car(sc->args) is cadr(sc->args));
}

DEFHANDLER(OP_EQV, "eqv?", scheme *sc)
{
	s_retbool(eqv(car(sc->args), cadr(sc->args)));
}

DEFHANDLER(OP_CURR_SEC, "current-second", scheme *sc)
{
	num v = {.is_fixnum = true,.value = {.rvalue = time(nullptr)}
	};
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_EVAL_CNT, "eval-count", scheme *sc)
{
	num v = {.is_fixnum = true,.value = {.ivalue = evalcnt}
	};
	s_return(sc, mk_number(sc, v));
}

DEFHANDLER(OP_FORCE, "force", scheme *sc)
{
	sc->code = car(sc->args);
	if (is_promise(sc->code)) {
		/* Should change type to closure here */
		s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
		sc->args = sc->NIL;
		s_goto(sc, OP_APPLY);
	} else {
		s_return(sc, sc->code);
	}
}

DEFHANDLER(OP_SAVE_FORCED, "save forced value replacing promise", scheme *sc)
{
	memcpy(sc->code, sc->value, sizeof(struct cell));
	s_return(sc, sc->value);
}

#define redirect_output()						\
 	if (is_pair(cdr(sc->args))) {					\
		if (cadr(sc->args) isnt sc->outport) {			\
			pointer x##__LINE__ = cons(sc, sc->outport, sc->NIL); \
			s_save(sc, OP_SET_OUTPORT, x##__LINE__, sc->NIL); \
			sc->outport = cadr(sc->args);			\
		}							\
	}
pointer
write_helper(scheme *sc, int print_flag)
{
	redirect_output();
	sc->args = car(sc->args);
	sc->print_flag = print_flag;
	s_goto(sc, OP_P0LIST);
}

DEFHANDLER(OP_WRITE, "write", scheme *sc)
{
	return write_helper(sc, 1);
}

DEFHANDLER(OP_DISPLAY, "display", scheme *sc)
{
	return write_helper(sc, 0);
}

DEFHANDLER(OP_WRITE_CHAR, "write-char", scheme *sc)
{
	return write_helper(sc, 0);
}

DEFHANDLER(OP_WRITE_U8, "write-u8", scheme *sc)
{
	redirect_output();
	putcharacter(sc, ivalue(car(sc->args)));
	s_return(sc, sc->T);
}

DEFHANDLER(OP_NEWLINE, "newline", scheme *sc)
{
	redirect_output();
	putstr(sc, "\n");
	s_return(sc, sc->T);
}

DEFHANDLER(OP_ERR0, "error", scheme *sc)
{
	sc->retcode = -1;
	if (not is_string(car(sc->args))) {
		sc->args = cons(sc, mk_string(sc, " -- "), sc->args);
		setimmutable(car(sc->args));
	}
	putstr(sc, "Error: ");
	putstr(sc, str2C(strvalue(car(sc->args))));
	sc->args = cdr(sc->args);
	s_goto(sc, OP_ERR1);
}

DEFHANDLER(OP_ERR1, "error", scheme *sc)
{
	putstr(sc, " ");
	if (sc->args isnt sc->NIL) {
		s_save(sc, OP_ERR1, cdr(sc->args), sc->NIL);
		sc->args = car(sc->args);
		sc->print_flag = true;
		s_goto(sc, OP_P0LIST);
	} else {
		putstr(sc, "\n");
		if (sc->interactive_repl) {
			s_goto(sc, OP_T0LVL);
		} else {
			return sc->NIL;
		}
	}
}

DEFHANDLER(OP_QUIT, "quit", scheme *sc)
{
	if (is_pair(sc->args))
		sc->retcode = ivalue(car(sc->args));
	return (sc->NIL);
}

DEFHANDLER(OP_GC, "gc", scheme *sc)
{
	gc(sc, sc->NIL, sc->NIL);
	s_return(sc, sc->T);
}

DEFHANDLER(OP_GCVERB, "gc-verbose", scheme *sc)
{
	int was = sc->gc_verbose;
	sc->gc_verbose = (car(sc->args) isnt sc->F);
	s_retbool(was);
}

DEFHANDLER(OP_NEWSEGMENT, "new-segment", scheme *sc)
{
	if (not is_pair(sc->args) or not is_number(car(sc->args)))
		error_named_0(sc, "argument must be a number");
	alloc_cellseg(sc, (int)ivalue(car(sc->args)));
	s_return(sc, sc->T);
}

pointer
open_port_helper(scheme *sc, int kind)
{
	pointer p =
	    port_from_filename(sc, str2C(strvalue(car(sc->args))), kind);
	if (p is sc->NIL)
		s_return(sc, sc->F);
	s_return(sc, p);
}

DEFHANDLER(OP_OPEN_INFILE, "open-input-file", scheme *sc)
{
	return open_port_helper(sc, PORT_INPUT);
}

DEFHANDLER(OP_OPEN_OUTFILE, "open-output-file", scheme *sc)
{
	return open_port_helper(sc, PORT_OUTPUT);
}

DEFHANDLER(OP_OPEN_INOUTFILE, "open-input-output-file", scheme *sc)
{
	return open_port_helper(sc, PORT_INPUT | PORT_OUTPUT);
}

#if USE_STRING_PORTS
pointer
open_string_port_helper(scheme *sc, int kind)
{
	pointer p = port_from_string(sc, str2C(strvalue(car(sc->args))),
				     str2C(strvalue(car(sc->args)) +
					   strlength(car(sc->args))), kind);
	if (p is sc->NIL)
		s_return(sc, sc->F);
	s_return(sc, p);
}

DEFHANDLER(OP_OPEN_INSTRING, "open-input-string", scheme *sc)
{
	return open_string_port_helper(sc, PORT_INPUT);
}

DEFHANDLER(OP_OPEN_INOUTSTRING, "open-input-output-string", scheme *sc)
{
	return open_string_port_helper(sc, PORT_INPUT | PORT_OUTPUT);
}

DEFHANDLER(OP_OPEN_OUTSTRING, "open-output-string", scheme *sc)
{
	pointer p;
	if (car(sc->args) is sc->NIL) {
		p = port_from_scratch(sc);
		if (p is sc->NIL)
			s_return(sc, sc->F);
	} else {
		p = port_from_string(sc,
				     str2C(strvalue(car(sc->args))),
				     str2C(strvalue(car(sc->args)) +
					   strlength(car(sc->args))),
				     PORT_OUTPUT);
		if (p is sc->NIL)
			s_return(sc, sc->F);
	}
	s_return(sc, p);
}

DEFHANDLER(OP_GET_OUTSTRING, "get-output-string", scheme *sc)
{
	port *p;
	if ((p = car(sc->args)->_object._port)->kind & PORT_STRING) {
		int size = p->rep.string.curr - p->rep.string.start + 1;
		char *str = (char *)sc->malloc(size);
		if (str isnt nullptr) {
			memcpy(str, p->rep.string.start, size - 1);
			str[size - 1] = '\0';
			pointer s = mk_counted_string(sc, str, size - 1);
			sc->free(str);
			s_return(sc, s);
		}
	}
	s_return(sc, sc->F);
}
#endif
DEFHANDLER(OP_CLOSE_INPORT, "close-input-port", scheme *sc)
{
	port_close(sc, car(sc->args), PORT_INPUT);
	s_return(sc, sc->T);
}

DEFHANDLER(OP_CLOSE_OUTPORT, "close-output-port", scheme *sc)
{
	port_close(sc, car(sc->args), PORT_OUTPUT);
	s_return(sc, sc->T);
}

// ========== reading part ==========
DEFHANDLER(OP_READ, "read???", scheme *sc)
{
	if (not is_pair(sc->args))
		s_goto(sc, OP_READ_INTERNAL);
	if (not is_inport(car(sc->args)))
		error_named_1(sc, "not an input port:", car(sc->args));
	if (car(sc->args) is sc->inport)
		s_goto(sc, OP_READ_INTERNAL);
	pointer x = sc->inport;
	sc->inport = car(sc->args);
	x = cons(sc, x, sc->NIL);
	s_save(sc, OP_SET_INPORT, x, sc->NIL);
	s_goto(sc, OP_READ_INTERNAL);
}

#define redirect_input()						\
	if (is_pair(sc->args)) {					\
		if (car(sc->args) isnt sc->inport) {			\
			pointer x##__LINE__ = sc->inport;		\
			x##__LINE__ = cons(sc, x##__LINE__, sc->NIL);	\
			s_save(sc, OP_SET_INPORT, x##__LINE__, sc->NIL); \
			sc->inport = car(sc->args);			\
		}							\
	}
pointer
read_peek_char_helper(scheme *sc, bool peek)
{
	redirect_input();
	int c = inchar(sc);
	if (c is EOF)
		s_return(sc, sc->EOF_OBJ);
	if (peek)
		backchar(sc, c);
	s_return(sc, mk_character(sc, c));
}

DEFHANDLER(OP_READ_CHAR, "read-char", scheme *sc)
{
	return read_peek_char_helper(sc, false);
}

DEFHANDLER(OP_PEEK_CHAR, "peek-char", scheme *sc)
{
	return read_peek_char_helper(sc, true);
}

pointer
read_peek_u8_helper(scheme *sc, bool peek)
{
	redirect_input();
	int c = inchar8(sc);
	if (c is EOF)
		s_return(sc, sc->EOF_OBJ);
	if (peek)
		backchar(sc, c);
	s_return(sc, mk_integer(sc, c));
}

DEFHANDLER(OP_READ_U8, "read-u8", scheme *sc)
{
	return read_peek_u8_helper(sc, false);
}

DEFHANDLER(OP_PEEK_U8, "peek-u8", scheme *sc)
{
	return read_peek_u8_helper(sc, true);
}

DEFHANDLER(OP_CHAR_READY, "char-ready?", scheme *sc)
{
	pointer p = sc->inport;
	if (is_pair(sc->args))
		p = car(sc->args);
	int res = p->_object._port->kind & PORT_STRING;
	s_retbool(res);
}

DEFHANDLER(OP_SET_INPORT, "set-input-port", scheme *sc)
{
	sc->inport = car(sc->args);
	s_return(sc, sc->value);
}

DEFHANDLER(OP_SET_OUTPORT, "set-output-port", scheme *sc)
{
	sc->outport = car(sc->args);
	s_return(sc, sc->value);
}

#define check_nesting()							\
	if (sc->nesting isnt 0) {					\
		int n = sc->nesting;					\
		sc->nesting = 0;					\
		sc->retcode = -1;					\
		error_1(sc, "unmatched parentheses:", mk_integer(sc, n)); \
	}

DEFHANDLER(OP_RDSEXPR, "read s-expression", scheme *sc)
{
	check_nesting();
	pointer x;
	switch (sc->tok) {
	case TOK_EOF:
		s_return(sc, sc->EOF_OBJ);
	case TOK_BVEC:
	case TOK_VEC:
		s_save(sc,
		       (sc->tok is TOK_BVEC ? OP_RDBVEC : OP_RDVEC),
		       sc->NIL, sc->NIL);
		/* fall through */
	case TOK_LPAREN:
		sc->tok = token(sc);
		if (sc->tok is TOK_RPAREN) {
			s_return(sc, sc->NIL);
		} else if (sc->tok is TOK_DOT) {
			error_0(sc, "syntax error: illegal dot expression");
		} else {
			sc->nesting_stack[sc->file_i]++;
			s_save(sc, OP_RDLIST, sc->NIL, sc->NIL);
			s_goto(sc, OP_RDSEXPR);
		}
	case TOK_QUOTE:
		s_save(sc, OP_RDQUOTE, sc->NIL, sc->NIL);
		sc->tok = token(sc);
		s_goto(sc, OP_RDSEXPR);
	case TOK_BQUOTE:
		sc->tok = token(sc);
		if (sc->tok is TOK_VEC) {
			s_save(sc, OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
			sc->tok = TOK_LPAREN;
			s_goto(sc, OP_RDSEXPR);
		} else {
			s_save(sc, OP_RDQQUOTE, sc->NIL, sc->NIL);
		}
		s_goto(sc, OP_RDSEXPR);
	case TOK_COMMA:
		s_save(sc, OP_RDUNQUOTE, sc->NIL, sc->NIL);
		sc->tok = token(sc);
		s_goto(sc, OP_RDSEXPR);
	case TOK_ATMARK:
		s_save(sc, OP_RDUQTSP, sc->NIL, sc->NIL);
		sc->tok = token(sc);
		s_goto(sc, OP_RDSEXPR);
	case TOK_ATOM:
		s_return(sc, mk_atom(sc, readstr_upto(sc, DELIMITERS)));
	case TOK_DQUOTE:
		x = readstrexp(sc);
		if (x is sc->F)
			error_0(sc, "Error reading string");
		setimmutable(x);
		s_return(sc, x);
	case TOK_SHARP:{
			pointer f = find_slot_in_env(sc, sc->envir,
						     sc->SHARP_HOOK, 1);
			if (f is sc->NIL) {
				error_0(sc, "undefined sharp expression");
			} else {
				sc->code =
				    cons(sc, slot_value_in_env(f), sc->NIL);
				s_goto(sc, OP_EVAL);
			}
		}
	case TOK_SHARP_CONST:
		if ((x =
		     mk_sharp_const(sc,
				    readstr_upto(sc, DELIMITERS))) is sc->NIL) {
			error_0(sc, "undefined sharp expression");
		} else {
			s_return(sc, x);
		}
	default:
		error_0(sc, "syntax error: illegal token");
	}
}

DEFHANDLER(OP_RDLIST, "read parenthesized list", scheme *sc)
{
	check_nesting();
	sc->args = cons(sc, sc->value, sc->args);
	sc->tok = token(sc);
	if (sc->tok is TOK_EOF) {
		s_return(sc, sc->EOF_OBJ);
	} else if (sc->tok is TOK_RPAREN) {
		int c = inchar(sc);
		if (c isnt '\n')
			backchar(sc, c);
#if SHOW_ERROR_LINE
		else if (sc->load_stack[sc->file_i].kind & PORT_FILE)
			sc->load_stack[sc->file_i].rep.stdio.curr_line++;
#endif
		sc->nesting_stack[sc->file_i]--;
		s_return(sc, reverse_in_place(sc, sc->NIL, sc->args));
	} else if (sc->tok is TOK_DOT) {
		s_save(sc, OP_RDDOT, sc->args, sc->NIL);
		sc->tok = token(sc);
		s_goto(sc, OP_RDSEXPR);
	} else {
		s_save(sc, OP_RDLIST, sc->args, sc->NIL);;
		s_goto(sc, OP_RDSEXPR);
	}
}

DEFHANDLER(OP_RDDOT, "read dotted list", scheme *sc)
{
	check_nesting();
	if (token(sc) isnt TOK_RPAREN) {
		error_0(sc, "syntax error: illegal dot expression");
	} else {
		sc->nesting_stack[sc->file_i]--;
		s_return(sc, reverse_in_place(sc, sc->value, sc->args));
	}
}

DEFHANDLER(OP_RDQUOTE, "read quote", scheme *sc)
{
	check_nesting();
	s_return(sc, cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
}

DEFHANDLER(OP_RDQQUOTE, "read `quasiquote", scheme *sc)
{
	check_nesting();
	s_return(sc, cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
}

// Why?
DEFHANDLER(OP_RDQQUOTEVEC, "read quasiquoted `#(vector)", scheme *sc)
{
	check_nesting();
	s_return(sc, cons(sc, mk_symbol(sc, "apply"),
			  cons(sc, mk_symbol(sc, "vector"),
			       cons(sc, cons(sc, sc->QQUOTE,
					     cons(sc, sc->value,
						  sc->NIL)), sc->NIL))));
}

DEFHANDLER(OP_RDUNQUOTE, "read ,unquote", scheme *sc)
{
	check_nesting();
	s_return(sc, cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
}

DEFHANDLER(OP_RDUQTSP, "read ,@unquote-splicing", scheme *sc)
{
	check_nesting();
	s_return(sc, cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));
}

DEFHANDLER(OP_RDBVEC, "read bytevector", scheme *sc)
{
	check_nesting();
	sc->args = sc->value;
	s_goto(sc, OP_BVECTOR);
}

DEFHANDLER(OP_RDVEC, "read vector", scheme *sc)
{
	check_nesting();
	/*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
	   s_goto(sc,OP_EVAL); Cannot be quoted */
	/*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
	   s_return(sc,x); Cannot be part of pairs */
	/*sc->code=mk_proc(sc,OP_VECTOR);
	   sc->args=sc->value;
	   s_goto(sc,OP_APPLY); */
	sc->args = sc->value;
	s_goto(sc, OP_VECTOR);
}

// ========== printing part ==========
DEFHANDLER(OP_P0LIST, "print list", scheme *sc)
{
	check_nesting();
	if (is_vector(sc->args)) {
		putstr(sc, "#(");
		sc->args = cons(sc, sc->args, mk_integer(sc, 0));
		s_goto(sc, OP_PVECFROM);
	} else if (is_bvector(sc->args)) {
		putstr(sc, "#u8(");
		sc->args = cons(sc, sc->args, mk_integer(sc, 0));
		s_goto(sc, OP_PBVECFROM);
	} else if (is_environment(sc->args)) {
		putstr(sc, "#<environment>");
		s_return(sc, sc->T);
	} else if (not is_pair(sc->args)) {
		printatom(sc, sc->args, sc->print_flag);
		s_return(sc, sc->T);
	} else if (car(sc->args) is sc->QUOTE and ok_abbrev(cdr(sc->args))) {
		putstr(sc, "'");
		sc->args = cadr(sc->args);
		s_goto(sc, OP_P0LIST);
	} else if (car(sc->args) is sc->QQUOTE and ok_abbrev(cdr(sc->args))) {
		putstr(sc, "`");
		sc->args = cadr(sc->args);
		s_goto(sc, OP_P0LIST);
	} else if (car(sc->args) is sc->UNQUOTE and ok_abbrev(cdr(sc->args))) {
		putstr(sc, ",");
		sc->args = cadr(sc->args);
		s_goto(sc, OP_P0LIST);
	} else if (car(sc->args) is sc->UNQUOTESP and ok_abbrev(cdr(sc->args))) {
		putstr(sc, ",@");
		sc->args = cadr(sc->args);
		s_goto(sc, OP_P0LIST);
	} else {
		putstr(sc, "(");
		s_save(sc, OP_P1LIST, cdr(sc->args), sc->NIL);
		sc->args = car(sc->args);
		s_goto(sc, OP_P0LIST);
	}
}

DEFHANDLER(OP_P1LIST, "print list", scheme *sc)
{
	check_nesting();
	if (is_pair(sc->args)) {
		s_save(sc, OP_P1LIST, cdr(sc->args), sc->NIL);
		putstr(sc, " ");
		sc->args = car(sc->args);
		s_goto(sc, OP_P0LIST);
	} else if (is_vector(sc->args)) {
		s_save(sc, OP_P1LIST, sc->NIL, sc->NIL);
		putstr(sc, " . ");
		s_goto(sc, OP_P0LIST);
	} else {
		if (sc->args isnt sc->NIL) {
			putstr(sc, " . ");
			printatom(sc, sc->args, sc->print_flag);
		}
		putstr(sc, ")");
		s_return(sc, sc->T);
	}
}

DEFHANDLER(OP_PBVECFROM, "print bytevector", scheme *sc)
{
	check_nesting();
	int i = ivalue_unchecked(cdr(sc->args));
	pointer bvec = car(sc->args);
	int len = bveclength(bvec);
	if (i == len) {
		putstr(sc, ")");
		s_return(sc, sc->T);
	} else {
		pointer elem = mk_integer(sc, bvector_elem(bvec, i));
		ivalue_unchecked(cdr(sc->args)) = i + 1;
		s_save(sc, OP_PBVECFROM, sc->args, sc->NIL);
		sc->args = elem;
		if (i > 0)
			putstr(sc, " ");
		s_goto(sc, OP_P0LIST);
	}
}

DEFHANDLER(OP_PVECFROM, "print vector", scheme *sc)
{
	check_nesting();
	int i = ivalue_unchecked(cdr(sc->args));
	pointer vec = car(sc->args);
	int len = veclength(vec);
	if (i == len) {
		putstr(sc, ")");
		s_return(sc, sc->T);
	} else {
		pointer elem = vector_elem(vec, i);
		veclength(cdr(sc->args)) = i + 1;
		s_save(sc, OP_PVECFROM, sc->args, sc->NIL);
		sc->args = elem;
		if (i > 0)
			putstr(sc, " ");
		s_goto(sc, OP_P0LIST);
	}
}

DEFHANDLER(OP_ASSQ, "assq", scheme *sc)
{
	pointer x = car(sc->args), y;
	for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
		if (not is_pair(car(y))) {
			error_0(sc, "unable to handle non pair element");
		}
		if (x is caar(y))
			break;
	}
	if (is_pair(y)) {
		s_return(sc, car(y));
	} else {
		s_return(sc, sc->F);
	}
}

DEFHANDLER(OP_GET_CLOSURE, "get-closure-code", scheme *sc)
{
	sc->args = car(sc->args);
	if (sc->args is sc->NIL) {
		s_return(sc, sc->F);
	} else if (is_closure(sc->args)) {
		s_return(sc, cons(sc, sc->LAMBDA, closure_code(sc->value)));
	} else if (is_macro(sc->args)) {
		s_return(sc, cons(sc, sc->LAMBDA, closure_code(sc->value)));
	} else {
		s_return(sc, sc->F);
	}
}

DEFHANDLER(OP_CLOSUREP, "closure?", scheme *sc)
{
	/*
	 * Note, macro object is also a closure.
	 * Therefore, (closure? <#MACRO>) ==> #t
	 */
	s_retbool(is_closure(car(sc->args)));
}

DEFHANDLER(OP_MACROP, "macro?", scheme *sc)
{
	s_retbool(is_macro(car(sc->args)));
}

#define INF_ARG 0xffff

DEFHANDLER(OP_ARITY, "procedure-arity", scheme *sc)
{
	pointer proc = car(sc->args);
	if (is_proc(proc))
		s_return(sc,
			 cons(sc, mk_integer(sc, procminarity(proc)),
			      (procmaxarity(proc) is INF_ARG ? sc->T :
			       mk_integer(sc, procmaxarity(proc)))));
	if (is_closure(proc)) {
		pointer code = closure_code(proc), args = car(code);
		int len = (is_symbol(args) ? -2 : list_length(sc, args));
		if (len < 0)
			s_return(sc, cons(sc, mk_integer(sc, -len - 2), sc->T));
		else
			s_return(sc,
				 cons(sc, mk_integer(sc, len),
				      mk_integer(sc, len)));
		s_return(sc, cons(sc, sc->F, sc->F));
	} else {
		s_return(sc, sc->F);
	}
}

DEFHANDLER(OP_GENSYM, "gensym", scheme *sc)
{
	char_t *pattern = (sc->args is sc->NIL ? nullptr : strvalue(car(sc->args)));
	s_return(sc, gensym(sc, pattern));
}

#define DEFSHORTHANDLER(op, scmname, ...)    \
	static pointer DO_##op(scheme *sc) { s_return(sc, __VA_ARGS__); }
// *INDENT-OFF*
DEFSHORTHANDLER(OP_LAMBDA1, "internal lambda",
		mk_closure(sc, sc->value, sc->envir))
DEFSHORTHANDLER(OP_QUOTE, "quote", car(sc->code))
DEFSHORTHANDLER(OP_CAR, "car", caar(sc->args))
DEFSHORTHANDLER(OP_CDR, "cdr", cdar(sc->args))
DEFSHORTHANDLER(OP_REVERSE, "reverse", reverse(sc, car(sc->args)))
DEFSHORTHANDLER(OP_LIST_STAR, "list*", list_star(sc, sc->args))
DEFSHORTHANDLER(OP_STRLEN, "string-length",
		mk_integer(sc, strlength(car(sc->args))))
DEFSHORTHANDLER(OP_VECLEN, "vector-length", mk_integer(sc, veclength(car(sc->args))))
DEFSHORTHANDLER(OP_STRUCTLEN, "struct-length",
		mk_integer(sc, structlength(car(sc->args))))
DEFSHORTHANDLER(OP_STRUCTNAME, "struct-name", structname(car(sc->args)))
DEFSHORTHANDLER(OP_EXP, "exp", mk_real(sc, exp(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_LOG, "log", mk_real(sc, log(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_SIN, "sin", mk_real(sc, sin(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_COS, "cos", mk_real(sc, cos(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_TAN, "tan", mk_real(sc, tan(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_ASIN, "asin", mk_real(sc, asin(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_ACOS, "acos", mk_real(sc, acos(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_SQRT, "sqrt", mk_real(sc, sqrt(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_FLOOR, "floor", mk_real(sc, floor(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_CEILING, "ceiling",
		mk_real(sc, ceil(rvalue(car(sc->args)))))
DEFSHORTHANDLER(OP_OBLIST, "oblist", oblist_all_symbols(sc))
DEFSHORTHANDLER(OP_CURR_INPORT, "current-input-port", sc->inport)
DEFSHORTHANDLER(OP_CURR_OUTPORT, "current-output-port", sc->outport)
DEFSHORTHANDLER(OP_INT_ENV, "interaction-environment", sc->global_env)
DEFSHORTHANDLER(OP_CURR_ENV, "current-environment", sc->envir)
// *INDENT-ON*

typedef pointer(*ophandler) (scheme *);
static ophandler ophandlers[OP_MAXDEFINED] = {
#define _OP_DEF(NAME, MINARITY, MAXARITY, TYPES, OP) DO_##OP,
#include "scheme-ops.h"
};

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

static bool
is_nonneg(pointer p)
{
	return ivalue(p) >= 0 and is_integer(p);
}

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

// correspond with preceding struct "tests"
#define TST_NONE nullptr
#define TST_ANY "\001"
#define TST_STRING "\002"
#define TST_SYMBOL "\003"
#define TST_PORT "\004"
#define TST_INPORT "\005"
#define TST_OUTPORT "\006"
#define TST_ENVIRONMENT "\007"
#define TST_PAIR "\010"
#define TST_LIST "\011"
#define TST_CHAR "\012"
#define TST_VECTOR "\013"
#define TST_NUMBER "\014"
#define TST_INTEGER "\015"
#define TST_NATURAL "\016"
#define TST_BVECTOR "\017"
#define TST_STRUCT "\020"
#define TST_PROCEDURE "\021"

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

static op_code_info dispatch_table[] = {
#define _OP_DEF(name, minarity, maxarity, types, op) \
	{name, minarity, maxarity, types},
#include "scheme-ops.h"
	{nullptr, 0, 0, nullptr}
};

static const char *
procname(pointer x)
{
	int n = procnum(x);
	const char *name = dispatch_table[n].name;
	if (name is nullptr) {
		name = "ILLEGAL!";
	}
	return name;
}

static inline int
procminarity(pointer x)
{
	return dispatch_table[procnum(x)].min_arity;
}

static inline int
procmaxarity(pointer x)
{
	return dispatch_table[procnum(x)].max_arity;
}

/* kernel of this interpreter */
static void
eval_cycle(scheme *sc, enum scheme_opcode op)
{
	sc->op = op;
	for (;;) {
		op_code_info *pcd = dispatch_table + sc->op;
		if (pcd->name isnt nullptr) {	/* if built-in function, check arguments */
			char msg[AUXBUFF_SIZE];
			int ok = 1;
			int n = list_length(sc, sc->args);

			/* Check number of arguments */
			if (n < pcd->min_arity) {
				ok = 0;
				snprintf(msg, AUXBUFF_SIZE,
					 "%s: needs%s %d argument(s)",
					 pcd->name,
					 pcd->min_arity ==
					 pcd->max_arity ? "" : " at least",
					 pcd->min_arity);
			}
			if (ok and n > pcd->max_arity) {
				ok = 0;
				snprintf(msg, AUXBUFF_SIZE,
					 "%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 isnt nullptr) {
					int i = 0;
					int j;
					const char *t = pcd->arg_tests_encoding;
					pointer arglist = sc->args;
					do {
						pointer arg = car(arglist);
						j = (int)t[0];
						if (j is TST_LIST[0]) {
							if (arg != sc->NIL
							    and not
							    is_pair(arg))
								break;
						} else {
							if (not
							    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, AUXBUFF_SIZE,
							 "%s: argument %d must be: %s",
							 pcd->name, i + 1,
							 tests[j].kind);
					}
				}
			}
			if (not ok) {
				if (error_(sc, msg, nullptr) is sc->NIL)
					return;
				pcd = dispatch_table + sc->op;
			}
		}
		ok_to_freely_gc(sc);
		__opcode__ = (enum scheme_opcode)sc->op;
		// Taking a different data structure here might not be
		// the best approach, but both dispatch_table and
		// ophandlers are generated from the same data.
		if (ophandlers[sc->op] (sc) is sc->NIL) {
			return;
		}
		if (sc->no_memory) {
			fprintf(stderr, "No memory!\n");
			sc->retcode = 9;
			return;
		}
	}
}

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

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

static void
assign_proc(scheme *sc, enum scheme_opcode op, const char *name)
{
	pointer x = mk_symbol(sc, name), y = mk_proc(sc, op);
	new_slot_in_env(sc, x, y);
}

static pointer
mk_proc(scheme *sc, enum scheme_opcode op)
{
	pointer y = get_cell(sc, sc->NIL, sc->NIL);
	typeflag(y) = (T_PROC | T_ATOM);
	ivalue_unchecked(y) = (long)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 = str2C(strvalue(car(p)));
	switch (strlength(car(p))) {
	case 2:
		if (s[0] is 'i')
			return OP_IF0;	/* if */
		else
			return OP_OR0;	/* or */
	case 3:
		if (s[0] is '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 */
	}
}

/* initialization of TinyScheme */
#if USE_INTERFACE
INTERFACE pointer
s_cons(scheme *sc, pointer a, pointer b)
{
	return cons(sc, a, b);
}

INTERFACE pointer
s_immutable_cons(scheme *sc, pointer a, pointer b)
{
	return immutable_cons(sc, a, b);
}

static struct scheme_interface vtbl = {
#define _INTERFACE(RETTYPE, NAME, REAL_NAME, ...) REAL_NAME,
#include "interface.h"
};
#endif

scheme *
scheme_init_new(void)
{
	scheme *sc = (scheme *) malloc(sizeof(scheme));
	if (not scheme_init(sc)) {
		free(sc);
		return nullptr;
	} else {
		return sc;
	}
}

scheme *
scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free)
{
	scheme *sc = (scheme *) malloc(sizeof(scheme));
	if (not scheme_init_custom_alloc(sc, malloc, free)) {
		free(sc);
		return nullptr;
	} else {
		return sc;
	}
}

int
scheme_init(scheme *sc)
{
	return scheme_init_custom_alloc(sc, malloc, free);
}

int
scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free)
{
	size_t n = sizeof(dispatch_table) / sizeof(dispatch_table[0]);
	pointer x;

	num_zero.is_fixnum = true;
	num_zero.value.ivalue = 0;
	num_one.is_fixnum = true;
	num_one.value.ivalue = 1;

#if USE_INTERFACE
	sc->vptr = &vtbl;
#endif
	sc->gensym_cnt = 0;
	sc->malloc = malloc;
	sc->free = free;
	sc->last_cell_seg = -1;
	sc->backchar = -1;
	sc->sink = &sc->_sink;
	sc->NIL = &sc->_NIL;
	sc->T = &sc->_HASHT;
	sc->F = &sc->_HASHF;
	sc->EOF_OBJ = &sc->_EOF_OBJ;
	sc->free_cell = &sc->_NIL;
	sc->fcells = 0;
	sc->no_memory = false;
	sc->alloc_seg =
	    (char **)sc->malloc(sizeof(*(sc->alloc_seg)) * cell_nsegment);
	sc->cell_seg =
	    (pointer *) sc->malloc(sizeof(*(sc->cell_seg)) * cell_nsegment);
	sc->strbuff = (char *)sc->malloc(STRBUFF_INITIAL_SIZE);
	sc->strbuff_size = STRBUFF_INITIAL_SIZE;
	sc->inport = sc->NIL;
	sc->outport = sc->NIL;
	sc->save_inport = sc->NIL;
	sc->loadport = sc->NIL;
	sc->nesting = 0;
	sc->interactive_repl = false;

	if (alloc_cellseg(sc, FIRST_CELLSEGS) isnt FIRST_CELLSEGS) {
		sc->no_memory = true;
		return 0;
	}
	sc->gc_verbose = 0;
	dump_stack_initialize(sc);
	sc->code = sc->NIL;

	/* init sc->NIL */
	typeflag(sc->NIL) = (T_ATOM | MARK);
	car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
	/* init T */
	typeflag(sc->T) = (T_ATOM | MARK);
	car(sc->T) = cdr(sc->T) = sc->T;
	/* init F */
	typeflag(sc->F) = (T_ATOM | MARK);
	car(sc->F) = cdr(sc->F) = sc->F;
	/* init sink */
	typeflag(sc->sink) = (T_PAIR | MARK);
	car(sc->sink) = sc->NIL;
	/* init c_nest */
	sc->c_nest = sc->NIL;

	sc->oblist = oblist_initial_value(sc);
	/* init global_env */
	new_frame_in_env(sc, sc->NIL);
	sc->global_env = sc->envir;
	/* init else */
	x = mk_symbol(sc, "else");
	new_slot_in_env(sc, x, sc->T);

	assign_syntax(sc, "lambda");
	assign_syntax(sc, "quote");
	assign_syntax(sc, "define");
	assign_syntax(sc, "if");
	assign_syntax(sc, "begin");
	assign_syntax(sc, "set!");
	assign_syntax(sc, "let");
	assign_syntax(sc, "let*");
	assign_syntax(sc, "letrec");
	assign_syntax(sc, "cond");
	assign_syntax(sc, "delay");
	assign_syntax(sc, "and");
	assign_syntax(sc, "or");
	assign_syntax(sc, "cons-stream");
	assign_syntax(sc, "macro");
	assign_syntax(sc, "case");

	for (size_t i = 0; i < n; i++) {
		if (dispatch_table[i].name isnt nullptr) {
			assign_proc(sc, (enum scheme_opcode)i,
				    dispatch_table[i].name);
		}
	}

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

	return not sc->no_memory;
}

void
scheme_set_input_port_file(scheme *sc, FILE *fin)
{
	sc->inport = port_from_file(sc, fin, PORT_INPUT);
}

void
scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end)
{
	sc->inport = port_from_string(sc, start, past_the_end, PORT_INPUT);
}

void
scheme_set_output_port_file(scheme *sc, FILE *fout)
{
	sc->outport = port_from_file(sc, fout, PORT_OUTPUT);
}

void
scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end)
{
	sc->outport = port_from_string(sc, start, past_the_end, PORT_OUTPUT);
}

void
scheme_set_external_data(scheme *sc, void *p)
{
	sc->ext_data = p;
}

void
scheme_deinit(scheme *sc)
{
#if SHOW_ERROR_LINE
	char *fname;
#endif

	sc->oblist = sc->NIL;
	sc->global_env = sc->NIL;
	dump_stack_free(sc);
	sc->envir = sc->NIL;
	sc->code = sc->NIL;
	sc->args = sc->NIL;
	sc->value = sc->NIL;
	if (is_port(sc->inport)) {
		typeflag(sc->inport) = T_ATOM;
	}
	sc->inport = sc->NIL;
	sc->outport = sc->NIL;
	if (is_port(sc->save_inport)) {
		typeflag(sc->save_inport) = T_ATOM;
	}
	sc->save_inport = sc->NIL;
	if (is_port(sc->loadport)) {
		typeflag(sc->loadport) = T_ATOM;
	}
	sc->loadport = sc->NIL;
	sc->free(sc->strbuff);
	sc->gc_verbose = 0;
	gc(sc, sc->NIL, sc->NIL);

	for (int i = 0; i <= sc->last_cell_seg; i++) {
		sc->free(sc->alloc_seg[i]);
	}
	sc->free(sc->cell_seg);
	sc->free(sc->alloc_seg);

#if SHOW_ERROR_LINE
	for (int i = 0; i <= sc->file_i; i++) {
		if (sc->load_stack[i].kind & PORT_FILE) {
			fname = sc->load_stack[i].rep.stdio.filename;
			if (fname)
				sc->free(fname);
		}
	}
#endif
}

void
scheme_load_file(scheme *sc, FILE *fin)
{
	scheme_load_named_file(sc, fin, nullptr);
}

void
scheme_load_named_file(scheme *sc, FILE *fin, const char *filename)
{
	if (fin is nullptr) {
		fprintf(stderr,
			"File pointer can not be NULL when loading a file\n");
		return;
	}
	dump_stack_reset(sc);
	sc->envir = sc->global_env;
	sc->file_i = 0;
	sc->load_stack[0].kind = PORT_INPUT | PORT_FILE;
	sc->load_stack[0].rep.stdio.file = fin;
	sc->loadport = mk_port(sc, sc->load_stack);
	sc->retcode = 0;
	if (fin is stdin and not str_eq(filename, "--"))
		sc->interactive_repl = true;
#if SHOW_ERROR_LINE
	sc->load_stack[0].rep.stdio.curr_line = 0;
	if (fin isnt stdin and filename)
		sc->load_stack[0].rep.stdio.filename =
		    str2C(store_string(sc, strlen(filename), filename, 0));
	else
		sc->load_stack[0].rep.stdio.filename = nullptr;
#endif

	sc->args = mk_integer(sc, sc->file_i);
	eval_cycle(sc, OP_T0LVL);
	typeflag(sc->loadport) = T_ATOM;
	if (sc->retcode == 0) {
		sc->retcode = sc->nesting != 0;
	}
}

void
scheme_load_string(scheme *sc, const char *cmd)
{
	dump_stack_reset(sc);
	sc->envir = sc->global_env;
	sc->file_i = 0;
	sc->load_stack[0].kind = PORT_INPUT | PORT_STRING;
	sc->load_stack[0].rep.string.start = (char *)cmd;	/* This func respects const */
	sc->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen(cmd);
	sc->load_stack[0].rep.string.curr = (char *)cmd;
	sc->loadport = mk_port(sc, sc->load_stack);
	sc->retcode = 0;
	sc->interactive_repl = false;
	sc->args = mk_integer(sc, sc->file_i);
	eval_cycle(sc, OP_T0LVL);
	typeflag(sc->loadport) = T_ATOM;
	if (sc->retcode == 0)
		sc->retcode = sc->nesting != 0;
}

void
scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value)
{
	pointer x = find_slot_in_env(sc, envir, symbol, 0);
	if (x isnt sc->NIL) {
		set_slot_in_env(x, value);
	} else {
		new_slot_spec_in_env(sc, envir, symbol, value);
	}
}

#if !STANDALONE
void
scheme_register_foreign_func(scheme *sc, scheme_registerable *sr)
{
	scheme_define(sc,
		      sc->global_env, mk_symbol(sc, sr->name),
		      mk_foreign_func(sc, sr->f));
}

void
scheme_register_foreign_func_list(scheme *sc,
				  scheme_registerable *list, int count)
{
	for (int i = 0; i < count; i++) {
		scheme_register_foreign_func(sc, list + i);
	}
}

pointer
scheme_apply0(scheme *sc, const char *procname)
{
	return scheme_eval(sc, cons(sc, mk_symbol(sc, procname), sc->NIL));
}

void
save_from_C_call(scheme *sc)
{
	pointer saved_data = cons(sc,
				  car(sc->sink),
				  cons(sc,
				       sc->envir,
				       sc->dump));
	/* Push */
	sc->c_nest = cons(sc, saved_data, sc->c_nest);
	/* Truncate the dump stack so TS will return here when done, not
	   directly resume pre-C-call operations. */
	dump_stack_reset(sc);
}

void
restore_from_C_call(scheme *sc)
{
	car(sc->sink) = caar(sc->c_nest);
	sc->envir = cadar(sc->c_nest);
	sc->dump = cdr(cdar(sc->c_nest));
	/* Pop */
	sc->c_nest = cdr(sc->c_nest);
}

/* "func" and "args" are assumed to be already eval'ed. */
pointer
scheme_call(scheme *sc, pointer func, pointer args)
{
	bool old_repl = sc->interactive_repl;
	sc->interactive_repl = false;
	save_from_C_call(sc);
	sc->envir = sc->global_env;
	sc->args = args;
	sc->code = func;
	sc->retcode = 0;
	eval_cycle(sc, OP_APPLY);
	sc->interactive_repl = old_repl;
	restore_from_C_call(sc);
	return sc->value;
}

pointer
scheme_eval(scheme *sc, pointer obj)
{
	bool old_repl = sc->interactive_repl;
	sc->interactive_repl = false;
	save_from_C_call(sc);
	sc->args = sc->NIL;
	sc->code = obj;
	sc->retcode = 0;
	eval_cycle(sc, OP_EVAL);
	sc->interactive_repl = old_repl;
	restore_from_C_call(sc);
	return sc->value;
}
#endif

const char *
get_version(void)
{
	return VERSION;
}

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

#if STANDALONE

FILE *
open_file(char *fname)
{
	if (str_eq(fname, "-") or str_eq(fname, "--"))
		return stdin;
	return fopen(fname, "r");
}

void
init_from_env(void)
{
	char *val = getenv("TEENYCELLSEGSIZE");
	cell_segsize = val isnt nullptr ? atoi(val) : CELL_SEGSIZE;
	val = getenv("TEENYCELLNSEGMENT");
	cell_nsegment = val isnt nullptr ? atoi(val) : CELL_NSEGMENT;
#ifdef EVAL_LIMIT
	val = getenv("TEENYEVALLIMIT");
	eval_limit = val isnt nullptr ? atoll(val) : EVAL_LIMIT;
#endif
	val = getenv("TEENYLIBPATH");
	// Maybe make it a const char *?
	libdir = (char *)(val isnt nullptr ? val : LIBDIR);
}

int
main(int argc, char **argv)
{
	scheme sc;
	FILE *fin = nullptr;
	char *file_name = (char *)INITFILE;
	char *executable_name = argv[0];
	int retcode;
	bool isfile = 1;

	init_from_env();
	if (argc == 1) {
		printf("%s", get_version());
	}
	if (argc == 2 and str_eq(argv[1], "-h")) {
		printf("Usage:\n");
		printf("  %s -h\n", argv[0]);
		printf("  %s\n", argv[0]);
		printf("  %s [<file1> <file2> ...]\n", argv[0]);
		printf("  %s [<file1> <file2> ...] -1 <file> [<arg1> <arg2> ...]\n", argv[0]);
		printf("  %s [<file1> <file2> ...] -c <expr> [<arg1> <arg2> ...]\n", argv[0]);
		printf("Use - as filename for stdin.\n");
		printf("Use -- as filename for stdin in script mode.\n");
		return 1;
	}
	if (not scheme_init(&sc)) {
		fprintf(stderr, "Could not initialize!\n");
		return 2;
	}
	scheme_set_input_port_file(&sc, stdin);
	scheme_set_output_port_file(&sc, stdout);
#if USE_DL
	scheme_define(&sc, sc.global_env, mk_symbol(&sc, "load-extension"),
		      mk_foreign_func(&sc, scm_load_ext));
#endif
	argv++;
	if (access(file_name, 0) != 0) {
		char *p = getenv("TEENYINITFILE");
		if (p isnt nullptr) {
			file_name = p;
		} else {
			strcpy(sc.strbuff, executable_name);
			p = strrchr(sc.strbuff, '/');
			if (p isnt nullptr) {
				strcpy(p + 1, file_name);
				file_name = sc.strbuff;
			}
		}
	}
	evalcnt = 0;
	do {
		if (str_eq(file_name, "-1") or str_eq(file_name, "-c")) {
			pointer args = sc.NIL;
			isfile = file_name[1] is '1';
			file_name = *argv++;
			if (isfile)
				fin = open_file(file_name);
			for (; *argv; argv++) {
				pointer value = mk_string(&sc, *argv);
				args = cons(&sc, value, args);
			}
			args = reverse_in_place(&sc, sc.NIL, args);
			scheme_define(&sc, sc.global_env,
				      mk_symbol(&sc, "*args*"), args);

		} else {
			fin = open_file(file_name);
		}
		if (isfile and fin is nullptr) {
			fprintf(stderr, "Could not open file %s\n", file_name);
		} else {
			if (isfile) {
				scheme_load_named_file(&sc, fin, file_name);
			} else {
				scheme_load_string(&sc, file_name);
			}
			if (not isfile or fin isnt stdin) {
				if (sc.retcode != 0) {
					fprintf(stderr,
						"Errors encountered reading %s\n",
						file_name);
				}
				if (isfile) {
					fclose(fin);
				}
			}
		}
		file_name = *argv++;
	} while (file_name isnt nullptr);
	if (argc == 1) {
		scheme_load_named_file(&sc, stdin, "-");
	}
	retcode = sc.retcode;
	scheme_deinit(&sc);

	return retcode;
}

#endif