# minproto.leg -- minimal prototype langauge for semantic experiments
#
# last edited: 2024-05-09 10:17:11 by piumarta on zora-1034.local

%{
;
#ifndef GC
# define GC 1		// do not fill memory with unreachable junk
#endif

#ifndef TAGS
# define TAGS 1		// Integer and Float are immediate values encoded in their object "pointer"
#endif

#ifndef TYPECODES	// <ast>.eval() dispatches using switch(), instead of invoking a method
# define TYPECODES 0	// (approx. 210% performance increase, because no dynamic dispatch in eval())
#endif

#ifndef PRIMCLOSURE	// Lambda and Closure are primitive types, not subtypes of Object
# define PRIMCLOSURE 0	// (approx. 6% performance decrease, because every Object_get() is slower)
#endif

#ifndef DELOPT		// delegate is a member of Object structure, not a normal property
# define DELOPT 0	// (approx. 60% performance increase, becase no associative lookup of __delegate__)
#endif

#include <math.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <assert.h>
#include <stdarg.h>
#include <sys/errno.h>
#include <sys/resource.h> // getrusage()

#if GC
# include <gc.h>
# define xmalloc(N)		(GC_malloc(N))
# define xmallocAtomic(N)	(GC_malloc_atomic(N))
# define xrealloc(P, N)		(GC_realloc(P, N))
#else
# define GC_INIT()
# define xmalloc(N)		(calloc(1, N))
# define xmallocAtomic(N)	(calloc(1, N))
# define xrealloc(P, N)		(realloc(P, N))
#endif

#define indexableSize(A)	(sizeof(A) / sizeof(*(A)))

void fatal(char *fmt, ...);

int opt_O = 0;
int opt_d = 0;
int opt_v = 0;

union object;
typedef union object *oop;

#if PRIMCLOSURE
#define doTypes(_)								\
    _(Undefined)  _(Integer)  _(Float)  _(String)   _(Symbol)  _(Primitive)	\
    _(Lambda)   _(Closure)
#else
#define doTypes(_)								\
    _(Undefined)  _(Integer)  _(Float)  _(String)   _(Symbol)  _(Primitive)
#endif

#define makeType(X) X,
enum  type { doTypes(makeType) makeType(Object) };
#undef makeType

#define makeType(X) #X,
char *typeNames[] = { doTypes(makeType) makeType(Object) };
#undef makeType

typedef oop (*prim_t)(oop func, oop self, oop args, oop env);

#if TAGS
# define TAGBITS	2
# define TAGMASK	3
# define TAGINT		Integer // 1
# define TAGFLT		Float   // 2
#endif

#if PRIMCLOSURE
#define doProtos(_) _(Object) _(GetVar) _(SetVar) _(GetProp) _(SetProp) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal)
#else
#define doProtos(_) _(Object) _(GetVar) _(SetVar) _(GetProp) _(SetProp) _(GetArray) _(SetArray) _(Call) _(Invoke) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure)
#endif

#define  declareProto(NAME)	oop p##NAME = 0;
doProtos(declareProto);
#undef   declareProto

#if TYPECODES

#define  declareTypecode(NAME)	t##NAME,
enum typecode {
    doProtos(declareTypecode)
};
#undef   declareTypecode

#endif // TYPECODES

#define makeProto(NAME)  oop p##NAME = 0;
doTypes(makeProto);
#undef makeProto

#define doProperties(_) _(name) _(eval) _(delegate) _(codeon)

#define declareProp(NAME)	oop prop_##NAME = 0;
doProperties(declareProp);
#undef declareProp

#define doSymbols(_) _(t) _(name) _(expr) _(function) _(arguments) _(object) _(index) _(key) _(value) _(self) _(method) _(parameters) _(body) _(lambda) _(environment) _(operation) _(full) _(condition) _(consequent) _(alternate) _(expression) _(identifier) _(initialise) _(update) _(first) _(last) _(fixed)

#define declareSym(NAME)	oop sym_##NAME = 0;
doSymbols(declareSym);
#undef declareSym

struct property  { oop key, val; };

struct Integer 	 { enum type type;  long _value; };
struct Float   	 { enum type type;  double _value; };
struct String  	 { enum type type;  int length;  char *value; };
#if TYPECODES
struct Symbol  	 { enum type type;  char *name;  oop value;  enum typecode typecode; };
#else // !TYPECODES
struct Symbol  	 { enum type type;  char *name;  oop value; };
#endif
struct Primitive { enum type type;  oop name;  prim_t function; };
#if PRIMCLOSURE
struct Lambda    { enum type type;  oop parameters, body; };
struct Closure   { enum type type;  int fixed;  oop function, environment; };
#endif
struct Object    { enum type type;  int isize, icap, psize;
#                  if DELOPT
    oop delegate;
#                  endif
    oop *indexed;  struct property *properties; };

union object
{
    enum   type      type;
    struct Integer   Integer;
    struct Float     Float;
    struct String    String;
    struct Symbol    Symbol;
    struct Primitive Primitive;
#if PRIMCLOSURE
    struct Lambda    Lambda;
    struct Closure   Closure;
#endif
    struct Object    Object;
};

union object _nil = { Undefined };

#define nil (&_nil)

enum type getType(oop obj)
{
# if TAGS
    if ((intptr_t)obj & TAGMASK) return ((intptr_t)obj & TAGMASK);
# endif
    return obj->type;
}

char *getTypeName(oop obj)
{
    int type = getType(obj);			assert(0 <= type && type <= indexableSize(typeNames));
    return typeNames[type];
}

int is(enum type type, oop obj)	{ return type == getType(obj); }

oop _checkType(oop obj, enum type type, char *file, int line)
{
    if (getType(obj) != type) fatal("%s:%d: expected type %d, got %d\n", file, line, type, getType(obj));
    return obj;
}

#define get(OBJ, TYPE,FIELD)		(_checkType(OBJ, TYPE, __FILE__, __LINE__)->TYPE.FIELD)
#define set(OBJ, TYPE,FIELD, VAL)	(_checkType(OBJ, TYPE, __FILE__, __LINE__)->TYPE.FIELD = VAL)

#ifdef NDEBUG
# define _get(OBJ, TYPE,FIELD)		((OBJ)->TYPE.FIELD)
# define _set(OBJ, TYPE,FIELD, VAL)	((OBJ)->TYPE.FIELD = VAL)
#else
# define _get(OBJ, TYPE,FIELD)		get(OBJ, TYPE,FIELD)
# define _set(OBJ, TYPE,FIELD, VAL )	set(OBJ, TYPE,FIELD, VAL)
#endif

#define make(TYPE)	make_(sizeof(struct TYPE), TYPE)

oop make_(size_t size, enum type type)
{
    oop obj = xmalloc(size);
    obj->type = type;
    return obj;
}

oop newInteger(long value)
{
# if TAGS
    return (oop)((intptr_t)value << TAGBITS | TAGINT);
# else
    oop obj = make(Integer);
    _set(obj, Integer,_value, value);
    return obj;
# endif
}

#define isInteger(obj)	is(Integer, obj)

long _integerValue(oop obj)
{
# if TAGS
    return (intptr_t)obj >> TAGBITS;
# else
    return _get(obj, Integer,_value);
# endif
}

long integerValue(oop obj, char *op)
{
    if (!isInteger(obj)) fatal("%s: non-integer operand", op);
    return _integerValue(obj);
}

oop newFloat(double value)
{
# if TAGS
    union { intptr_t ptr;  double dbl; } bits = { .dbl = value };
    return (oop)((bits.ptr & ~TAGMASK) | TAGFLT);
# else
    oop obj = make(Float);
    _set(obj, Float,_value, value);
    return obj;
# endif
}

double _floatValue(oop obj)
{
# if TAGS
    union { intptr_t ptr;  double dbl; } bits = { .ptr = (intptr_t)obj };
    return bits.dbl;
# else
    return _get(obj, Float,_value);
# endif
}

double floatValue(oop obj, char *op)
{
    switch (getType(obj)) {
	case Integer:	return (double)_integerValue(obj);
	case Float:	return (double)_floatValue(obj);
	default:	fatal("%s: non-numeric operand", op);
    }
    return 0;
}

oop newStringLen(char *value, int length)
{
    oop   obj = make(String);
    char *str = xmallocAtomic(length+1);
    memcpy(str, value, length);
    str[length] = 0;
    _set(obj, String,length, length);
    _set(obj, String,value,  str);
    return obj;
}

oop newString(char *value)
{
    return newStringLen(value, strlen(value));
}

int digitValue(int digit, int base)
{
    if      ('a' <= digit && digit <= 'z') digit -= 'a' - 10;
    else if ('A' <= digit && digit <= 'Z') digit -= 'A' - 10;
    else if (digit < '0' || digit > '9') return -1;
    return (digit < base) ? digit : -1;
}

int readCharValue(char **stringp, int base, int limit)
{
    char *string = *stringp;
    int   value = 0, d = 0;
    while (limit-- && *string && (d = digitValue(*string, base)) >= 0) {
	++string;
	value = value * base + d;
    }
    *stringp = string;
    return value;
}

int   String_length(oop str)	{ return get(str, String,length); 			}
oop   String_reset (oop str)	{        set(str, String,length, 0);  return str;	}

void  String_clear(oop str)
{
    set(str, String,length, 0);
    set(str, String,value,  0);
}

oop String_append(oop str, int c)
{
    int  length = get(str, String,length);
    char *value = get(str, String,value);
    value = xrealloc(value, length + 1);
    set(str, String,value,  value);
    set(str, String,length, length+1);
    value[length] = c;
    return str;
}

oop String_appendAllLen(oop str, char *s, int len)
{
    int  length = get(str, String,length);
    char *value = get(str, String,value);
    value = xrealloc(value, length + len);
    memcpy(value + length, s, len);
    set(str, String,value,  value);
    set(str, String,length, length+len);
    return str;
}

oop String_appendAll(oop str, char *s)
{
    return String_appendAllLen(str, s, strlen(s));
}

oop String_format(oop str, char *fmt, ...)
{
    size_t  len = 0, cap = 16;
    int  length = get(str, String,length);
    char *value = get(str, String,value);
    for (;;) {
	value = xrealloc(value, length + cap);
	va_list ap;
	va_start(ap, fmt);
	len = vsnprintf(value + length, cap, fmt, ap);
	va_end(ap);
	if (len < cap) break;
	cap += len;
    }
    set(str, String,value,  value);
    set(str, String,length, length+len);
    return str;
}

char *String_content(oop str)
{
    String_append(str, 0);
    _get(str, String,length) -= 1;
    return _get(str, String,value);
}

oop newStringEscaped(char *string)
{
    oop buf = newStringLen(0, 0);
    while (*string) {
	int c = *string++;
	if ('\\' == c && *string) {
	    c = *string++;			assert(c != 0);
	    switch (c) {
		case '\"': c = '\"';  break;
		case '\'': c = '\'';  break;
		case '\\': c = '\\';  break;
		case 'a' : c = '\a';  break;
		case 'b' : c = '\b';  break;
		case 'f' : c = '\f';  break;
		case 'n' : c = '\n';  break;
		case 'r' : c = '\r';  break;
		case 't' : c = '\t';  break;
		case 'v' : c = '\v';  break;
		case 'X' :
		case 'x' : c = readCharValue(&string, 16, -1);		break;
		case '0' : c = readCharValue(&string, 8, 3);		break;
		default  : fatal("illegal character escape sequence");	break;
	    }
	}
	String_append(buf, c);
    }
    return buf;
}

oop newSymbol(char *name)
{
    oop obj = make(Symbol);
    _set(obj, Symbol,name,  strdup(name));
    _set(obj, Symbol,value, nil);
    return obj;
}

char *stringValue(oop obj, char *who)
{
    int type = getType(obj);
    if (type == String) return _get(obj, String,value);
    if (type == Symbol) return _get(obj, Symbol,name);
    fatal("%s: non-string operand", who);
    return 0;
}

oop newPrimitive(prim_t function)
{
    oop obj = make(Primitive);
    _set(obj, Primitive,name,     0);
    _set(obj, Primitive,function, function);
    return obj;
}

#if PRIMCLOSURE

oop newLambda(oop parameters, oop body)
{
    oop obj = make(Lambda);
    _set(obj, Lambda,parameters, parameters);
    _set(obj, Lambda,body,       body);
    return obj;
}

oop newClosure(oop function, oop environment)
{
    oop obj = make(Closure);
    _set(obj, Closure,function,    function);
    _set(obj, Closure,environment, environment);
    return obj;
}

int isClosure(oop obj) { return is(Closure, obj); }

#endif

oop     macros  = 0;
oop    *symbols = 0;
size_t nsymbols = 0;

oop intern(char *name)
{
    ssize_t lo = 0, hi = nsymbols - 1;
    while (lo <= hi) {
	ssize_t mid = (lo + hi) / 2;
	oop sym = symbols[mid];
	int cmp = strcmp(name, _get(sym, Symbol,name));
	if      (cmp < 0) hi = mid - 1;
	else if (cmp > 0) lo = mid + 1;
	else              return sym;
    }
    symbols = xrealloc(symbols, sizeof(*symbols) * ++nsymbols);
    memmove(symbols + lo + 1, symbols + lo, sizeof(*symbols) * (nsymbols - 1 - lo));
    return symbols[lo] = newSymbol(name);
}

oop Object_at(oop obj, size_t index)
{
    size_t size = get(obj, Object,isize);
    if (index >= size) fatal("index %zd out of range (%zd)", index, size);
    return _get(obj, Object,indexed)[index];
}

oop Object_atPut(oop obj, size_t index, oop val)
{
    size_t size = get(obj, Object,isize);
    if (index >= size) fatal("index %zd out of range (%zd)", index, size);
    return _get(obj, Object,indexed)[index] = val;
}

oop Object_push(oop obj, oop val)
{
    size_t  size =  get(obj, Object,isize);
    size_t   cap = _get(obj, Object,icap );
    oop *indexed = _get(obj, Object,indexed);
    if (size >= cap) {
	cap = cap ? cap * 2 : 4;
	indexed = xrealloc(indexed, sizeof(*indexed) * cap);
	_set(obj, Object,icap,    cap);
	_set(obj, Object,indexed, indexed);
    }
    indexed[size++] = val;
    _set(obj, Object,isize, size);
    return val;
}

oop Object_pop(oop obj)
{
    size_t  size =  get(obj, Object,isize);
    if (!size) fatal("pop: object is empty");
    oop *indexed = _get(obj, Object,indexed);
    oop  result  = indexed[--size];
    _set(obj, Object,isize, size);
    return result;
}

ssize_t Object_find(oop obj, oop key)
{
    ssize_t hi = get(obj, Object,psize) - 1;	// asserts obj is Object
    if (hi < 0) return -1;
    struct property *kvs = _get(obj, Object,properties);
    ssize_t lo = 0;
    while (lo <= hi) {
	ssize_t mid = (lo + hi) / 2;
	oop  midkey = kvs[mid].key;
	if      (key < midkey) hi = mid - 1;
	else if (key > midkey) lo = mid + 1;
	else 		   return mid;
    }
    return -1 - lo;
}

oop Object_getLocal(oop obj, oop key)
{
    if (!is(Object, obj)) return nil;
    ssize_t ind = Object_find(obj, key);
    if (ind >= 0) return _get(obj, Object,properties)[ind].val;
    return nil;
}

#if DELOPT
# define _getDelegate(OBJ)	_get(OBJ, Object,delegate)
# define _setDelegate(OBJ, VAL)	_set(OBJ, Object,delegate, VAL)
#else
# define _getDelegate(OBJ)	Object_getLocal(OBJ, prop_delegate)
# define _setDelegate(OBJ, VAL)	Object_put(OBJ, prop_delegate, VAL)
#endif

char *storeString(oop obj, int indent);

oop Object_get(oop obj, oop key)
{
    oop o;
    switch (getType(obj)) {
	case Undefined:	o = pUndefined;  break;
	case Integer:	o = pInteger;    break;
	case Float:	o = pFloat;      break;
	case String:	o = pString;     break;
	case Symbol:	o = pSymbol;     break;
	case Primitive:	o = pPrimitive;  break;
#     if PRIMCLOSURE
	case Lambda:
	    if (key == sym_parameters) return _get(obj, Lambda,parameters);
	    if (key == sym_body      ) return _get(obj, Lambda,body      );
	    o = pLambda;
	    break;
	case Closure:
	    if (key == sym_function   ) return _get(obj, Closure,function   );
	    if (key == sym_environment) return _get(obj, Closure,environment);
	    if (key == sym_fixed      ) return _get(obj, Closure,fixed) ? sym_t : nil;
	    o = pClosure;
	    break;
#     endif
	case Object: {
	    ssize_t ind = Object_find(obj, key);
	    if (ind >= 0) return _get(obj, Object,properties)[ind].val;
	    o = _getDelegate(obj);
	    break;
	}
    }
    if (key == prop_delegate) return o;
    while (is(Object, o)) {
	ssize_t ind = Object_find(o, key);
	if (ind >= 0) return _get(o, Object,properties)[ind].val;
	o = _getDelegate(o);
    }
    fatal("%s.%s is undefined", storeString(obj, 0), storeString(key, 0));
    return nil;
}

oop getvar(oop obj, oop key)
{
    while (is(Object, obj)) {
	ssize_t ind = Object_find(obj, key);
	if (ind >= 0) return _get(obj, Object,properties)[ind].val;
	obj = _getDelegate(obj);
    }
    return is(Symbol, key) ? _get(key, Symbol,value) : nil;
}

oop setvar(oop obj, oop key, oop val)
{
    while (is(Object, obj)) {
	ssize_t ind = Object_find(obj, key);
	if (ind >= 0) return _get(obj, Object,properties)[ind].val = val;
	obj = _getDelegate(obj);
    }
    return is(Symbol, key) ? _set(key, Symbol,value, val) : nil;
}

oop Object_put(oop obj, oop key, oop val)
{
# if PRIMCLOSURE
    switch (getType(obj)) {
	case Lambda:
	    if (key == sym_parameters ) { _set(obj, Lambda,parameters, val);  return val; }
	    if (key == sym_body       ) { _set(obj, Lambda,body,       val);  return val; }
	    break;
	case Closure:
	    if (key == sym_fixed   	 ) { _set(obj, Closure,fixed, nil != val);  return val; }
	    if (key == sym_function	 ) { _set(obj, Closure,function,     val);  return val; }
	    if (key == sym_environment) { _set(obj, Closure,environment,  val);  return val; }
	default:
	    break;
    }
# endif
    ssize_t ind = Object_find(obj, key);
    struct property *kvs = _get(obj, Object,properties);
    if (ind < 0) {
#     if DELOPT
	if (key == prop_delegate) return _setDelegate(obj, val);
#     endif
	int size = _get(obj, Object,psize);
	ind = -1 - ind;					assert(0 <= ind && ind <= size);
	kvs = xrealloc(kvs, sizeof(*kvs) * ++size);
	_set(obj, Object,properties, kvs);
	_set(obj, Object,psize,      size);
	memmove(kvs + ind + 1, kvs + ind, sizeof(*kvs) * (size - 1 - ind));
	kvs[ind].key = key;
    }							assert(ind < _get(obj, Object,psize));
    							assert(kvs[ind].key == key);
    return kvs[ind].val = val;
}

oop new(oop delegate)
{
    oop obj = make(Object);
    _set(obj, Object,isize,      0);
    _set(obj, Object,icap,       0);
    _set(obj, Object,indexed,    0);
# if DELOPT
    _set(obj, Object,psize,      0);
    _setDelegate(obj, delegate);
# else
    _set(obj, Object,psize,      1);
    _set(obj, Object,properties, xmalloc(sizeof(struct property)))
	[0] = (struct property) { prop_delegate, delegate };
# endif
    return obj;
}

oop newObjectWith(int isize, oop *indexed, int psize, struct property *properties)
{
    oop obj = make(Object);
    _set(obj, Object,isize,      isize);
    _set(obj, Object,icap,       isize);
    _set(obj, Object,psize,      psize);
    _set(obj, Object,indexed,    indexed);
    _set(obj, Object,properties, properties);
# if DELOPT
    _setDelegate(obj, nil);
# endif
    return obj;
}

oop apply(oop func, oop self, oop args, oop env);

oop codeOn(oop buf, oop obj, int indent);
oop storeOn(oop buf, oop obj, int indent);
oop printOn(oop buf, oop obj, int indent);

void codeParametersOn(oop str, oop object, char *begin, char *end)
{
    String_appendAll(str, begin);
    oop *indexed = _get(object, Object,indexed);
    int  isize   = _get(object, Object,isize);
    int  i;
    for (i = 0;  i < isize;  ++i) {
	if (i) String_appendAll(str, ", ");
	printOn(str, indexed[i], 0);
    }
    String_appendAll(str, end);
}

void codeBlockOn(oop str, oop object)
{
    String_appendAll(str, "{");
    oop *indexed = _get(object, Object,indexed);
    int  isize   = _get(object, Object,isize);
    int  i;
    for (i = 0;  i < isize;  ++i) {
	if (i) String_appendAll(str, "; "); else String_appendAll(str, " ");
	codeOn(str, indexed[i], 0);
    }
    if (isize) String_appendAll(str, " ");
    String_appendAll(str, "}");
}

oop codeOn(oop str, oop obj, int indent)
{
    switch (getType(obj)) {
	case Undefined:	String_appendAll(str, "nil");								break;
	case Integer:	String_format(str, "%ld", _integerValue(obj));						break;
	case Float:	String_format(str, "%f" , _floatValue(obj));						break;
	case String:    storeOn(str, obj, 0);									break;
	case Symbol:	String_format(str, "#%s", _get(obj, Symbol,name));					break;
	case Primitive: {
	    String_appendAll(str, "<primitive ");
	    if (_get(obj, Primitive,name)) codeOn(str, _get(obj, Primitive,name), indent);
	    else                           String_format(str, "%p", _get(obj, Primitive,function));
	    String_append(str, '>');
	    break;
	}
#if PRIMCLOSURE
	case Lambda: {
	    codeParametersOn(str, _get(obj, Lambda,parameters), "(", ")");
	    codeBlockOn(str, _get(obj, Lambda,body));
	    break;
	}
	case Closure: {
	    String_appendAll(str, "<closure>");
	    break;
	}
#endif
	case Object: {
	    oop evaluator = Object_get(obj, prop_codeon);
	    oop args      = new(pObject);
	    Object_push(args, str);
	    apply(evaluator, obj, args, nil);
	    break;
	}
	default:
	    assert(!"this cannot happen");
    }
    return str;
}

oop printOn(oop buf, oop obj, int indent)
{
    switch (getType(obj)) {
	case Undefined:	String_appendAll(buf, "nil");								break;
	case Integer:	String_format(buf, "%ld", _integerValue(obj));						break;
	case Float:	String_format(buf, "%f" , _floatValue(obj));						break;
	case String:	String_format(buf, "%.*s", (int)_get(obj, String,length), _get(obj, String,value));	break;
	case Symbol:	String_appendAll(buf, _get(obj, Symbol,name));						break;
	case Primitive: {
	    String_appendAll(buf, "<primitive ");
	    if (_get(obj, Primitive,name)) printOn(buf, _get(obj, Primitive,name), indent);
	    else                           String_format(buf, "%p", _get(obj, Primitive,function));
	    String_append(buf, '>');
	    break;
	}
#if PRIMCLOSURE
	case Lambda: {
	    String_appendAll(buf, "<<Lambda>>");
	    if (!indent) break;

	    String_append(buf, '\n');
	    for (int j = indent;  j--;) String_appendAll(buf, "  | ");
	    String_appendAll(buf, "  body: ");
	    printOn(buf, _get(obj, Lambda,body), indent+1);

	    String_append(buf, '\n');
	    for (int j = indent;  j--;) String_appendAll(buf, "  | ");
	    String_appendAll(buf, "  parameters: ");
	    printOn(buf, _get(obj, Lambda,parameters), indent+1);
	    break;
	}
	case Closure: {
	    String_appendAll(buf, "<<Closure>>");
	    if (!indent) break;

	    String_append(buf, '\n');
	    for (int j = indent;  j--;) String_appendAll(buf, "  | ");
	    String_appendAll(buf, "  environment: ");
	    printOn(buf, _get(obj, Closure,environment), indent+1);

	    String_append(buf, '\n');
	    for (int j = indent;  j--;) String_appendAll(buf, "  | ");
	    String_appendAll(buf, "  function: ");
	    printOn(buf, _get(obj, Closure,function), indent+1);
	    break;
	    break;
	}
#endif
	case Object: {
	    int level = 0;
	    oop proto = obj;
	    oop name  = nil;
	    do {
		++level;
		name = Object_getLocal(proto, prop_name);
		if (nil != name) break;
		proto = _getDelegate(proto);
	    } while (is(Object, proto));
	    for (int i = level;  i--;) String_append(buf, '<');
	    if (name != nil)
		printOn(buf, name, indent);
	    else
		String_appendAll(buf, "?");
	    for (int i = level;  i--;) String_append(buf, '>');
	    if (!indent) break;
	    for (;;) {
		int psize = _get(obj, Object,psize);
		struct property *props = _get(obj, Object,properties);
		for (int i = 0; i < psize;  ++i) {
		    if (prop_delegate == props[i].key) continue;
		    String_append(buf, '\n');
		    for (int j = indent;  j--;) String_appendAll(buf, "  | ");
		    String_appendAll(buf, "  ");
		    printOn(buf, props[i].key, indent+1);
		    String_appendAll(buf, ": ");
		    printOn(buf, props[i].val, indent+1);
		}
		int isize = _get(obj, Object,isize);
		oop *indexed = _get(obj, Object,indexed);
		for (int i = 0; i < isize;  ++i) {
		    String_append(buf, '\n');
		    for (int j = indent;  j--;) String_appendAll(buf, "  | ");
		    String_format(buf, "  %d: ", i);
		    printOn(buf, indexed[i], indent+1);
		}
		oop delegate = _getDelegate(obj);
		if (nil == delegate) break;
		if (nil != Object_getLocal(delegate, prop_name)) break;
		obj = delegate;
		// ++indent;
		String_appendAll(buf, " =>");
	    }
	    break;
	}
	default:
	    assert(!"this cannot happen");
    }
    return buf;
}

oop storeOn(oop buf, oop obj, int indent)
{
    switch (getType(obj)) {
	case String: {
	    String_append(buf, '"');
	    char *str = _get(obj, String,value);
	    int   len = _get(obj, String,length);
	    for (int i = 0;  i < len;  ++i) {
		int c = str[i];
		switch (c) {
		    case '\a': String_appendAll(buf,  "\\a");	break;
		    case '\b': String_appendAll(buf,  "\\b");	break;
		    case '\f': String_appendAll(buf,  "\\f");	break;
		    case '\n': String_appendAll(buf,  "\\n");	break;
		    case '\r': String_appendAll(buf,  "\\r");	break;
		    case '\t': String_appendAll(buf,  "\\t");	break;
		    case '\v': String_appendAll(buf,  "\\v");	break;
		    case  '"': String_appendAll(buf, "\\\"");	break;
		    case '\\': String_appendAll(buf, "\\\\");	break;
		    default:
			if (c < ' ' || c > '~') String_format(buf, "\\%04o", c);
			else                    String_append(buf, c);
			break;
		}
	    }
	    String_append(buf, '"');
	    break;
	}
	default:	printOn(buf, obj, indent);
    }
    return buf;
}

char *codeString(oop obj, int indent)
{
    oop str = newStringLen(0, 0);
    codeOn(str, obj, indent);
    return String_content(str);
}

void code(oop obj, int indent)
{
    printf("%s", codeString(obj, indent));
}

void codeln(oop obj, int indent)
{
    code(obj, indent);
    printf("\n");
}

char *printString(oop obj, int indent)
{
    oop buf = newStringLen(0, 0);
    printOn(buf, obj, indent);
    return String_content(buf);
}

void print(oop obj, int indent)
{
    printf("%s", printString(obj, indent));
}

void println(oop obj, int indent)
{
    print(obj, indent);
    printf("\n");
}

char *storeString(oop obj, int indent)
{
    oop buf = newStringLen(0, 0);
    storeOn(buf, obj, indent);
    return String_content(buf);
}

void store(oop obj, int indent)
{
    printf("%s", storeString(obj, indent));
}

void storeln(oop obj, int indent)
{
    store(obj, indent);
    printf("\n");
}

char *filename = "<stdin>";
int   lineno   = 1;

oop trace = nil;

void fatal(char *fmt, ...)
{
    fflush(stdout);
    va_list ap;
    va_start(ap, fmt);
    fprintf(stderr, "\n%s:%d: ", filename, lineno);
    vfprintf(stderr, fmt, ap);
    fprintf(stderr, "\n");
    va_end(ap);
    if (is(Object, trace)) {
	int w = 1 + log10(_get(trace, Object,isize));
	for (int i = _get(trace, Object,isize);  i--;) {
	    printf("%*d: ", w, i);
	    codeln(_get(trace, Object,indexed)[i], 1);
	}
    }
    exit(1);
}

#include <signal.h>

void sigint(int sig)
{
    fatal("keyboard interrupt");
}

typedef struct Input {
    struct Input *next;
    char	 *text;
    int 	  size;
    int 	  position;
} Input;

Input *newInput(void)
{
    return xmalloc(sizeof(Input));
}

Input *input = 0;

Input *makeInput(void)
{
    return xmalloc(sizeof(Input));
}

#define YYSTYPE oop

#define YY_MALLOC(C, N)		GC_malloc(N)
#define YY_REALLOC(C, P, N)	GC_realloc(P, N)
#define YY_FREE(C, P)		GC_free(P)

#define YY_INPUT(buf, result, max_size)				\
    {								\
	result= (input->position >= input->size)		\
	    ? 0							\
	    : ((*(buf)= input->text[input->position++]), 1);	\
	/* printf("<%c>", *(buf)); */				\
    }

YYSTYPE yysval = 0;

oop eval(oop exp, oop env);
oop evargs(oop list, oop env);

oop  Object_eval(oop exp, oop env)		{ return exp; }

void Object_codeOn(oop exp, oop str, oop env)
{
    storeOn(str, exp, 0);
}

oop newGetVar(oop name)
{
    oop o = new(pGetVar);
    Object_put(o, sym_name, name);
    return o;
}

oop  GetVar_eval(oop exp, oop env)		{ return getvar(env, Object_get(exp, sym_name)); }

void GetVar_codeOn(oop exp, oop str, oop env)	{ printOn(str, Object_get(exp, sym_name), 0); }

oop newSetVar(oop name, oop expr)
{
    oop o = new(pSetVar);
    Object_put(o, sym_name, name);
    Object_put(o, sym_expr, expr);
    return o;
}

oop SetVar_eval(oop exp, oop env)
{
    oop key =      Object_get(exp, sym_name)      ;
    oop val = eval(Object_get(exp, sym_expr), env);
    return setvar(env, key, val);
}

void SetVar_codeOn(oop exp, oop str, oop env)
{
    printOn(str, Object_get(exp, sym_name), 0);
    String_appendAll(str, " = ");
    codeOn(str, Object_get(exp, sym_expr), 0);
}

oop newGetProp(oop object, oop key)
{
    oop o = new(pGetProp);
    Object_put(o, sym_object, object);
    Object_put(o, sym_key   , key   );
    return o;
}

oop GetProp_eval(oop exp, oop env)
{
    oop obj = eval(Object_get(exp, sym_object), env);
    oop key =      Object_get(exp, sym_key   )      ;
    return Object_get(obj, key);
}

void GetProp_codeOn(oop exp, oop str, oop env)
{
    codeOn(str, Object_get(exp, sym_object), 0);
    String_appendAll(str, ".");
    printOn(str, Object_get(exp, sym_key   ), 0);
}

oop newSetProp(oop object, oop key, oop value)
{
    oop o = new(pSetProp);
    Object_put(o, sym_object, object);
    Object_put(o, sym_key   , key   );
    Object_put(o, sym_value , value );
    return o;
}

oop SetProp_eval(oop exp, oop env)
{
    oop obj = eval(Object_get(exp, sym_object), env);
    oop key =      Object_get(exp, sym_key   )      ;
    oop val = eval(Object_get(exp, sym_value ), env);
    return Object_put(obj, key, val);
}

void SetProp_codeOn(oop exp, oop str, oop env)
{
    codeOn(str, Object_get(exp, sym_object), 0);
    oop key = Object_get(exp, sym_key);
    if (is(Symbol,key)) {
	String_appendAll(str, ".");
	printOn(str, key, 0);
    }
    else {
	String_appendAll(str, "[");
	codeOn(str, key, 0);
	String_appendAll(str, "]");
    }
    String_appendAll(str, " = ");
    codeOn(str, Object_get(exp, sym_value ), 0);
}

oop newGetArray(oop object, oop index)
{
    oop o = new(pGetArray);
    Object_put(o, sym_object, object);
    Object_put(o, sym_index , index );
    return o;
}

void oob(oop obj, int index)
{
    fatal("[]: index %d out of bounds in %s", index, storeString(obj, 0));
}

char *String_aref(oop obj, int index)
{
    if (index >= _get(obj, String,length)) oob(obj, index);
    return _get(obj, String,value) + index;
}

char *Symbol_aref(oop obj, int index)
{
    if (index >= strlen(_get(obj, Symbol,name))) oob(obj, index);
    return _get(obj, Symbol,name) + index;
}

oop *Object_aref(oop obj, int index)
{
    if (index >= _get(obj, Object,isize)) oob(obj, index);
    return _get(obj, Object,indexed) + index;
}

oop GetArray_eval(oop exp, oop env)
{
    oop obj = eval(Object_get(exp, sym_object), env);
    oop ind = eval(Object_get(exp, sym_index ), env);
    if (isInteger(ind)) {
	int index = _integerValue(ind);
	switch (getType(obj)) {
	    case String: return newInteger(*String_aref(obj, index));
	    case Symbol: return newInteger(*Symbol_aref(obj, index));
	    case Object: return *Object_aref(obj, index);
	    default:     fatal("[]: %s is not indexable", storeString(obj, 0));
	}
    }
    if (!is(Object, obj)) fatal("[]: %s is not an object", storeString(obj, 0));
    return Object_getLocal(obj, ind);
}

void GetArray_codeOn(oop exp, oop str, oop env)
{
    codeOn(str, Object_get(exp, sym_object), 0);
    String_appendAll(str, "[");
    codeOn(str, Object_get(exp, sym_index), 0);
    String_appendAll(str, "]");
}

oop newSetArray(oop object, oop index, oop value)
{
    oop o = new(pSetArray);
    Object_put(o, sym_object, object);
    Object_put(o, sym_index , index );
    Object_put(o, sym_value , value );
    return o;
}

oop SetArray_eval(oop exp, oop env)
{
    oop obj = eval(Object_get(exp, sym_object), env);
    oop ind = eval(Object_get(exp, sym_index ), env);
    oop val = eval(Object_get(exp, sym_value ), env);
    if (isInteger(ind)) {
	int index = _integerValue(ind);
	switch (getType(obj)) {
	    case String: *String_aref(obj, index) = integerValue(val, "[]=");	break;
	    case Symbol: *Symbol_aref(obj, index) = integerValue(val, "[]=");	break;
	    case Object: *Object_aref(obj, index) = val;			break;
	    default:	 fatal("[]=: %s is not indexable", storeString(obj, 0));
	}
	return val;
    }
    if (!is(Object, obj)) fatal("[]=: %s is not an object", storeString(obj, 0));
    return Object_put(obj, ind, val);
}

void SetArray_codeOn(oop exp, oop str, oop env)
{
    codeOn(str, Object_get(exp, sym_object), 0);
    String_appendAll(str, "[");
    codeOn(str, Object_get(exp, sym_index), 0);
    String_appendAll(str, "] = ");
    codeOn(str, Object_get(exp, sym_value), 0);
}

oop newCall(oop function, oop arguments)
{
    oop o = new(pCall);
    Object_put(o, sym_function , function );
    Object_put(o, sym_arguments, arguments);
    return o;
}

oop newApply(oop function, oop arguments)
{
    if (_getDelegate(function) == pGetVar) {
	oop symbol = Object_get(function, sym_name);
	assert(is(Symbol, symbol));
	oop macro = Object_getLocal(macros, symbol);
	if (nil != macro) return apply(macro, nil, arguments, nil);
    }
    return newCall(function, arguments);
}

int isFixed(oop func)
{
# if PRIMCLOSURE
    return is(Closure, func) && _get(func, Closure,fixed);
# else
    return Object_getLocal(func, sym_fixed) != nil;
# endif
}

oop Call_eval(oop exp, oop env)
{
    oop cfunc = eval  (Object_get(exp, sym_function ), env);
    oop cargs =        Object_get(exp, sym_arguments);
    if (!isFixed(cfunc)) cargs = evargs(cargs, env);
    return apply(cfunc, nil, cargs, env);
}

void codeArgumentsOn(oop str, oop object, char *begin, char *end)
{
    String_appendAll(str, begin);
    oop *indexed = _get(object, Object,indexed);
    int  isize   = _get(object, Object,isize);
    int  i;
    for (i = 0;  i < isize;  ++i) {
	if (i) String_appendAll(str, ", ");
	codeOn(str, indexed[i], 0);
    }
    struct property *kvs   = _get(object, Object,properties);
    int              psize = _get(object, Object,psize);
    for (int j = 0;  j < psize;  ++j) {
	if (prop_delegate == kvs[j].key && pObject == kvs[j].val) continue;
	if (i++) String_appendAll(str, ", ");
	printOn(str, kvs[j].key, 0);
	String_appendAll(str, ": ");
	codeOn(str, kvs[j].val, 0);
    }
    String_appendAll(str, end);
}

void Call_codeOn(oop exp, oop str, oop env)
{
    codeOn(str, Object_get(exp, sym_function ), 0);
    codeArgumentsOn(str, Object_get(exp, sym_arguments), "(", ")");
}

oop newInvoke(oop self, oop method, oop arguments)
{
    oop o = new(pInvoke);
    Object_put(o, sym_self     , self     );
    Object_put(o, sym_method   , method   );
    Object_put(o, sym_arguments, arguments);
    return o;
}

oop Invoke_eval(oop exp, oop env)
{
    oop self  = eval  (Object_get(exp, sym_self     ), env);
    oop meth  =        Object_get(exp, sym_method   )       ;
    oop iargs = evargs(Object_get(exp, sym_arguments), env);
    oop ifunc = Object_get(self, meth);
    if (nil == ifunc) fatal("%s.%s is undefined", storeString(self, 0), storeString(meth, 0));
    return apply(ifunc, self, iargs, env);
}

void Invoke_codeOn(oop exp, oop str, oop env)
{
    codeOn(str, Object_get(exp, sym_self     ), 0);
    String_appendAll(str, ".");
    printOn(str, Object_get(exp, sym_method   ), 0);
    codeArgumentsOn(str, Object_get(exp, sym_arguments), "(", ")");
}

#if !PRIMCLOSURE

oop newLambda(oop parameters, oop body)
{
    oop o = new(pLambda);
    Object_put(o, sym_parameters, parameters);
    Object_put(o, sym_body      , body      );
    return o;
}

oop newClosure(oop function, oop environment)
{
    oop o = new(pClosure);
    Object_put(o, sym_function   , function   );
    Object_put(o, sym_environment, environment);
    return o;
}

int isClosure(oop obj)
{
    return is(Object, obj) && pClosure == _getDelegate(obj);
}

oop Lambda_eval(oop exp, oop env)
{
    return newClosure(exp, env);
}

void Lambda_codeOn(oop exp, oop str, oop env)
{
    codeParametersOn(str, Object_get(exp, sym_parameters), "(", ")");
    codeBlockOn(str, Object_get(exp, sym_body));
}

oop Closure_eval(oop exp, oop env)
{
    return exp;
}

void Closure_codeOn(oop exp, oop str, oop env)
{
    assert(!"this cannot happen");
}

#endif // !PRIMCLOSURE

#define doBinops(_)							\
    _(opLogOr,  ||)							\
    _(opLogAnd, &&)							\
    _(opBitOr,   |)							\
    _(opBitXor,  ^)							\
    _(opBitAnd,  &)							\
    _(opEq,     ==) _(opNotEq,  !=)					\
    _(opLess,   < ) _(opLessEq, <=) _(opGrtr,   >=) _(opGrtrEq, > )	\
    _(opShl,    <<) _(opShr,    >>)					\
    _(opAdd,     +) _(opSub,     -)					\
    _(opMul,     *) _(opDiv,     /) _(opMod,     %)

#define defineBinop(NAME, OP) NAME,
enum binop {
    doBinops(defineBinop)
};
#undef defineBinop

#define nameBinop(NAME, OP) #OP,
char *binopNames[] = {
    doBinops(nameBinop)
};
#undef nameBinop

oop newBinop(int operation, oop lhs, oop rhs)
{
    oop o = new(pBinop);
    Object_put(o, sym_operation, newInteger(operation));
    Object_push(o, lhs);
    Object_push(o, rhs);
    return o;
}

intptr_t cmp(oop l, oop r, char *who)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr) return _integerValue(l)   - _integerValue(r);
    if (Float   == tl || Float   == tr) return floatValue(l, who) - floatValue(r, who);
    if (String  == tl || String  == tr) return strcmp(stringValue(l, who), stringValue(r, who));
    if (Symbol  == tl || Symbol  == tr) return strcmp(stringValue(l, who), stringValue(r, who));
    return (intptr_t)l - (intptr_t)r;
}

oop shl(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr)
	return newInteger(_integerValue(l) << _integerValue(r));
    fatal("<<: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
    return 0;
}

oop shr(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr)
	return newInteger(_integerValue(l) >> _integerValue(r));
    fatal(">>: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
    return 0;
}

#define binop(NAME, OP)											\
oop NAME(oop l, oop r)											\
{													\
    int tl = getType(l), tr = getType(r);								\
    if (Integer == tl && Integer == tr) return newInteger(_integerValue(l   ) OP _integerValue(r   ));	\
    if (Float   == tl || Float   == tr) return newFloat  ( floatValue(l, #OP) OP  floatValue(r, #OP));	\
    fatal(#OP": illegal operand types %s and %s", getTypeName(l), getTypeName(r));			\
    return 0;												\
}

binop(add, +);
binop(sub, -);
binop(mul, *);

#undef binop

oop quo(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr) {
	long   vl = _integerValue(l), vr = _integerValue(r);
	ldiv_t qr = ldiv(vl, vr);
	if (!qr.rem) return newInteger(qr.quot);   // division was exact
	return newFloat((double)vl / (double)vr);
    }
    if (Float == tl || Float == tr) return newFloat  (floatValue(l, "/") / floatValue(r, "/"));
    fatal("/: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
    return 0;
}

oop rem(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr) return newInteger(  _integerValue(l)  % _integerValue(r     ) );
    if (Float   == tl || Float   == tr) return newFloat  (fmod(floatValue(l, "%"), floatValue(r, "%")));
    fatal("/: illegal operand types %s and %s", getTypeName(l), getTypeName(r));
    return 0;
}

#define newBoolean(TF)	((TF) ? sym_t : nil)

oop Binop_eval(oop exp, oop env)
{							assert(_get(exp, Object,isize) == 2);
    oop op   = Object_get(exp, sym_operation);
    oop lhs  = _get(exp, Object,indexed)[0];
    oop rhs  = _get(exp, Object,indexed)[1];
    enum binop code = integerValue(op, "Binop.operation");
    lhs = eval(lhs, env);
    switch (code) {
	case opLogOr:	return nil != lhs ? lhs : eval(rhs, env);
	case opLogAnd:	return nil == lhs ? lhs : eval(rhs, env);
	default:	break;
    }
    rhs = eval(rhs, env);
    switch (code) {
	case opBitOr:	return newInteger(integerValue(lhs, "|") | integerValue(rhs, "|"));
	case opBitXor:	return newInteger(integerValue(lhs, "^") ^ integerValue(rhs, "^"));
	case opBitAnd:	return newInteger(integerValue(lhs, "&") & integerValue(rhs, "&"));
	case opEq:	return newBoolean(cmp(lhs, rhs, "==") == 0);
	case opNotEq:	return newBoolean(cmp(lhs, rhs, "!=") != 0);
	case opLess:	return newBoolean(cmp(lhs, rhs, "<" ) <  0);
	case opLessEq:	return newBoolean(cmp(lhs, rhs, "<=") <= 0);
	case opGrtrEq:	return newBoolean(cmp(lhs, rhs, ">=") >= 0);
	case opGrtr:	return newBoolean(cmp(lhs, rhs, ">" ) >  0);
	case opShl:	return shl(lhs, rhs);
	case opShr:	return shr(lhs, rhs);
	case opAdd:  	return add(lhs, rhs);
	case opSub:  	return sub(lhs, rhs);
	case opMul:  	return mul(lhs, rhs);
	case opDiv:  	return quo(lhs, rhs);
	case opMod:  	return rem(lhs, rhs);
	default:     	break;
    }
    fatal("illegal binary operation %d", code);
    return 0;
}

void Binop_codeOn(oop exp, oop str, oop env)
{							assert(_get(exp, Object,isize) == 2);
    oop op   = Object_get(exp, sym_operation);
    oop lhs  = _get(exp, Object,indexed)[0];
    oop rhs  = _get(exp, Object,indexed)[1];
    codeOn(str, lhs, 0);
    enum binop code = integerValue(op, "Binop.operation");
    assert(0 <= code && code <= indexableSize(binopNames));
    String_format(str, " %s ", binopNames[code]);
    codeOn(str, rhs, 0);
}

#define doUnyops(_)						\
    _(opNot, !) _(opCom, ~) _(opNeg, -) _(opQuasiquote, `) _(opUnquote, @)

#define defineUnyop(NAME, OP_) NAME,

enum unyop {
    doUnyops(defineUnyop)
};

#undef defineUnyop

#define nameUnyop(NAME, OP) #OP,

char *unyopNames[] = {
    doUnyops(nameUnyop)
};

#undef nameUnyop

oop newUnyop(int operation, oop value)
{
    oop o = new(pUnyop);
    Object_put(o, sym_operation, newInteger(operation));
    Object_push(o, value);
    return o;
}

oop quasiclone(oop exp, oop env)
{
    if (is(Object, exp)) {
	if (pUnyop == _getDelegate(exp)) {
	    oop op    	    = Object_get(exp, sym_operation);
	    oop value 	    = _get(exp, Object,indexed)[0];
	    enum unyop code = integerValue(op, "Unyop.operation");
	    if (code == opUnquote) return eval(value, env);
	}
	oop  clone   = new(_getDelegate(exp));
	oop *indexed = _get(exp, Object,indexed);
	int  isize   = _get(exp, Object,isize);
	for (int i = 0;  i < isize;  ++i)
	    Object_push(clone, quasiclone(indexed[i], env));
	struct property *kvs   = _get(exp, Object,properties);
	int              psize = _get(exp, Object,psize);
	for (int i = 0;  i < psize;  ++i)
	    if (kvs[i].key != prop_delegate)
		Object_put(clone, kvs[i].key, quasiclone(kvs[i].val, env));
	oop delegate = _getDelegate(exp);
	if (nil != delegate) // always shallow copied
	    Object_put(clone, prop_delegate, delegate);
	return clone;
    }
    return exp;
}

oop neg(oop n)
{
    int tn = getType(n);
    switch (tn) {
	case Integer:	return newInteger(-_integerValue(n));
	case Float:	return newFloat  (-_floatValue  (n));
	default:	break;
    }
    fatal("-: illegal operand type %s", getTypeName(n));
    return 0;
}

oop com(oop n)
{
    int tn = getType(n);
    switch (tn) {
	case Integer:	return newInteger(~_integerValue(n));
	default:	break;
    }
    fatal("~: illegal operand type %s", getTypeName(n));
    return 0;
}

oop Unyop_eval(oop exp, oop env)
{							assert(_get(exp, Object,isize) == 1);
    oop op    = Object_get(exp, sym_operation);
    oop value = _get(exp, Object,indexed)[0];
    enum unyop code = integerValue(op, "Unyop.operation");
    if (code == opQuasiquote) return quasiclone(value, env);
    if (code == opUnquote   ) fatal("@ outside quasiquotation");
    value = eval(value, env);
    switch (code) {
	case opNot:		return newBoolean(value == nil);
	case opNeg:		return neg(value);
	case opCom:		return com(value);
	default:     	break;
    }
    fatal("illegal unary operation %d", code);
    return 0;
}

void Unyop_codeOn(oop exp, oop str, oop env)
{							assert(_get(exp, Object,isize) == 1);
    oop op    = Object_get(exp, sym_operation);
    oop value = _get(exp, Object,indexed)[0];
    enum unyop code = integerValue(op, "Unyop.operation");
    assert(0 <= (int)code && (int)code <= indexableSize(unyopNames));
    String_appendAll(str, unyopNames[code]);
    codeOn(str, value, 0);
}

oop newIf(oop condition, oop consequent, oop alternate)
{
    oop o = new(pIf);
    Object_put(o, sym_condition,  condition );
    Object_put(o, sym_consequent, consequent);
    Object_put(o, sym_alternate,  alternate );
    return o;
}

oop If_eval(oop exp, oop env)
{
    oop condition  = eval(Object_get(exp, sym_condition ), env);
    oop consequent = 	  Object_get(exp, sym_consequent)      ;
    oop alternate  = 	  Object_get(exp, sym_alternate )      ;
    return eval(nil != condition ? consequent : alternate, env);
}

void If_codeOn(oop exp, oop str, oop env)
{
    oop condition  = Object_get(exp, sym_condition );
    oop consequent = Object_get(exp, sym_consequent);
    oop alternate  = Object_get(exp, sym_alternate );
    String_appendAll(str, "if (");
    codeOn(str, condition, 0);
    String_appendAll(str, ") ");
    codeOn(str, consequent, 0);
    if (nil != alternate) {
	String_appendAll(str, " else ");
	codeOn(str, alternate, 0);
    }
}

oop newWhile(oop condition, oop body)
{
    oop o = new(pWhile);
    Object_put(o, sym_condition, condition );
    Object_put(o, sym_body,      body      );
    return o;
}

oop While_eval(oop exp, oop env)
{
    oop condition = Object_get(exp, sym_condition);
    oop body      = Object_get(exp, sym_body     );
    oop result    = nil;
    while (nil != eval(condition, env)) result = eval(body, env);
    return result;
}

void While_codeOn(oop exp, oop str, oop env)
{
    oop condition = Object_get(exp, sym_condition);
    oop body      = Object_get(exp, sym_body     );
    String_appendAll(str, "while (");
    codeOn(str, condition, 0);
    String_appendAll(str, ") ");
    codeOn(str, body, 0);
    if (pBlock != _getDelegate(body)) String_appendAll(str, ";");
}

oop newBlock(oop body)
{
    oop o = new(pBlock);
    Object_put(o, sym_body, body);
    return o;
}

oop Block_eval(oop exp, oop env)
{
    oop body     = Object_get(exp, sym_body);
    oop *indexed = _get(body, Object,indexed);
    int size     = _get(body, Object,isize);
    oop result   = nil;
    oop env2     = new(pObject);
    _setDelegate(env2, env);
    for (int i = 0;  i < size;  ++i) result = eval(indexed[i], env2);
    return result;
}

void Block_codeOn(oop exp, oop str, oop env)
{
    codeBlockOn(str, Object_get(exp, sym_body));
}

oop newFor(oop initialise, oop condition, oop update, oop body)
{
    oop o = new(pFor);
    Object_put(o, sym_initialise, initialise);
    Object_put(o, sym_condition,  condition);
    Object_put(o, sym_update,     update);
    Object_put(o, sym_body,       body);
    return o;
}

oop For_eval(oop exp, oop env)
{
    oop initialise = Object_get(exp, sym_initialise);
    oop condition  = Object_get(exp, sym_condition);
    oop update     = Object_get(exp, sym_update);
    oop body       = Object_get(exp, sym_body);
    oop env2 = new(pObject);
    _setDelegate(env2, env);
    oop result     = eval(initialise, env2);
    while (nil != eval(condition, env2)) {
	result = eval(body, env2);
	eval(update, env2);
    }
    return result;
}

void For_codeOn(oop exp, oop str, oop env)
{
    oop initialise = Object_get(exp, sym_initialise);
    oop condition  = Object_get(exp, sym_condition);
    oop update     = Object_get(exp, sym_update);
    oop body       = Object_get(exp, sym_body);
    String_appendAll(str, "for (");
    codeOn(str, initialise, 0);
    String_appendAll(str, "; ");
    codeOn(str, condition, 0);
    String_appendAll(str, "; ");
    codeOn(str, update, 0);
    String_appendAll(str, ") ");
    codeOn(str, body, 0);
}

oop newForIn(oop identifier, oop expression, oop body)
{
    oop o = new(pForIn);
    Object_put(o, sym_identifier, identifier);
    Object_put(o, sym_expression, expression);
    Object_put(o, sym_body,       body);
    return o;
}

oop ForIn_eval(oop exp, oop env)
{
    oop identifier = Object_get(exp, sym_identifier);
    oop expression = Object_get(exp, sym_expression);
    oop body       = Object_get(exp, sym_body);
    oop result     = nil;
    oop vals       = eval(expression, env);
    oop env2 = new(pObject);
    _setDelegate(env2, env);
    if (isInteger(vals)) {
	long limit = _integerValue(vals);
	for (long i = 0;  i < limit;  ++i) {
	    Object_put(env2, identifier, newInteger(i));
	    result = eval(body, env2);
	}
	return result;
    }
    if (is(String, vals)) {
	int   len = _get(vals, String,length);
	char *val = _get(vals, String,value);
	for (int i = 0;  i < len;  ++i) {
	    Object_put(env2, identifier, newInteger(val[i]));
	    result = eval(body, env2);
	}
	return result;
    }
    if (!is(Object, vals)) fatal("for: non-object sequence %s", storeString(vals, 0));
    oop *indexed   = _get(vals, Object,indexed);
    int size       = _get(vals, Object,isize);
    for (int i = 0;  i < size;  ++i) {
	Object_put(env2, identifier, indexed[i]);
	result = eval(body, env2);
    }
    return result;
}

void ForIn_codeOn(oop exp, oop str, oop env)
{
    oop identifier = Object_get(exp, sym_identifier);
    oop expression = Object_get(exp, sym_expression);
    oop body       = Object_get(exp, sym_body);
    String_appendAll(str, "for (");
    printOn(str, identifier, 0);
    String_appendAll(str, " in ");
    codeOn(str, expression, 0);
    String_appendAll(str, ") ");
    codeOn(str, body, 0);
}

oop newForFromTo(oop identifier, oop first, oop last, oop body)
{
    oop o = new(pForFromTo);
    Object_put(o, sym_identifier, identifier);
    Object_put(o, sym_first,      first);
    Object_put(o, sym_last,       last);
    Object_put(o, sym_body,       body);
    return o;
}

oop ForFromTo_eval(oop exp, oop env)
{
    oop identifier = Object_get(exp, sym_identifier);
    oop first      = Object_get(exp, sym_first);
    oop last       = Object_get(exp, sym_last);
    oop body       = Object_get(exp, sym_body);
    oop env2       = new(pObject);
    _setDelegate(env2, env);
    long start 	= integerValue(first, "for");
    long stop  	= integerValue(last,  "for");
    long step  	= start < stop ? 1  : -1;
    oop  result = nil;
    for (;;) {
	Object_put(env2, identifier, newInteger(start));
	result = eval(body, env2);
	if (start == stop) break;
	start += step;
    }
    return result;
}

void ForFromTo_codeOn(oop exp, oop str, oop env)
{
    oop identifier = Object_get(exp, sym_identifier);
    oop first      = Object_get(exp, sym_first);
    oop last       = Object_get(exp, sym_last);
    oop body       = Object_get(exp, sym_body);
    String_appendAll(str, "for (");
    printOn(str, identifier, 0);
    String_appendAll(str, " from ");
    codeOn(str, first, 0);
    String_appendAll(str, " to ");
    codeOn(str, last, 0);
    String_appendAll(str, ") ");
    codeOn(str, body, 0);
}

oop newLiteral(oop object)
{
    oop o = new(pLiteral);
    Object_put(o, sym_object, object);
    return o;
}

#if DELOPT

oop Literal_eval(oop exp, oop env)
{
    oop  object  = Object_get(exp, sym_object);
    oop  clone   = new(pObject);
    oop *indexed = _get(object, Object,indexed);
    int  isize   = _get(object, Object,isize);
    for (int i = 0;  i < isize;  ++i)
	Object_push(clone, eval(indexed[i], env));
    struct property *kvs     = _get(object, Object,properties);
    int              psize   = _get(object, Object,psize);
    for (int i = 0;  i < psize;  ++i)
	Object_put(clone, kvs[i].key, eval(kvs[i].val, env));
    oop delegate = _getDelegate(object);
    if (nil != delegate)
	Object_put(clone, prop_delegate, eval(delegate, env));
    return clone;
}

#else // !DELOPT

oop Literal_eval(oop exp, oop env)
{
    oop  object  = Object_get(exp, sym_object);
    oop  clone   = new(pObject);
    oop *indexed = _get(object, Object,indexed);
    int  isize   = _get(object, Object,isize);
    for (int i = 0;  i < isize;  ++i)
	Object_push(clone, eval(indexed[i], env));
    struct property *kvs     = _get(object, Object,properties);
    int              psize   = _get(object, Object,psize);
    for (int i = 0;  i < psize;  ++i)
	Object_put(clone, kvs[i].key, eval(kvs[i].val, env));
    return clone;
}

#endif // !DELOPT

void Literal_codeOn(oop exp, oop str, oop env)
{
    oop  object  = Object_get(exp, sym_object);
    oop *indexed = _get(object, Object,indexed);
    int  isize   = _get(object, Object,isize);
    String_appendAll(str, "[");
    int  i;
    for (i = 0;  i < isize;  ++i) {
	if (i) String_appendAll(str, ", ");
	codeOn(str, indexed[i], 0);
    }
    struct property *kvs     = _get(object, Object,properties);
    int              psize   = _get(object, Object,psize);
    for (int j = 0;  j < psize;  ++j) {
	if (i++) String_appendAll(str, ", ");
	codeOn(str, kvs[j].key, 0);
	String_appendAll(str, ": ");
	codeOn(str, kvs[j].val, 0);
    }
    String_appendAll(str, "]");
}

%}


start	= - ( s:stmt				{ yysval = s }
	    | !.				{ yysval = 0 }
	    | < (!EOL .)* >			{ fatal("syntax error near: %s", yytext) }
	    )

stmt	= WHILE LPAREN c:expr RPAREN s:stmt	{ $$ = newWhile(c, s) }
	| IF LPAREN c:expr RPAREN s:stmt
	  ( ELSE t:stmt				{ $$ = newIf(c, s, t  ) }
	  |					{ $$ = newIf(c, s, nil) }
	  )
	| FOR LPAREN i:id IN e:expr RPAREN
	      s:stmt				{ $$ = newForIn(i, e, s) }
	| FOR LPAREN i:id FROM a:expr
	         TO  b:expr RPAREN s:stmt	{ $$ = newForFromTo(i, a, b, s) }
	| FOR LPAREN i:expr SEMI c:expr SEMI
	             u:expr RPAREN s:stmt	{ $$ = newFor(i, c, u, s) }
	|             i:id p:params b:block	{ $$ = newSetVar(i, newLambda(p, b)) }
	| v:proto DOT i:id p:params b:block	{ $$ = newSetProp(v, i, newLambda(p, b)) }
	| b:block				{ $$ = newBlock(b) }
	| e:expr EOS				{ $$ = e }

proto	= v:var ( DOT j:id !LPAREN		{ v = newGetProp(v, j) }
	  	)*    	   			{ $$ = v }

EOS	= SEMI+ | &RBRACE | &ELSE

expr	= p:postfix
	  ( DOT   i:id         ASSIGN e:expr 	{ $$ = newSetProp(p, i, e) }
          | LBRAK i:expr RBRAK ASSIGN e:expr	{ $$ = newSetArray(p, i, e) }
	  )
	| i:id ASSIGN e:expr 			{ $$ = newSetVar(i, e) }
	| logor

logor	= l:logand ( BARBAR r:logand		{ l = newBinop(opLogOr,  l, r) }
		   )*				{ $$ = l }

logand	= l:bitor ( ANDAND r:bitor		{ l = newBinop(opLogAnd, l, r) }
		  )*				{ $$ = l }

bitor	= l:bitxor ( OR r:bitxor		{ l = newBinop(opBitOr,  l, r) }
		   )*				{ $$ = l }

bitxor	= l:bitand ( XOR r:bitand		{ l = newBinop(opBitXor, l, r) }
		   )*				{ $$ = l }

bitand	= l:eq ( AND r:eq			{ l = newBinop(opBitAnd, l, r) }
	       )*				{ $$ = l }

eq	= l:ineq ( EQ    r:ineq			{ l = newBinop(opEq,    l, r) }
	  	 | NOTEQ r:ineq			{ l = newBinop(opNotEq, l, r) }
	  	 )*				{ $$ = l }

ineq	= l:shift ( LESS   r:shift		{ l = newBinop(opLess,   l, r) }
	  	  | LESSEQ r:shift		{ l = newBinop(opLessEq, l, r) }
	  	  | GRTREQ r:shift		{ l = newBinop(opGrtrEq, l, r) }
	  	  | GRTR   r:shift		{ l = newBinop(opGrtr,   l, r) }
	  	  )*				{ $$ = l }

shift	= l:sum ( SHL r:sum			{ l = newBinop(opShl, l, r) }
	  	| SHR r:sum			{ l = newBinop(opShr, l, r) }
	  	)*				{ $$ = l }

sum	= l:prod ( PLUS  r:prod			{ l = newBinop(opAdd, l, r) }
	  	 | MINUS r:prod			{ l = newBinop(opSub, l, r) }
	  	 )*				{ $$ = l }

prod	= l:prefix ( STAR  r:prefix		{ l = newBinop(opMul, l, r) }
	  	   | SLASH r:prefix		{ l = newBinop(opDiv, l, r) }
	  	   | PCENT r:prefix		{ l = newBinop(opMod, l, r) }
	  	   )*				{ $$ = l }

prefix  = PLING  p:prefix			{ $$ = newUnyop(opNot, p) }
	| MINUS  p:prefix			{ $$ = newUnyop(opNeg, p) }
	| TILDE  p:prefix			{ $$ = newUnyop(opCom, p) }
	| BQUOTE s:stmt				{ $$ = newUnyop(opQuasiquote, s) }
	| COMMAT e:expr				{ $$ = newUnyop(opUnquote, e) }
	| postfix

postfix	= p:primary
          ( LBRAK e:expr RBRAK !ASSIGN		{ p = newGetArray(p, e) }
	  | DOT   i:id a:args  !ASSIGN !LBRACE	{ p = newInvoke(p, i, a) }
          | DOT   i:id         !ASSIGN		{ p = newGetProp(p, i) }
          |            a:args  !ASSIGN !LBRACE	{ p = newApply(p, a) }
	  )*					{ $$ = p }

args	= LPAREN a:mkobj
	  ( ( k:id COLON e:expr			{ Object_put(a, k, e) }
	    | e:expr				{ Object_push(a, e) }
	    )
            ( COMMA ( k:id COLON e:expr		{ Object_put(a, k, e) }
	    	    | e:expr			{ Object_push(a, e) }
		    ) )* )? RPAREN		{ $$ = a }

params	= LPAREN p:mkobj
	  ( i:id				{ Object_push(p, i) }
            ( COMMA i:id 			{ Object_push(p, i) }
	    )* )? RPAREN			{ $$ = p }

mkobj	= 					{ $$ = new(pObject) }

primary	= nil | number | string | symbol | var | lambda | subexpr | literal

lambda	= p:params b:block			{ $$ = newLambda(p, b) }

subexpr	= LPAREN e:expr  RPAREN			{ $$ = e }
	|        b:block			{ $$ = newBlock(b) }

literal	= LBRAK o:mkobj
	  ( ( i:id COLON e:expr			{ Object_put(o, i, e) }
	    | e:expr				{ Object_push(o, e) }
	    ) ( COMMA ( i:id COLON e:expr	{ Object_put(o, i, e) }
	    	      | e:expr			{ Object_push(o, e) }
	  	      ) )* )? RBRAK		{ $$ = newLiteral(o) }

block	= LBRACE b:mkobj
	    (  e:stmt		 		{ Object_push(b, e) }
	    )* RBRACE				{ $$ = b }

nil   	= NIL					{ $$ = nil }

number	= "-" u:unsign				{ $$ = neg(u) }
	| "+" n:number				{ $$ = u }
	|     u:unsign				{ $$ = u }

unsign	= < DIGIT+ '.' DIGIT* EXP? > -		{ $$ = newFloat(strtod(yytext, 0)) }
	| < DIGIT* '.' DIGIT+ EXP? > -		{ $$ = newFloat(strtod(yytext, 0)) }
	| "0" [bB] < BIGIT+ > -			{ $$ = newInteger(strtol(yytext, 0,  2)) }
	| "0" [xX] < HIGIT+ > -			{ $$ = newInteger(strtol(yytext, 0, 16)) }
	| "0" < OIGIT* > -			{ $$ = newInteger(strtol(yytext, 0,  8)) }
	| < DIGIT+ > -				{ $$ = newInteger(strtol(yytext, 0, 10)) }

string	= '"' < ( !'"' . )* > '"' -		{ $$ = newStringEscaped(yytext) }
	| "'" < ( !"'" . )* > "'" -		{ $$ = newStringEscaped(yytext) }

symbol	= HASH i:id				{ $$ = i }

var	= i:id					{ $$ = newGetVar(i) }

id	= < LETTER ALNUM* > -			{ $$ = intern(yytext) }

BIGIT	= [0-1]
OIGIT	= [0-7]
DIGIT	= [0-9]
HIGIT	= [0-9A-Fa-f]
LETTER	= [A-Za-z_]
ALNUM	= LETTER | DIGIT
SIGN	= [-+]
EXP	= [eE] SIGN DIGIT+

-	= SPACE*

SPACE	= [ \t] | EOL | '//' (!EOL .)*
EOL	= [\n\r]				{ ++lineno }

NIL	= "nil"     !ALNUM  -
WHILE	= "while"   !ALNUM  -
IF	= "if"      !ALNUM  -
ELSE	= "else"    !ALNUM  -
FOR	= "for"     !ALNUM  -
IN	= "in"      !ALNUM  -
FROM	= "from"    !ALNUM  -
TO	= "to"      !ALNUM  -

BQUOTE	= "`"      	-
COMMAT	= "@"      	-
HASH	= "#"      	-
SEMI	= ";"      	-
ASSIGN	= "="  ![=] 	-
COMMA	= ","      	-
COLON	= ":"      	-
LPAREN	= "(" 		-
RPAREN	= ")" 		-
LBRAK	= "[" 		-
RBRAK	= "]" 		-
LBRACE	= "{" 		-
RBRACE	= "}" 		-
BARBAR  = "||" ![=]	-
ANDAND  = "&&" ![=]	-
OR	= "|"  ![|=]	-
XOR	= "^"  ![=]	-
AND	= "&"  ![&=]	-
EQ	= "=="	     	-
NOTEQ	= "!="	     	-
LESS    = "<"  ![<=]   	-
LESSEQ  = "<="   	-
GRTREQ  = ">="   	-
GRTR    = ">"  ![=] 	-
SHL	= "<<" ![=]   	-
SHR	= ">>" ![=]   	-
PLUS	= "+"  ![+=]   	-
MINUS	= "-"  ![-=]    -
STAR	= "*"  ![=]     -
SLASH	= "/"  ![/=]    -
PCENT	= "%"  ![*=]    -
DOT	= "."	     	-
PLING	= "!"  ![=]	-
TILDE	= "~"  		-

%%;

#define SEND(RCV, MSG) ({						\
	    oop _rcv = RCV;						\
	    oop _fun = Object_get(_rcv, sym_##MSG);			\
	    get(_fun, Primitive,function)(_fun, _rcv, nil, nil);	\
	})

oop sym_x = 0;
oop sym_y = 0;

oop Point_magnitude(oop func, oop self, oop args, oop env)
{
    double x = floatValue(Object_get(self, sym_x), "Point.magnitude");
    double y = floatValue(Object_get(self, sym_y), "Point.magnitude");
    return newFloat(sqrt(x * x + y * y));
}

oop apply(oop func, oop self, oop args, oop env)
{
    int functype = getType(func);
    if (Primitive == functype)
	return _get(func, Primitive,function)(func, self, args, env);
#if PRIMCLOSURE
    if (Closure != functype)
	fatal("cannot %s %s", (nil == self ? "call" : "invoke"), storeString(func, 0));
    oop  lambda      = _get(func, Closure,function);
    oop  environment = _get(func, Closure,environment);
    oop  parameters  = _get(lambda, Lambda,parameters);
    oop  body        = _get(lambda, Lambda,body);
#else
    if (Object != functype || pClosure  != _getDelegate(func))
	fatal("cannot %s %s", (nil == self ? "call" : "invoke"), storeString(func, 0));
    oop  lambda      = Object_get(func,   sym_function);
    oop  environment = Object_get(func,   sym_environment);
    oop  parameters  = Object_get(lambda, sym_parameters);
    oop  body        = Object_get(lambda, sym_body);
#endif
    oop *exprs       =  get(body, Object,indexed);
    int  size        = _get(body, Object,isize);
    oop  result      = nil;
    assert(is(Object, args));
    // inherit from closure's captured environment
    _setDelegate(args, environment);
    Object_put(args, sym_self, self);
    int  nparam = _get(parameters, Object,isize);
    oop *pparam = _get(parameters, Object,indexed);
    int  nargs  = _get(args,       Object,isize);
    oop *pargs  = _get(args,       Object,indexed);
    for (int i = 0;  i < nparam;  ++i)
	Object_put(args, pparam[i], i < nargs ? pargs[i] : nil);
    for (int i = 0;  i < size;  ++i)
	result = eval(exprs[i], args);
    return result;
}

oop getArg(oop args, int index, char *who)
{											assert(is(Object, args));
    if (index >= _get(args, Object,isize)) fatal("%s: too few arguments", who);
    return _get(args, Object,indexed)[index];
}

oop getArgType(oop args, int index, int type, char *who)
{											assert(is(Object, args));
    oop arg = getArg(args, index, who);
    if (type != getType(arg)) fatal("%s: non-%s arg: ", who, typeNames[type], storeString(arg, 0));
    return arg;
}

#if TYPECODES

enum typecode getTypecode(oop exp)
{
    oop delegate       = _getDelegate(exp);
    oop name           = Object_get(delegate, prop_name);
    enum typecode type = _get(name, Symbol,typecode);
    return type;
}

#else // !TYPECODES

#define defineEval(NAME)								\
    static inline oop prim_##NAME##_eval(oop func, oop exp, oop args, oop env) {	\
        return NAME##_eval(exp, env);							\
    }

doProtos(defineEval)

#undef defineEval

#endif // !TYPECODES

#define defineCodeOn(NAME)								\
    static inline oop prim_##NAME##_codeOn(oop func, oop exp, oop args, oop env) {	\
        NAME##_codeOn(exp, getArgType(args, 0, String, #NAME".codeOn"), env);		\
	return exp;									\
    }											\

doProtos(defineCodeOn)

#undef defineCodeOn

static inline oop evalobj(oop exp, oop env)
{
# if !TYPECODES

    oop delegate  = _getDelegate(exp);
    oop evaluator = Object_get(delegate, prop_eval);
    return apply(evaluator, exp, new(pObject), env);

# else // TYPECODES

    enum typecode type = getTypecode(exp);

#   define defineEval(NAME) case t##NAME: return NAME##_eval(exp, env);
    switch (type) {
	doProtos(defineEval);
    }
#   undef defineEval

    return exp;

# endif // TYPECODES
}

long evaluations = 0;

oop eval(oop exp, oop env)
{
    ++evaluations;
    enum type type = getType(exp);
# if PRIMCLOSURE
    if (Lambda == type) return newClosure(exp, env);
# endif
    if (Object != getType(exp)) return exp;
    if (!opt_O) Object_push(trace, exp);
    oop result = evalobj(exp, env);
    if (!opt_O) Object_pop(trace);
    return result;
}

oop evargs(oop list, oop env)
{
    if (!is(Object, list)) return list;
    int 	     isize    = _get(list, Object,isize);
    int 	     psize    = _get(list, Object,psize);
    oop 	    *indexed  = _get(list, Object,indexed);
    struct property *props    = _get(list, Object,properties);
    oop             *indexed2 = isize ? xmalloc(sizeof(*indexed2) * isize) : 0;
    struct property *props2   = psize ? xmalloc(sizeof(*props2  ) * psize) : 0;
    for (int i = 0;  i < isize;  ++i)
	indexed2[i] = eval(indexed[i], env);
    for (int i = 0;  i < psize;  ++i) {
	props2[i].key =      props[i].key      ;
	props2[i].val = eval(props[i].val, env);
    }
    return newObjectWith(isize, indexed2, psize, props2);
}

oop prim_new(oop func, oop self, oop args, oop env)
{							assert(is(Object, args));
    _setDelegate(args, self);
    return args;
}

oop prim_push(oop func, oop self, oop args, oop env)
{							assert(is(Object, args));
    if (!is(Object, self)) fatal("push: not an object");
    int argc     = _get(args, Object,isize);
    oop *indexed = _get(args, Object,indexed);
    for (int i = 0;  i < argc;  ++i) Object_push(self, indexed[i]);
    return self;
}

oop prim_pop(oop func, oop self, oop args, oop env)
{							assert(is(Object, args));
    if (!is(Object, self)) fatal("pop: not an object");
    int size = _get(self, Object,isize);
    if (size < 1) fatal("pop: object is empty\n");
    --size;
    _set(self, Object,isize, size);
    return _get(self, Object,indexed)[size];
}

oop prim_length(oop func, oop self, oop args, oop env)
{							assert(is(Object, args));
    if (!is(Object, self)) fatal("length: not an object");
    return newInteger(_get(self, Object,isize));
}

oop prim_keys(oop func, oop self, oop args, oop env)
{
    oop keys = new(pObject);
# if DELOPT
    if (nil != _getDelegate(self)) Object_push(keys, prop_delegate);
# endif
    switch (getType(self)) {
	case Undefined: case Integer: case Float: case String: case Symbol: case Primitive:
	    break;
	case Object: {
	    int             size = _get(self, Object,psize);
	    struct property *kvs = _get(self, Object,properties);
	    for (int i = 0;  i < size;  ++i) Object_push(keys, kvs[i].key);
	    break;
	}
#     if PRIMCLOSURE
	case Lambda: {
	    Object_push(keys, sym_parameters);
	    Object_push(keys, sym_body);
	    break;
	}
	case Closure: {
	    Object_push(keys, sym_fixed);
	    Object_push(keys, sym_lambda);
	    Object_push(keys, sym_environment);
	    break;
	}
#     endif
    }
    return keys;
}

oop prim_env(oop func, oop self, oop args, oop env)
{
    return env;
}

oop prim_eval(oop func, oop self, oop args, oop env)
{
    int argc     = _get(args, Object,isize);
    oop *indexed = _get(args, Object,indexed);
    oop result   = nil;
    for (int i = 0;  i < argc;  ++i) result = eval(indexed[i], env);
    return result;
}

oop prim_print(oop func, oop self, oop args, oop env)
{
    int argc     = _get(args, Object,isize);
    oop *indexed = _get(args, Object,indexed);
    oop result   = nil;
    int indent   = 0;
    if (nil != Object_getLocal(args, sym_full)) indent = 1;
    for (int i = 0;  i < argc;  ++i) print(result = indexed[i], indent);
    fflush(stdout);
    return nil;
}

oop prim_codeString(oop func, oop self, oop args, oop env)
{
    int argc     = _get(args, Object,isize);
    oop *indexed = _get(args, Object,indexed);
    oop result   = newStringLen(0, 0);
    int indent   = 0;
    if (nil != Object_getLocal(args, sym_full)) indent = 1;
    for (int i = 0;  i < argc;  ++i) codeOn(result, indexed[i], 0);
    return result;
}

oop prim_sqrt(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    if (1 != argc) fatal("sqrt: 1 argument expected");
    return newFloat(sqrt(floatValue(_get(args, Object,indexed)[0], "sqrt")));
}

oop prim_round(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    if (1 != argc) fatal("round: 1 argument expected");
    return newInteger(round(floatValue(_get(args, Object,indexed)[0], "round")));
}

oop prim_truncate(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    if (1 != argc) fatal("truncate: 1 argument expected");
    return newInteger(floatValue(_get(args, Object,indexed)[0], "truncate"));
}

oop prim_cputime(oop func, oop self, oop args, oop env)
{
    struct rusage ru;
    getrusage(RUSAGE_SELF, &ru);
    return newFloat(ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1000000.0);
}

oop prim_evaluations(oop func, oop self, oop args, oop env)
{
    return newInteger(evaluations);
}

oop prim_len(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    if (1 != argc) fatal("len: 1 argument expected");
    oop arg = _get(args, Object,indexed)[0];
    switch (getType(arg)) {
	case String: return newInteger(_get(arg, String,length));
	case Symbol: return newInteger(strlen(_get(arg, Symbol,name)));
	case Object: return newInteger(_get(arg, Object,isize));
	default:     break;
    }
    return newInteger(0);
}

oop prim_ord(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    if (1 != argc) fatal("ord: 1 argument expected");
    oop arg = _get(args, Object,indexed)[0];
    if (!is(String, arg)) fatal("ord: string argument expected");
    if (1 != _get(arg, String,length)) fatal("ord: string of length 1 expected");
    return newInteger(_get(arg, String,value)[0]);
}

oop prim_chr(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    oop str  = newStringLen(0, 0);
    for (int i = 0;  i < argc;  ++i)
	String_append(str, integerValue(_get(args, Object,indexed)[i], "chr"));
    return str;
}

void readFile(FILE *file, char **textp, int *sizep)
{
    size_t size = 0;
    char  *text = xmallocAtomic(4096);
    for (;;) {
	ssize_t n = fread(text+size, 1, 4096, file);
	if (n < 1) break;
	size += n;
	if (n < 4096) break;
	text = xrealloc(text, size + 4096);
    }
    *textp = text;
    *sizep = size;
}

oop prim_readfile(oop func, oop self, oop args, oop env)
{
    oop str  = newStringLen(0, 0);
    int argc = _get(args, Object,isize);
    for (int i = 0;  i < argc;  ++i) {
	oop   name = _get(args, Object,indexed)[i];
	if (!is(String, name)) fatal("readfile: non-string argument: %s", storeString(name, 0));
	FILE *file = fopen(_get(name, String,value), "r");
	if (!file) fatal("%s: %s", _get(name, String,value), strerror(errno));
	char *text = 0;
	int   tlen = 0;
	readFile(file, &text, &tlen);
	fclose(file);
	String_appendAllLen(str, text, tlen);
    }
    return str;
}

oop prim_exit(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    int status = 0;
    if (argc >  1) fatal("exit: too many arguments");
    if (argc == 1) status = integerValue(_get(args, Object,indexed)[0], "exit");
    exit(status);
    return nil;
}

oop replFile(FILE *in)
{
    int oldline = lineno;
    lineno = 0;
    input = newInput();
    readFile(in, &input->text, &input->size);
    oop result = nil;
    while (yyparse() && yysval) {
	if (opt_v) {
	    printf(">>> ");
	    (opt_d ? println : codeln)(yysval, opt_v >2);
	}
	result = eval(yysval, nil);
	if (opt_v) {
	    printf("==> ");
	    if      (opt_v >= 3) storeln(result, 1);
	    else if (opt_v >= 1) storeln(result, 0);
	}
    }
    lineno   = oldline;
    return result;
}

oop replPath(char *path)
{
    FILE *in = fopen(path, "r");
    if (!in) fatal("%s: %s", path, strerror(errno));
    char *oldname = filename;
    filename = path;
    oop result = replFile(in);
    filename = oldname;
    fclose(in);
    return result;
}

int main(int argc, char **argv)
{
    GC_INIT();

# define defineProp(NAME) 	prop_##NAME = intern("__"#NAME"__");
    doProperties(defineProp);
# undef defineProp

# define defineSym(NAME) 	sym_##NAME = intern(#NAME);
    doSymbols(defineSym);
# undef defineSym

    pObject = nil;

# define defineProto(NAME)						\
    p##NAME = new(pObject);						\
    Object_put(p##NAME, prop_name, intern(#NAME));			\
    _set(intern(#NAME), Symbol,value,    p##NAME);			\

    doProtos(defineProto);
    doTypes(defineProto);

# undef defineProto

#if TYPECODES

    Object_put(pObject, prop_eval, newPrimitive(prim_env));	// inherited by all objects

# define defineEvaluator(NAME)						\
    _set(intern(#NAME), Symbol,typecode, t##NAME);
#else // !TYPECODES

# define defineEvaluator(NAME)						\
    Object_put(p##NAME, prop_eval, newPrimitive(prim_##NAME##_eval));

#endif // !TYPECODES

    doProtos(defineEvaluator);

# undef defineEvaluator

# define defineCodeOn(NAME)							\
    Object_put(p##NAME, prop_codeon, newPrimitive(prim_##NAME##_codeOn));

    doProtos(defineCodeOn);

# undef  defineCodeOn

    macros = Object_put(pSymbol, intern("macros"), new(pObject));

    _set(intern("__env__"    ), Symbol,value, newPrimitive(prim_env));
    _set(intern("eval"       ), Symbol,value, newPrimitive(prim_eval));
    _set(intern("print"      ), Symbol,value, newPrimitive(prim_print));
    _set(intern("codeString" ), Symbol,value, newPrimitive(prim_codeString));
    _set(intern("sqrt"       ), Symbol,value, newPrimitive(prim_sqrt));
    _set(intern("round"      ), Symbol,value, newPrimitive(prim_round));
    _set(intern("truncate"   ), Symbol,value, newPrimitive(prim_truncate));
    _set(intern("cputime"    ), Symbol,value, newPrimitive(prim_cputime));
    _set(intern("evaluations"), Symbol,value, newPrimitive(prim_evaluations));
    _set(intern("len"        ), Symbol,value, newPrimitive(prim_len));
    _set(intern("ord"        ), Symbol,value, newPrimitive(prim_ord));
    _set(intern("chr"        ), Symbol,value, newPrimitive(prim_chr));
    _set(intern("readfile"   ), Symbol,value, newPrimitive(prim_readfile));
    _set(intern("exit"       ), Symbol,value, newPrimitive(prim_exit));

    Object_put(pObject, intern("new"),    newPrimitive(prim_new   ));
    Object_put(pObject, intern("push"),   newPrimitive(prim_push  ));
    Object_put(pObject, intern("pop"),    newPrimitive(prim_pop   ));
    Object_put(pObject, intern("length"), newPrimitive(prim_length));
    Object_put(pObject, intern("keys"),   newPrimitive(prim_keys  ));

    trace = new(pObject);

    signal(SIGINT, sigint);

    int repled = 0;

    for (int argn = 1;  argn < argc;  ++argn) {
	char *arg = argv[argn];
	if ('-' == *arg) {
	    while (*++arg) {
		switch (*arg) {
		    case 'O':	++opt_O;		break;
		    case 'd':	++opt_d, ++opt_v;	break;
		    case 'v':	++opt_v;		break;
		    default:	fatal("unknown command-line option '%c'", *arg);
		}
	    }
	}
	else {
	    replPath(arg);
	    ++repled;
	}
    }

    if (!repled) replFile(stdin);

    return 0;
}