eval.c

#include <stddef.h>
#include <stdio.h>
#include <stdarg.h>
#include <string.h>
#include <signal.h>
#include <sys/types.h>
#include <errno.h>
#include <wchar.h>
#include <locale.h>
#include <math.h>
#include <stdint.h>
#include <stdbool.h>
#include "ffi.h"
#include <assert.h>

extern int isatty(int);



#define	TAG_INT	0
//#define	LIB_GC	1

#define GC_APP_HEADER	int type;
#define GC_SAVE		1

#if (LIB_GC)
# include "libgc.c"
#else
# include "gc.c"
#endif
#include "wcs.c"
#include "buffer.c"

# include <malloc.h>
# define swnprintf swprintf


union Object;

typedef union Object *oop;

typedef oop (*imp_t)(oop args, oop env);

typedef union {
    int		 arg_int;
    int32_t	 arg_int32;
    int64_t	 arg_int64;
    long	 arg_long;
    float	 arg_float;
    double	 arg_double;
    void	*arg_pointer;
    char	*arg_string;
    wchar_t	*arg_String;
} arg_t;

typedef void (*cast_t)(oop arg, void **argp, arg_t *buf);

typedef struct {
    int		 arg_count;
    int		 arg_rest;
    ffi_type	*arg_types[32];
    cast_t	 arg_casts[32];
} proto_t;

#define nil ((oop)0)

enum { Undefined, Data, Long, Double, String, Symbol, Pair, _Array, Array, Expr, Form, Fixed, Subr, Variable, Env, Context, Int64 };

struct Data { int empty[0]; };
struct Long	{ long	    bits; };
struct Int64 { int64_t bits; };
struct Double	{ double    bits; };
struct String	{ oop       size;  wchar_t *bits; };	/* bits is in managed memory */
struct Symbol	{ wchar_t  *bits; };
struct Pair	{ oop 	    head, tail, source; };
struct Array	{ oop       size, _array; };
struct Expr	{ oop 	    name, defn, ctx, profile; };
struct Form	{ oop 	    function, symbol; };
struct Fixed	{ oop       function; };
struct Subr	{ wchar_t  *name;  imp_t imp;  proto_t *sig;  int profile; };
struct Variable	{ oop 	    name, value, env, index, type; };
struct Env	{ oop 	    parent, level, offset, bindings, stable; };
struct Context	{ oop 	    home, env, bindings, callee, pc; };

union Object {
  struct Data		Data;
  struct Long		Long;
  struct Int64      Int64;
  struct Double		Double;
  struct String		String;
  struct Symbol		Symbol;
  struct Pair		Pair;
  struct Array		Array;
  struct Expr		Expr;
  struct Form		Form;
  struct Fixed		Fixed;
  struct Subr		Subr;
  struct Variable	Variable;
  struct Env		Env;
  struct Context	Context;
};

static void fatal(char *reason, ...);

#define setType(OBJ, TYPE)		(ptr2hdr(OBJ)->type= (TYPE))

#if (TAG_INT)
  static inline int getType(oop obj)	{ return obj ? (((long)obj & 1) ? Long : ptr2hdr(obj)->type) : Undefined; }
#else
  static inline int getType(oop obj)	{ return obj ? ptr2hdr(obj)->type : Undefined; }
#endif

#define is(TYPE, OBJ)			((OBJ) && (TYPE == getType(OBJ)))

#if defined(NDEBUG)
# define checkType(OBJ, TYPE) OBJ
#else
# define checkType(OBJ, TYPE) _checkType(OBJ, TYPE, #TYPE, __FILE__, __LINE__)
  static inline oop _checkType(oop obj, int type, char *name, char *file, int line)
  {
    if (obj && !((uint64_t)obj & 1) && !ptr2hdr(obj)->used)	fatal("%s:%i: attempt to access dead object %s\n", file, line, name);
    if (!is(type, obj))					fatal("%s:%i: typecheck failed for %s (%i != %i)\n", file, line, name, type, getType(obj));
    return obj;
  }
#endif

#define get(OBJ, TYPE, FIELD)		(checkType(OBJ, TYPE)->TYPE.FIELD)
#define set(OBJ, TYPE, FIELD, VALUE)	(checkType(OBJ, TYPE)->TYPE.FIELD= (VALUE))

#define getHead(OBJ)	get(OBJ, Pair,head)
#define getTail(OBJ)	get(OBJ, Pair,tail)

#define setHead(OBJ, VAL)	set(OBJ, Pair,head, VAL)
#define setTail(OBJ, VAL)	set(OBJ, Pair,tail, VAL)

static oop car(oop obj)			{ return is(Pair, obj) ? getHead(obj) : nil; }
static oop cdr(oop obj)			{ return is(Pair, obj) ? getTail(obj) : nil; }

static oop caar(oop obj)		{ return car(car(obj)); }
static oop cadr(oop obj)		{ return car(cdr(obj)); }
static oop cddr(oop obj)		{ return cdr(cdr(obj)); }
//static oop caaar(oop obj)		{ return car(car(car(obj))); }
//static oop cadar(oop obj)		{ return car(cdr(car(obj))); }
static oop caddr(oop obj)		{ return car(cdr(cdr(obj))); }
static oop cadddr(oop obj)		{ return car(cdr(cdr(cdr(obj)))); }

#define newBits(TYPE)	_newBits(TYPE, sizeof(struct TYPE))
#define newOops(TYPE)	_newOops(TYPE, sizeof(struct TYPE))

static oop _newBits(int type, size_t size)	{ oop obj= GC_malloc_atomic(size);	setType(obj, type);  return obj; }
static oop _newOops(int type, size_t size)	{ oop obj= GC_malloc(size);		setType(obj, type);  return obj; }

static char *argv0;

static oop symbols= nil, globals= nil, expanders= nil, encoders= nil, evaluators= nil, applicators= nil, backtrace= nil, arguments= nil, input= nil, output= nil;
static oop s_set= nil, s_define= nil, s_let= nil, s_lambda= nil, s_quote= nil, s_quasiquote= nil, s_unquote= nil, s_unquote_splicing= nil, s_t= nil, s_dot= nil, s_bracket= nil, s_brace= nil, s_main= nil;
static oop f_set= nil, f_quote= nil, f_lambda= nil, f_let= nil, f_define;

static int opt_b= 0, opt_g= 0, opt_O= 0, opt_p= 0, opt_v= 0;

static oop traceStack= nil;
static int traceDepth= 0;

static oop newData(size_t len)		{ return _newBits(Data, len); }

#if (TAG_INT)
  static inline int  isLong(oop x)	{ return (((long)x & 1) || Long == getType(x)); }
  static inline oop  newLong(long x)	{ if ((x ^ (x << 1)) < 0) { oop obj= newBits(Long);  set(obj, Long,bits, x);  return obj; }  return ((oop)((x << 1) | 1)); }
  static inline long getLong(oop x)	{ if ((long)x & 1) return (long)x >> 1;  return get(x, Long,bits); }
#else
# define     isLong(X)			is(Long, (X))
  static oop newLong(long bits)		{ oop obj= newBits(Long);  set(obj, Long,bits, bits);  return obj; }
# define     getLong(X)			get((X), Long,bits)
  static oop newInt64(int64_t bits) { oop obj = newBits(Int64); set(obj, Int64, bits, bits); return obj; }
  #define getInt64(X) get((X), Int64, bits)
  #define isInt64(X) is(Int64, (X))
#endif

static void   setDouble(oop obj, double bits)	{		memcpy(&obj->Double.bits, &bits, sizeof(bits)); }
static double getDouble(oop obj)		{ double bits;  memcpy(&bits, &obj->Double.bits, sizeof(bits));  return bits; }

#define isDouble(X)			is(Double, (X))
#define isPair(X)			is(Pair, (X))

static inline int isNumeric(oop obj)	{ return isLong(obj) || isDouble(obj); }

static oop newDouble(double bits)	{ oop obj= newBits(Double);  setDouble(obj, bits);  return obj; }

static oop _newString(size_t len)
{
  wchar_t *gstr= (wchar_t *)_newBits(-1, sizeof(wchar_t) * (len + 1));	GC_PROTECT(gstr);	/* + 1 to ensure null terminator */
  oop       obj= newOops(String);				GC_PROTECT(obj);
  set(obj, String,size, newLong(len));				GC_UNPROTECT(obj);
  set(obj, String,bits, gstr);					GC_UNPROTECT(gstr);
  return obj;
}

static oop newStringN(wchar_t *cstr, size_t len)
{
  oop obj= _newString(len);
  memcpy(get(obj, String,bits), cstr, sizeof(wchar_t) * len);
  return obj;
}

static oop newString(wchar_t *cstr)
{
    return newStringN(cstr, wcslen(cstr));
}

static int stringLength(oop string)
{
  return getLong(get(string, String,size));
}

static oop newSymbol(wchar_t *cstr)	{ 
    oop obj= newBits(Symbol);	
    set(obj, Symbol,bits, wcsdup(cstr));			
    return obj; 
}

static oop newPair(oop head, oop tail)	{ oop obj= newOops(Pair);	set(obj, Pair,head, head);  set(obj, Pair,tail, tail);	return obj; }

static oop newPairFrom(oop head, oop tail, oop source)
{
  oop obj= newOops(Pair);
  set(obj, Pair,head, 	head);
  set(obj, Pair,tail, 	tail);
  set(obj, Pair,source, get(source, Pair,source));
  return obj;
}

static oop newArray(int size)
{
  int cap=  size ? size : 1;
  oop elts= _newOops(_Array, sizeof(oop) * cap);	GC_PROTECT(elts);
  oop obj=   newOops( Array);				GC_PROTECT(obj);
  set(obj, Array,_array, elts);
  set(obj, Array,size, newLong(size));			GC_UNPROTECT(obj);  GC_UNPROTECT(elts);
  return obj;
}

static int arrayLength(oop obj)
{
  return is(Array, obj) ? getLong(get(obj, Array,size)) : 0;
}

static oop arrayAt(oop array, int index)
{
  if (is(Array, array)) {
    oop elts= get(array, Array,_array);
    int size= arrayLength(array);
    if ((unsigned)index < (unsigned)size)
      return ((oop *)elts)[index];
  }
  return nil;
}

static oop arrayAtPut(oop array, int index, oop val)
{
  if (is(Array, array)) {
    int size= arrayLength(array);
    oop elts= get(array, Array,_array);
    if ((unsigned)index >= (unsigned)size) {
      GC_PROTECT(array);
      int cap= GC_size(elts) / sizeof(oop);
      if (index >= cap) {
	while (cap <= index) cap *= 2;
	oop oops= _newOops(_Array, sizeof(oop) * cap);
	memcpy((oop *)oops, (oop *)elts, sizeof(oop) * size);
	elts= set(array, Array,_array, oops);
      }
      set(array, Array,size, newLong(index + 1));
      GC_UNPROTECT(array);
    }
    return ((oop *)elts)[index]= val;
  }
  return nil;
}

static oop arrayAppend(oop array, oop val)
{
  return arrayAtPut(array, arrayLength(array), val);
}

static oop arrayInsert(oop obj, size_t index, oop value)
{
  size_t len= arrayLength(obj);
  arrayAppend(obj, value);
  if (index < len) {
    oop  elts= get(obj, Array,_array);
    oop *oops= (oop *)elts + index;
    memmove(oops + 1, oops, sizeof(oop) * (len - index));
  }
  arrayAtPut(obj, index, value);
  return value;
}

static oop oopAt(oop obj, int index)
{
  if (obj && !isLong(obj) && !GC_atomic(obj)) {
    int size= GC_size(obj) / sizeof(oop);
    if ((unsigned)index < (unsigned)size) return ((oop *)obj)[index];
  }
  return nil;
}

static oop oopAtPut(oop obj, int index, oop value)
{
  if (obj && !isLong(obj) && !GC_atomic(obj)) {
    int size= GC_size(obj) / sizeof(oop);
    if ((unsigned)index < (unsigned)size) return ((oop *)obj)[index]= value;
  }
  return nil;
}

static oop newExpr(oop defn, oop ctx)
{
  oop obj= newOops(Expr);		GC_PROTECT(obj);
  set(obj, Expr,defn,    defn);
  set(obj, Expr,ctx,     ctx);
  set(obj, Expr,profile, newLong(0));	GC_UNPROTECT(obj);
  return obj;
}

static oop newForm(oop fn, oop sym)	{ oop obj= newOops(Form);	set(obj, Form,function, fn);	set(obj, Form,symbol, sym);	return obj; }
static oop newFixed(oop function)	{ oop obj= newOops(Fixed);	set(obj, Fixed,function, function);				return obj; }

static oop newSubr(wchar_t *name, imp_t imp, proto_t *sig)
{
  oop obj= newBits(Subr);
  set(obj, Subr,name,    name);
  set(obj, Subr,imp,     imp);
  set(obj, Subr,sig,     sig);
  set(obj, Subr,profile, 0);
  return obj;
}

static oop newVariable(oop name, oop value, oop env, int index)
{
  oop obj= newOops(Variable);			GC_PROTECT(obj);
  set(obj, Variable,name,  name);
  set(obj, Variable,value, value);
  set(obj, Variable,env,   env);
  set(obj, Variable,index, newLong(index));
  set(obj, Variable,type,  0);			GC_UNPROTECT(obj);
  return obj;
}

static oop newEnv(oop parent, int level, int offset)
{
  oop obj= newOops(Env);			GC_PROTECT(obj);
  set(obj, Env,parent,   parent);
  set(obj, Env,level,    newLong((nil == parent) ? 0 : getLong(get(parent, Env,level)) + level));
  set(obj, Env,offset,   newLong(offset));
  set(obj, Env,bindings, newArray(0));		GC_UNPROTECT(obj);
  return obj;
}

static oop newBaseContext(oop home, oop caller, oop env)
{
  oop obj= newOops(Context);			GC_PROTECT(obj);
  set(obj, Context,home,     home);
  set(obj, Context,env,      env);
  set(obj, Context,bindings, newArray(0));	GC_UNPROTECT(obj);
  return obj;
}

static oop newContext(oop home, oop caller, oop env)
{
  oop obj= nil;
  //xxx fix escape analysis for nested lambdas with free variables
#if 0
  if ((nil != caller) && (nil != (obj= get(caller, Context,callee)))) {
    set(obj, Context,home, home);
    set(obj, Context,env,  env);
    return obj;
  }
#endif
  obj= newBaseContext(home, caller, env);
  if (nil != caller) set(caller, Context,callee, obj);
  return obj;
}

static void dump(oop);
static void dumpln(oop);

static oop findLocalVariable(oop env, oop name)
{
    oop bindings= get(env, Env,bindings);
    int index= arrayLength(bindings);
    while (--index >= 0) {
	oop var= arrayAt(bindings, index);
	if (get(var, Variable,name) == name)
	    return var;
    }
    return nil;
}

static oop findVariable(oop env, oop name)
{
    while (nil != env) {
	oop var= findLocalVariable(env, name);
	if (nil != var) return var;
	env= get(env, Env,parent);
    }
    return nil;
}

static oop lookup(oop env, oop name)
{
  oop var= findVariable(env, name);
  if (nil == var) fatal("undefined variable: %ls", get(name, Symbol,bits));
  return get(var, Variable,value);
}

static oop define(oop env, oop name, oop value)
{
  oop bindings= get(env, Env,bindings);
  {
    int index= arrayLength(bindings);
    while (--index >= 0) {
      oop var= arrayAt(bindings, index);
      if (get(var, Variable,name) == name) {
	set(var, Variable,value, value);
	return var;
      }
    }
  }
  int off= getLong(get(env, Env,offset));
  oop var= newVariable(name, value, env, off);	GC_PROTECT(var);
  arrayAppend(bindings, var);			GC_UNPROTECT(var);
  set(env, Env,offset, newLong(off + 1));
  if (is(Expr, value) && (nil == get(value, Expr,name)))
    set(value, Expr,name, name);
  return var;
}

static int isGlobal(oop var)
{
  oop env= get(var, Variable,env);
  return (nil != env) && (0 == getLong(get(env, Env,level)));
}

static oop newBool(int b)		{ return b ? s_t : nil; }

#if defined(_MSC_VER)
#include <BaseTsd.h>
typedef SSIZE_T ssize_t;
#endif

static oop intern(wchar_t *string)
{
  ssize_t lo= 0, hi= arrayLength(symbols) - 1, c= 0;

  oop s= nil;
  while (lo <= hi) {
    size_t m= (lo + hi) / 2;
    s= arrayAt(symbols, m);
    c= wcscmp(string, get(s, Symbol,bits));
    if      (c < 0)	hi= m - 1;
    else if (c > 0)	lo= m + 1;
    else		return s;
  }
  GC_PROTECT(s);
  s= newSymbol(string);
  arrayInsert(symbols, lo, s);
  GC_UNPROTECT(s);
  return s;
}

#include "chartab.h"

static int isPrint(int c)	{ return (0 <= c && c <= 127 && (CHAR_PRINT    & chartab[c])) || (c >= 128); }
static int isAlpha(int c)	{ return (0 <= c && c <= 127 && (CHAR_ALPHA    & chartab[c])) || (c >= 128); }
static int isDigit10(int c)	{ return (0 <= c && c <= 127 && (CHAR_DIGIT10  & chartab[c])); }
static int isDigit16(int c)	{ return (0 <= c && c <= 127 && (CHAR_DIGIT16  & chartab[c])); }
static int isLetter(int c)	{ return (0 <= c && c <= 127 && (CHAR_LETTER   & chartab[c])) || (c >= 128); }

#define DONE	((oop)-4)	/* cannot be a tagged immediate */

static oop currentPath= 0;
static oop currentLine= 0;
static oop currentSource= 0;

static void beginSource(wchar_t *path)
{
  currentPath= newString(path);
  currentLine= newLong(1);
  currentSource= newPair(currentSource, nil);
  set(currentSource, Pair,source, newPair(currentPath, currentLine));
}

static void advanceSource(void)
{
  currentLine= newLong(getLong(currentLine) + 1);
  set(currentSource, Pair,source, newPair(currentPath, currentLine));
}

static void endSource(void)
{
  currentSource= get(currentSource, Pair,head);
  oop src= get(currentSource, Pair,source);
  currentPath= car(src);
  currentLine= cdr(src);
}

static oop read(FILE *fp);

static oop readList(FILE *fp, int delim)
{
  oop head= nil, tail= head, obj= nil;
  GC_PROTECT(head);
  GC_PROTECT(obj);
  obj= read(fp);
  if (obj == DONE) goto eof;
  head= tail= newPairFrom(obj, nil, currentSource);
  for (;;) {
    obj= read(fp);
    if (obj == DONE) goto eof;
    if (obj == s_dot) {
      obj= read(fp);
      if (obj == DONE)		fatal("missing item after .");
      tail= set(tail, Pair,tail, obj);
      obj= read(fp);
      if (obj != DONE)		fatal("extra item after .");
      goto eof;
    }
    obj= newPairFrom(obj, nil, currentSource);
    tail= set(tail, Pair,tail, obj);
  }
eof:;
  int c= getwc(fp);
  if (c != delim) {
    if (c < 0) fatal("EOF while reading list");
    fatal("mismatched delimiter: expected '%c' found '%c'", delim, c);
  }
  GC_UNPROTECT(obj);
  GC_UNPROTECT(head);
  return head;
}

static int digitValue(wint_t c)
{
    if (c >= '0' && c <= '9') return c - '0';
    else if (c >= 'A' && c <= 'Z') return c - 'A' + 10;
    else if (c >= 'a' && c <= 'z') return c - 'a' + 10;
    else return 0;
}

static int isHexadecimal(wint_t c)
{
    if ((c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) return 1;
    else return 0;
}

static int isOctal(wint_t c)
{
  return '0' <= c && c <= '7';
}

static int readChar(wint_t c, FILE *fp)
{
  if ('\\' == c) {
    c= getwc(fp);
    switch (c) {
      case 'a':   return '\a';
      case 'b':   return '\b';
      case 'f':   return '\f';
      case 'n':   return '\n';
      case 'r':   return '\r';
      case 't':   return '\t';
      case 'v':   return '\v';
      case 'u': {
	wint_t a= getwc(fp), b= getwc(fp), c= getwc(fp), d= getwc(fp);
	return (digitValue(a) << 12) + (digitValue(b) << 8) + (digitValue(c) << 4) + digitValue(d);
      }
      case 'x': {
	int x= 0;
	if (isHexadecimal(c= getwc(fp))) {
	  x= digitValue(c);
	  if (isHexadecimal(c= getwc(fp))) {
	    x= x * 16 + digitValue(c);
	    c= getwc(fp);
	  }
	}
	ungetwc(c, fp);
	return x;
      }
      case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': {
	int x= digitValue(c);
	if (isOctal(c= getwc(fp))) {
	  x= x * 8 + digitValue(c);
	  if (isOctal(c= getwc(fp))) {
	    x= x * 8 + digitValue(c);
	    c= getwc(fp);
	  }
	}
	ungetwc(c, fp);
	return x;
      }
      default:
	if (isAlpha(c) || isDigit10(c)) fatal("illegal character escape: \\%c", c);
	return c;
    }
  }
  return c;
}

static oop read(FILE *fp)
{
  for (;;) {
    wint_t c= getwc(fp);
    switch (c) {
      case WEOF: {
	return DONE;
      }
      case '\n': {
	while ('\r' == (c= getwc(fp)));
	if (c >= 0) ungetwc(c, fp);
	advanceSource();
	continue;
      }
      case '\r': {
	while ('\n' == (c= getwc(fp)));
	ungetwc(c, fp);
	advanceSource();
	continue;
      }
      case '\t':  case ' ': {
	continue;
      }
      case ';': {
	for (;;) {
	  c= getwc(fp);
	  if (EOF == c) break;
	  if ('\n' == c || '\r' == c) {
	    ungetwc(c, fp);
	    break;
	  }
	}
	continue;
      }
      case '"': {
	static struct buffer buf= BUFFER_INITIALISER;
	buffer_reset(&buf);
	for (;;) {
	  c= getwc(fp);
	  if ('"' == c) break;
	  c= readChar(c, fp);
	  if (EOF == c)			fatal("EOF in string literal");
	  buffer_append(&buf, c);
	}
	oop obj= newString(buffer_contents(&buf));
	//buffer_free(&buf);
	return obj;
      }
      case '?': {
	return newLong(readChar(getwc(fp), fp));
      }
      case '\'': {
	oop obj= read(fp);
	if (obj == DONE)
	  obj= s_quote;
	else {
	  GC_PROTECT(obj);
	  obj= newPairFrom(obj, nil, currentSource);
	  obj= newPairFrom(s_quote, obj, currentSource);
	  GC_UNPROTECT(obj);
	}
	return obj;
      }
      case '`': {
	oop obj= read(fp);
	if (obj == DONE)
	  obj= s_quasiquote;
	else {
	  GC_PROTECT(obj);
	  obj= newPairFrom(obj, nil, currentSource);
	  obj= newPairFrom(s_quasiquote, obj, currentSource);
	  GC_UNPROTECT(obj);
	}
	return obj;
      }
      case ',': {
	oop sym= s_unquote;
	c= getwc(fp);
	if ('@' == c)	sym= s_unquote_splicing;
	else		ungetwc(c, fp);
	oop obj= read(fp);
	if (obj == DONE)
	  obj= sym;
	else {
	  GC_PROTECT(obj);
	  obj= newPairFrom(obj, nil, currentSource);
	  obj= newPairFrom(sym, obj, currentSource);
	  GC_UNPROTECT(obj);
	}
	return obj;
      }
      case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9':
      doDigits:	{
	static struct buffer buf= BUFFER_INITIALISER;
	buffer_reset(&buf);
	do {
	  buffer_append(&buf, c);
	  c= getwc(fp);
	} while (isDigit10(c));
	if (('.' == c) || ('e' == c)) {
	    if ('.' == c) {
		do {
		    buffer_append(&buf, c);
		    c= getwc(fp);
		} while (isDigit10(c));
	    }
	    if ('e' == c) {
		buffer_append(&buf, c);
		c= getwc(fp);
		if ('-' == c) {
		    buffer_append(&buf, c);
		    c= getwc(fp);
		}
		while (isDigit10(c)) {
		    buffer_append(&buf, c);
		    c= getwc(fp);
		}
	    }
	    ungetwc(c, fp);
	    oop obj=  newDouble(wcstod(buffer_contents(&buf), 0));
	    return obj;
	}
	if (('x' == c) && (1 == buf.position))
	  do {
	    buffer_append(&buf, c);
	    c= getwc(fp);
	  } while (isDigit16(c));
	ungetwc(c, fp);
	oop obj= newLong(wcstoul(buffer_contents(&buf), 0, 0));
	return obj;
      }
      case '(': return readList(fp, ')');      case ')': ungetwc(c, fp);  return DONE;
      case '[': {
	  oop obj= readList(fp, ']');			GC_PROTECT(obj);
	  obj= newPairFrom(s_bracket, obj, obj);	GC_UNPROTECT(obj);
	  return obj;
      }
      case ']': ungetwc(c, fp);  return DONE;
      case '{': {
	  oop obj= readList(fp, '}');			GC_PROTECT(obj);
	  obj= newPairFrom(s_brace, obj, obj);		GC_UNPROTECT(obj);
	  return obj;
      }
      case '}': ungetwc(c, fp);  return DONE;
      case '-': {
	wint_t d= getwc(fp);
	ungetwc(d, fp);
	if (isDigit10(d)) goto doDigits;
	/* fall through... */
      }
      default: {
	if (isLetter(c)) {
	  static struct buffer buf= BUFFER_INITIALISER;
	  oop obj= nil;						GC_PROTECT(obj);
	  //oop in= nil;					GC_PROTECT(in);
	  buffer_reset(&buf);
	  while (isLetter(c) || isDigit10(c)) {
//	    if (('.' == c) && buf.position) {
//	      c= getwc(fp);
//	      if (!isLetter(c) && !isDigit10(c)) {
//		ungetwc(c, fp);
//		c= '.';
//	      }
//	      else {
//		obj= intern(buffer_contents(&buf));
//		in=  newPair(obj, in);
//		buffer_reset(&buf);
//	      }
//	    }
	    buffer_append(&buf, c);
	    c= getwc(fp);
	  }
	  ungetwc(c, fp);
	  obj= intern(buffer_contents(&buf));
//	  while (nil != in) {
//	    obj= newPair(obj, nil);
//	    obj= newPair(getHead(in), obj);
//	    obj= newPair(s_in, obj);
//	    in= getTail(in);
//	  }
	  //GC_UNPROTECT(in);
	  GC_UNPROTECT(obj);
	  return obj;
	}
	fatal(isPrint(c) ? "illegal character: 0x%02x '%c'" : "illegal character: 0x%02x", c, c);
      }
    }
  }
}

static void doprint(FILE *stream, oop obj, int storing)
{
  if (!obj) {
    fprintf(stream, "()");
    return;
  }
  if (obj == get(globals, Variable,value)) {
    fprintf(stream, "<globals>");
    return;
  }
  switch (getType(obj)) {
    case Undefined:	fprintf(stream, "UNDEFINED");		break;
    case Data: {
	//int i, j= GC_size(obj);
	fprintf(stream, "<data[%i]", (int)GC_size(obj));
	//for (i= 0;  i < j;  ++i) fprintf(stream, " %02x", ((unsigned char *)obj)[i]);
	fprintf(stream, ">");
	break;
    }
    case Long:		fprintf(stream, "%ld", getLong(obj));	break;
    case Double:	fprintf(stream, "%lf", getDouble(obj));	break;
    case String: {
      if (!storing)
	fprintf(stream, "%ls", get(obj, String,bits));
      else {
	wchar_t *p= get(obj, String,bits);
	int c;
	putc('"', stream);
	while ((c= *p++)) {
	  if (c >= ' ')
	    switch (c) {
	      case '"':  printf("\\\"");  break;
	      case '\\': printf("\\\\");  break;
	      default:	 putwc(c, stream);  break;
	    }
	  else fprintf(stream, "\\%03o", c);
	}
	putc('"', stream);
      }
      break;
    }
    case Symbol:	fprintf(stream, "%ls", get(obj, Symbol,bits));	break;
    case Pair: {
#if 1
      if (nil != get(obj, Pair,source)) {
	oop source= get(obj, Pair,source);
	oop path= car(source);
	oop line= cdr(source);
	fprintf(stream, "<%ls:%ld>", get(path, String,bits), getLong(line));
      }
#endif
      fprintf(stream, "(");
      for (;;) {
	assert(is(Pair, obj));
#if defined(NDEBUG)
	if (is(Env, getHead(obj))) {
	  obj= getTail(obj);
	  if (!is(Pair, obj)) break;
	  continue;
	}
#endif
	doprint(stream, getHead(obj), storing);
	obj= getTail(obj);
	if (!is(Pair, obj)) break;
	fprintf(stream, " ");
      }
      if (nil != obj) {
	fprintf(stream, " . ");
	doprint(stream, obj, storing);
      }
      fprintf(stream, ")");
      break;
    }
    case Array: {
      int i, len= arrayLength(obj);
      fprintf(stream, "Array<%d>(", arrayLength(obj));
      for (i= 0;  i < len;  ++i) {
	if (i) fprintf(stream, " ");
	doprint(stream, arrayAt(obj, i), storing);
      }
      fprintf(stream, ")");
      break;
    }
    case Expr: {
      fprintf(stream, "Expr");
      if (nil != (get(obj, Expr,name))) {
	fprintf(stream, ".");
	doprint(stream, get(obj, Expr,name), storing);
      }
      fprintf(stream, "=");
      doprint(stream, cadr(get(obj, Expr,defn)), storing);
      break;
    }
    case Form: {
      fprintf(stream, "Form(");
      doprint(stream, get(obj, Form,function), storing);
      fprintf(stream, ", ");
      doprint(stream, get(obj, Form,symbol), storing);
      fprintf(stream, ")");
      break;
    }
    case Fixed: {
      if (isatty(1)) {
	fprintf(stream, "");
	doprint(stream, get(obj, Fixed,function), storing);
	fprintf(stream, "");
      }
      else {
	fprintf(stream, "Fixed<");
	doprint(stream, get(obj, Fixed,function), storing);
	fprintf(stream, ">");
      }
      break;
    }
    case Subr: {
      if (get(obj, Subr,name))
	fprintf(stream, "%ls", get(obj, Subr,name));
      else
	fprintf(stream, "Subr<%p>", get(obj, Subr,imp));
      break;
    }
    case Variable: {
      if (!isGlobal(obj) && isatty(1)) fprintf(stream, "");
      doprint(stream, get(obj, Variable,name), 0);
      if (!isGlobal(obj) && isatty(1)) fprintf(stream, "");
#if !defined(NDEBUG)
      oop env= get(obj, Variable,env);
      if (nil != env) fprintf(stream, ";%ld+%ld", getLong(get(env, Env,level)), getLong(get(obj, Variable,index)));
#endif
      break;
    }
    case Env: {
      oop level= get(obj, Env,level);
      oop offset= get(obj, Env,offset);
      fprintf(stream, "Env%s%s<%ld+%ld:", ((nil == get(obj, Env,parent)) ? "*" : ""), ((nil == get(obj, Env,stable)) ? "=" : ""),
	      is(Long, level) ? getLong(level) : -1, is(Long, offset) ? getLong(offset) : -1);
#if 0
      oop bnd= get(obj, Env,bindings);
      int idx= arrayLength(bnd);
      while (--idx >= 0) {
	doprint(stream, arrayAt(bnd, idx), storing);
	if (idx) fprintf(stream, " ");
      }
#endif
      fprintf(stream, ">");
      break;
    }
    case Context: {
      fprintf(stream, "Context<");
      doprint(stream, get(obj, Context,env), storing);
      fprintf(stream, "=");
      doprint(stream, get(obj, Context,bindings), storing);
      fprintf(stream, ">");
      break;
    }
    default: {
      oop name= lookup(get(globals, Variable,value), intern(L"%type-names"));
      if (is(Array, name)) {
	name= arrayAt(name, getType(obj));
	if (is(Symbol, name)) {
	  fprintf(stream, "%ls", get(name, Symbol,bits));
	  break;
	}
      }
      fprintf(stream, "<type=%i>", getType(obj));
      break;
    }
  }
}

static void print(oop obj)			{ doprint(stdout, obj, 0);  fflush(stdout); }

static void fdump(FILE *stream, oop obj)	{ doprint(stream, obj, 1);  fflush(stream); }
static void dump(oop obj)			{ fdump(stdout, obj); }

static void fdumpln(FILE *stream, oop obj)
{
  fdump(stream, obj);
  fprintf(stream, "\n");
  fflush(stream);
}

static void dumpln(oop obj)			{ fdumpln(stdout, obj); }

static oop apply(oop fun, oop args, oop ctx);

static oop concat(oop head, oop tail)
{
  if (!is(Pair, head)) return tail;
  tail= concat(getTail(head), tail);		GC_PROTECT(tail);
  head= newPairFrom(getHead(head), tail, head);	GC_UNPROTECT(tail);
  return head;
}

static void setSource(oop obj, oop src)
{
  if (!is(Pair, obj)) return;
  if (nil == get(obj, Pair,source)) set(obj, Pair,source, src);
  setSource(getHead(obj), src);
  setSource(getTail(obj), src);
}

static oop exlist(oop obj, oop env);

static oop expand(oop expr, oop env)
{
  if (opt_v > 1) { printf("EXPAND ");  dumpln(expr); }
  if (is(Pair, expr)) {
    oop head= expand(getHead(expr), env);			GC_PROTECT(head);
    if (is(Symbol, head)) {
      oop val= findVariable(env, head);
      if (is(Variable, val)) val= get(val, Variable,value);
      if (is(Form, val) && (nil != get(val, Form,function))) {
	oop args= newPairFrom(env, getTail(expr), expr);	GC_PROTECT(args);
	head= apply(get(val, Form,function), args, nil);	GC_UNPROTECT(args);
	head= expand(head, env);				GC_UNPROTECT(head);
	if (opt_v > 1) { printf("EXPAND => ");  dumpln(head); }
	setSource(head, get(expr, Pair,source));
	return head;
      }
    }
    oop tail= getTail(expr);					GC_PROTECT(tail);
    if (s_quote != head) tail= exlist(tail, env);
    if (s_set == head && is(Pair, car(tail)) && is(Symbol, caar(tail)) /*&& s_in != caar(tail)*/) {
      static struct buffer buf= BUFFER_INITIALISER;
      buffer_reset(&buf);
      buffer_appendAll(&buf, L"set-");
      buffer_appendAll(&buf, get(getHead(getHead(tail)), Symbol,bits));
      head= intern(buffer_contents(&buf));
      tail= concat(getTail(getHead(tail)), getTail(tail));
    }
    expr= newPairFrom(head, tail, expr);			GC_UNPROTECT(tail);  GC_UNPROTECT(head);
  }
  else if (is(Symbol, expr)) {
    oop val= findVariable(env, expr);
    if (is(Variable, val)) val= get(val, Variable,value);
    if (is(Form, val) && (nil != get(val, Form,symbol))) {
      oop args= newPair(expr, nil);			GC_PROTECT(args);
      args= newPair(env, args);
      args= apply(get(val, Form,symbol), args, nil);
      args= expand(args, env);				GC_UNPROTECT(args);
      setSource(args, expr);
      return args;
    }
  }
  else {
    oop fn= arrayAt(get(expanders, Variable,value), getType(expr));
    if (nil != fn) {
      oop args= newPair(expr, nil);		GC_PROTECT(args);
      args= apply(fn, args, nil);		GC_UNPROTECT(args);
      setSource(args, expr);
      return args;
    }
  }
  if (opt_v > 1) { printf("EXPAND => ");  dumpln(expr); }
  return expr;
}

static oop exlist(oop list, oop env)
{
  if (!is(Pair, list)) return expand(list, env);
  oop head= expand(getHead(list), env);			GC_PROTECT(head);
  oop tail= exlist(getTail(list), env);			GC_PROTECT(tail);
  head= newPairFrom(head, tail, list);			GC_UNPROTECT(tail);  GC_UNPROTECT(head);
  return head;
}

static oop enlist(oop obj, oop env);

static void define_bindings(oop bindings, oop innerEnv)
{										GC_PROTECT(bindings);
    while (is(Pair, bindings))
    {
	oop var= getHead(bindings);						GC_PROTECT(var);
	if (!is(Symbol, var)) var= car(var);
	var= define(innerEnv, var, nil);					GC_UNPROTECT(var);
	bindings= getTail(bindings);
    }										GC_UNPROTECT(bindings);
}

static oop encode_bindings(oop expr, oop bindings, oop outerEnv, oop innerEnv)
{
    if (is(Pair, bindings))
    {										GC_PROTECT(bindings);
	oop binding= getHead(bindings);						GC_PROTECT(binding);
	if (is(Symbol, binding)) binding= newPairFrom(binding, nil, expr);
	oop var= car(binding);							GC_PROTECT(var);
	oop val= cdr(binding);							GC_PROTECT(val);
	var= findLocalVariable(innerEnv, var);					assert(nil != var);
	val= enlist(val, outerEnv);
	binding= newPairFrom(var, val, expr);					GC_UNPROTECT(val);  GC_UNPROTECT(var);
	oop rest= encode_bindings(expr, getTail(bindings), outerEnv, innerEnv); GC_PROTECT(rest);
	bindings= newPairFrom(binding, rest, expr);				GC_UNPROTECT(rest);  GC_UNPROTECT(binding);  GC_UNPROTECT(bindings);
    }
    return bindings;
}

static oop encode_let(oop expr, oop tail, oop env)
{
    oop args= car(tail);							GC_PROTECT(tail);  GC_PROTECT(env);
    oop env2= newEnv(env, 0, getLong(get(env, Env,offset)));			GC_PROTECT(env2);
    define_bindings(args, env2);
    set(env, Env,offset, newLong(getLong(get(env2, Env,offset))));
    oop bindings= encode_bindings(expr, args, env, env2);			GC_PROTECT(bindings);
    oop body= cdr(tail);							GC_PROTECT(body);
    body= enlist(body, env2);
    tail= newPairFrom(bindings, body, expr);					GC_UNPROTECT(body);  GC_UNPROTECT(bindings);
    tail= newPairFrom(env2, tail, expr);					GC_UNPROTECT(env2);  GC_UNPROTECT(env);  GC_UNPROTECT(tail);
    return tail;
}

static oop encode(oop expr, oop env)
{
  if (opt_O < 2) arrayAtPut(traceStack, traceDepth++, expr);
  if (opt_v > 1) { printf("ENCODE ");  dumpln(expr); }
  if (is(Pair, expr)) {
    oop head= encode(getHead(expr), env);			GC_PROTECT(head);
    oop tail= getTail(expr);					GC_PROTECT(tail);
    if (f_let == head) { // (let ENV (bindings...) . body)
	tail= encode_let(expr, tail, env);
    }
    else if (f_lambda == head) { // (lambda ENV params . body)
      oop args= car(tail);
      env= newEnv(env, 1, 0);					GC_PROTECT(env);
      while (is(Pair, args)) {
	if (!is(Symbol, getHead(args))) {
	  fprintf(stderr, "\nerror: non-symbol parameter name: ");
	  fdumpln(stderr, getHead(args));
	  fatal(0);
	}
	define(env, getHead(args), nil);
	args= getTail(args);
      }
      if (nil != args) {
	if (!is(Symbol, args)) {
	  fprintf(stderr, "\nerror: non-symbol parameter name: ");
	  fdumpln(stderr, args);
	  fatal(0);
	}
	define(env, args, nil);
      }
      tail= enlist(tail, env);
      tail= newPairFrom(env, tail, expr);			GC_UNPROTECT(env);
    }
    else if (f_define == head) {
      oop var= define(get(globals, Variable,value), car(tail), nil);
      tail= enlist(cdr(tail), env);
      tail= newPairFrom(var, tail, expr);
    }
    else if (f_set == head) {
      oop var= findVariable(env, car(tail));
      if (nil == var) fatal("set: undefined variable: %ls", get(car(tail), Symbol,bits));
      tail= enlist(cdr(tail), env);
      tail= newPairFrom(var, tail, expr);
    }
    else if (f_quote != head)
      tail= enlist(tail, env);
    expr= newPairFrom(head, tail, expr);			GC_UNPROTECT(tail);  GC_UNPROTECT(head);
  }
  else if (is(Symbol, expr)) {
    oop val= findVariable(env, expr);
    if (nil == val) fatal("undefined variable: %ls", get(expr, Symbol,bits));
    expr= val;
    if (isGlobal(expr)) {
      val= get(expr, Variable,value);
      if (is(Form, val) || is(Fixed, val))
	expr= val;
    }
    else {
      oop venv= get(val, Variable,env);
      if (getLong(get(venv, Env,level)) != getLong(get(env, Env,level)))
	set(venv, Env,stable, s_t);
    }
  }
  else {
    oop fn= arrayAt(get(encoders, Variable,value), getType(expr));
    if (nil != fn) {
      oop args= newPair(env, nil);		GC_PROTECT(args);
      args= newPair(expr, args);
      expr= apply(fn, args, nil);		GC_UNPROTECT(args);
    }
  }
  if (opt_v > 1) { printf("ENCODE => ");  dumpln(expr); }
  --traceDepth;
  return expr;
}

static oop enlist(oop list, oop env)
{
  if (!is(Pair, list)) return encode(list, env);
  oop head= encode(getHead(list), env);			GC_PROTECT(head);
  oop tail= enlist(getTail(list), env);			GC_PROTECT(tail);
  head= newPairFrom(head, tail, list);			GC_UNPROTECT(tail);  GC_UNPROTECT(head);
  return head;
}

static oop evlist(oop obj, oop env);

static int fprintSource(FILE *stream, oop exp)
{
    if (is(Pair, exp)) {
	oop src= get(exp, Pair,source);
	if (nil != src) {
	    oop path= car(src);
	    oop line= cdr(src);
	    if (is(String, path) && is(Long, line)) {
		return fprintf(stream, "%ls:%ld", get(path, String,bits), getLong(line));
	    }
	}
    }
    return 0;
}

static int printSource(oop exp)
{
    return fprintSource(stdout, exp);
}

static void fatal(char *reason, ...)
{
  if (reason) {
    va_list ap;
    va_start(ap, reason);
    fprintf(stderr, "\nerror: ");
    vfprintf(stderr, reason, ap);
    fprintf(stderr, "\n");
    va_end(ap);
  }

  oop tracer= get(backtrace, Variable,value);

  if (nil != tracer) {
    oop args= newLong(traceDepth);		GC_PROTECT(args);
    args= newPair(args, nil);
    args= newPair(traceStack, args);
    apply(tracer, args, nil);			GC_UNPROTECT(args);
  }
  else {
      if (traceDepth) {
	  int i= traceDepth;
	  int j= 12;
	  while (i-- > 0) {
	      //printf("%3d: ", i);
	      oop exp= arrayAt(traceStack, i);
	      printf("[?7l");
	      int l= printSource(exp);
	      if (l >= j) j= l;
	      if (!l) while (l < 3) l++, putchar('.');
	      while (l++ < j) putchar(' ');
	      printf(" ");
	      dumpln(arrayAt(traceStack, i));
	      printf("[?7h");
	  }
      }
      else {
	  printf("no backtrace\n");
      }
    }
}

static oop eval(oop obj, oop ctx)
{
  if (opt_v > 2) { printf("EVAL ");  dump(obj); printf(" IN ");  dumpln(ctx); }
  switch (getType(obj)) {
    case Undefined:
    case Long:
    case Double:
    case String: {
      return obj;
    }
    case Pair: {
      if (opt_O < 2) arrayAtPut(traceStack, traceDepth++, obj);
      oop head= eval(getHead(obj), ctx);		GC_PROTECT(head);
      if (is(Fixed, head))
	head= apply(get(head, Fixed,function), getTail(obj), ctx);
      else  {
	oop args= evlist(getTail(obj), ctx);		GC_PROTECT(args);
	if (opt_g) arrayAtPut(traceStack, traceDepth++, newPair(head, args));
	head= apply(head, args, ctx);			GC_UNPROTECT(args);
	if (opt_g) --traceDepth;
      }							GC_UNPROTECT(head);
      --traceDepth;
      return head;
    }
    case Variable: {
      if (isGlobal(obj)) return get(obj, Variable,value);
      int delta= getLong(get(get(ctx, Context,env), Env,level)) - getLong(get(get(obj, Variable,env), Env,level));
      oop cx= ctx;
      while (delta--) cx= get(cx, Context,home);
      return arrayAt(get(cx, Context,bindings), getLong(get(obj, Variable,index)));
    }
    default: {
      if (opt_g) arrayAtPut(traceStack, traceDepth++, obj);
      oop ev= arrayAt(get(evaluators, Variable,value), getType(obj));
      if (nil != ev) {
	oop args= newPair(obj, nil);			GC_PROTECT(args);
	obj= apply(ev, args, ctx);			GC_UNPROTECT(args);
      }
      if (opt_g) --traceDepth;
      return obj;
    }
  }
  return nil;
}

static oop evlist(oop obj, oop ctx)
{
  if (!is(Pair, obj)) return obj;
  oop head= eval(getHead(obj), ctx);		GC_PROTECT(head);
  oop tail= evlist(getTail(obj), ctx);		GC_PROTECT(tail);
  //head= newPairFrom(head, tail, obj);		GC_UNPROTECT(tail);  GC_UNPROTECT(head);
  head= newPair(head, tail);			GC_UNPROTECT(tail);  GC_UNPROTECT(head);
  return head;
}

static oop ffcall(oop subr, oop arguments);

static oop apply(oop fun, oop arguments, oop ctx)
{
  if (opt_v > 2) { printf("APPLY ");  dump(fun);  printf(" TO ");  dump(arguments);  printf(" IN ");  dumpln(ctx); }
  switch (getType(fun)) {
    case Expr: {
      if (opt_p) arrayAtPut(traceStack, traceDepth++, fun);
      oop args=    arguments;
      oop defn=    get(fun, Expr,defn);				GC_PROTECT(defn);
      oop env=     car(defn);
      oop formals= cadr(defn);
      ctx=         newContext(get(fun, Expr,ctx), ctx, env);	GC_PROTECT(ctx);
      oop locals=  get(ctx, Context,bindings);
      //oop tmp=     nil;					GC_PROTECT(tmp);
      while (is(Pair, formals)) {
	if (!is(Pair, args)) {
	  fprintf(stderr, "\nerror: too few arguments applying ");
	  fdump(stderr, fun);
	  fprintf(stderr, " to ");
	  fdumpln(stderr, arguments);
	  fatal(0);
	}
	arrayAtPut(locals, getLong(get(getHead(formals), Variable,index)), getHead(args));
	formals= getTail(formals); // xxx formals should be in env with fixed argument arity in defn
	args= getTail(args); // xxx args should be set up in the callee context
      }
      if (is(Variable, formals)) {
	arrayAtPut(locals, getLong(get(formals, Variable,index)), args);
	args= nil;
      }
      if (nil != args) {
	fprintf(stderr, "\nerror: too many arguments applying ");
	fdump(stderr, fun);
	fprintf(stderr, " to ");
	fdumpln(stderr, arguments);
	fatal(0);
      }
      oop ans= nil;
      oop body= cddr(defn);
      if (opt_g) arrayAtPut(traceStack, traceDepth++, body);
      while (is(Pair, body)) {
	if (opt_g) arrayAtPut(traceStack, traceDepth - 1, getHead(body));
	set(ctx, Context,pc, body);
	ans= eval(getHead(body), ctx);
	body= getTail(body);
      }
      if (opt_g || opt_p) --traceDepth;
      //GC_UNPROTECT(tmp);
      GC_UNPROTECT(ctx);
      GC_UNPROTECT(defn);
      if (nil != get(env, Env,stable))	set(ctx, Context,callee, nil);
      return ans;
    }
    case Fixed: {
      return apply(get(fun, Fixed,function), arguments, ctx);
    }
    case Subr: {
      if (opt_p) arrayAtPut(traceStack, traceDepth++, fun);
      oop ans= get(fun, Subr,sig) ? ffcall(fun, arguments) : get(fun, Subr,imp)(arguments, ctx);
      if (opt_p) --traceDepth;
      return ans;
    }
    default: {
      oop args= arguments;
      oop ap= arrayAt(get(applicators, Variable,value), getType(fun));      
      if (nil != ap) {						GC_PROTECT(args);
	if (opt_g) arrayAtPut(traceStack, traceDepth++, fun);
	args= newPair(fun, args);
	args= apply(ap, args, ctx);				GC_UNPROTECT(args);
	if (opt_g) --traceDepth;
	return args;
      }
      fprintf(stderr, "\nerror: cannot apply: ");
      fdumpln(stderr, fun);
      fatal(0);
    }
  }
  return nil;
}

static ffi_type ffi_type_long;

#define ffcast(NAME, OTYPE)													\
    static void ff##NAME(oop arg, void **argp, arg_t *buf)									\
    {																\
	switch (getType(arg)) {													\
	    case OTYPE:	buf->arg_##NAME= get##OTYPE(arg);  *argp= &buf->arg_##NAME;					 break;	\
	    default:	fprintf(stderr, "\nnon-"#OTYPE" argument in foreign call: ");  fdumpln(stderr, arg);  fatal(0);  break;	\
	}															\
    }

ffcast(int,	Long)
ffcast(int32,	Long)
ffcast(int64,	Long)
ffcast(long,	Long)
ffcast(float,	Double)
ffcast(double,	Double)

#undef ffcast

static void ffpointer(oop arg, void **argp, arg_t *buf)
{
    void *ptr= 0;
    switch (getType(arg)) {
	case Undefined:	ptr= 0;					break;
	case Data:	ptr= (void *)arg;			break;
	case Long:	ptr= (void *)getLong(arg);		break;
	case Double:	ptr= (void *)arg;			break;
	case String:	ptr= get(arg, String,bits);		break;
	case Symbol:	ptr= get(arg, Symbol,bits);		break;
	case Expr:	ptr= (void *)arg;			break;
	case Subr:	ptr= get(arg, Subr,imp);		break;
	case Variable:	ptr= &get(arg, Variable,value);		break;
	default:
	    if (GC_atomic(arg))
		ptr= (void *)arg;
	    else {
		fprintf(stderr, "\ninvalid pointer argument: ");
		fdumpln(stderr, arg);
		fatal(0);
	    }
	    break;
    }
    buf->arg_pointer= ptr;
    *argp= &buf->arg_pointer;
}

static void ffstring(oop arg, void **argp, arg_t *buf)
{
    if (!is(String, arg)) {
	fprintf(stderr, "\nnon-String argument in foreign call: ");
	fdumpln(stderr, arg);
	fatal(0);
    }
    buf->arg_string= wcs2mbs(get(arg, String,bits));
    *argp= &buf->arg_string;
}

static ffi_type *ffdefault(oop arg, void **argp, arg_t *buf)
{
    switch (getType(arg))
    {
	case Undefined:	buf->arg_pointer= 0;					*argp= &buf->arg_pointer;	return &ffi_type_pointer;
	case Long:	buf->arg_long=    getLong(arg);				*argp= &buf->arg_long;		return &ffi_type_long;
	case Double:	buf->arg_double=  getDouble(arg);			*argp= &buf->arg_double;	return &ffi_type_double;
	case String:	buf->arg_string=  wcs2mbs(get(arg, String,bits));	*argp= &buf->arg_string;	return &ffi_type_pointer;
	case Subr:	buf->arg_pointer= get(arg, Subr,imp);			*argp= &buf->arg_pointer;	return &ffi_type_pointer;
    }
    fprintf(stderr, "\ncannot pass object through '...': ");
    fdumpln(stderr, arg);
    fatal(0);
    return 0;
}

static oop ffcall(oop subr, oop arguments)
{
    proto_t  *sig= get(subr, Subr,sig);
    imp_t     imp= get(subr, Subr,imp);
    oop       argp= arguments;
    int       arg_count= 0;
    void     *args[32];
    arg_t     bufs[32];
    ffi_cif   cif;
    ffi_type  ret_type= ffi_type_pointer;
    ffi_arg   result;
    ffi_type *arg_types[32];
    while ((arg_count < sig->arg_count) && (nil != argp)) {
	sig->arg_casts[arg_count](car(argp), &args[arg_count], &bufs[arg_count]);
	arg_types[arg_count]= sig->arg_types[arg_count];
	++arg_count;
	argp= getTail(argp);
    }
    if (arg_count != sig->arg_count) fatal("too few arguments (%i < %i) in call to %S", arg_count, sig->arg_count, get(subr, Subr,name));
    if (sig->arg_rest) {
	while ((nil != argp) && (arg_count < 32)) {
	    arg_types[arg_count]= ffdefault(car(argp), &args[arg_count], &bufs[arg_count]);
	    ++arg_count;
	    argp= getTail(argp);
	}
    }
    if (nil != argp) fatal("too many arguments in call to %S", get(subr, Subr,name));
    if (FFI_OK != ffi_prep_cif(&cif, FFI_DEFAULT_ABI, arg_count, &ret_type, arg_types)) fatal("FFI call setup failed");
    ffi_call(&cif, FFI_FN(imp), &result, args);
    return newLong((long)result);
}

static int length(oop list)
{
  if (!is(Pair, list)) return 0;
  return 1 + length(getTail(list));
}

static void arity(oop args, char *name)
{
  fatal("wrong number of arguments (%i) in: %s\n", length(args), name);
}

static void arity1(oop args, char *name)
{
  if (!is(Pair, args) || is(Pair, getTail(args))) arity(args, name);
}

static void arity2(oop args, char *name)
{
  if (!is(Pair, args) || !is(Pair, getTail(args)) || is(Pair, getTail(getTail(args)))) arity(args, name);
}

static void arity3(oop args, char *name)
{
  if (!is(Pair, args) || !is(Pair, getTail(args)) || !is(Pair, getTail(getTail(args))) || is(Pair, getTail(getTail(getTail(args))))) arity(args, name);
}

#define subr(NAME)	oop subr_##NAME(oop args, oop ctx)

static subr(if)
{
  if (nil != eval(car(args), ctx))
    return eval(cadr(args), ctx);
  oop ans= nil;
  args= cddr(args);
  while (is(Pair, args)) {
    ans= eval(getHead(args), ctx);
    args= cdr(args);
  }
  return ans;
}

static subr(and)
{
  oop ans= s_t;
  for (;  is(Pair, args);  args= getTail(args))
    if (nil == (ans= eval(getHead(args), ctx)))
      break;
  return ans;
}

static subr(or)
{
  oop ans= nil;
  for (;  is(Pair, args);  args= getTail(args))
    if (nil != (ans= eval(getHead(args), ctx)))
      break;
  return ans;
}

static subr(set)
{
  oop var= car(args);
  if (!is(Variable, var)) {
    fprintf(stderr, "\nerror: cannot set undefined variable: ");
    fdumpln(stderr, var);
    fatal(0);
  }
  oop val= eval(cadr(args), ctx);
  if (is(Expr, val) && (nil == get(val, Expr,name))) set(val, Expr,name, get(var, Variable,name));
  if (isGlobal(var)) return set(var, Variable,value, val);
  int delta= getLong(get(get(ctx, Context,env), Env,level)) - getLong(get(get(var, Variable,env), Env,level));
  oop cx= ctx;
  while (delta--) cx= get(cx, Context,home);
  return arrayAtPut(get(cx, Context,bindings), getLong(get(var, Variable,index)), val);
}

static subr(let)
{
  oop tmp=  nil;		GC_PROTECT(tmp);
  oop bindings= cadr(args);
  oop body= cddr(args);
  oop locals= get(ctx, Context,bindings);
  while (is(Pair, bindings)) {
    oop binding= getHead(bindings);
    if (is(Pair, binding)) {
      oop var=    getHead(binding);
      oop prog=   getTail(binding);
      while (is(Pair, prog)) {
	oop value= getHead(prog);
	tmp= eval(value, ctx);
	prog= getTail(prog);
      }
      arrayAtPut(locals, getLong(get(var, Variable,index)), tmp);
    }
    bindings= getTail(bindings);
  }
  oop ans= nil;			GC_UNPROTECT(tmp);
  while (is(Pair, body)) {
    ans= eval(getHead(body), ctx);
    body= getTail(body);
  }
  return ans;
}

static subr(while)
{
  oop tst= car(args);
  while (nil != eval(tst, ctx)) {
    oop body= cdr(args);
    while (is(Pair, body)) {
      eval(getHead(body), ctx);
      body= getTail(body);
    }
  }
  return nil;
}

static subr(quote)
{
  return car(args);
}

static subr(lambda)
{
  return newExpr(args, ctx);
}

static subr(define)
{
  oop var= car(args);
  if (!is(Variable, var)) {
    fprintf(stderr, "\nerror: non-variable in define: ");
    fdumpln(stderr, var);
    fatal(0);
  }
  oop value= eval(cadr(args), ctx);
  set(var, Variable,value, value);
  oop expr= value;
  if (is(Form, expr)) expr= get(value, Form,function);
  if (is(Expr, expr) && (nil == get(expr, Expr,name))) set(expr, Expr,name, get(var, Variable,name));
  return value;
}

static subr(definedP)
{
  oop symbol= car(args);
  oop theenv= cadr(args);
  if (nil == theenv) theenv= get(globals, Variable,value);
  return findVariable(theenv, symbol);
}

#define _do_unary()								\
  _do(com, ~)

#define _do(NAME, OP)								\
  static subr(NAME)								\
  {										\
    arity1(args, #OP);								\
    oop rhs= getHead(args);							\
    if (isLong(rhs)) return newLong(OP getLong(rhs));				\
    fprintf(stderr, "%s: non-integer argument: ", #OP);				\
    fdumpln(stderr, rhs);							\
    fatal(0);									\
    return nil;									\
  }

_do_unary()

#undef _do

#define _do_ibinary()								\
  _do(bitand,  &)  _do(bitor,   |)  _do(bitxor,  ^)  _do(shl, <<)  _do(shr, >>)

#define _do(NAME, OP)								\
  static subr(NAME)								\
  {										\
    arity2(args, #OP);								\
    oop lhs= getHead(args);							\
    oop rhs= getHead(getTail(args));						\
    if (isLong(lhs) && isLong(rhs))						\
      return newLong(getLong(lhs) OP getLong(rhs));				\
    fprintf(stderr, "%s: non-integer argument: ", #OP);				\
    if (!isLong(lhs))	fdumpln(stderr, lhs);					\
    else		fdumpln(stderr, rhs);					\
    fatal(0);									\
    return nil;									\
    }

_do_ibinary()

#undef _do

#define _do_binary()								\
  _do(add,     +)  _do(mul,     *)  _do(div,     /)

#define _do(NAME, OP)										\
    static subr(NAME)										\
    {												\
	arity2(args, #OP);									\
	oop lhs= getHead(args);									\
	oop rhs= getHead(getTail(args));							\
	if (isLong(lhs)) {									\
	    if (isLong(rhs))	return newLong(getLong(lhs) OP getLong(rhs));			\
	    if (isDouble(rhs))	return newDouble((double)getLong(lhs) OP getDouble(rhs));	\
	}											\
	else if (isDouble(lhs)) {								\
	    if (isDouble(rhs))	return newDouble(getDouble(lhs) OP getDouble(rhs));		\
	    if (isLong(rhs))	return newDouble(getDouble(lhs) OP (double)getLong(rhs));	\
	}											\
	fprintf(stderr, "%s: non-numeric argument: ", #OP);					\
	if (!isNumeric(lhs))	fdumpln(stderr, lhs);						\
	else			fdumpln(stderr, rhs);						\
	fatal(0);										\
	return nil;										\
    }

_do_binary()

#undef _do

static subr(sub)
{
    if (!is(Pair, args)) arity(args, "-");
    oop lhs= getHead(args);  args= getTail(args);
    if (!is(Pair, args)) {
	if (isLong  (lhs))	return newLong  (- getLong  (lhs));
	if (isDouble(lhs))	return newDouble(- getDouble(lhs));
	fprintf(stderr, "-: non-numeric argument: ");
	fdumpln(stderr, lhs);
	fatal(0);
    }
    oop rhs= getHead(args);  args= getTail(args);
    if (is(Pair, args)) arity(args, "-");
    if (isLong(lhs)) {
	if (isLong(rhs))	return newLong(getLong(lhs) - getLong(rhs));
	if (isDouble(rhs))	return newDouble((double)getLong(lhs) - getDouble(rhs));
    }
    if (isDouble(lhs)) {
	if (isDouble(rhs))	return newDouble(getDouble(lhs) - getDouble(rhs));
	if (isLong(rhs))	return newDouble(getDouble(lhs) - (double)getLong(rhs));
	lhs= rhs; // for error msg
    }
    fprintf(stderr, "-: non-numeric argument: ");
    fdumpln(stderr, lhs);
    fatal(0);
    return nil;
}

static subr(mod)
{
    if (!is(Pair, args)) arity(args, "%");
    oop lhs= getHead(args);  args= getTail(args);
    if (!is(Pair, args)) arity(args, "%");
    oop rhs= getHead(args);  args= getTail(args);
    if (is(Pair, args)) arity(args, "%");
    if (isLong(lhs)) {
	if (isLong(rhs))	return newLong(getLong(lhs) % getLong(rhs));
	if (isDouble(rhs))	return newDouble(fmod((double)getLong(lhs), getDouble(rhs)));
    }
    else if (isDouble(lhs)) {
	if (isDouble(rhs))	return newDouble(fmod(getDouble(lhs), getDouble(rhs)));
	if (isLong(rhs))	return newDouble(fmod(getDouble(lhs), (double)getLong(rhs)));
    }
    fprintf(stderr, "%%: non-numeric argument: ");
    if (!isNumeric(lhs))	fdumpln(stderr, lhs);
    else			fdumpln(stderr, rhs);
    fatal(0);
    return nil;
}

#define _do_relation()									\
  _do(lt,   <)  _do(le,  <=)  _do(ge,  >=)  _do(gt,   >)

#define _do(NAME, OP)										\
    static subr(NAME)										\
    {												\
	arity2(args, #OP);									\
	oop lhs= getHead(args);									\
	oop rhs= getHead(getTail(args));							\
	if (isLong(lhs)) {									\
	    if (isLong(rhs))	return newBool(getLong(lhs) OP getLong(rhs));			\
	    if (isDouble(rhs))	return newBool((double)getLong(lhs) OP getDouble(rhs));		\
            lhs= rhs;										\
	}											\
	else if (isDouble(lhs)) {								\
	    if (isDouble(rhs))	return newBool(getDouble(lhs) OP getDouble(rhs));		\
	    if (isLong(rhs))	return newBool(getDouble(lhs) OP (double)getLong(rhs));		\
	    lhs= rhs;										\
	}											\
	fprintf(stderr, "%s: non-numeric argument: ", #OP);					\
	fdumpln(stderr, lhs);									\
	fatal(0);										\
	return nil;										\
    }

_do_relation()

#undef _do

static int equal(oop lhs, oop rhs)
{
    int ans= 0;
    switch (getType(lhs)) {
	case Long:
	    switch (getType(rhs)) {
		case Long:	ans= (        getLong  (lhs) ==         getLong  (rhs));	break;
		case Double:	ans= ((double)getLong  (lhs) ==         getDouble(rhs));	break;
	    }
	    break;
	case Double:
	    switch (getType(rhs)) {
		case Long:	ans= (        getDouble(lhs) == (double)getLong  (rhs));	break;
		case Double:	ans= (        getDouble(lhs) ==         getDouble(rhs));	break;
	    }
	    break;
	case String:		ans= (is(String, rhs) 	&& !wcscmp(get(lhs, String,bits), get(rhs, String,bits)));	break;
	default:		ans= (lhs == rhs);									break;
    }
    return ans;
}

static subr(eq)
{
    arity2(args, "=");
    oop lhs= getHead(args);
    oop rhs= getHead(getTail(args));
    return newBool(equal(lhs, rhs));
}

static subr(ne)
{
    arity2(args, "!=");
    oop lhs= getHead(args);
    oop rhs= getHead(getTail(args));
    return newBool(!equal(lhs, rhs));
}

static subr(exit)
{
  oop n= car(args);
  exit(isLong(n) ? getLong(n) : 0);
}

static subr(abort)
{
  fatal(0);
  return nil;
}

static subr(open)
{
  oop arg= car(args);
  if (!is(String, arg)) { fprintf(stderr, "open: non-string argument: ");  fdumpln(stderr, arg);  fatal(0); }
  char *name= strdup(wcs2mbs(get(arg, String,bits)));
  char *mode= "r";
  long  wide= 1;
  if (is(String, cadr(args))) mode= wcs2mbs(get(cadr(args), String,bits));
  if (is(Long, caddr(args))) wide= getLong(caddr(args));
  FILE *stream= (FILE *)fopen(name, mode);
  free(name);
  if (stream) fwide(stream, wide);
  return stream ? newInt64((uint64_t)stream) : nil;
}

static subr(close)
{
  oop arg= car(args);
  if (!isLong(arg) && !isInt64(arg)) { fprintf(stderr, "close: non-integer argument: ");  fdumpln(stderr, arg);  fatal(0);}
  FILE *stream;
  if (isLong(arg)) {
      stream = (FILE *)getLong(arg);
  }
  else stream = (FILE *)getInt64(arg);
  fclose((FILE *)stream);
  return arg;
}

static subr(getb)
{
  oop arg= car(args);
  if (nil == arg) arg= get(input, Variable,value);
  if (!isLong(arg) && !isInt64(arg)) { fprintf(stderr, "getb: non-integer argument: ");  fdumpln(stderr, arg);  fatal(0);}
  FILE *stream;
  if (isLong(arg)) {
      stream = (FILE *)getLong(arg);
  }
  else stream = (FILE *)getInt64(arg);
  int c= getc(stream);
  return (EOF == c) ? nil : newLong(c);
}

static subr(getc)
{
  oop arg= car(args);
  if (nil == arg) arg= get(input, Variable,value);
  if (!isLong(arg) && !isInt64(arg)) { fprintf(stderr, "getc: non-integer argument: ");  fdumpln(stderr, arg);  fatal(0); }
  FILE *stream;
  if (isLong(arg)) {
      stream = (FILE *)getLong(arg);
  }
  else stream = (FILE *)getInt64(arg);
  int c= getwc(stream);
  return (WEOF == c) ? nil : newLong(c);
}

static subr(putb)
{
  oop chr= car(args);
  oop arg= cadr(args);
  if (nil == arg) arg= get(output, Variable,value);
  if (!isLong(chr)) { fprintf(stderr, "putb: non-integer character: ");  fdumpln(stderr, chr);  fatal(0); }
  if (!isLong(arg)) { fprintf(stderr, "putb: non-integer argument: ");  fdumpln(stderr, arg);  fatal(0); }
  FILE *stream= (FILE *)getLong(arg);
  int c= putc(getLong(chr), stream);
  return (EOF == c) ? nil : chr;
}

static subr(putc)
{
  oop chr= car(args);
  oop arg= cadr(args);
  if (nil == arg) arg= get(output, Variable,value);
  if (!isLong(chr)) { fprintf(stderr, "putc: non-integer character: ");  fdumpln(stderr, chr);  fatal(0); }
  if (!isLong(arg)) { fprintf(stderr, "putc: non-integer argument: ");  fdumpln(stderr, arg);  fatal(0); }
  FILE *stream= (FILE *)getLong(arg);
  int c= putwc(getLong(chr), stream);
  return (WEOF == c) ? nil : chr;
}

static subr(read)
{
  FILE *stream= stdin;
  oop   head= nil;
  if (nil == args) {
    beginSource(L"<stdin>");
    oop obj= read(stdin);
    endSource();
    if (obj == DONE) obj= nil;
    return obj;
  }
  oop arg= car(args);
  if (is(String, arg)) {
      wchar_t *path= get(arg, String,bits);
      stream= fopen(wcs2mbs(path), "r");
      if (!stream) return nil;
      fwide(stream, 1);
      beginSource(path);
      head= newPairFrom(nil, nil, currentSource);		GC_PROTECT(head);
      oop tail= head;
      oop obj= nil;						GC_PROTECT(obj);
      for (;;) {
	  obj= read(stream);
	  if (obj == DONE) break;
	  tail= setTail(tail, newPairFrom(obj, nil, currentSource));
	  if (stdin == stream) break;
      }
      head= getTail(head);				GC_UNPROTECT(obj);
      fclose(stream);				GC_UNPROTECT(head);
      endSource();
  }
  else if (isLong(arg)) {
      stream= (FILE *)getLong(arg);
      if (stream) head= read(stream);
      if (head == DONE) head= nil;
  }
  else {
      fprintf(stderr, "read: non-String/Long argument: ");
      fdumpln(stderr, arg);
      fatal(0);
  }
  return head;
}

static subr(expand)
{
  oop x= car(args);  args= cdr(args);		GC_PROTECT(x);
  oop e= car(args);
  if (nil == e) e= get(ctx, Context,env);
  x= expand(x, e);				GC_UNPROTECT(x);
  return x;
}

static subr(encode)
{
  oop x= car(args);  args= cdr(args);		GC_PROTECT(x);
  oop e= car(args);
  if (nil == e) e= get(ctx, Context,env);
  x= encode(x, e);				GC_UNPROTECT(x);
  return x;
}

static subr(eval)
{
  oop x= car(args);  args= cdr(args);				GC_PROTECT(x);
  oop e= car(args);
  if (nil == e) e= newEnv(get(globals, Variable,value), 1, 0);	GC_PROTECT(e);
  x= expand(x, e);
  x= encode(x, e);
  oop c= newBaseContext(nil, nil, e);				GC_PROTECT(c);
  x= eval  (x, c);						GC_UNPROTECT(c);  GC_UNPROTECT(e);  GC_UNPROTECT(x);
  return x;
}

static subr(apply)
{
    if (!is(Pair, args))					fatal("too few arguments in: apply");
    oop f= car(args);
    oop a= args;						assert(is(Pair, a));
    oop b= getTail(a);
    oop c= cdr(b);
    while (is(Pair, c)) a= b, c= cdr(b= c);			assert(is(Pair, a));
    setTail(a, car(b));
    return apply(f, cdr(args), ctx);
}

static subr(type_of)
{
  arity1(args, "type-of");
  return newLong(getType(getHead(args)));
}

static subr(warn)
{
  while (is(Pair, args)) {
    doprint(stderr, getHead(args), 0);
    args= getTail(args);
  }
  return nil;
}

static subr(print)
{
  while (is(Pair, args)) {
    print(getHead(args));
    args= getTail(args);
  }
  return nil;
}

static subr(dump)
{
  while (is(Pair, args)) {
    dump(getHead(args));
    args= getTail(args);
  }
  return nil;
}

static subr(format)
{
  arity2(args, "format");
  oop     ofmt= car(args);		if (!is(String, ofmt)) fatal("format is not a string");
  oop     oarg= cadr(args);
  wchar_t *fmt= get(ofmt, String,bits);
  int     farg= 0;
  union { long l;  void *p;  double d; } arg;
  switch (getType(oarg)) {
      case Undefined:					  break;
      case Long:	arg.l= getLong(oarg);		  break;
      case Double:	arg.d= getDouble(oarg);  ++farg;  break;
      case String:	arg.p= get(oarg, String,bits);	  break;
      case Symbol:	arg.p= get(oarg, Symbol,bits);	  break;
      default:		arg.p= oarg;			  break;
  }
  size_t size= 100;
  wchar_t *p, *np;
  oop ans= nil;
  if (!(p= malloc(sizeof(wchar_t) * size))) return nil;
  for (;;) {
      int n = farg ? swnprintf(p, size, fmt, (wchar_t)arg.d) : swnprintf(p, size, fmt, (wchar_t)arg.p);
    if (0 <= n && n < size) {
      ans= newString(p);
      free(p);
      break;
    }
    if (n < 0 && errno == EILSEQ) return nil;
    if (n >= 0)	size= n + 1;
    else	size *= 2;
    if (!(np= realloc(p, sizeof(wchar_t) * size))) {
      free(p);
      break;
    }
    p= np;
  }
  return ans;
}

static subr(form)
{
  return newForm(car(args), cadr(args));
}

static subr(fixedP)
{
  arity1(args, "fixed?");
  return newBool(is(Fixed, getHead(args)));
}

static subr(cons)
{
  oop lhs= car(args);
  oop rhs= cadr(args);
  return newPair(lhs, rhs);	// (is(Pair, rhs) ? newPairFrom(lhs, rhs, rhs) : newPair(lhs, rhs));
}

static subr(pairP)
{
  arity1(args, "pair?");
  return newBool(is(Pair, getHead(args)));
}

static subr(car)
{
  arity1(args, "car");
  return car(getHead(args));
}

static subr(set_car)
{
  arity2(args, "set-car");
  oop arg= getHead(args);				if (!is(Pair, arg)) return nil;
  return setHead(arg, getHead(getTail(args)));
}

static subr(cdr)
{
  arity1(args, "cdr");
  return cdr(getHead(args));
}

static subr(set_cdr)
{
  arity2(args, "set-cdr");
  oop arg= getHead(args);				if (!is(Pair, arg)) return nil;
  return setTail(arg, getHead(getTail(args)));
}

static subr(formP)
{
  arity1(args, "form?");
  return newBool(is(Form, getHead(args)));
}

static subr(symbolP)
{
  arity1(args, "symbol?");
  return newBool(is(Symbol, getHead(args)));
}

static subr(stringP)
{
  arity1(args, "string?");
  return newBool(is(String, getHead(args)));
}

static subr(string)
{
  oop arg= car(args);
  int num= isLong(arg) ? getLong(arg) : 0;
  return _newString(num);
}

static subr(string_length)
{
  arity1(args, "string-length");
  oop arg= getHead(args);		if (!is(String, arg)) { fprintf(stderr, "string-length: non-String argument: ");  fdumpln(stderr, arg);  fatal(0); }
  return newLong(stringLength(arg));
}

static subr(string_at)
{
  arity2(args, "string-at");
  oop arr= getHead(args);		if (!is(String, arr)) { fprintf(stderr, "string-at: non-String argument: ");  fdumpln(stderr, arr);  fatal(0); }
  oop arg= getHead(getTail(args));	if (!isLong(arg)) return nil;
  int idx= getLong(arg);
  if (0 <= idx && idx < stringLength(arr)) return newLong(get(arr, String,bits)[idx]);
  return nil;
}

static subr(set_string_at)
{
  arity3(args, "set-string-at");
  oop arr= getHead(args);			if (!is(String, arr)) { fprintf(stderr, "set-string-at: non-string argument: ");  fdumpln(stderr, arr);  fatal(0); }
  oop arg= getHead(getTail(args));		if (!isLong(arg)) { fprintf(stderr, "set-string-at: non-integer index: ");  fdumpln(stderr, arg);  fatal(0); }
  oop val= getHead(getTail(getTail(args)));	if (!isLong(val)) { fprintf(stderr, "set-string-at: non-integer value: ");  fdumpln(stderr, val);  fatal(0); }
  int idx= getLong(arg);
  if (idx < 0) return nil;
  int len= stringLength(arr);
  if (len <= idx) {
    if (len < 2) len= 2;
    while (len <= idx) len *= 2;
    set(arr, String,bits, (wchar_t *)GC_realloc(get(arr, String,bits), sizeof(wchar_t) * (len + 1)));
    set(arr, String,size, newLong(len));
  }
  get(arr, String,bits)[idx]= getLong(val);
  return val;
}

static subr(string_copy)	// string from len
{
  oop str= car(args);			if (!is(String, str)) { fprintf(stderr, "string-copy: non-string argument: ");  fdumpln(stderr, str);  fatal(0); }
  int ifr= 0;
  int sln= stringLength(str);
  oop ofr= cadr(args);
  if (nil != ofr) {			if (!isLong(ofr)) { fprintf(stderr, "string-copy: non-integer start: ");  fdumpln(stderr, ofr);  fatal(0); }
      ifr= getLong(ofr);
      if (ifr < 0  ) ifr= 0;
      if (ifr > sln) ifr= sln;		assert(ifr >= 0 && ifr <= sln);
      sln -= ifr;			assert(sln >= 0);
  }
  oop oln= caddr(args);
  if (nil != oln) {			if (!isLong(oln)) { fprintf(stderr, "string-copy: non-integer length: ");  fdumpln(stderr, oln);  fatal(0); }
      int iln= getLong(oln);
      if (iln < 0) iln= 0;
      if (iln > sln) iln= sln;		assert(iln >= 0 && ifr + iln <= sln);
      sln= iln;
  }
  return newStringN(get(str, String,bits) + ifr, sln);
}

static subr(string_compare)	// string substring offset=0 length=strlen(substring)
{
  oop str= car(args);			if (!is(String, str)) { fprintf(stderr, "string-compare: non-string argument: ");  fdumpln(stderr, str);  fatal(0); }
  oop arg= cadr(args);			if (!is(String, arg)) { fprintf(stderr, "string-compare: non-string argument: ");  fdumpln(stderr, arg);  fatal(0); }
  oop oof= caddr(args);
  int off= 0;
  if (nil != oof) {			if (!isLong(oof)) { fprintf(stderr, "string-compare: non-integer offset: ");  fdumpln(stderr, oof);  fatal(0); }
      off= getLong(oof);
  }
  oop oln= cadddr(args);
  int len= stringLength(str);
  if (nil != oln) {			if (!isLong(oln)) { fprintf(stderr, "string-compare: non-integer length: ");  fdumpln(stderr, oln);  fatal(0); }
      len= getLong(oln);
  }
  if (off < 0 || len < 0) return newLong(-1);
  if (off >= stringLength(str)) return newLong(-1);
  return newLong(wcsncmp(get(str, String,bits) + off, get(arg, String,bits), len));
}

static subr(symbol_compare)
{
  arity2(args, "symbol-compare");
  oop str= getHead(args);			if (!is(Symbol, str)) { fprintf(stderr, "symbol-compare: non-symbol argument: ");  fdumpln(stderr, str);  fatal(0); }
  oop arg= getHead(getTail(args));		if (!is(Symbol, arg)) { fprintf(stderr, "symbol-compare: non-symbol argument: ");  fdumpln(stderr, arg);  fatal(0); }
  return newLong(wcscmp(get(str, Symbol,bits), get(arg, Symbol,bits)));
}

static subr(string_symbol)
{
  oop arg= car(args);				if (is(Symbol, arg)) return arg;  if (!is(String, arg)) return nil;
  return intern(get(arg, String,bits));
}

static subr(symbol_string)
{
  oop arg= car(args);				if (is(String, arg)) return arg;  if (!is(Symbol, arg)) return nil;
  return newString(get(arg, Symbol,bits));
}

static subr(long_double)
{
  oop arg= car(args);				if (is(Double, arg)) return arg;  if (!isLong(arg)) return nil;
  return newDouble(getLong(arg));
}

static subr(long_string)
{
  oop arg= car(args);				if (is(String, arg)) return arg;  if (!isLong(arg)) return nil;
  wchar_t buf[32];
  swnprintf(buf, 32, L"%ld", getLong(arg));
  return newString(buf);
}

static subr(string_long)
{
    oop arg= car(args);				if (isLong(arg)) return arg;  if (!is(String, arg)) return nil;
    return newLong(wcstol(get(arg, String,bits), 0, 0));
}

static subr(double_long)
{
  oop arg= car(args);				if (isLong(arg)) return arg;  if (!isDouble(arg)) return nil;
  return newLong((long)getDouble(arg));
}

static subr(double_string)
{
    oop arg= car(args);				if (is(String, arg)) return arg;  if (!isDouble(arg)) return nil;
    wchar_t buf[32];
    swnprintf(buf, 32, L"%f", (wchar_t)getDouble(arg));
    return newString(buf);
}

static subr(string_double)
{
    oop arg= car(args);				if (is(Double, arg)) return arg;  if (!is(String, arg)) return nil;
    return newDouble(wcstod(get(arg, String,bits), 0));
}

static subr(array)
{
  oop arg= car(args);
  int num= isLong(arg) ? getLong(arg) : 0;
  return newArray(num);
}

static subr(arrayP)
{
  return is(Array, car(args)) ? s_t : nil;
}

static subr(array_length)
{
  arity1(args, "array-length");
  oop arg= getHead(args);		if (!is(Array, arg)) { fprintf(stderr, "array-length: non-Array argument: ");  fdumpln(stderr, arg);  fatal(0); }
  return get(arg, Array,size);
}

static subr(array_at)
{
  arity2(args, "array-at");
  oop arr= getHead(args);
  oop arg= getHead(getTail(args));	if (!isLong(arg)) return nil;
  return arrayAt(arr, getLong(arg));
}

static subr(set_array_at)
{
  arity3(args, "set-array-at");
  oop arr= getHead(args);
  oop arg= getHead(getTail(args));		if (!isLong(arg)) return nil;
  oop val= getHead(getTail(getTail(args)));
  return arrayAtPut(arr, getLong(arg), val);
}

static subr(array_compare)	// array subarray offset=0 length=arrlen(subarray)
{
  oop arr= car(args);			if (!is(Array, arr)) { fprintf(stderr, "array-compare: non-array argument: ");  fdumpln(stderr, arr);  fatal(0); }
  oop brr= cadr(args);			if (!is(Array, brr)) { fprintf(stderr, "array-compare: non-array argument: ");  fdumpln(stderr, brr);  fatal(0); }
  int off= 0;
  int len= 0;
  int aln= arrayLength(arr);
  int bln= arrayLength(brr);
  oop oof= caddr(args);
  if (nil != oof) {			if (!isLong(oof)) { fprintf(stderr, "array-compare: non-integer offset: ");  fdumpln(stderr, oof);  fatal(0); }
      off= getLong(oof);
      if (off < 0) off += aln;
      if (off < 0 || off >= aln)	return newLong(-1);
  }
  oop oln= cadddr(args);
  if (nil != oln) {			if (!isLong(oln)) { fprintf(stderr, "array-compare: non-integer length: ");  fdumpln(stderr, oln);  fatal(0); }
      len= getLong(oln);
      if (len < 0 || len > bln
	  || off + len >= aln)		return newLong(-1);
  }
  else {
      len= arrayLength(arr) - off;
  }
  long *aptr= (long *)get(arr, Array,_array) + off;
  long *bptr= (long *)get(brr, Array,_array);
  long  cmp = 0;
  while (!cmp && len--) cmp= *aptr++ - *bptr++;
  return newLong(cmp);
}

static subr(data)
{
    oop arg= car(args);
    int num= isLong(arg) ? getLong(arg) : 0;
    return newData(num);
}

static subr(data_length)
{
  arity1(args, "data-length");
  oop arg= getHead(args);		if (!is(Data, arg)) { fprintf(stderr, "data-length: non-Data argument: ");  fdumpln(stderr, arg);  fatal(0); }
  return newLong(GC_size(arg));
}

static void idxtype(oop args, char *who)
{
    fprintf(stderr, "\n%s: non-integer index: ", who);
    fdumpln(stderr, args);
    fatal(0);
}

static void valtype(oop args, char *who)
{
    fprintf(stderr, "\n%s: improper store: ", who);
    fdumpln(stderr, args);
    fatal(0);
}

static inline uint64_t checkRange(oop obj, unsigned long offset, unsigned long eltsize, oop args, char *who)
{
    if (isLong(obj)) return getLong(obj) + offset;
    if (offset + eltsize > GC_size(obj)) {
	fprintf(stderr, "\n%s: index (%ld) out of range: ", who, offset);
	fdumpln(stderr, args);
	fatal(0);
    exit(666);
    }
    return (uint64_t)obj + offset;
}

#define accessor(name, otype, ctype)											\
    static subr(name##_at)												\
    {															\
	oop arg= args;						if (!isPair(arg)) arity(args, #name"-at");		\
	oop obj= getHead(arg);		arg= getTail(arg);	if (!isPair(arg)) arity(args, #name"-at");		\
	oop idx= getHead(arg);		arg= getTail(arg);	if (!isLong(idx)) idxtype(args, #name"-at");		\
	unsigned long off= getLong(idx);										\
	if (isPair(arg)) {												\
	    oop mul= getHead(arg);				if (!isLong(mul)) idxtype(args, #name"-at");		\
	    off *= getLong(mul);				if (nil != getTail(arg)) arity(args, #name"-at");	\
	}														\
	else														\
	    off *= sizeof(ctype);											\
	return new##otype(*(ctype *)checkRange(obj, off, sizeof(ctype), args, #name"-at"));				\
    }															\
															\
    static subr(set_##name##_at)											\
    {															\
	oop arg= args;						if (!isPair(arg)) arity(args, "set-"#name"-at");	\
	oop obj= getHead(arg);		arg= getTail(arg);	if (!isPair(arg)) arity(args, "set-"#name"-at");	\
	oop idx= getHead(arg);		arg= getTail(arg);	if (!isPair(arg)) arity(args, "set-"#name"-at");	\
	oop val= getHead(arg);		arg= getTail(arg);	if (!isLong(idx)) idxtype(args, "set-"#name"-at");	\
	unsigned long off= getLong(idx);										\
	if (isPair(arg)) {					if (!isLong(val)) idxtype(args, "set-"#name"-at");	\
	    off *= getLong(val);											\
	    val= getHead(arg);					if (nil != getTail(arg)) arity(args, "set-"#name"-at");	\
	}														\
	else														\
	    off *= sizeof(ctype);				if (!is##otype(val)) valtype(args, "set-"#name"-at");	\
	*(ctype *)checkRange(obj, off, sizeof(ctype), args, "set-"#name"-at")= get##otype(val);				\
	return val;													\
    }

accessor(byte,		Long, 	 unsigned char)
accessor(char,		Long, 	 char)
accessor(short,		Long, 	 short)
accessor(wchar,		Long, 	 wchar_t)
accessor(int,		Long, 	 int)
accessor(int32,		Long, 	 int32_t)
accessor(int64,		Long, 	 int64_t)
accessor(long,		Long, 	 long)
accessor(longlong,	Long, 	 long long)
accessor(pointer,	Long, 	 long)
accessor(float,		Double,	 float)
accessor(double,	Double,	 double)
accessor(longdouble,	Double,	 long double)

#undef accessor


static subr(native_call)
{
    oop  obj= car(args);
    union { long l[34]; float f[34]; double d[17]; } argv;
    int  argc= 0;
    args= cdr(args);
    while (is(Pair, args) && argc < 32)
    {
	oop arg= getHead(args);
	args= getTail(args);
	switch (getType(arg))
	{
	    case Undefined:	argv.l[argc]= 0;						break;
	    case Long:		argv.l[argc]= getLong(arg);					break;
 	    case Double:
#if 1
				argc= (argc + 1) & -2;  argv.d[argc++ >> 2]= getDouble(arg);	break;
#else
				argv.f[argc]= getDouble(arg);					break;
#endif
 	    case String:	argv.l[argc]= (uint64_t)wcs2mbs(get(arg, String,bits));		break;
	    case Subr:		argv.l[argc]= (uint64_t)get(arg, Subr,imp);				break;
	    default:		argv.l[argc]= (uint64_t)arg;					break;
	}
	++argc;
    }
    void  *addr= 0;
    size_t size= 0;
    switch (getType(obj))
    {
	case Data:	addr= obj;			size= GC_size(obj);	break;
	case Long:	addr= (void *)getLong(obj);				break;
	case Subr:	addr= get(obj, Subr,imp);				break;
	default:	fatal("call: cannot call object of type %i", getType(obj));
    }
   
    return newLong(((int (*)())addr)(argv));
}

#include "windows.h"

static subr(subr)
{
    oop arg= car(args);
    wchar_t *name= 0;
    switch (getType(arg))
    {
	case String:	name= get(arg, String,bits);  break;
	case Symbol:	name= get(arg, Symbol,bits);  break;
	default:	fatal("subr: argument must be string or symbol");
    }
    char *sym= wcs2mbs(name);
    HANDLE currentModuleHandle = GetModuleHandle(NULL);
    FARPROC addr = GetProcAddress(currentModuleHandle, sym);
    if (!addr) fatal("could not find symbol: %s", sym);
    proto_t *sig= 0;
    arg= cadr(args);
    if (nil != arg) {				if (!is(String, arg)) { fprintf(stderr, "subr: non-String signature: ");  fdumpln(stderr, arg);  fatal(0); }
	wchar_t  *spec = get(arg, String,bits);
	int       mode = 0;
	cast_t    cast = 0;
	ffi_type *type = 0;
	sig= calloc(1, sizeof(proto_t));
	sig->arg_count= 0;
	sig->arg_rest=  0;
	while ((mode= *spec++)) {
	    switch (mode) {
		case 'd':	type= &ffi_type_double;	  cast= ffdouble;	break;
		case 'f':	type= &ffi_type_float;	  cast= fffloat;	break;
		case 'i':	type= &ffi_type_sint;	  cast= ffint;		break;
		case 'j':	type= &ffi_type_sint32;	  cast= ffint32;	break;
		case 'k':	type= &ffi_type_sint64;	  cast= ffint64;	break;
		case 'l':	type= &ffi_type_slong;	  cast= fflong;		break;
		case 'p':	type= &ffi_type_pointer;  cast= ffpointer;	break;
		case 's':	type= &ffi_type_pointer;  cast= ffstring;	break;
		case 'S':	type= &ffi_type_pointer;  cast= ffpointer;	break;
		case '.':	sig->arg_rest++;				break;
		default:	fatal("illegal type specification: %s", get(arg, String,bits));
	    }
	    if (sig->arg_rest) break;
	    sig->arg_types[sig->arg_count]= type;
	    sig->arg_casts[sig->arg_count]= cast;
	    sig->arg_count++;
	}
    }
    return newSubr(name, (imp_t)addr, sig);
}

static subr(subr_name)
{
    oop arg= car(args);				if (!is(Subr, arg)) { fprintf(stderr, "subr-name: non-Subr argument: ");  fdumpln(stderr, arg);  fatal(0); }
    return newString(get(arg, Subr,name));
}

static subr(allocate)
{
  arity2(args, "allocate");
  oop type= getHead(args);			if (!isLong(type)) return nil;
  oop size= getHead(getTail(args));		if (!isLong(size)) return nil;
  return _newOops(getLong(type), sizeof(oop) * getLong(size));
}

static subr(allocate_atomic)
{
    arity2(args, "allocate-atomic");
    oop type= getHead(args);			if (!isLong(type)) return nil;
    oop size= getHead(getTail(args));		if (!isLong(size)) return nil;
    return _newBits(getLong(type), getLong(size));
}

static subr(oop_at)
{
  arity2(args, "oop-at");
  oop obj= getHead(args);
  oop arg= getHead(getTail(args));	if (!isLong(arg)) return nil;
  return oopAt(obj, getLong(arg));
}

static subr(set_oop_at)
{
  arity3(args, "set-oop-at");
  oop obj= getHead(args);
  oop arg= getHead(getTail(args));		if (!isLong(arg)) return nil;
  oop val= getHead(getTail(getTail(args)));
  return oopAtPut(obj, getLong(arg), val);
}

static subr(not)
{
  arity1(args, "not");
  oop obj= getHead(args);
  return (nil == obj) ? s_t : nil;
}

static subr(verbose)
{
  oop obj= car(args);
  if (nil == obj) return newLong(opt_v);
  if (!isLong(obj)) return nil;
  opt_v= getLong(obj);
  return obj;
}

static subr(optimised)
{
  oop obj= car(args);
  if (nil == obj) return newLong(opt_O);
  if (!isLong(obj)) return nil;
  opt_O= getLong(obj);
  return obj;
}

static subr(sin)
{
  oop obj= getHead(args);
  double arg= 0.0;
  if	  (isDouble(obj)) arg=         getDouble(obj);
  else if (isLong  (obj)) arg= (double)getLong  (obj);
  else {
    fprintf(stderr, "sin: non-numeric argument: ");
    fdumpln(stderr, obj);
    fatal(0);
  }
  return newDouble(sin(arg));
}

static subr(cos)
{
  oop obj= getHead(args);
  double arg= 0.0;
  if	  (isDouble(obj)) arg=         getDouble(obj);
  else if (isLong  (obj)) arg= (double)getLong  (obj);
  else {
    fprintf(stderr, "cos: non-numeric argument: ");
    fdumpln(stderr, obj);
    fatal(0);
  }
  return newDouble(cos(arg));
}

static subr(log)
{
  oop obj= getHead(args);
  double arg= 0.0;
  if	  (isDouble(obj)) arg=         getDouble(obj);
  else if (isLong  (obj)) arg= (double)getLong  (obj);
  else {
    fprintf(stderr, "log: non-numeric argument: ");
    fdumpln(stderr, obj);
    fatal(0);
  }
  return newDouble(log(arg));
}

static subr(address_of)
{
  oop arg= car(args);
  return newLong((uint64_t)arg);
}

#include <winsock.h>
#include <time.h>
#if defined(WIN32)
    struct rusage {
      struct timeval ru_utime;
      struct timeval ru_stime;
    };

#   define RUSAGE_SELF 0

#   define timersub(a, b, result)					\
    do {								\
      (result)->tv_sec = (a)->tv_sec - (b)->tv_sec;			\
      (result)->tv_usec = (a)->tv_usec - (b)->tv_usec;			\
      if ((result)->tv_usec < 0) {					\
	--(result)->tv_sec;						\
	(result)->tv_usec += 1000000;					\
      }									\
    } while (0)

    static void getrusage(int who, struct rusage *ru)
    {
      clock_t cl= clock();
      long ms= cl * 1000 / CLOCKS_PER_SEC;
      ru->ru_utime.tv_sec=  (ms / 1000);
      ru->ru_utime.tv_usec= (ms % 1000) * 1000;
      ru->ru_stime.tv_sec=  0;
      ru->ru_stime.tv_usec= 0;
    }
#else
# include <sys/resource.h>
#endif

static struct timeval epoch;

static void init_times(void)
{
    //gettimeofday(&epoch, 0);
}

static subr(times)
{
    struct timeval tv = { 0 };
    struct rusage ru = { 0 };
    //gettimeofday(&tv, 0);
    getrusage(RUSAGE_SELF, &ru);
    oop secs= newLong(tv.tv_sec);						GC_PROTECT(secs);
    timersub(&tv, &epoch, &tv);
    oop real= newLong(tv.tv_sec * 1000 + tv.tv_usec / 1000);			GC_PROTECT(real);
    oop user= newLong(ru.ru_utime.tv_sec * 1000 + ru.ru_utime.tv_usec / 1000);	GC_PROTECT(user);
    oop syst= newLong(ru.ru_stime.tv_sec * 1000 + ru.ru_stime.tv_usec / 1000);	GC_PROTECT(syst);
    secs= newPair(secs, nil);
    syst= newPair(syst, secs);
    user= newPair(user, syst);							GC_UNPROTECT(syst);
    real= newPair(real, user);							GC_UNPROTECT(user);
										GC_UNPROTECT(real);
										GC_UNPROTECT(secs);
    return real;
}

typedef struct { char *name;  imp_t imp; } subr_ent_t;

static subr_ent_t subr_tab[256];

#if !defined(LIB_GC)

static void saver(FILE *out, void *ptr)
{
    oop obj= (oop)ptr;								assert(ptr && !((uint64_t)ptr & 1));
    int type= ptr2hdr(ptr)->type;
    if (out) put32(out, type);
    switch (type) {
	case Symbol: {
	    wchar_t *str= get(obj, Symbol,bits);
	    int      len= wcslen(str);
	    if (out) {
		int i;
		put32(out, len);
		for (i= 0;  i < len;  ++i) put32(out, str[i]);
	    }
	    break;
	}
	case Subr: {
	    wchar_t *str= get(obj, Subr,name);
	    int      len= wcslen(str);
	    if (out) {
		int i;
		put32(out, len);
		for (i= 0;  i < len;  ++i) put32(out, str[i]);
	    }
	    break;
	}
	default:
	    GC_saver(out, ptr);
	    break;
    }
}

static void loader(FILE *in, void *ptr)
{
    oop obj= (oop)ptr;								assert(ptr && !((uint64_t)ptr & 1));
    int tmp32;
    int type= get32(in, &tmp32);
    ptr2hdr(ptr)->type= type;
    switch (type) {
	case Symbol: {
	    int      len= get32(in, &tmp32);
	    wchar_t *str= (wchar_t *)alloca(4 * len + 4);
	    int      i;
	    for (i= 0;  i < len;  ++i) str[i]= get32(in, &tmp32);
	    str[i]= 0;
	    //wprintf(L"loading Symbol %ls\n", str);
	    set(obj, Symbol,bits, _wcsdup(str));
	    break;
	}
	case Subr: {
	    int i, len= get32(in, &tmp32);
	    wchar_t *str= (wchar_t *)alloca(4 * len + 4);
	    for (i= 0;  i < len;  ++i) str[i]= get32(in, &tmp32);
	    str[i]= 0;
	    //wprintf(L"loading Subr %ls\n", str);
	    set(obj, Subr,name, _wcsdup(str));
	    set(obj, Subr,imp,  0);
	    char *sym= wcs2mbs(str);
	    void *addr= 0;
	    subr_ent_t *ptr= subr_tab;
	    for (ptr= subr_tab;  ptr->name;  ++ptr) {
		if (!strcmp(sym, ptr->name + 1)) {
		    addr= ptr->imp;
		    break;
		}
	    }
	    if (!addr) {
            HMODULE handle = GetModuleHandle(NULL);
		    addr= GetProcAddress(handle, sym);
		if (!addr) fatal("loader: could not find Subr name: %s", sym);
	    }
	    set(obj, Subr,imp, addr);
	    break;
	}
	default:
	    GC_loader(in, ptr);
	    break;
    }
}

#include <sys/stat.h>

static subr(save)
{
    oop       arg= car(args);		if (!is(String, arg)) { fprintf(stderr, "save: non-String argument: ");  fdumpln(stderr, arg);  fatal(0); }
    wchar_t *name= get(arg, String,bits);
    char    *path= wcs2mbs(name);
    FILE  *stream= fopen(path, "wb");
    if (!stream) return nil;
    fprintf(stream, "#!%s -l\n", argv0);
    GC_save(stream, saver);
    fclose(stream);
    return arg;
}

#endif

#undef subr

static void replFile(FILE *stream, wchar_t *path)
{
  set(input, Variable,value, newLong((uint64_t)stream));
  beginSource(path);
  for (;;) {
    if (stream == stdin) {
      printf(".");
      fflush(stdout);
    }
    oop obj= read(stream);
    if (obj == DONE) break;
    GC_PROTECT(obj);
    if (opt_v) {
      dumpln(obj);
      fflush(stdout);
    }
    oop env= newEnv(get(globals, Variable,value), 1, 0);	GC_PROTECT(env);
    obj= expand(obj, env);
    obj= encode(obj, env);
    oop ctx= newBaseContext(nil, nil, env);			GC_PROTECT(ctx);
    obj= eval  (obj, ctx);					GC_UNPROTECT(ctx);  GC_UNPROTECT(env);
    if ((stream == stdin) || (opt_v > 0)) {
      printf(" => ");
      fflush(stdout);
      dumpln(obj);
      fflush(stdout);
    }
    GC_UNPROTECT(obj);
    if (opt_v) {
#if (!LIB_GC)
      GC_gcollect();
      printf("%ld collections, %ld objects, %ld bytes, %4.1f%% fragmentation\n",
	     (long)GC_collections, (long)GC_count_objects(), (long)GC_count_bytes(),
	     GC_count_fragments() * 100.0);
#endif
    }
  }
  int c= getwc(stream);
  if (WEOF != c)			fatal("unexpected character 0x%02x '%c'\n", c, c);
  endSource();
}

static void replPath(wchar_t *path)
{
  FILE *stream= fopen(wcs2mbs(path), "r");
  if (!stream) {
    int err= errno;
    fprintf(stderr, "\nerror: ");
    errno= err;
    perror(wcs2mbs(path));
    fatal(0);
  }
  fwide(stream, 1);
  if (fscanf(stream, "#!%*[^\012\015]"));
  replFile(stream, path);
  fclose(stream);
}

static void sigint(int signo)
{
  fatal("\nInterrupt");
}

#if !defined(WIN32) && (!LIB_GC)

static int profilerCount= 0;

static void sigvtalrm(int signo)
{
    if (traceDepth < 1) return;
    ++profilerCount;
    oop func= arrayAt(traceStack, traceDepth - 1);
    switch (getType(func))
    {
	case Expr: {
	    oop profile= get(func, Expr,profile);
	    if ((long)profile & 1) {
		set(func, Expr,profile, (oop)((long)profile + 2));
	    }
	    else printf("? %p\n", func);
	    break;
	}
	case Subr: {
	    set(func, Subr,profile, 1 + get(func, Subr,profile));
	    break;
	}
    }
}

#include <sys/time.h>

static void profilingEnable(void)
{
    struct itimerval itv= { { 0, opt_p }, { 0, opt_p } };	/* VTALARM every opt_p mSecs */
    setitimer(ITIMER_VIRTUAL, &itv, 0);
}

static void profilingDisable(int stats)
{
    struct itimerval itv= { { 0, 0 }, { 0, 0 } };
    setitimer(ITIMER_VIRTUAL, &itv, 0);
    if (stats)
    {
	struct profile { int profile;  oop object, source; } profiles[64];
	int nprofiles= 0;
	fprintf(stderr, "%i profiles\n", profilerCount);
	GC_gcollect();
	oop obj;
	for (obj= GC_first_object();  obj;  obj= GC_next_object(obj)) {
	    int profile= 0;
	    oop source= nil;
	    switch (getType(obj))
	    {
		case Expr: {
		    oop oprof= get(obj, Expr,profile);
		    if (isLong(oprof)) {
			profile= getLong(get(obj, Expr,profile));
			source=  cddr(get(obj, Expr,defn));
		    }
		    break;
		}
		case Subr: {
		    profile= get(obj, Subr,profile);
		    break;
		}
	    }
	    if (profile) {
		int index= 0;
		while (index < nprofiles && profile <= profiles[index].profile) ++index;
		if (nprofiles < 64) ++nprofiles;
		int jndex;
		for (jndex= nprofiles - 1;  jndex > index;  --jndex) profiles[jndex] = profiles[jndex - 1];
		profiles[index]= (struct profile){ profile, obj, source };
	    }
	}
	int i;
	for (i= 0;  i < nprofiles;  ++i) {
	    fprintf(stderr, "%i\t", profiles[i].profile);
	    int l= fprintSource(stderr, profiles[i].source);
	    if (l < 20) fprintf(stderr, "%*s", 20 - l, "");
	    fprintf(stderr, " ");
	    fdumpln(stderr, profiles[i].object);
	}
    }
}

#endif

static subr_ent_t subr_tab[] = {
# define _do(NAME, OP)				\
    { " "#OP,			subr_##NAME },
    _do_unary()
    _do_ibinary()
    _do_binary()
    { " -",			subr_sub },
    { " %",			subr_mod },
    _do_relation()
    { " =",			subr_eq },
    { " !=",			subr_ne },
# undef _do
    { ".if",			subr_if },
    { ".and",			subr_and },
    { ".or",			subr_or },
    { ".set",			subr_set },
    { ".let",			subr_let },
    { ".while",			subr_while },
    { ".quote",			subr_quote },
    { ".lambda",		subr_lambda },
    { ".define",		subr_define },
    { " defined?",		subr_definedP },
    { " exit",			subr_exit },
    { " abort",			subr_abort },
//  { " current-environment",	subr_current_environment },
    { " open",			subr_open },
    { " close",			subr_close },
    { " getb",			subr_getb },
    { " getc",			subr_getc },
    { " putb",			subr_putb },
    { " putc",			subr_putc },
    { " read",			subr_read },
    { " expand",		subr_expand },
    { " encode",		subr_encode },
    { " eval",			subr_eval },
    { " apply",			subr_apply },
    { " type-of",		subr_type_of },
    { " warn",			subr_warn },
    { " print",			subr_print },
    { " dump",			subr_dump },
    { " format",		subr_format },
    { " form",			subr_form },
    { " fixed?",		subr_fixedP },
    { " cons",			subr_cons },
    { " pair?",			subr_pairP },
    { " car",			subr_car },
    { " set-car",		subr_set_car },
    { " cdr",			subr_cdr },
    { " set-cdr",		subr_set_cdr },
    { " form?",			subr_formP },
    { " symbol?",		subr_symbolP },
    { " string?",		subr_stringP },
    { " string", 		subr_string },
    { " string-length",		subr_string_length },
    { " string-at",		subr_string_at },
    { " set-string-at",		subr_set_string_at },
    { " string-copy",		subr_string_copy },
    { " string-compare",	subr_string_compare },
    { " symbol->string", 	subr_symbol_string },
    { " string->symbol", 	subr_string_symbol },
    { " symbol-compare", 	subr_symbol_compare },
    { " long->double",   	subr_long_double },
    { " long->string",   	subr_long_string },
    { " string->long",   	subr_string_long },
    { " double->long",   	subr_double_long },
    { " double->string", 	subr_double_string },
    { " string->double", 	subr_string_double },
    { " array",			subr_array },
    { " array?",		subr_arrayP },
    { " array-length",		subr_array_length },
    { " array-at",		subr_array_at },
    { " set-array-at",		subr_set_array_at },
    { " array-compare",		subr_array_compare },
    { " data",			subr_data },
    { " data-length",		subr_data_length },
    { " byte-at",		subr_byte_at },
    { " set-byte-at",		subr_set_byte_at },
    { " char-at",		subr_char_at },
    { " set-char-at",		subr_set_char_at },
    { " short-at",		subr_short_at },
    { " set-short-at",		subr_set_short_at },
    { " wchar-at",		subr_wchar_at },
    { " set-wchar-at",		subr_set_wchar_at },
    { " int-at",		subr_int_at },
    { " set-int-at",		subr_set_int_at },
    { " int32-at",		subr_int32_at },
    { " set-int32-at",		subr_set_int32_at },
    { " int64-at",		subr_int64_at },
    { " set-int64-at",		subr_set_int64_at },
    { " long-at",		subr_long_at },
    { " set-long-at",		subr_set_long_at },
    { " longlong-at",		subr_longlong_at },
    { " set-longlong-at",	subr_set_longlong_at },
    { " pointer-at",		subr_pointer_at },
    { " set-pointer-at",	subr_set_pointer_at },
    { " float-at",		subr_float_at },
    { " set-float-at",		subr_set_float_at },
    { " double-at",		subr_double_at },
    { " set-double-at",		subr_set_double_at },
    { " longdouble-at",		subr_longdouble_at },
    { " set-longdouble-at",	subr_set_longdouble_at },
    { " native-call",		subr_native_call },
    { " subr",			subr_subr },
    { " subr-name",		subr_subr_name },
    { " allocate",		subr_allocate },
    { " allocate-atomic",	subr_allocate_atomic },
    { " oop-at",		subr_oop_at },
    { " set-oop-at",		subr_set_oop_at },
    { " not",			subr_not },
    { " verbose",		subr_verbose },
    { " optimised",		subr_optimised },
    { " sin",			subr_sin },
    { " cos",			subr_cos },
    { " log",			subr_log },
    { " address-of",		subr_address_of },
    { " times",			subr_times },
#if !defined(LIB_GC)
    { " save",			subr_save },
#endif
    { 0,			0 }};

int main(int argc, char **argv)
{
  switch (sizeof(long)) {
      case  4: ffi_type_long= ffi_type_sint32;	break;
      case  8: ffi_type_long= ffi_type_sint64;	break;
      case 16: fatal("I cannot run here");	break;
  }

  argv0= argv[0];

  init_times();

  if ((fwide(stdin, 1) <= 0) || (fwide(stdout, -1) >= 0) || (fwide(stderr, -1) >= 0)) {
    fprintf(stderr, "Cannot set stream widths.\n");
    return 1;
  }

  if (!setlocale(LC_CTYPE, "")) {
    fprintf(stderr, "Cannot set the locale.  Verify your LANG, LC_CTYPE, LC_ALL.\n");
    return 1;
  }

  GC_INIT();

  GC_add_root(&symbols);
  GC_add_root(&globals);
  GC_add_root(&expanders);
  GC_add_root(&encoders);
  GC_add_root(&evaluators);
  GC_add_root(&applicators);
  GC_add_root(&backtrace);
  GC_add_root(&arguments);
  GC_add_root(&input);
  GC_add_root(&output);

  symbols= newArray(0);

  s_set			= intern(L"set");			GC_add_root(&s_set		);
  s_define		= intern(L"define");			GC_add_root(&s_define		);
  s_let			= intern(L"let");			GC_add_root(&s_let		);
  s_lambda		= intern(L"lambda");			GC_add_root(&s_lambda		);
  s_quote		= intern(L"quote");			GC_add_root(&s_quote		);
  s_quasiquote		= intern(L"quasiquote");		GC_add_root(&s_quasiquote	);
  s_unquote		= intern(L"unquote");			GC_add_root(&s_unquote		);
  s_unquote_splicing	= intern(L"unquote-splicing");		GC_add_root(&s_unquote_splicing	);
  s_t			= intern(L"t");				GC_add_root(&s_t		);
  s_dot			= intern(L".");				GC_add_root(&s_dot		);
  s_bracket		= intern(L"bracket");			GC_add_root(&s_bracket		);
  s_brace		= intern(L"brace");			GC_add_root(&s_brace		);
  s_main		= intern(L"*main*");			GC_add_root(&s_main		);

  oop tmp= nil;		GC_PROTECT(tmp);

  globals= newEnv(nil, 0, 0);
  globals= define(globals, intern(L"*globals*"), globals);

  expanders=	define(get(globals, Variable,value), intern(L"*expanders*"),   nil);
  encoders=	define(get(globals, Variable,value), intern(L"*encoders*"),    nil);
  evaluators=	define(get(globals, Variable,value), intern(L"*evaluators*"),  nil);
  applicators=	define(get(globals, Variable,value), intern(L"*applicators*"), nil);

  traceStack=	newArray(32);					GC_add_root(&traceStack);

  backtrace=	define(get(globals, Variable,value), intern(L"*backtrace*"), nil);
  input=	define(get(globals, Variable,value), intern(L"*input*"), nil);
  output=	define(get(globals, Variable,value), intern(L"*output*"), nil);

  currentPath= nil;			GC_add_root(&currentPath);
  currentLine= nil;			GC_add_root(&currentLine);
  currentSource= newPair(nil, nil);	GC_add_root(&currentSource);

  {
    subr_ent_t *ptr;
    for (ptr= subr_tab;  ptr->name;  ++ptr) {
      wchar_t *name= _wcsdup(mbs2wcs(ptr->name + 1));
      tmp= newSubr(name, ptr->imp, 0);
      if ('.' == ptr->name[0]) tmp= newFixed(tmp);
      define(get(globals, Variable,value), intern(name), tmp);
    }
  }

  tmp= nil;		GC_UNPROTECT(tmp);

  f_set=    lookup(get(globals, Variable,value), s_set   );		GC_add_root(&f_set);
  f_quote=  lookup(get(globals, Variable,value), s_quote );		GC_add_root(&f_quote);
  f_lambda= lookup(get(globals, Variable,value), s_lambda);		GC_add_root(&f_lambda);
  f_let=    lookup(get(globals, Variable,value), s_let   );		GC_add_root(&f_let);
  f_define= lookup(get(globals, Variable,value), s_define);		GC_add_root(&f_define);

  int repled= 0;

#if !defined(LIB_GC)

  if (argc > 2 && !strcmp(argv[1], "-l")) {
      FILE *stream= fopen(argv[2], "rb");
      //printf("load memory from %s %p\n", argv[2], stream);
      if (!stream) {
	  perror(argv[2]);
	  exit(1);
      }
      while ('\n' != getc(stream));
      GC_load(stream, loader);
      fclose(stream);
      argc -= 2;
      argv += 2;
      opt_b= 1;	// don't load boot.l
      GC_gcollect();
  }

#endif

  {
      tmp= nil;		GC_PROTECT(tmp);

      while (--argc) {
	  tmp= newPair(nil, tmp);
	  setHead(tmp, newString(mbs2wcs(argv[argc])));
      }
      arguments= define(get(globals, Variable,value), intern(L"*arguments*"), tmp);

      tmp= nil;		GC_UNPROTECT(tmp);
  }

  signal(SIGINT, sigint);

#if !defined(WIN32) && (!LIB_GC)
  {
      struct sigaction sa;
      sa.sa_handler= sigvtalrm;
      sigemptyset(&sa.sa_mask);
      sa.sa_flags= 0;
      if (sigaction(SIGVTALRM, &sa, 0)) perror("vtalrm");
  }
#endif

  {
      oop func= findVariable(get(globals, Variable,value), s_main);
      if (is(Variable, func)) {
	  apply(get(func, Variable,value), nil, nil);
	  exit(0);
      }
  }

  while (is(Pair, get(arguments, Variable,value))) {
    oop argl= get(arguments, Variable,value);		GC_PROTECT(argl);
    oop args= getHead(argl);
    oop argt= getTail(argl);
    wchar_t *arg= get(args, String,bits);
    if 	    (!wcscmp (arg, L"-v"))	{ ++opt_v; }
    else if (!wcscmp (arg, L"-b"))	{ ++opt_b; }
    else if (!wcscmp (arg, L"-g"))	{ ++opt_g;  opt_p= 0; }
    else if (!wcscmp (arg, L"-O"))	{ ++opt_O; }
#  if !defined(WIN32) && (!LIB_GC)
    else if (!wcsncmp(arg, L"-p", 2)) {
	opt_g= 0;
	opt_p= wcstoul(arg + 2, 0, 0);
	if (!opt_p) opt_p= 1000;
	printf("profiling every %i uSec(s)\n", opt_p);
    }
#  endif
    else
    {
	if (!opt_b)
	{
	    replPath(L"boot.l");
	    opt_b= 1;
	}
	else
	{
#          if !defined(WIN32) && (!LIB_GC)
	    if (opt_p) profilingEnable();
#	   endif
	    set(arguments, Variable,value, argt);
	    replPath(arg);
	    repled= 1;
#	   if !defined(WIN32) && (!LIB_GC)
	    if (opt_p) profilingDisable(0);
#	   endif
	}
	argt= get(arguments, Variable,value);
    }
    set(arguments, Variable,value, argt);		GC_UNPROTECT(argl);
  }

  if (opt_v) {
#if (!LIB_GC)
    GC_gcollect();
    printf("%ld collections, %ld objects, %ld bytes, %4.1f%% fragmentation\n",
	   (long)GC_collections, (long)GC_count_objects(), (long)GC_count_bytes(),
	   GC_count_fragments() * 100.0);
#endif
  }

  set(output, Variable,value, newLong((uint64_t)stdout));

  if (!repled) {
    if (!opt_b) replPath(L"boot.l");
    replFile(stdin, L"<stdin>");
    printf("\nmorituri te salutant\n");
  }

#if !defined(WIN32) && (!LIB_GC)
  if (opt_p) profilingDisable(1);
#endif

  return 0;
}