# main.leg -- C parser + interpreter
#
# Last edited: 2025-01-28 04:46:58 by piumarta on zora

%{
;
#include <stdio.h>
#include <stdlib.h>
#include <stdint.h>
#include <string.h>
#include <math.h>
#include <assert.h>
#include <stdarg.h>
#include <errno.h>

#define TRACE	printf("TRACE %s:%d:%s\n", __FILE__, __LINE__, __PRETTY_FUNCTION__);

void fatal(char *fmt, ...)
{
    va_list ap;
    va_start(ap, fmt);
    fprintf(stderr, "\n");
    vfprintf(stderr, fmt, ap);
    fprintf(stderr, "\n");
    va_end(ap);
    exit(1);
}

#define USEGC 1

#if USEGC
# include <gc/gc.h>
# define MALLOC(N)	GC_malloc(N)
# define REALLOC(P, N)	GC_realloc(P, N)
# define FREE(P)	GC_free(P)
#else
# define MALLOC(N)	malloc(N)
# define REALLOC(P, N)	realloc(P, N)
# define free(P)	free(P)
#endif

#define TAGBITS		2
#define TAGMASK		((1UL << TAGBITS) - 1)

#if TAGBITS >= 1
# define TAGPTR		0b00
# define TAGINT		0b01
# if TAGBITS >= 2
#   define TAGFLOAT	0b10
# endif
#endif

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

typedef union Object Object, *oop;

#define YYSTYPE oop

#define _do_types(_)										\
    _(Undefined) _(Input) _(Integer) _(Float) _(Pointer) _(Symbol) _(Pair) _(String) _(Array)	\
    _(Memory) _(Reference) _(Closure) _(Call) _(Block)						\
    _(Addressof) _(Dereference) _(Sizeof) _(Unary) _(Binary) _(Assign) _(Cast)			\
    _(While) _(For) _(If) _(Return) _(Continue) _(Break)					\
    _(Tvoid) _(Tchar) _(Tshort) _(Tint) _(Tlong) _(Tfloat) _(Tdouble)				\
    _(Tpointer) _(Tarray) _(Tstruct) _(Tfunction) _(Tetc)					\
    _(Scope) _(TypeName) _(Variable) _(Constant) _(Function) _(Primitive)			\
    _(VarDecls) _(TypeDecls)

#define _do_unaries(_)									\
    _(NEG) _(NOT) _(COM) _(PREINC) _(PREDEC) _(POSTINC) _(POSTDEC)

#define _do_binaries(_)					\
    _(INDEX)						\
    _(MUL) _(DIV) _(MOD) _(ADD) _(SUB) _(SHL) _(SHR)	\
    _(LT) _(LE) _(GE) _(GT) _(EQ) _(NE)			\
    _(BAND) _(BXOR) _(BOR) _(LAND) _(LOR)

#define _(X) X,

typedef enum { _do_types(_)    } type_t;
typedef enum { _do_unaries(_)  } unary_t;
typedef enum { _do_binaries(_) } binary_t;

#undef _

#define _(X) #X,

char *unaryName(int op) {
    static char *names[] = { _do_unaries(_) };
    assert(0 <= op && op < indexableSize(names));
    return names[op];
}

char *binaryName(int op) {
    static char *names[] = { _do_binaries(_) };
    assert(0 <= op && op < indexableSize(names));
    return names[op];
}

#undef _

#define _do_primitives(_)			\
    _(printf) _(assert) _(malloc) _(free)

#define _(X) oop s_##X = 0;
_do_primitives(_)
#undef _

typedef oop (* prim_t)(int nargs, oop *arguments, oop environment);

typedef oop (*cvt_t)(oop input);

struct Undefined   { type_t _type; };
struct Input 	   { type_t _type;  char *name;  FILE *file;  oop next; };
struct Integer 	   { type_t _type;  long value; };
struct Float 	   { type_t _type;  double value; };
struct Pointer 	   { type_t _type;  oop type, base;  int offset; };
struct Symbol  	   { type_t _type;  char *name; oop value; };
struct Pair   	   { type_t _type;  oop head, tail; };
struct String  	   { type_t _type;  int size;  char *elements; };
struct Array   	   { type_t _type;  int size;  oop *elements; };
struct Memory      { type_t _type;  void *base;  size_t size; };
struct Reference   { type_t _type;  oop target; };
struct Closure	   { type_t _type;  oop function, environment; };
struct Call   	   { type_t _type;  oop function, arguments; };
struct Block   	   { type_t _type;  oop statements; };
struct Addressof   { type_t _type;  oop rhs; };
struct Dereference { type_t _type;  oop rhs; };
struct Sizeof      { type_t _type;  oop rhs, size; };
struct Unary   	   { type_t _type;  unary_t  operator;  oop      rhs; };
struct Binary  	   { type_t _type;  binary_t operator;  oop lhs, rhs; };
struct Assign  	   { type_t _type;  oop lhs, rhs; };
struct Cast   	   { type_t _type;  oop type, rhs;  cvt_t converter; };
struct While   	   { type_t _type;  oop condition, expression; };
struct For   	   { type_t _type;  oop initialiser, condition, update, body; };
struct If      	   { type_t _type;  oop condition, consequent, alternate; };
struct Return  	   { type_t _type;  oop value; };
struct Continue	   { type_t _type; };
struct Break  	   { type_t _type; };

struct Tvoid	   { type_t _type; };
struct Tchar	   { type_t _type; };
struct Tshort	   { type_t _type; };
struct Tint	   { type_t _type; };
struct Tlong	   { type_t _type; };
struct Tfloat	   { type_t _type; };
struct Tdouble	   { type_t _type; };
struct Tpointer	   { type_t _type;  oop target; };
struct Tarray	   { type_t _type;  oop target;  oop size; };
struct Tstruct 	   { type_t _type;  oop tag, members; };
struct Tfunction   { type_t _type;  oop result, parameters; };
struct Tetc        { type_t _type; };

struct Scope	   { type_t _type;  oop names, types, values; };
struct TypeName	   { type_t _type;  oop name, type; };
struct Variable	   { type_t _type;  oop name, type, value; };
struct Constant	   { type_t _type;  oop name, type, value; };
struct Function	   { type_t _type;  oop name, type, parameters, body, *code;  int variadic; };
struct Primitive   { type_t _type;  oop name, type, parameters; prim_t function;  int variadic; };
struct VarDecls	   { type_t _type;  oop type, variables; };
struct TypeDecls   { type_t _type;  oop type, typenames; };

union Object
{
    type_t             _type;
# define _(X) struct X X;
    _do_types(_)
# undef _
};

void println(oop obj);
char *toString(oop obj);

int opt_O = 0; // optimise (use VM)
int opt_v = 0; // verbose (print eval output, parser output, compiled code)
int opt_x = 0; // disable execution

Object _nil = { ._type = Undefined };

#define nil	(&_nil)

oop false = 0;
oop true  = 0;

oop _new(size_t size, type_t type)
{
    oop obj = MALLOC(size);
    obj->_type  = type;
    return obj;
}

#define new(TYPE) _new(sizeof(struct TYPE), TYPE)

#define CTOR0(Type)				\
    oop new##Type(void) {			\
	return new(Type);			\
    }

#define CTOR1(Type, A)				\
    oop new##Type(oop A) {			\
	oop obj = new(Type);			\
	obj->Type.A = A;			\
	return obj;				\
    }

#define CTOR2(Type, A, B)			\
    oop new##Type(oop A, oop B) {		\
	oop obj = new(Type);			\
	obj->Type.A = A;			\
	obj->Type.B = B;			\
	return obj;				\
    }

#define CTOR3(Type, A, B, C)			\
    oop new##Type(oop A, oop B, oop C) {	\
	oop obj = new(Type);			\
	obj->Type.A = A;			\
	obj->Type.B = B;			\
	obj->Type.C = C;			\
	return obj;				\
    }

#define CTOR4(Type, A, B, C, D)			\
    oop new##Type(oop A, oop B, oop C, oop D) {	\
	oop obj = new(Type);			\
	obj->Type.A = A;			\
	obj->Type.B = B;			\
	obj->Type.C = C;			\
	obj->Type.D = D;			\
	return obj;				\
    }

oop newInteger(long value)
{
# if TAGINT
    value <<= 1; // make room for bit on right
    value  |= 1; // set it to 1
    return (oop )(intptr_t)value;
# else
    oop obj = new(Integer);
    obj->Integer.value = value;
    return obj;
# endif
}

oop newPointer(oop type, oop base, int offset)
{
    oop obj = new(Pointer);
    obj->Pointer.type   = type;
    obj->Pointer.base   = base;
    obj->Pointer.offset = offset;
    return obj;
}

oop newFloat(double value)
{
# if TAGFLOAT
    union { double d;  intptr_t i;  oop p; } u;
    u.d  = value;
    u.i &= ~TAGMASK;
    u.i |= TAGFLOAT;
    return u.p;
# else
    oop obj = new(Float);
    obj->Float.value = value;
    return obj;
# endif
}

char *typeName(int type)
{
    static char *typeNames[] = {
#     define _(X) #X,
	_do_types(_)
#     undef _
    };
    if (type < 0 || type >= indexableSize(typeNames)) fatal("unknown type %d", type);
    return typeNames[type];
}

type_t getType(oop obj)
{
# if TAGINT
    if ((intptr_t)obj & 1) return Integer;
# endif
# if TAGFLOAT
    if (((intptr_t)obj & TAGMASK) == TAGFLOAT) return Float;
# endif
    return obj->_type;
}

char *getTypeName(oop obj)	{ return typeName(getType(obj)); }

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

oop _check(oop obj, type_t type, char *file, int line)
{
    if (type != getType(obj))
	fatal("%s:%d: expected %s, got %s", file, line, typeName(type), getTypeName(obj));
    return obj;
}

#define get(OBJ, TYPE, MEMBER)   	(_check(OBJ, TYPE, __FILE__, __LINE__)->TYPE.MEMBER)
#define set(OBJ, TYPE, MEMBER, VALUE)   (_check(OBJ, TYPE, __FILE__, __LINE__)->TYPE.MEMBER = (VALUE))

long _integerValue(oop obj)
{
# if TAGINT
    assert(is(Integer, obj));
    return (intptr_t)obj >> 1;
# else
    return get(obj, Integer,value);
# endif
}

double _floatValue(oop obj)
{
# if TAGFLOAT
    union { double d;  oop p; } u;
    u.p = obj;
    return u.d;
# else
    return get(obj, Float,value);
# endif
}

long integerValue(oop obj)
{
    switch (getType(obj)) {
	case Integer:	return _integerValue(obj);
	case Float:	return _floatValue(obj);
	default: 	break;
    }
    fatal("cannot convert %s to integer: %s", getTypeName(obj), toString(obj));
    return 0;
}

double floatValue(oop obj)
{
    switch (getType(obj)) {
	case Integer:	return _integerValue(obj);
	case Float:	return _floatValue(obj);
	default: 	break;
    }
    fatal("cannot convert type %d to float", getType(obj));
    return 0;
}

oop newSymbol(char *name)
{
    oop obj = new(Symbol);
    obj->Symbol.name = strdup(name);
    obj->Symbol.value = nil;
    return obj;
}

char *symbolName(oop obj)
{
    return get(obj, Symbol,name);
}

oop *symbols = 0;
int     nsymbols = 0;

oop intern(char *name)
{
    // find existing
    int lo = 0, hi = nsymbols - 1;
    while (lo <= hi) {
	int     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; // target found
    }
    // create new
    oop sym = newSymbol(name); // sizeof Symbol
    // insert new symbol at index lo (where sym would have been found)
    symbols = REALLOC(symbols, sizeof(*symbols) * (nsymbols + 1));
    memmove(symbols + lo + 1,	// move entries to this location in the array
	    symbols + lo,	// move entries from this location
	    sizeof(*symbols) * (nsymbols - lo)	// element size * number to move
	);
    symbols[lo] = sym;
    ++nsymbols;
    return sym;
}

CTOR2(Pair, head, tail);

oop head(oop pair)	{ return get(pair, Pair,head); }
oop tail(oop pair)	{ return get(pair, Pair,tail); }

oop assoc(oop alist, oop key)
{
    while (is(Pair, alist)) {
	oop pair = head(alist);
	if (key == get(pair, Pair,head)) return pair;
	alist = tail(alist);
    }
    return nil;
}

oop newString(void)
{
    oop obj = new(String);
    obj->String.elements = 0; // empty string
    obj->String.size     = 0;
    return obj;
}

oop newStringWith(char *s)
{
    oop obj = new(String);
    obj->String.elements = strdup(s);
    obj->String.size     = strlen(s);
    return obj;
}

int String_append(oop string, int element)
{
    char *elements = get(string, String,elements);
    int       size = get(string, String,size);
    elements = REALLOC(elements, sizeof(*elements) * (size + 1));
    set(string, String,elements, elements);
    set(string, String,size, size + 1);
    return elements[size] = element;
}

char *String_appendAll(oop string, char *chars, int len)
{
    char *elements = get(string, String,elements);
    int       size = get(string, String,size);
    int    newSize = size + len;
    elements = REALLOC(elements, sizeof(*elements) * newSize);
    memcpy(elements + size, chars, len);
    set(string, String,elements, elements);
    set(string, String,size, newSize);
    return chars;
}

char *String_format(oop string, char *format, ...)
{
    static char *buf    = 0;
    static int   buflen = 0;
    int n = 0;
    for (;;) {
	va_list ap;
	va_start(ap, format);
	n = vsnprintf(buf, buflen, format, ap);
	va_end(ap);
	if (n < buflen) break;
	buflen = n + 1;
	buf = realloc(buf, sizeof(*buf) * buflen);
    }
    String_appendAll(string, buf, n);
    return buf;
}

#define Array_do(ARR, VAR)							\
    for (oop do_array = (ARR), VAR = nil;  do_array;  do_array = 0)		\
	for (int do_size = get(do_array, Array,size), do_index = 0;		\
	     do_index < do_size && (VAR = do_array->Array.elements[do_index]);	\
	     ++do_index)

oop newArray(void)
{
    oop obj = new(Array);
    obj->Array.elements = 0; // empty array
    obj->Array.size     = 0;
    return obj;
}

oop Array_append(oop array, oop element)
{
    oop *elements = get(array, Array,elements);
    int      size = get(array, Array,size);
    elements = REALLOC(elements, sizeof(*elements) * (size + 1));
    set(array, Array,elements, elements);
    set(array, Array,size, size + 1);
    return elements[size] = element;
}

oop newArray1(oop a)
{
    oop obj = newArray();
    Array_append(obj, a);
    return obj;
}

oop newArray2(oop a, oop b)
{
    oop obj = newArray1(a);
    Array_append(obj, b);
    return obj;
}

int Array_size(oop array)
{
    return get(array, Array,size);
}

oop Array_last(oop array)
{
    int  size = get(array, Array,size);
    oop *elts = get(array, Array,elements);
    assert(size > 0);
    return elts[size - 1];
}

oop Array_popLast(oop array)
{
    int  size = get(array, Array,size);
    oop *elts = get(array, Array,elements);
    assert(size > 0);
    oop  last = elts[--size];
    elts[size] = nil;
    set(array, Array,size, size);
    return last;
}

oop Array_get(oop array, int index)
{
    oop *elements = get(array, Array,elements);
    int      size     = get(array, Array,size);
    if (index >= size) fatal("array index %d out of bounds %d", index, size);
    return elements[index];
}

oop Array_set(oop array, int index, oop element)
{
    oop *elements = get(array, Array,elements);
    int      size     = get(array, Array,size);
    if (index >= size) fatal("array index %d out of bounds %d", index, size);
    return elements[index] = element;
}

int Array_equal(oop array, oop brray)
{
    if (Array_size(array) != Array_size(brray)) return 0;
    Array_do(array, a) {
	oop b = get(brray, Array,elements)[do_index];
	if (a != b) return 0;
    }
    return 1;
}

struct keyval { oop key, val; };

oop newMap(void)
{
    return newArray();
}

int Map_find(oop map, oop key)
{
    int            size = get(map, Array,size) / 2;
    struct keyval *kvs  = (struct keyval *)get(map, Array,elements);
    int lo = 0, hi = size - 1;
    while (lo <= hi) {
	int mi = (lo + hi) / 2;
	if      (key < kvs[mi].key)	hi = mi - 1;
	else if (key > kvs[mi].key)	lo = mi + 1;
	else				return mi;
    }
    return -1 - lo; // not found, encoding expected location
}

oop Map_set(oop map, oop key, oop val)
{
    int            size  = get(map, Array,size) / 2;
    struct keyval *kvs   = (struct keyval *)get(map, Array,elements);
    int            index = Map_find(map, key);
    if (index > 0) return kvs[index].val = val;
    index = -1 - index;
    int last = size++;
    kvs = realloc(kvs, sizeof(*kvs) * size);
    while (last > index) {
	kvs[last] = kvs[last - 1];
	--last;
    }
    kvs[index].key = key;
    return kvs[index].val = val;
}

oop Map_get(oop map, oop key)
{
    struct keyval *kvs   = (struct keyval *)get(map, Array,elements);
    int            index = Map_find(map, key);
    if (index < 0) fatal("key not found in map");
    return kvs[index].val;
}

oop newMemory(void *base, size_t size)
{
    oop obj = new(Memory);
    obj->Memory.base = base;
    obj->Memory.size = size;
    return obj;
}

CTOR1(Reference,   target);
CTOR2(Closure,     function, environment);
CTOR2(Call,    	   function, arguments);
CTOR1(Block,   	   statements);
CTOR1(Addressof,   rhs);
CTOR1(Dereference, rhs);

oop newSizeof(oop operand)
{
    oop obj = new(Sizeof);
    obj->Sizeof.rhs      = operand;
    obj->Sizeof.size     = nil;
    return obj;
}

oop newUnary(unary_t operator, oop operand)
{
    oop obj = new(Unary);
    obj->Unary.operator = operator;
    obj->Unary.rhs      = operand;
    return obj;
}

oop newBinary(binary_t operator, oop lhs, oop rhs)
{
    oop obj = new(Binary);
    obj->Binary.operator = operator;
    obj->Binary.lhs      = lhs;
    obj->Binary.rhs      = rhs;
    return obj;
}

CTOR2(Assign, lhs, rhs);

oop newCast(oop type, oop rhs)
{
    oop obj = new(Cast);
    obj->Cast.type      = type;
    obj->Cast.rhs       = rhs;
    obj->Cast.converter = 0;
    return obj;
}

CTOR2(While,  condition, expression);
CTOR4(For,    initialiser, condition, update, body);
CTOR3(If,     condition, consequent, alternate);
CTOR1(Return, value);
CTOR0(Continue);
CTOR0(Break);

CTOR0(Tvoid);
CTOR0(Tchar);
CTOR0(Tshort);
CTOR0(Tint);
CTOR0(Tlong);
CTOR0(Tfloat);
CTOR0(Tdouble);

int isTypeName(oop obj)
{
    switch (getType(obj)) {
	case Tvoid:
	case Tchar:
	case Tshort:
	case Tint:
	case Tlong:
	case Tfloat:
	case Tdouble:
	case TypeName:	return 1;
	default:	break;
    }
    return 0;
}

oop s_etc    = 0;
oop t_etc    = 0;
oop t_void   = 0;
oop t_char   = 0;
oop t_short  = 0;
oop t_int    = 0;
oop t_long   = 0;
oop t_float  = 0;
oop t_double = 0;
oop t_pvoid  = 0;
oop t_pchar  = 0;
oop t_ppchar = 0;

oop newTpointer(oop target)
{
    static oop pointers = 0;
    if (!pointers) pointers = newArray();
    Array_do(pointers, t)
	if (target == get(t, Tpointer,target))
	    return t; // uniqe types allow comparison by identity
    oop obj = new(Tpointer);
    obj->Tpointer.target = target;
    Array_append(pointers, obj);
    return obj;
}

oop newTarray(oop target, oop size)
{
    static oop arrays = 0;
    if (!arrays) arrays = newArray();
    Array_do(arrays, t)
	if (target == get(t, Tarray,target) && size == get(t, Tarray,size))
	    return t; // uniqe types allow comparison by identity
    oop obj = new(Tarray);
    obj->Tarray.target = target;
    obj->Tarray.size   = size;
    Array_append(arrays, obj);
    return obj;
}

oop newTstruct(oop tag, oop members)
{
    oop obj = new(Tstruct);
    obj->Tstruct.tag     = tag;
    obj->Tstruct.members = members;
    return obj;
}

oop vars2types(oop vars)
{
    oop types = newArray();
    Array_do(vars, var)
	Array_append(types, get(var, Variable,type));
    return types;
}

oop newTfunction(oop result, oop parameters)
{
    static oop functions = 0;
    if (!functions) functions = newArray();
    Array_do(functions, t) {
	oop tres = get(t, Tfunction,result);
	oop tpar = get(t, Tfunction,parameters);
	if (result == tres && Array_equal(parameters, tpar))
	    return t; // uniqe types allow comparison by identity
    }
    oop obj = new(Tfunction);
    obj->Tfunction.result     = result;
    obj->Tfunction.parameters = parameters;
    Array_append(functions, obj);
    return obj;
}

CTOR0(Tetc);

oop newScope(void)
{
    oop obj = new(Scope);
    obj->Scope.names  = newArray();
    obj->Scope.types  = newArray();
    obj->Scope.values = newArray();
    return obj;
}

int Scope_find(oop scope, oop name)
{
    oop  names = get(scope, Scope,names);
    int  size  = get(names, Array,size);
    oop *elts  = get(names, Array,elements);
    for (int i = size;  i--;) // fixme: binary search
	if (name == elts[i])
	    return i;
    return -1;
}

oop scopes = 0;

void Scope_begin(void)
{
    Array_append(scopes, newScope());
}

void Scope_end(void)
{
    Array_popLast(scopes);
}

oop Scope_lookup(oop name)
{
    int  n    = get(scopes, Array,size);
    oop *elts = get(scopes, Array,elements);
    while (n--) {
	oop scope = elts[n];
	int i = Scope_find(scope, name);
	if (i >= 0) return get(get(scope, Scope,values), Array,elements)[i];
    }
    return 0; // NOTE: 0 means undefined (rather than nil, which means uninitialised)
}

oop Scope_local(oop name)
{
    oop scope = Array_last(scopes);
    int i = Scope_find(scope, name);
    if (i >= 0) return get(get(scope, Scope,values), Array,elements)[i];
    return 0; // NOTE: 0 means undefined (rather than nil, which means uninitialised)
}

oop Scope_redeclare(oop name, oop value)
{
    int  n    = get(scopes, Array,size);
    oop *elts = get(scopes, Array,elements);
    while (n--) {
	oop scope = elts[n];
	int i = Scope_find(scope, name);
	if (i >= 0) return get(get(scope, Scope,values), Array,elements)[i] = value;
    }
    return 0; // NOTE: 0 means undefined (rather than nil, which means uninitialised)
}

CTOR2(TypeName, name, type);
CTOR3(Variable, name, type, value);
CTOR3(Constant, name, type, value);

oop newFunction(oop name, oop type, oop parameters, oop body)
{
    oop obj = new(Function);
    obj->Function.name       = name;
    obj->Function.type       = type;
    obj->Function.parameters = parameters;
    obj->Function.body       = body;
    obj->Function.code       = 0;
    obj->Function.variadic   = 0;
    return obj;
}

oop newPrimitive(oop name, oop type, oop parameters, prim_t function)
{
    oop obj = new(Primitive);
    obj->Primitive.name       = name;
    obj->Primitive.type       = type;
    obj->Primitive.parameters = parameters;
    obj->Primitive.function   = function;
    obj->Primitive.variadic   = 0;
    return obj;
}

oop makeType(oop base, oop type)
{
    switch (getType(type)) {
	case Undefined:	return base;
	case Symbol:	return base;
	case Assign:	return makeType(base, get(type, Assign,lhs));
	case Tpointer:	return newTpointer(makeType(base, get(type, Tpointer,target)));
	case Tarray:	return newTarray(makeType(base, get(type, Tarray,target)),
					 get(type, Tarray,size));
	case Tfunction:	return newTfunction(base, get(type, Tfunction,parameters));
	default:	break;
    }
    fatal("cannot make type from delcaration: %s %s", toString(base), toString(type));
    return 0;
}

oop makeName(oop decl)
{
    switch (getType(decl)) {
	case Undefined:
	case Symbol:	return decl;
	case Assign:	return makeName(get(decl, Assign,lhs));
	case Tpointer:	return makeName(get(decl, Tpointer,target));
	case Tarray:	return makeName(get(decl, Tarray,target));
	case Tfunction:	return makeName(get(decl, Tfunction,result));
	default:	break;
    }
    fatal("cannot make name from delcaration: %s", toString(decl));
    return 0;
}

oop makeBaseType(oop type)
{
    if (is(Symbol, type)) {
	oop value = Scope_lookup(type);
	if (!value || !is(TypeName, value))
	    fatal("identifier '%s' does not name a type", type);
	type = get(value, TypeName,type);
    }
    return type;
}

void VarDecls_append(oop vds, oop decl)
{
    Array_append(get(vds, VarDecls,variables), decl);
}

oop newVarDecls(oop type, oop decl)
{
    oop obj = new(VarDecls);
    obj->VarDecls.type         = type;
    obj->VarDecls.variables    = newArray();
    VarDecls_append(obj, decl);
    return obj;
}

void TypeDecls_append(oop tds, oop decl)
{
    Array_append(get(tds, TypeDecls,typenames), decl);
}

oop newTypeDecls(oop type, oop decl)
{
    oop obj = new(TypeDecls);
    obj->TypeDecls.type         = type;
    obj->TypeDecls.typenames    = newArray();
    TypeDecls_append(obj, decl);
    return obj;
}

#undef CTOR4
#undef CTOR3
#undef CTOR2
#undef CTOR1
#undef CTOR0

oop baseType(oop type)
{
    switch (getType(type)) {
	case Symbol: {
	    oop value = Scope_lookup(type);
	    if (!value || !is(TypeName, value))
		fatal("baseType: '%s' does not name a type");
	    return baseType(get(value, TypeName,type));
	}
	case Tvoid:
	case Tchar:
	case Tshort:
	case Tint:
	case Tlong:
	case Tfloat:
	case Tdouble:	return type;
	case Tpointer:	return baseType(get(type, Tpointer,target));
	case Tarray:	return baseType(get(type, Tarray,target));
	case Tfunction:	return baseType(get(type, Tfunction,result));
	default:	fatal("cannot find base type of %s", getTypeName(type));
    }
    return nil;
}

oop toStringOn(oop obj, oop str);

void declareStringOn(oop type, oop name, oop str)
{
    switch (getType(type)) {
	case Symbol: {
	    oop value = Scope_lookup(type);
	    if (!value || !is(TypeName, value))
		fatal("declareString: '%s' does not name a type");
	    declareStringOn(get(value, TypeName,type), name, str);
	    return;
	}
	case Tvoid:
	case Tchar:
	case Tshort:
	case Tint:
	case Tlong:
	case Tfloat:
	case Tdouble:
	    toStringOn(name, str);
	    break;
	case Tpointer:
	    String_append(str, '*');
	    declareStringOn(get(type, Tpointer,target), name, str);
	    break;
	case Tarray: {
	    declareStringOn(get(type, Tarray,target), name, str);
	    String_append(str, '[');
	    toStringOn(get(type, Tarray,size), str);
	    String_append(str, ']');
	    break;
	}
	case Tfunction: {
	    declareStringOn(get(type, Tfunction,result), name, str);
	    String_append(str, '(');
	    Array_do(get(type, Tfunction,parameters), parameter) {
		if (do_index) String_appendAll(str, ", ", 2);
		toStringOn(parameter, str);
	    }
	    String_append(str, ')');
	    break;
	}
	default:
	    fatal("cannot convert to declaration: %s", getTypeName(type));
    }
}

char *declareString(oop type, oop name)
{
    oop str = newString();
    declareStringOn(type, name, str);
    String_append(str, 0);
    return get(str, String,elements);
}

oop toStringOn(oop obj, oop str)
{
    int n = 0;
    switch (getType(obj)) {
	case Undefined:
	    String_appendAll(str, "<NIL>", 5);
	    break;
	case Integer:
	    String_format(str, "%d", _integerValue(obj));
	    break;
	case Pointer: {
	    oop base = get(obj, Pointer,base);
	    switch (getType(base)) {
		case Integer:
		    String_format(str, "<%p", (void *)(intptr_t)_integerValue(base));
		    break;
		case Variable:
		    String_format(str, "<&%s", symbolName(get(base, Variable,name)));
		    break;
		case Memory:
		    String_format(str, "<%p[%d]", get(base, Memory,base), get(base, Memory,size));
		    break;
		default:
		    fatal("cannot convert pointer base %s to string", toString(base));
		    break;
	    }
	    String_format(str, "%+d>", get(obj, Pointer,offset));
	    break;
	}
	case Symbol:
	    String_format(str, "%s", get(obj, Symbol,name));
	    break;
	case String: {
	    String_append(str, '"');
	    char *chars = get(obj, String,elements);
	    for (int i = 0, n = get(obj, String,size);  i < n;  ++i) {
		int c = chars[i];
		if ((' ' <= c) && (c <= 126)) String_append(str, c);
		else String_format(str, "\\x%02x", c);
	    }
	    String_append(str, '"');
	    break;
	}
	case Memory: {
	    String_format(str, "<%p+%zd>", get(obj, Memory,base), get(obj, Memory,size));
	    break;
	}
	case Cast: {
	    String_append(str, '(');
	    toStringOn(get(obj, Cast,type), str);
	    String_append(str, ')');
	    toStringOn(get(obj, Cast,rhs), str);
	    break;
	}
	case Dereference: {
	    String_append(str, '*');
	    toStringOn(get(obj, Dereference,rhs), str);
	    break;
	}
	case Sizeof: {
	    String_format(str, "sizeof(%d)", toString(get(obj, Sizeof,rhs)));
	    break;
	}
	case Unary: {
	    char *name = 0;
	    oop rhs = get(obj, Unary,rhs);
	    switch (get(obj, Unary,operator)) {
		case NEG: 	name = "-";	break;
		case NOT: 	name = "!";	break;
		case COM: 	name = "~";	break;
		case PREINC:	String_format(str, "++");  toStringOn(rhs, str);  return str;
		case PREDEC:	String_format(str, "--");  toStringOn(rhs, str);  return str;
		case POSTINC:	toStringOn(rhs, str);  String_format(str, "++");  return str;
		case POSTDEC:	toStringOn(rhs, str);  String_format(str, "--");  return str;
	    }
	    String_format(str, "%s", name);
	    toStringOn(rhs, str);
	    break;
	}
	case Binary: {
	    char *name = 0;
	    char *lhs = toString(get(obj, Binary,lhs));
	    char *rhs = toString(get(obj, Binary,rhs));
	    switch (get(obj, Binary,operator)) {
		case INDEX: 	String_format(str, "%s[%s]", lhs, rhs);  return str;
		case MUL:	name = "*";	break;
		case DIV:	name = "/";	break;
		case MOD:	name = "%";	break;
		case ADD:	name = "+";	break;
		case SUB:	name = "-";	break;
		case SHL:	name = "<<";	break;
		case SHR:	name = ">>";	break;
		case LT:	name = "<";	break;
		case LE:	name = "<=";	break;
		case GE:	name = ">=";	break;
		case GT:	name = ">";	break;
		case EQ:	name = "==";	break;
		case NE:	name = "!=";	break;
		case BAND:	name = "&";	break;
		case BXOR:	name = "^";	break;
		case BOR:	name = "|";	break;
		case LAND:	name = "&&";	break;
		case LOR:	name = "||";	break;
	    }
	    String_format(str, "%s %s %s", lhs, name, rhs);
	    break;
	}
	case Assign: {
	    toStringOn(get(obj, Assign,lhs), str);
	    String_format(str, " = ");
	    toStringOn(get(obj, Assign,rhs), str);
	    break;
	}
	case Call: {
	    toStringOn(get(obj, Call,function), str);
	    String_append(str, '(');
	    Array_do(get(obj, Call,arguments), arg) {
		if (do_index) String_format(str, ", ");
		toStringOn(arg, str);
	    }
	    String_append(str, ')');
	    break;
	}
	case If: {
	    String_format(str, "if (");
	    toStringOn(get(obj, If,condition), str);
	    String_format(str, ") ");
	    toStringOn(get(obj, If,consequent), str);
	    if (nil != get(obj, If,alternate)) {
		String_format(str, "; else ");
		toStringOn(get(obj, If,alternate), str);
	    }
	    break;
	}
	case While: {
	    String_format(str, "while (");
	    toStringOn(get(obj, While,condition), str);
	    String_format(str, ") ");
	    toStringOn(get(obj, While,expression), str);
	    break;
	}
	case For: {
	    String_format(str, "for (");
	    toStringOn(get(obj, For,initialiser), str);
	    String_format(str, "; ");
	    toStringOn(get(obj, For,condition), str);
	    String_format(str, "; ");
	    toStringOn(get(obj, For,update), str);
	    String_format(str, ") ");
	    toStringOn(get(obj, For,body), str);
	    break;
	}
	case Tvoid:	String_format(str, "void");	break;
	case Tchar:	String_format(str, "char");	break;
	case Tshort:	String_format(str, "short");	break;
	case Tint:	String_format(str, "int");	break;
	case Tlong:	String_format(str, "long");	break;
	case Tfloat:	String_format(str, "float");	break;
	case Tdouble:	String_format(str, "double");	break;
	case Tpointer: {
	    oop target = get(obj, Tpointer,target);
	    toStringOn(target, str);
	    if (isTypeName(target)) String_append(str, ' ');
	    String_append(str, '*');
	    break;
	}
	case Tfunction: {
	    oop result = get(obj, Tfunction,result);
	    oop params = get(obj, Tfunction,parameters);
	    toStringOn(result, str);
	    String_append(str, '(');
	    Array_do(params, param) {
		if (do_index) String_appendAll(str, ", ", 2);
		toStringOn(param, str);
	    }
	    String_append(str, ')');
	    break;
	}
	case Reference: {
	    String_append(str, '&');
	    toStringOn(get(obj, Reference,target), str);
	    break;
	}
	case Variable: {
	    oop type = get(obj, Variable,type);
	    oop name = get(obj, Variable,name);
	    toStringOn(baseType(type), str);
	    String_append(str, ' ');
	    declareStringOn(type, name, str);
	    break;
	}
	case Function: {
	    toStringOn(get(get(obj, Function,type), Tfunction,result), str);
	    String_append(str, ' ');
	    toStringOn(get(obj, Function,name), str);
	    String_append(str, '(');
	    oop params = get(obj, Function,parameters);
	    Array_do(params, param) {
		if (do_index) String_appendAll(str, ", ", 2);
		toStringOn(param, str);
	    }
	    String_append(str, ')');
	    break;
	}
	case Primitive: {
	    String_format(str, "%s", symbolName(get(obj, Primitive,name)));
	    break;
	}
	case VarDecls: {
	    oop vars = get(obj, VarDecls,variables);
	    oop base  = get(obj, VarDecls,type);
	    Array_do(vars, var) {
		if (do_index) String_appendAll(str, ", ", 2);
		toStringOn(var, str);
	    }
	    break;
	}
	case TypeDecls: {
	    oop types = get(obj, TypeDecls,typenames);
	    oop base  = get(obj, TypeDecls,type);
	    Array_do(types, type) {
		if (do_index) String_appendAll(str, ", ", 2);
		toStringOn(type, str);
	    }
	    break;
	}
	default:
	    fatal("cannot convert %s to string", getTypeName(obj));
	    break;
    }
    return str;
}

char *toString(oop obj)
{
    oop str = toStringOn(obj, newString());
    String_append(str, 0);
    return get(str, String,elements);
}

void printiln(oop obj, int indent)
{
    printf("%*s", indent*2, "");
    switch (getType(obj)) {
	case Undefined:	    printf("nil\n");	    			break;
	case Input:	    printf("<%s>\n", get(obj, Input,name));	break;
	case Integer:	    printf("%ld\n", integerValue(obj));		break;
	case Float:	    printf("%f\n",  floatValue(obj));		break;
	case Pointer: {
	    printf("POINTER %s [%d]\n", toString(get(obj, Pointer,type)), get(obj, Pointer,offset));
	    printiln(get(obj, Pointer,base), indent+1);
	    break;
	}
	case Symbol:	    printf("%s\n",  symbolName  (obj));	    	break;
	case Pair: {
	    printf("PAIR\n");
	    printiln(head(obj), indent+1);
	    printiln(tail(obj), indent+1);
	    break;
	}
	case String: {
	    char *elts = get(obj, String,elements);
	    int   size = get(obj, String,size);
	    printf("STRING %d \"", size);
	    for (int i = 0;  i < size;  ++i) {
		int c = elts[i];
		if ('"' == c)
		    printf("\\\"");
		else if (31 < c && c < 127)
		    putchar(c);
		else
		    printf("\\x%02x", c);
	    }
	    printf("\"\n");
	    break;
	}
	case Array: {
	    oop *elts = get(obj, Array,elements);
	    int size = get(obj, Array,size);
	    printf("ARRAY %d\n", size);
	    for (int i = 0;  i < size;  ++i)
		printiln(elts[i], indent+1);
	    break;
	}
	case Primitive: {
	    printf("PRIMITIVE\n");
	    printiln(get(obj, Primitive,name), indent+1);
	    printiln(get(obj, Primitive,type), indent+1);
	    break;
	}
	case Memory: {
	    printf("MEMORY %p + %zd\n", get(obj, Memory,base), get(obj, Memory,size));
	    break;
	}
	case Reference: {
	    printf("REFERENCE\n");
	    printiln(get(obj, Reference,target), indent+1);
	    break;
	}
	case Closure: {
	    printf("CLOSURE\n");
	    printiln(get(obj, Closure,function), indent+1);
	    break;
	}
	case Call: {
	    printf("CALL\n");
	    printiln(get(obj, Call,function ), indent+1);
	    printiln(get(obj, Call,arguments), indent+1);
	    break;
	}
	case Block: {
	    printf("BLOCK\n");
	    printiln(get(obj, Block,statements), indent+1);
	    break;
	}
	case Addressof: {
	    printf("ADDRESSOF\n");
	    printiln(get(obj, Addressof,rhs), indent+1);
	    break;
	}
	case Dereference: {
	    printf("DEREFERENCE\n");
	    printiln(get(obj, Dereference,rhs), indent+1);
	    break;
	}
	case Sizeof: {
	    printf("SIZEOF ");
	    println(get(obj, Sizeof,size));
	    printiln(get(obj, Sizeof,rhs), indent+1);
	    break;
	}
	case Unary: {
	    switch (get(obj, Unary,operator)) {
		case NEG: 	printf("NEG\n");   	break;
		case NOT: 	printf("NOT\n");   	break;
		case COM: 	printf("COM\n");   	break;
		case PREINC:	printf("PREINC\n");   	break;
		case PREDEC:	printf("PREDEC\n");   	break;
		case POSTINC:	printf("POSTINC\n");	break;
		case POSTDEC:	printf("POSTDEC\n");   	break;
	    }
	    printiln(get(obj, Unary,rhs), indent+1);
	    break;
	}
	case Binary: {
	    switch (get(obj, Binary,operator)) {
		case INDEX:	printf("INDEX\n"); 	break;
		case MUL: 	printf("MUL\n"); 	break;
		case DIV: 	printf("DIV\n"); 	break;
		case MOD: 	printf("MOD\n"); 	break;
		case ADD: 	printf("ADD\n"); 	break;
		case SUB: 	printf("SUB\n"); 	break;
		case SHL: 	printf("SHL\n"); 	break;
		case SHR: 	printf("SHR\n"); 	break;
		case LT: 	printf("LT\n"); 	break;
		case LE: 	printf("LE\n"); 	break;
		case GE: 	printf("GE\n"); 	break;
		case GT: 	printf("GT\n"); 	break;
		case EQ: 	printf("EQ\n"); 	break;
		case NE: 	printf("NE\n"); 	break;
		case BAND: 	printf("BAND\n"); 	break;
		case BXOR: 	printf("BXOR\n"); 	break;
		case BOR: 	printf("BOR\n"); 	break;
		case LAND: 	printf("LAND\n"); 	break;
		case LOR: 	printf("LOR\n"); 	break;
	    }
	    printiln(get(obj, Binary,lhs), indent+1);
	    printiln(get(obj, Binary,rhs), indent+1);
	    break;
	}
	case Assign: {
	    printf("ASSIGN\n");
	    printiln(get(obj, Assign,lhs), indent+1);
	    printiln(get(obj, Assign,rhs), indent+1);
	    break;
	}
	case Cast: {
	    printf("CAST\n");
	    printiln(get(obj, Cast,type      ), indent+1);
	    printiln(get(obj, Cast,rhs       ), indent+1);
	    break;
	}
	case While: {
	    printf("WHILE\n");
	    printiln(get(obj, While,condition), indent+1);
	    printiln(get(obj, While,expression), indent+1);
	    break;
	}
	case For: {
	    printf("For\n");
	    printiln(get(obj, For,initialiser), indent+1);
	    printiln(get(obj, For,condition),   indent+1);
	    printiln(get(obj, For,update),      indent+1);
	    printiln(get(obj, For,body),        indent+1);
	    break;
	}
	case If: {
	    printf("IF\n");
	    printiln(get(obj, If,condition),  indent+1);
	    printiln(get(obj, If,consequent), indent+1);
	    printiln(get(obj, If,alternate),  indent+1);
	    break;
	}
	case Return: {
	    printf("RETURN\n");
	    printiln(get(obj, Return,value),  indent+1);
	    break;
	}
	case Continue: {
	    printf("CONTINUE\n");
	    break;
	}
	case Break: {
	    printf("BREAK\n");
	    break;
	}
	case Tvoid:	printf("<void:1>\n");	break;
	case Tchar:	printf("<char:1>\n");	break;
	case Tshort:	printf("<short:2>\n");	break;
	case Tint:	printf("<int:4>\n");	break;
	case Tlong:	printf("<long:8>\n");	break;
	case Tfloat:	printf("<float:4>\n");	break;
	case Tdouble:	printf("<double:8>\n");	break;
	case Tetc:	printf("<...>\n");	break;
	case Tpointer: {
	    printf("Tpointer\n");
	    printiln(get(obj, Tpointer,target), indent+1);
	    break;
	}
	case Tarray: {
	    printf("Tarray\n");
	    printiln(get(obj, Tarray,size  ), indent+1);
	    printiln(get(obj, Tarray,target), indent+1);
	    break;
	}
	case Tstruct: {
	    printf("Tstruct\n");
	    printiln(get(obj, Tstruct,tag    ),  indent+1);
	    printiln(get(obj, Tstruct,members),  indent+1);
	    break;
	}
	case Tfunction: {
	    printf("Tfunction\n");
	    printiln(get(obj, Tfunction,result    ),  indent+1);
	    printiln(get(obj, Tfunction,parameters),  indent+1);
	    break;
	}
	case VarDecls: {
	    printf("VarDecls\n");
	    printiln(get(obj, VarDecls,type        ),  indent+1);
	    printiln(get(obj, VarDecls,variables   ),  indent+1);
	    break;
	}
	case TypeDecls: {
	    printf("TypeDecls\n");
	    printiln(get(obj, TypeDecls,type        ),  indent+1);
	    printiln(get(obj, TypeDecls,typenames   ),  indent+1);
	    break;
	}
	case Scope: {
	    printf("SCOPE ");
	    oop names = get(obj, Scope,names);
	    Array_do(names, name) printf(" %s", toString(name));
	    printf("\n");
	    break;
	}
	case TypeName: {
	    printf("TypeName\n");
	    printiln(get(obj, TypeName,name), indent+1);
	    printiln(get(obj, TypeName,type), indent+1);
	    break;
	}
	case Variable: {
	    printf("Variable %s\n", toString(obj));
	    printiln(get(obj, Variable,name ), indent+1);
	    printiln(get(obj, Variable,type ), indent+1);
	    printiln(get(obj, Variable,value), indent+1);
	    break;
	}
	case Constant: {
	    printf("Constant\n");
	    printiln(get(obj, Constant,name ), indent+1);
	    printiln(get(obj, Constant,type ), indent+1);
	    printiln(get(obj, Constant,value), indent+1);
	    break;
	};
	case Function: {
	    printf("Function %s\n", toString(get(obj, Function,name)));
	    printiln(get(obj, Function,type      ), indent+1);
	    printiln(get(obj, Function,parameters), indent+1);
	    printiln(get(obj, Function,body      ), indent+1);
	    break;
	}
    }
}

void println(oop obj)
{
    printiln(obj, 0);
}

oop input = 0;

oop pushInput(char *name, FILE *file)
{
    oop obj = new(Input);
    obj->Input.name = strdup(name);
    obj->Input.file = file;
    obj->Input.next = input;
    return input = obj;
}

void popInput(void)
{
    if (!input) return;
    oop obj = input;
    input = get(obj, Input,next);
    free(get(obj, Input,name));
    fclose(get(obj, Input,file));
    FREE(obj);
}

FILE *sysOpen(char *path)
{
    char abspath[1024];
    snprintf(abspath, sizeof(abspath), "include/%s", path);
    FILE *fp = fopen(abspath, "r");
    if (!fp) fatal("#include <%s>: %s", path, strerror(errno));
    return fp;
}

FILE *usrOpen(char *path)
{
    FILE *fp = fopen(path, "r");
    if (!fp) fatal("#include \"%s\": %s", path, strerror(errno));
    return fp;
}

int getChar(char *buf)
{
    while (input) {
	int c = getc(get(input, Input,file));
	if (c != EOF) {
	    *buf = c;
	    return 1;
	}
	popInput();
    }
    return 0;
}

#define YY_INPUT(buf, result, max_size) { result = getChar(buf); }

YYSTYPE yysval = 0;

void expected(oop where, char *what)
{
    fatal("%s expected near: %.*s", what, get(where, String,size), get(where, String,elements));
}

oop eval(oop exp, oop env);

%}

start	= - (   interp		{ yysval = 0 }
	    |   include		{ yysval = 0 }
	    | x:tldecl		{ yysval = x }
	    |   !.		{ yysval = 0 }
	    |  e:error		{ expected(e, "declaration") }
	    )

error	= < (![\n\r] .)* > 	{ $$ = newStringWith(yytext) }

interp	= HASH PLING (![\n\r] .)*

include	= HASH INCLUDE (
	    '<' < [a-zA-Z0-9_.]* > '>' @{ pushInput(yytext, sysOpen(yytext)) }
	  | '"' < [a-zA-Z0-9_.]* > '"' @{ pushInput(yytext, usrOpen(yytext)) }
	  )

tldecl	= typedec | fundefn | primdef | vardecl

typedec	= TYPEDEF
	  t:tname d:decltor		{ d = newTypeDecls(t, d) }
	  ( COMMA e:decltor		{ TypeDecls_append(d, e) }
	  )* SEMI			{ $$ = d }

vardecl	= t:tname d:inidecl		{ d = newVarDecls(t, d) }
	  ( COMMA e:inidecl		{ VarDecls_append(d, e) }
	  )* SEMI			{ $$ = d }

tname	= VOID				{ $$ = t_void }
	| CHAR				{ $$ = t_char }
	| SHORT				{ $$ = t_short }
	| INT				{ $$ = t_int  }
	| LONG				{ $$ = t_long }
	| FLOAT				{ $$ = t_float }
	| DOUBLE			{ $$ = t_double }
	| struct
	| id

struct	= STRUCT ( i:id m:members	{ $$ = newTstruct(  i,   m) }
	  	 | i:id			{ $$ = newTstruct(nil,   m) }
	  	 |      m:members	{ $$ = newTstruct(  i, nil) }
		 | e:error		{ expected(e, "structure/union definition") }
	  	 )

members = LBRACE vardecl* ( RBRACE
	  	 	  | e:error	{ expected(e, "struct/union member specification") }
			  )

inidecl	= d:decltor ( ASSIGN ( e:initor	{ $$ = newAssign(d, e) }
	  	      	     | e:error	{ expected(e, "variable initialiser") }
			     )
	  	    |			{ $$ = d }
		    )

decltor	= STAR d:decltor		{ $$ = newTpointer(d) }
	| ddector

ddector	= ( LPAREN d:decltor RPAREN
	  | d:idopt
          ) ( LBRAK e:expropt RBRAK	{ d = newTarray(d, e) }
	    | p:params  		{ d = newTfunction(d, vars2types(p)) }
	    )*				{ $$ = d }

params	= LPAREN a:mkArray
	  ( p:pdecl			{ Array_append(a, p) }
	    ( COMMA p:pdecl		{ Array_append(a, p) }
	    )* )? ( ( COMMA ETC		{ Array_append(a, t_etc) }
	       	    )? RPAREN		{ $$ = a }
	       	  | e:error		{ expected(e, "parameter declaration") }
		  )

pdecl	= t:tname d:decltor		{ $$ = newVariable(d, t, nil) }

initor	= agrinit | expr

agrinit	= LBRACE i:mkArray
	  ( j:initor			{ Array_append(i, j) }
	    ( COMMA j:initor		{ Array_append(i, j) }
	    )* COMMA? )? RBRACE		{ $$ = i }

fundefn	= t:tname d:funid
	  p:params b:block		{ $$ = newFunction(d, t, p, b) }

funid	= STAR   d:funid		{ $$ = newTpointer(d) }
	| LPAREN d:funid RPAREN		{ $$ = d }
	| id

primdef	= EXTERN t:tname d:funid
	  p:params SEMI			{ $$ = newPrimitive(d, t, p, 0) }

block	= LBRACE b:mkArray
	  ( s:stmt			{ Array_append(b, s) }
	  )* ( RBRACE			{ $$ = newBlock(b) }
	     | e:error			{ expected(e, "statement") }
	     )

stmt	= WHILE c:cond s:stmt	 	{ $$ = newWhile(c, s) }
	| FOR LPAREN
	  ( i:expropt SEMI | i:vardecl )
	  c:expropt SEMI u:expropt RPAREN
	  b:stmt			{ $$ = newFor(i, c, u, b) }
	| IF c:cond s:stmt
	  ( ELSE t:stmt			{ $$ = newIf(c, s,   t) }
	  |				{ $$ = newIf(c, s, nil) }
	  )
	| RETURN e:expropt SEMI		{ $$ = newReturn(e) }
	| CONTINU SEMI			{ $$ = newContinue() }
	| BREAK  SEMI			{ $$ = newBreak() }
	| block
	| e:expr SEMI			{ $$ = e }
	| vardecl

cond	= LPAREN e:expr RPAREN		{ $$ = e }

expropt	= expr | { $$ = nil }

expr	= assign

assign	= l:unary ASSIGN x:expr		{ $$ = newAssign(l, x) }
	| logor

logor	= l:logand  ( BARBAR r:logand	{ l  = newBinary(LOR, l, r) }
	  	    )* 	   		{ $$ = l }

logand	= l:bitor   ( ANDAND r:bitor	{ l  = newBinary(LAND, l, r) }
	  	    )* 	   		{ $$ = l }

bitor	= l:bitxor  ( BAR    r:bitxor	{ l  = newBinary(BOR, l, r) }
	  	    )* 	   		{ $$ = l }

bitxor	= l:bitand  ( HAT    r:bitand	{ l  = newBinary(BXOR, l, r) }
	  	    )* 	   		{ $$ = l }

bitand	= l:equal   ( AND    r:equal	{ l  = newBinary(BAND, l, r) }
	  	    )* 	   		{ $$ = l }

equal	= l:inequal ( EQUAL  r:inequal	{ l  = newBinary(EQ, l, r) }
	  	    | NEQUAL r:inequal	{ l  = newBinary(NE, l, r) }
	  	    )* 	   		{ $$ = l }

inequal	= l:shift   ( LESS   r:shift	{ l  = newBinary(LT, l, r) }
	  	    | LESSEQ r:shift	{ l  = newBinary(LE, l, r) }
	  	    | GRTREQ r:shift	{ l  = newBinary(GE, l, r) }
	  	    | GRTR   r:shift	{ l  = newBinary(GT, l, r) }
	  	    )* 	   		{ $$ = l }

shift	= l:sum     ( LSHIFT r:sum	{ l  = newBinary(SHL, l, r) }
	  	    | RSHIFT r:sum	{ l  = newBinary(SHR, l, r) }
	  	    )* 	   		{ $$ = l }

sum	= l:prod    ( PLUS  r:prod	{ l  = newBinary(ADD, l, r) }
	  	    | MINUS r:prod	{ l  = newBinary(SUB, l, r) }
	  	    )* 	   		{ $$ = l }

prod	= l:unary   ( STAR  r:unary	{ l  = newBinary(MUL, l, r) }
	  	    | SLASH r:unary	{ l  = newBinary(DIV, l, r) }
	  	    | PCENT r:unary	{ l  = newBinary(MOD, l, r) }
	  	    )* 	   		{ $$ = l }

unary	= MINUS  r:unary		{ $$ = newUnary(NEG,   	r) }
	| PLING  r:unary		{ $$ = newUnary(NOT,   	r) }
	| TILDE  r:unary		{ $$ = newUnary(COM,   	r) }
	| STAR   r:unary		{ $$ = newDereference(r) }
	| AND    r:unary		{ $$ = newAddressof(r) }
	| PPLUS	 r:unary		{ $$ = newUnary(PREINC, r) }
	| MMINUS r:unary		{ $$ = newUnary(PREDEC, r) }
	| SIZEOF
	  (        r:unary		{ $$ = newSizeof(r) }
    	  | LPAREN t:tnamdec RPAREN	{ $$ = newSizeof(t) }
	  )
	| 	 cast
	|        postfix

cast	= LPAREN t:tnamdec
	  RPAREN r:unary		{ $$ = newCast(t, r) }

tnamdec	= t:tname d:decltor		{ $$ = makeType(t, d) }

postfix	= v:value ( a:args		{ v = newCall(v, a) }
	  	  | i:index		{ v = newBinary(INDEX, v, i) }
	  	  | PPLUS		{ v = newUnary(POSTINC, a) }
	  	  | MMINUS		{ v = newUnary(POSTDEC, a) }
	  	  )*			{ $$ = v }

args	= LPAREN a:mkArray
	  	 ( e:expr		{ Array_append(a, e) }
	  	   ( COMMA e:expr	{ Array_append(a, e) }
	  	   )* )? RPAREN		{ $$ = a }

index	= LBRAK e:expr RBRAK		{ $$ = e }

value	= LPAREN e:expr RPAREN		{ $$ = e }
	| float
	| integer
	| string
       	| id

mkArray	=					{ $$ = newArray() }

float	= < [-+]? [0-9]* '.'  [0-9]+ ( [eE] [-+]? [0-9]+ )? >	-	{ $$ = newFloat(atof(yytext)) }
	| < [-+]? [0-9]+ '.'  [0-9]* ( [eE] [-+]? [0-9]+ )? >	-	{ $$ = newFloat(atof(yytext)) }
	| < [-+]? [0-9]+ '.'? [0-9]* ( [eE] [-+]? [0-9]+ )  >	-	{ $$ = newFloat(atof(yytext)) }

integer	= "0x" < [0-9a-fA-F]+ > -	{ $$ = newInteger(strtol(yytext, 0, 16)) }
	| "0b" < [0-1]+ > -		{ $$ = newInteger(strtol(yytext, 0,  2)) }
	| < [0-9]+ > -			{ $$ = newInteger(strtol(yytext, 0, 10)) }
	| "'" !"'" c:char "'" -		{ $$ = c }

mkStr	=				{ $$ = newString() }

string	= '"' s:mkStr
	      ( !'"' c:char		{ String_append(s, _integerValue(c)) }
	      )* '"' -			{ $$ = s }

char    = '\\' e:escaped		{ $$ = e }
	| < . >				{ $$ = newInteger(yytext[0]) }

escaped	= 'a'				{ $$ = newInteger('\a') }
	| 'b'				{ $$ = newInteger('\b') }
	| 'f'				{ $$ = newInteger('\f') }
	| 'n'				{ $$ = newInteger('\n') }
	| 'r'				{ $$ = newInteger('\r') }
	| 't'				{ $$ = newInteger('\t') }
	| 'v'				{ $$ = newInteger('\v') }
	| "'"				{ $$ = newInteger('\'') }
	| '"'				{ $$ = newInteger('\"') }
	| '\\'				{ $$ = newInteger('\\') }
	| < OCT OCT? OCT? >		{ $$ = newInteger(strtol(yytext, 0,  8)) }
	| 'x' < HEX? HEX? >		{ $$ = newInteger(strtol(yytext, 0, 16)) }
	| 'u' < HEX? HEX? HEX? HEX? >	{ $$ = newInteger(strtol(yytext, 0, 16)) }

OCT	= [0-7]
HEX	= [0-9a-fA-F]

idopt	= id | { $$ = nil }

id	= !keyword < alpha alnum*  > -	{ $$ = intern(yytext) }

keyword	= EXTERN | TYPEDEF | VOID | CHAR | SHORT | INT | LONG | FLOAT | DOUBLE | STRUCT
	| IF | ELSE | WHILE | FOR | RETURN | CONTINU | BREAK

alpha	= [a-zA-Z_]
alnum	= [a-zA-Z_0-9]

-	= blank*
blank	= [ \t\n\r] | comment
comment = "//" < (![\n\r] .)* >
	| "/*" (!"*/" .)* "*/"

INCLUDE	= "include"  ![_a-zA-Z0-9] -
EXTERN	= "extern"   ![_a-zA-Z0-9] -
TYPEDEF	= "typedef"  ![_a-zA-Z0-9] -
VOID	= "void"     ![_a-zA-Z0-9] -
CHAR	= "char"     ![_a-zA-Z0-9] -
SHORT	= "short"    ![_a-zA-Z0-9] -
INT	= "int"      ![_a-zA-Z0-9] -
LONG	= "long"     ![_a-zA-Z0-9] -
FLOAT	= "float"    ![_a-zA-Z0-9] -
DOUBLE	= "double"   ![_a-zA-Z0-9] -
STRUCT	= "struct"   ![_a-zA-Z0-9] -
# UNION	= "union"    ![_a-zA-Z0-9] -
# ENUM	= "enum"     ![_a-zA-Z0-9] -
SIZEOF	= "sizeof"   ![_a-zA-Z0-9] -
IF	= "if"	     ![_a-zA-Z0-9] -
ELSE	= "else"     ![_a-zA-Z0-9] -
WHILE	= "while"    ![_a-zA-Z0-9] -
FOR	= "for"      ![_a-zA-Z0-9] -
RETURN	= "return"   ![_a-zA-Z0-9] -
CONTINU = "continue" ![_a-zA-Z0-9] -
BREAK	= "break"    ![_a-zA-Z0-9] -
ETC     = "..."         -
HASH    = "#"           -
ASSIGN	= "=" !"="	-
PLUS	= "+" !"+"	-
PPLUS	= "++"		-
MINUS	= "-" !"-"	-
MMINUS	= "--"		-
STAR	= "*"		-
BAR	= "|" !"|"	-
BARBAR	= "||"		-
AND	= "&" !"&"	-
ANDAND	= "&&"		-
HAT	= "^"		-
EQUAL	= "=="		-
NEQUAL	= "!="		-
LESS	= "<" ![=<]	-
LESSEQ	= "<="		-
GRTREQ	= ">="		-
GRTR	= ">" ![=>]	-
LSHIFT	= "<<"		-
RSHIFT	= ">>"		-
SLASH	= "/"		-
PCENT	= "%"		-
PLING	= "!" !"="	-
TILDE	= "~"		-
LPAREN	= "("		-
RPAREN	= ")"		-
LBRAK	= "["		-
RBRAK	= "]"		-
LBRACE	= "{"		-
RBRACE	= "}"		-
COMMA   = ","		-
SEMI    = ";"		-

%%
;

#include <setjmp.h>

enum { NLR_INIT = 0, NLR_RETURN, NLR_CONTINUE, NLR_BREAK };

Object  *nlrValue = 0;

jmp_buf *nlrStack = 0;
int      nlrCount = 0;
int      nlrMax   = 0;

void _nlrPush(void)
{
    if (nlrCount >= nlrMax)
	nlrStack = realloc(nlrStack, sizeof(*nlrStack) * (nlrMax += 8));
}

#define nlrPush()	setjmp((_nlrPush(), nlrStack[nlrCount++]))

oop nlrPop(void)
{
    assert(nlrCount > 0);
    --nlrCount;
    return nlrValue;
}

#define nlrReturn(TYPE, VAL)	((nlrValue = (VAL), longjmp(nlrStack[nlrCount-1], TYPE)))

#define IBINOP(L, OP, R)	newInteger(integerValue(L) OP integerValue(R))
#define IRELOP(L, OP, R)	(integerValue(L) OP integerValue(R) ? true : false)

#define FBINOP(L, OP, R)	newFloat(floatValue(L) OP floatValue(R))
#define FRELOP(L, OP, R)	(floatValue(L) OP floatValue(R) ? true : false)

#define isNil(O)	(nil   == (O))
#define isFalse(O)	(false == (O))
#define isTrue(O)	(true  == (O))

oop declareVariable(oop name, oop type, oop value);

oop apply(oop function, oop arguments, oop env)
{
    if (opt_v > 2) { printf("APPLY ");  println(function); }
    switch (getType(function)) {
	default: {
	    fatal("type %s is not callable", getTypeName(function));
	}
	case Primitive: {
	    oop argv = newArray();
	    Array_do(arguments, arg) Array_append(argv, eval(arg, nil));
	    return get(function, Primitive,function)
		( get(argv, Array,size),
		  get(argv, Array,elements),
		  env );
	}
	case Function: {
	    oop parameters = get(function, Function,parameters);
	    oop body       = get(function, Function,body);
	    int variadic   = get(function, Function,variadic);
	    int parc       = get(parameters, Array,size);
	    int argc       = get(arguments,  Array,size);
	    if (argc < parc)
		fatal("too few arguments calling %s", toString(function));
	    if (argc > parc && !variadic)
		fatal("too many arguments calling %s", toString(function));
	    oop *parv = get(parameters, Array,elements);
	    oop *argv = get(arguments,  Array,elements);
	    Scope_begin();
	    int  argn = 0;
	    while (argn < parc) {
		oop var = parv[argn];
		oop arg = argv[argn];
		declareVariable(get(var, Variable,name), get(var, Variable,type), eval(arg, nil));
		++argn;
	    }
	    if (argn < argc) { // put varargs array in local variable called "..."
		oop etc = newArray();
		while (argn < argc) Array_append(etc, eval(argv[argn++], nil));
		declareVariable(s_etc, t_etc, etc);
	    }
	    switch (nlrPush()) { // longjmp occurred
		case NLR_INIT:     break;
		case NLR_RETURN:   Scope_end();  return nlrPop();
		case NLR_CONTINUE: fatal("continue outside loop");
		case NLR_BREAK:	   fatal("break outside loop");
	    }
	    oop result = eval(body, nil);
	    Scope_end();
	    nlrPop();
	    return result;
	}
    }
}

oop declare(oop name, oop value)
{
    oop scope = Array_last(scopes);
    int index = Scope_find(scope, name); // searches active scope only
    if (index >= 0) {
	oop old     = Scope_lookup(name);		assert(old);
	switch (getType(old)) {
	    case Variable: {
		oop oldtype = get(old, Variable,type);
		if (is(Tfunction, oldtype)) {
		    switch (getType(value)) {
			case Variable: {
			    oop valtype = get(value, Variable,type);
			    if (oldtype == valtype) return value; // function declaration
			    printf("FUNCTION FORWARD TYPE MISMATCH 1\n");
			    break;
			}
			case Function: { // replace forard declaration with actual function
			    Scope_redeclare(name, value);
			    return value;
			}
			default:
			    break;
		    }
		}
		break;
	    }
	    case Function: {
		if (is(Variable, value)) {
		    oop oldtype = get(old, Function,type);
		    oop valtype = get(old, Variable,type);
		    if (oldtype == valtype) return value; // compatible redeclaration
		    printf("FUNCTION FORWARD TYPE MISMATCH 2\n");
		}
		break;
	    }
	    default:
		break;
	}
	fatal("name '%s' redefined\n", get(name, Symbol,name));
    }
    Array_append(get(scope, Scope,names ), name );
    Array_append(get(scope, Scope,values), value);
    return value;
}

oop declareVariable(oop name, oop type, oop value)
{
    return declare(name, newVariable(name, type, value));
}

oop declareType(oop name, oop type)
{
    return declare(name, newTypeName(name, type));
}

oop declarePrimitive(oop name, oop type, oop parameters, prim_t function)
{
    return declare(name, newPrimitive(name, type, parameters, function));
}

oop cvt_(oop obj)	{ return obj; }
oop cvtI(oop obj)	{ return newInteger((int)_integerValue(obj)); }
oop cvtP(oop obj)	{ return newPointer(t_pvoid, obj, 0); }

cvt_t converter(int tfrom, int tto)
{
    static cvt_t converters[9][9] = {
	/* void char short   int  long float double pointer array <- FROM TO -v */
	{     0,   0,    0,    0,    0,    0,     0,      0,    0 },	// void
	{     0,   0,    0,    0,    0,    0,     0,      0,    0 },	// char
	{     0,   0,    0,    0,    0,    0,     0,      0,    0 },	// short
	{     0,   0,    0, cvtI, cvtI,    0,     0,      0,    0 },	// int
	{     0,   0,    0, cvtI,    0,    0,     0,   cvt_,    0 },	// long
	{     0,   0,    0,    0,    0,    0,     0,      0,    0 },	// float
	{     0,   0,    0,    0,    0,    0,     0,      0,    0 },	// double
	{     0,   0,    0,    0, cvt_,    0,     0,   cvt_,    0 },	// pointer
	{     0,   0,    0,    0,    0,    0,     0,      0,    0 },	// array
    };
    if (tfrom < Tvoid || tfrom > Tarray) return 0;
    if (tto   < Tvoid || tto   > Tarray) return 0;
    return converters[tto - Tvoid][tfrom - Tvoid];
}

oop incr(oop val, int amount)
{
    switch (getType(val)) {
	case Integer:	return newInteger(integerValue(val) + amount);
	case Float:	return newFloat  (  floatValue(val) + amount);
	default:	fatal("cannot increment: %s", toString(val));
    }
    return nil;
}

int isType(oop obj)
{
    type_t type = getType(obj);
    return Tvoid <= type && type <= Tfunction;
}

int typeSize(oop type)
{
    switch (getType(type)) {
	case Tvoid: 	return 1;
	case Tchar: 	return 1;
	case Tshort: 	return 2;
	case Tint: 	return 4;
	case Tlong: 	return 8;
	case Tfloat: 	return 4;
	case Tdouble: 	return 8;
	case Tpointer:	return 8; // fixme: make this a parameter
	case Tstruct:	assert(!"unimplemented");
	case Tarray:	assert(!"unimplemented");
	case Tfunction:	assert(!"unimplemented");
	default:	assert(!"this cannot happen");
    }
    return 0;
}

int toBoolean(oop arg)
{
    switch (getType(arg)) {
	case Integer:	return _integerValue(arg);
	case Float:	return  integerValue(arg);
	case Reference:	return 1;
	default:	fatal("cannot convert %s to boolean", getTypeName(arg));
    }
    return 0;
}

oop prim_printf(int argc, oop *argv, oop env) // array
{
    oop result = nil;
    if (argc < 1) fatal("printf: no format string");
    oop format = argv[0];
    if (!is(String, format)) fatal("printf: format is not a string");
    char *fmt  = get(format, String,elements);
    int   size = get(format, String,size);
    int   n    = 0;
    int   argn = 1;
    for (int i = 0;  i < size;) {
	int c = fmt[i++];
	if (c == '%' && fmt[i]) {
	    c = fmt[i++];
	    if (c == '%') goto echo;
	    if (argn >= argc) fatal("too few arguments for printf format string");
	    oop arg = argv[argn++];
	    switch (c) {
		case 'd': {
		    if (!is(Integer, arg))
			fatal("%%d conversion argument is %s", getTypeName(arg));
		    n += printf("%ld", _integerValue(arg));
		    continue;
		}
		case 'p': {
		    switch (getType(arg)) {
			case Pointer: {
			    oop base   = get(arg, Pointer,base);
			    switch (getType(base)) {
				case Integer:
				    n += printf("<%p", (void *)(intptr_t)_integerValue(base));
				    break;
				case Variable:
				    n += printf("<&%s", symbolName(get(base, Variable,name)));
				    break;
				case Memory:
				    n += printf("<%p[%zd]", get(base, Memory,base), get(base, Memory,size));
				    break;
				default:
				    fatal("%%p conversion base is %s", getTypeName(base));
				    break;
			    }
			    printf("%+d>", get(arg, Pointer,offset));
			    continue;
			}
			default:
			    break;
		    }
		    fatal("%%p conversion argument is %s", getTypeName(arg));
		    continue;
		}
		case 's': {
		    switch (getType(arg)) {
			case String: {
			    n += printf("%.*s", get(arg, String,size), get(arg, String,elements));
			    continue;
			}
			case Pointer: {
			    oop type = get(arg, Pointer,type);
			    if (t_pchar != type)
				fatal("%%s conversion of non-string pointer: %s %s",
				      toString(type), toString(arg));
			    oop base   = get(arg, Pointer,base);
			    switch (getType(base)) {
				case Integer: {
				    if (!_integerValue(base))
					fatal("%%s conversion of null pointer");
				    fatal("%%s conversion of arbitrary pointer: %s", toString(arg));
				}
				case Variable:	fatal("%%s conversion of variable: %s", toString(arg));
				case Memory:	fatal("%%s conversion of memory: %s", toString(arg));
				default:	assert(!"this cannot happen");
			    }
			    break;
			}
			default:
			    break;
		    }
		    fatal("%%s conversion argument is: %s", toString(arg));
		    continue;
		}
		default:
		    fatal("illegal printf conversion: %%%c", c);
	    }
	}
      echo:
	putchar(c);
	++n;
    }
    if (argn != argc) fatal("too many arguments for printf format string");
    return newInteger(n);
}

oop prim_assert(int argc, oop *argv, oop env) // array
{
    if (argc != 1) fatal("assert: wrong number of arguments");
    int value = toBoolean(argv[0]);
    if (!value) fatal("assertion failed\n");
    return nil;
}

oop prim_malloc(int argc, oop *argv, oop env) // array
{
    if (argc != 1) fatal("malloc: wrong number of arguments");
    oop arg = argv[0];
    if (is(Integer,arg)) {
	size_t size = _integerValue(arg);
	if (size >= 0) {
	    if (size > 10*1024*1024)
		fatal("cowardly refusing to allocate memory of size %zd", size);
	    void *mem = malloc(_integerValue(arg));
	    if (!mem) fatal("malloc(%zd) failed", size);
	    return newPointer(t_pvoid, newMemory(mem, size), 0);
	}
    }
    fatal("malloc: invalid argument: %s", toString(arg));
    return 0;
}

oop prim_free(int argc, oop *argv, oop env) // array
{
    if (argc != 1) fatal("free: wrong number of arguments");
    oop arg = argv[0];
    if (!is(Pointer,arg)) fatal("free: argument is not a pointer");
    oop base = get(arg, Pointer,base);
    switch (getType(base)) {
	case Integer:	fatal("attempt to free arbitrary pointer %s", toString(arg));
	case Variable:	fatal("attempt to free pointer to variable %s", toString(arg));
	case Memory:	free(get(base, Memory,base));  break;
	default:	assert(!"this cannot happen");
    }
    return nil;
}

oop typeCheck(oop exp, oop fntype)
{
    switch (getType(exp)) {
	case Integer:	return t_int;
	case Float:	return t_float;
	case Pointer: 	break;
	case String:	return t_pchar;
	case Symbol: {
	    oop value = Scope_lookup(exp);
	    if (!value) 	fatal("undefined variable '%s'", symbolName(exp));
	    if (nil == value) 	fatal("uninitialised variable '%s'", symbolName(exp));
	    switch (getType(value)) {
		case Primitive:	return get(value, Primitive,type);
		case Function:	return get(value, Function,type);
		case Variable:	return get(value, Variable,type);
		default:
		    fatal("cannot typecheck value of type %s", getTypeName(value));
	    }
	    return nil;
	}
	case Addressof: {
	    return newTpointer(typeCheck(get(exp, Addressof,rhs), fntype));
	}
	case Dereference: {
	    oop rhs = typeCheck(get(exp, Dereference,rhs), fntype);
	    if (!is(Tpointer, rhs)) {
		fatal("cannot dereference '%s'", toString(rhs));
	    }
	    return get(rhs, Tpointer,target);
	}
	case Cast: {
	    oop lhs = makeBaseType(get(exp, Cast,type));
	    oop rhs = get(exp, Cast,rhs);
	    set(exp, Cast,type, lhs);
	    type_t lht = getType(lhs);
	    if (Tpointer == lht && is(Integer,rhs) && !_integerValue(rhs)) {
		set(exp, Cast,converter, cvtP);
		return lhs;
	    }
	    rhs = typeCheck(get(exp, Cast,rhs), fntype);
	    cvt_t cvt = converter(getType(rhs), lht);
	    if (!cvt) fatal("cannot convert '%s' to '%s'", toString(rhs), toString(lhs));
	    set(exp, Cast,converter, cvt);
	    return lhs;
	}
	case Sizeof: {
	    oop rhs  = get(exp, Sizeof,rhs);
	    if (!isType(rhs)) rhs = typeCheck(rhs, fntype);	assert(isType(rhs));
	    set(exp, Sizeof,size, newInteger(typeSize(rhs)));
	    return t_long;
	}
	case Unary: {
	    oop rhs = typeCheck(get(exp, Unary,rhs), fntype);
	    switch (get(exp, Unary,operator)) {
		case NEG:	assert(!"unimplemented");
		case NOT:	assert(!"unimplemented");
		case COM:	assert(!"unimplemented");
		case PREINC:	return rhs;
		case PREDEC:	return rhs;
		case POSTINC:	assert(!"unimplemented");
		case POSTDEC:	assert(!"unimplemented");
	    }
	    return nil;
	}
	case Binary: {
	    oop lhs = typeCheck(get(exp, Binary,lhs), fntype);
	    oop rhs = typeCheck(get(exp, Binary,rhs), fntype);
	    switch (get(exp, Binary,operator)) {
		case INDEX:	assert(!"unimplemented"); 	break;
		case MUL: 	assert(!"unimplemented"); 	break;
		case DIV: 	assert(!"unimplemented"); 	break;
		case MOD: 	assert(!"unimplemented"); 	break;
		case ADD: {
		    if (lhs == rhs) {
			if (t_int == lhs) return lhs;
		    }
		    fatal("cannot add '%s' and '%s'", toString(lhs), toString(rhs));
		    break;
		}
		case SUB: 	assert(!"unimplemented"); 	break;
		case SHL: 	assert(!"unimplemented"); 	break;
		case SHR: 	assert(!"unimplemented"); 	break;
		case LT:	return t_int;
		case LE: 	assert(!"unimplemented"); 	break;
		case GE: 	assert(!"unimplemented"); 	break;
		case GT: 	return t_int;
		case EQ: 	return t_int;
		case NE: 	return t_int;
		case BAND: 	assert(!"unimplemented"); 	break;
		case BXOR: 	assert(!"unimplemented"); 	break;
		case BOR: 	assert(!"unimplemented"); 	break;
		case LAND: 	assert(!"unimplemented"); 	break;
		case LOR: 	assert(!"unimplemented"); 	break;
	    }
	    return nil;
	}
	case Assign: {
	    oop lhs = typeCheck(get(exp, Assign,lhs), fntype);
	    oop rhs = typeCheck(get(exp, Assign,rhs), fntype);
	    if (lhs != rhs)
		fatal("incompatible types assigning '%s' to '%s'", toString(rhs), toString(lhs));
	    return lhs;
	}
	case If: {
	    if (t_int != typeCheck(get(exp, If,condition), fntype)) fatal("if condition is not 'int'");
	    typeCheck(get(exp, If,consequent), fntype);
	    if (nil != get(exp, If,alternate))
		typeCheck(get(exp, If,alternate), fntype);
	    return nil;
	}
	case While: {
	    oop cond = get(exp, While,condition);
	    oop body = get(exp, While,expression);
	    cond = typeCheck(cond, fntype);
	    if (t_int != cond) fatal("while condition is not 'int'");
	    typeCheck(body, fntype);
	    return nil;
	}
	case For: {
	    oop init = get(exp, For,initialiser);
	    oop cond = get(exp, For,condition);
	    oop step = get(exp, For,update);
	    oop body = get(exp, For,body);
	    typeCheck(init, fntype);
	    cond = typeCheck(cond, fntype);
	    if (t_int != cond) fatal("for condition is not 'int'");
	    typeCheck(step, fntype);
	    typeCheck(body, fntype);
	    return nil;
	}
	case Primitive: {
	    oop type       = get(exp, Primitive,type      );
	    oop name       = get(exp, Primitive,name      );
	    oop parameters = get(exp, Primitive,parameters);
	    oop ptypes     = newArray();
	    oop result     = makeType(type, name);
	    name = makeName(name);
	    set(exp, Primitive,name, name);
	    set(exp, Primitive,type, result);
	    if (Array_size(parameters) && t_etc == Array_last(parameters)) {
		Array_popLast(parameters);
		set(exp, Primitive,variadic, 1);
	    }
	    Array_do(parameters, var) {
		oop ptype = makeBaseType(get(var, Variable,type));
		if (t_void == ptype && (do_index || do_size > 1))
		    fatal("illegal void parameter");
		oop pname = get(var, Variable,name);
		ptype = makeType(ptype, pname);
		pname = makeName(pname);
		set(var, Variable,name, pname);
		set(var, Variable,type, ptype);
		Array_append(ptypes, ptype);
	    }
	    if (1 == Array_size(ptypes) && Array_last(ptypes) == t_void) {
		Array_popLast(ptypes);
		Array_popLast(parameters);
	    }
	    assert(isNil(fntype));
	    if (get(exp, Primitive,variadic)) Array_append(ptypes, t_etc);
            fntype = newTfunction(result, ptypes);
	    set(exp, Primitive,type, fntype);
#         define _(X) if (s_##X == name) set(exp, Primitive,function, prim_##X);
	    _do_primitives(_);
#         undef _
	    if (!get(exp, Primitive,function))
		fatal("external symbol '%s' is undefined", toString(name));
	    declare(name, exp);
	    return nil;
	}
	case Function: {
	    oop type       = makeBaseType(get(exp, Function,type));
	    oop name       = get(exp, Function,name      );
	    oop parameters = get(exp, Function,parameters);
	    oop body       = get(exp, Function,body      );
	    oop ptypes     = newArray();
	    oop result     = makeType(type, name);
	    name = makeName(name);
	    set(exp, Function,name, name);
	    set(exp, Function,type, result);
	    if (Array_size(parameters) && t_etc == Array_last(parameters)) {
		Array_popLast(parameters);
		set(exp, Function,variadic, 1);
	    }
	    Array_do(parameters, var) {
		oop ptype = makeBaseType(get(var, Variable,type));
		if (t_void == ptype && (do_index || do_size > 1))
		    fatal("illegal void parameter");
		oop pname = get(var, Variable,name);
		ptype = makeType(ptype, pname);
		pname = makeName(pname);
		set(var, Variable,name, pname);
		set(var, Variable,type, ptype);
		Array_append(ptypes, ptype);
	    }
	    if (1 == Array_size(ptypes) && Array_last(ptypes) == t_void) {
		Array_popLast(ptypes);
		Array_popLast(parameters);
	    }
	    assert(isNil(fntype));
	    if (get(exp, Function,variadic)) Array_append(ptypes, t_etc);
            fntype = newTfunction(result, ptypes);
	    set(exp, Function,type, fntype);
	    declare(name, exp);	// add function to global scope so recursive calls will work
	    Scope_begin();	// parameters
	    Array_do(parameters, param) declare(get(param, Variable,name), param);
	    typeCheck(body, fntype); // block
	    Scope_end();
	    return nil;
	}
	case Block: {
	    Scope_begin();
	    oop statements = get(exp, Block,statements);
	    Array_do(statements, statement) typeCheck(statement, fntype);
	    Scope_end();
	    return nil;
	}
	case Call: {
	    oop function  = get(exp, Call,function );
	    oop arguments = get(exp, Call,arguments);
	    oop tfunc     = typeCheck(function, fntype);
	    if (!is(Tfunction, tfunc)) fatal("cannot call %s", getTypeName(tfunc));
	    oop  params = get(tfunc, Tfunction,parameters);
	    int  argc   = get(arguments, Array,size);
	    oop *argv   = get(arguments, Array,elements);
	    int  parc   = get(params, Array,size);
	    oop *parv   = get(params, Array,elements);
	    int  vararg = parc && (t_etc == parv[parc - 1]);
	    if ((!vararg && (argc != parc)) || (vararg && (argc < parc - 1)))
		fatal("wrong number (%d) of arguments, expected %d", argc, parc);
	    int  argn = 0;
	    while (argn < argc) {
		oop part = parv[argn];
		if (part == t_etc) break;
		oop arg  = argv[argn++];
		oop argt = typeCheck(arg, fntype);
		if (argt != part) {
		    if (is(Tpointer, argt) && t_pvoid == part) continue;
		    if (is(Tpointer, part) && t_pvoid == argt) continue;
		    fatal("cannot pass argument of type '%s' to parameter of type '%s': %s ",
			  toString(argt), toString(part), toString(exp));
		}
	    }
	    while (argn < argc) typeCheck(argv[argn++], fntype);
	    return get(tfunc, Tfunction,result);
	}
	case Return: {
	    assert(nil != fntype);
	    oop result = get(fntype, Tfunction,result);
	    oop value  = get(exp, Return,value);
	    oop vtype  = isNil(value) ? t_void : typeCheck(value, fntype);
	    if (vtype != result)
		fatal("incompatible return of %s from function returning %s",
		      toString(vtype), toString(result));
	    return result;
	}
	case VarDecls: {
	    oop base  = makeBaseType(get(exp, VarDecls,type));
	    oop decls = get(exp, VarDecls,variables);
	    oop vars  = newArray();
	    Array_do(decls, decl) {
		oop init = nil;
		if (is(Assign, decl)) {
		    init = get(decl, Assign,rhs);
		    decl = get(decl, Assign,lhs);
		}
		oop varname = makeName(decl);
		oop vartype = makeType(base, decl);
		if (is(Tfunction, vartype)) {
		    oop ptypes = get(vartype, Tfunction,parameters);
		    if (1 == Array_size(ptypes) && t_void == Array_last(ptypes)) {
			Array_popLast(ptypes);
			// make unique
			vartype = newTfunction(get(vartype, Tfunction,result), ptypes);
		    }
		}
		oop old = Scope_local(varname);
		if (old) { // declared
		    oop oldtype = nil;
		    switch (getType(old)) {
			case Variable: {
			    oldtype = get(old, Variable,type);
			    if (oldtype == vartype) { // identical declarations
				oop oldval = get(old, Variable,value);
				if (isNil(fntype)) // global declarations
				    if (isNil(init) || isNil(oldval)) // at most one initialiser
					continue; // redeclaration is permitted
				fatal("multiple definiton of variable '%s'", toString(varname));
			    }
			    break;
			}
			case Function:	oldtype = get(old, Function,type);	break;
			case Primitive:	oldtype = get(old, Primitive,type);	break;
			default:
			    fatal("cannot find type of declaration: %s", toString(old));
		    }
		    if (vartype == oldtype) continue;
		    fatal("identifier '%s' redefined as different type: %s -> %s",
			  toString(varname),
			  declareString(oldtype, varname),
			  declareString(vartype, varname));
		}
		// do this now so that initialiser can refer to the new variable
		oop var = declareVariable(varname, vartype, init);
		Array_append(vars, var);
		if (!isNil(init)) {
		    oop initype = typeCheck(init, fntype);
		    cvt_t cvt   = converter(getType(initype), getType(vartype));
		    if (!cvt) {
			fatal("initialising '%s': cannot convert '%s' to '%s'",
			      toString(varname), toString(vartype), toString(initype));
		    }
		}
	    }
	    set(exp, VarDecls,variables, vars);
	    return nil;
	}
	case TypeDecls: {
	    oop base  	  = makeBaseType(get(exp, TypeDecls,type));
	    oop decls 	  = get(exp, TypeDecls,typenames);
	    oop typenames = newArray();
	    Array_do(decls, decl) {
		oop name = makeName(decl);
		oop type = makeType(base, decl);
		if (is(Tfunction, type)) {
		    oop ptypes = get(type, Tfunction,parameters);
		    if (1 == Array_size(ptypes) && t_void == Array_last(ptypes)) {
			Array_popLast(ptypes);
			type = newTfunction(get(type, Tfunction,result), ptypes);
		    }
		}
		oop old = Scope_local(name);
		if (old) { // declared
		    if (getType(old) != TypeName)
			fatal("'%s' redeclared as different kind of symbol", toString(name));
		    oop oldtype = get(old, TypeName,type);
		    if (oldtype != type)
			fatal("incompatible declarations of type '%s': %s -> %s",
			      toString(name), toString(oldtype), toString(type));
		}
		else {
		    oop typename = declareType(name, type);
		    Array_append(typenames, typename);
		}
	    }
	    set(exp, TypeDecls,typenames, typenames);
	    return nil;
	}
	default:
	    break;
    }
    fatal("cannot typeCheck: %s", toString(exp));
    return 0;
}

oop assign(oop lhs, oop rhs)
{
    //printf("ASSIGN ");  println(lhs);
    //printf("     = ");  println(rhs);
    oop dst = lhs;
    if (is(Symbol, lhs)) lhs = Scope_lookup(lhs);
    switch (getType(lhs)) {
	case Variable: {
	    oop ltype = get(lhs, Variable,type);
	    if (is(Tpointer, ltype)) {
		switch (getType(rhs)) {
		    case Integer: {
			rhs = newPointer(ltype, rhs, 0);
			break;
		    }
		    case Pointer: {
			if (get(rhs, Pointer,type) != ltype)
			    rhs = newPointer(ltype, get(rhs, Pointer,base), get(rhs, Pointer,offset));
			break;
		    }
		    default: {
			fatal("cannot assign '%s' = '%s'", getTypeName(lhs), getTypeName(rhs));
		    }
		}
	    }
	    return set(lhs, Variable,value, rhs);
	}
	case Dereference: { // *<&var> = rhs
	    lhs = eval(get(dst, Dereference,rhs), nil);
	    switch (getType(lhs)) {
		case Pointer: { // &x
		    oop base   = get(lhs, Pointer,base);
		    int offset = get(lhs, Pointer,offset);
		    oop type   = get(get(lhs, Pointer,type), Tpointer,target);
		    int scale  = typeSize(type);
		    switch (getType(base)) {
			case Integer: { // (void *)(intptr_t)N
			    fatal("attempt to store into arbitrary memory location");
			}
			case Variable: { // &var
			    if (offset) fatal("pointer modified");
			    return set(base, Variable,value, rhs);
			}
			case Memory: {
			    int size = get(base, Memory,size);
			    if (offset < 0 || offset * scale > size - scale)
				fatal("assigning to out-of-bounds pointer");
			    void *addr = get(base, Memory,base) + offset * scale;
			    switch (getType(type)) {
				case Tchar:    	return newInteger(*(char   *)addr = _integerValue(rhs));
				case Tshort:   	return newInteger(*(short  *)addr = _integerValue(rhs));
				case Tint:     	return newInteger(*(int    *)addr = _integerValue(rhs));
				case Tlong:    	return newInteger(*(long   *)addr = _integerValue(rhs));
				case Tfloat:   	return newFloat  (*(float  *)addr = _floatValue(rhs));
				case Tdouble:  	return newFloat  (*(double *)addr = _floatValue(rhs));
				default:	break;
			    }
			    fatal("cannot store '%s' through pointer", getTypeName(type));
			}
			default: break;
		    }
		}
		default: break;
	    }
	}
	default: break;
    }
    if (dst == lhs)
	fatal("cannot assign to: %s", toString(lhs));
    else
	fatal("invalid rvalue '%s' assigning to: %s",
	      toString(lhs), toString(dst));
    abort();
    return 0;
}

int equal(oop a, oop b)
{
    if (a == b) return 1;
    type_t ta = getType(a), tb = getType(b);
    if (ta == tb) {
	switch (getType(a)) {
	    case Integer:	return _integerValue(a) == _integerValue(b);
	    case Float:		return _floatValue(a) == _floatValue(b);
	    case Pointer:	return get(a, Pointer,base) == get(b, Pointer,base);
	    default:		break;
	}
	fatal("cannot compare %ss", getTypeName(a));
    }
    else {
	if (is(Pointer, a) && is(Integer, b)) {
	    oop base = get(a, Pointer,base);
	    if (is(Integer, base)) {
		oop type   = get(a, Pointer,type);
		int offset = get(a, Pointer,offset);
		int scale  = typeSize(get(type, Tpointer,target));
		return _integerValue(base) + offset * scale == _integerValue(b);
	    }
	    return 0;
	}
    }
    fatal("cannot compare %s with %s", getTypeName(a), getTypeName(b));
    return 0;
}

oop eval(oop exp, oop env)
{
    if (opt_v > 2) { printf("EVAL  "); println(exp); }
    switch (getType(exp)) {
	case Undefined:	assert(!"this cannot happen");
	case Input:	assert(!"this cannot happen");
	case Integer:	return exp;
	case Float:	return exp;
	case Pointer:	return exp;
	case Symbol: {
	    oop value = Scope_lookup(exp);
	    if (!value) 	fatal("'%s' is undefined\n",     get(exp, Symbol,name));
	    if (isNil(value))	fatal("'%s' is uninitialised\n", get(exp, Symbol,name));
	    switch (getType(value)) {
		case Variable:	return get(value, Variable,value);
		case Function:	return value;
		case Primitive:	return value;
		default:	fatal("cannot eval: %s", toString(value));
	    }
	    break;
	}
	case Pair:	assert(!"this cannot happen");
	case String:	return exp;
	case Array: 	assert(!"this cannot happen");
	case Memory:	assert(!"this cannot happen");
	case Primitive:	return exp;
	case Reference: return exp;
	case Closure:	return exp;
	case Call: {
 	    oop fun  = eval(get(exp, Call,function), env);
 	    oop args = get(exp, Call,arguments);
 	    return apply(fun, args, nil);
	}
	case Block: {
	    Object  *stmts  = get(exp, Block,statements);
	    int      size   = get(stmts, Array,size);
	    oop *elts   = get(stmts, Array,elements);
	    Object  *result = nil;
	    Scope_begin();
	    switch (nlrPush()) { // longjmp occurred
		case NLR_INIT:     break;
		case NLR_RETURN:   Scope_end();  return nlrPop();
		case NLR_CONTINUE: Scope_end();  nlrReturn(NLR_CONTINUE, nlrPop());
		case NLR_BREAK:	   Scope_end();  nlrReturn(NLR_BREAK,    nlrPop());
	    }
	    for (int i = 0;  i < size;  ++i) {
		result = eval(elts[i], env);
	    }
	    Scope_end();
	    nlrPop();
	    return result;
	}
	case Addressof: {
	    oop rhs = get(exp, Addressof,rhs);
	    switch (getType(rhs)) {
		case Symbol: {
		    rhs = Scope_lookup(rhs);
		    if (!rhs) assert(!"this cannot happen");
		    switch (getType(rhs)) {
			case Variable:
			    return newPointer(newTpointer(get(rhs, Variable,type)), rhs, 0);
			default:
			    break;
		    }
		    break;
		}
		default:
		    break;
	    }
	    fatal("cannot take address of: %s", toString(rhs));
	    break;
	}
	case Dereference: {
	    oop rhs = get(exp, Dereference,rhs);
	    rhs = eval(rhs, nil);
	    switch (getType(rhs)) {
		case Pointer: {
		    oop base = get(rhs, Pointer,base);
		    switch (getType(base)) {
			case Variable:	return get(base, Variable,value);
			default:	break;
		    }
		    break;
		}
		default:	break;
	    }
	    printf("cannot dereference\n");
	    println(rhs);
	    exit(1);
	    break;
	}
	case Sizeof: {
	    return get(exp, Sizeof,size);
	}
	case Unary: {
	    unary_t op  = get(exp, Unary,operator);
	    oop     rhs = get(exp, Unary,rhs);
	    switch (op) {
		case PREINC:
		case PREDEC:
		case POSTINC:
		case POSTDEC: {
		    if (is(Symbol, rhs)) {
			rhs = Scope_lookup(rhs);
			switch (getType(rhs)) {
			    case Variable: {
				oop val    = get(rhs, Variable,value);
				oop result = nil;
				switch (op) {
				    case PREINC:  val = incr(val,  1);  result = val;  	break;
				    case PREDEC:  val = incr(val, -1);  result = val;  	break;
				    case POSTINC: result = val;  val = incr(val,  1);	break;
				    case POSTDEC: result = val;  val = incr(val, -1);	break;
				    default:	  assert("!this cannot happen");
				}
				set(rhs, Variable,value, val);
				return result;
			    }
			    default:  break;
			}
		    }
		    fatal("illegal increment operation: %s", toString(exp));
		}
		case NEG:
		case NOT:
		case COM: {
		    rhs = eval(rhs, env);
		    switch (op) {
			case NEG:	return ( is(Float, rhs)
						 ? newFloat  (-floatValue  (rhs))
						 : newInteger(-integerValue(rhs)) );
			case NOT:	return isFalse(rhs) ? true : false;
			case COM:	return newInteger(~integerValue(rhs));
			default:	break;
		    }
		}
	    }
	    assert("!this cannot happen");
	    break;
	}
	case Binary: {
	    oop lhs = get(exp, Binary,lhs);
	    oop rhs = get(exp, Binary,rhs);
	    switch (get(exp, Binary,operator)) {
		case LAND:   return isFalse(eval(lhs, env)) ? false : eval(rhs, env);
		case LOR:    return isTrue (eval(lhs, env)) ? true  : eval(rhs, env);
		default: {
		    lhs = eval(lhs, env);
		    rhs = eval(rhs, env);
		    if (Float == getType(lhs) || Float == getType(rhs)) { // floating point result
			switch (get(exp, Binary,operator)) {
			    case INDEX: assert(!"unimplemented");
			    case MUL: 	return FBINOP(lhs, * , rhs);
			    case DIV: 	return FBINOP(lhs, / , rhs);
			    case MOD: 	return newFloat(fmod(floatValue(lhs), floatValue(rhs)));
			    case ADD: 	return FBINOP(lhs, + , rhs);
			    case SUB: 	return FBINOP(lhs, - , rhs);
			    case SHL: 	return IBINOP(lhs, <<, rhs);
			    case SHR: 	return IBINOP(lhs, >>, rhs);
			    case LT: 	return FRELOP(lhs, < , rhs);
			    case LE: 	return FRELOP(lhs, <=, rhs);
			    case GE: 	return FRELOP(lhs, >=, rhs);
			    case GT: 	return FRELOP(lhs, > , rhs);
			    case EQ: 	return FRELOP(lhs, == , rhs);
			    case NE: 	return FRELOP(lhs, !=, rhs);
			    case BAND: 	return IBINOP(lhs, & , rhs);
			    case BXOR: 	return IBINOP(lhs, ^ , rhs);
			    case BOR: 	return IBINOP(lhs, | , rhs);
			    case LAND:
			    case LOR:
				break;
			}
		    }
		    else { // integer result
			switch (get(exp, Binary,operator)) {
			    case INDEX:	assert("!unimplemented");
			    case MUL: 	return IBINOP(lhs, * , rhs);
			    case DIV: 	return IBINOP(lhs, / , rhs);
			    case MOD: 	return IBINOP(lhs, % , rhs);
			    case ADD: 	return IBINOP(lhs, + , rhs);
			    case SUB: 	return IBINOP(lhs, - , rhs);
			    case SHL: 	return IBINOP(lhs, <<, rhs);
			    case SHR: 	return IBINOP(lhs, >>, rhs);
			    case LT: 	return IRELOP(lhs, < , rhs);
			    case LE: 	return IRELOP(lhs, <=, rhs);
			    case GE: 	return IRELOP(lhs, >=, rhs);
			    case GT: 	return IRELOP(lhs, > , rhs);
			    case EQ:	return equal(lhs, rhs) ? true : false;
			    case NE:	return equal(lhs, rhs) ? false : true;
			    case BAND: 	return IBINOP(lhs, & , rhs);
			    case BXOR: 	return IBINOP(lhs, ^ , rhs);
			    case BOR: 	return IBINOP(lhs, | , rhs);
			    case LAND:
			    case LOR:
				break;
			}
		    }
		}
	    }
	    assert(!"this cannot happen");
	    break;
	}
	case Assign: {
	    return assign(get(exp, Assign,lhs), eval(get(exp, Assign,rhs), nil));
	}
	case Cast: {
	    cvt_t cvt = get(exp, Cast,converter);		assert(cvt);
	    oop   rhs = eval(get(exp, Cast,rhs), nil);
	    return cvt(rhs);
	}
	case While: {
	    oop cond   = get(exp, While,condition);
	    oop expr   = get(exp, While,expression);
	    oop result = nil;
	    switch (nlrPush()) {
		case NLR_INIT:		break;
		case NLR_RETURN:	nlrReturn(NLR_RETURN, nlrPop()); // propagate upwards
		case NLR_CONTINUE:	break;
		case NLR_BREAK:		return nlrPop();
	    }
	    while (isTrue(eval(cond, env))) {
		result = eval(expr, env);
	    }
	    nlrPop();
	    return result;
	}
	case For: {
	    oop init = get(exp, For,initialiser);
	    oop cond = get(exp, For,condition);
	    oop step = get(exp, For,update);
	    oop body = get(exp, For,body);
	    eval(init, nil);
	    while (integerValue(eval(cond, nil))) {
		eval(body, nil);
		eval(step, nil);
	    }
	    return nil;
	}
	case If: {
	    oop cond   = get(exp, If,condition);
	    oop conseq = get(exp, If,consequent);
	    oop altern = get(exp, If,alternate);
	    if (isTrue(eval(cond, env))) eval(conseq, env);
	    else if (!isNil(altern)) eval(altern, env);
	    return nil;
	}
	case Return: {
	    nlrReturn(NLR_RETURN, eval(get(exp, Return,value), env));
	    break;
	}
	case Continue: {
	    nlrReturn(NLR_CONTINUE, nil);
	    break;
	}
	case Break: {
	    nlrReturn(NLR_BREAK, nil);
	    break;
	}
	case Tvoid:	assert(!"unimplemented");	    break;
	case Tchar:	assert(!"unimplemented");	    break;
	case Tshort:	assert(!"unimplemented");	    break;
	case Tint:	assert(!"unimplemented");	    break;
	case Tlong:	assert(!"unimplemented");	    break;
	case Tfloat:	assert(!"unimplemented");	    break;
	case Tdouble:	assert(!"unimplemented");	    break;
	case Tpointer:	assert(!"unimplemented");	    break;
	case Tarray:	assert(!"unimplemented");	    break;
	case Tstruct:	assert(!"unimplemented");	    break;
	case Tfunction:	assert(!"unimplemented");	    break;
	case Tetc:	assert(!"unimplemented");	    break;
	case VarDecls: {
	    oop vars = get(exp, VarDecls,variables);
	    Array_do(vars, var) {
		oop name = get(var, Variable,name);
		oop type = get(var, Variable,type);
		oop init = get(var, Variable,value);
		if (is(Tfunction, type)) continue;	// function declaration
		// do this now so that init can refer to the new variable
		oop var = declareVariable(name, type, nil);
		if (!isNil(init)) assign(var, eval(init, nil));
	    }
	    return nil;
	}
	case TypeDecls: {
	    oop types = get(exp, TypeDecls,typenames);
	    Array_do(types, type) {
		oop name = get(type, TypeName,name);
		oop type = get(type, TypeName,type);
		declareType(name, type);
	    }
	    return nil;
	}
	case Scope:	break;
	case TypeName:	break;
	case Variable:	break;
	case Constant:	break;
	case Function:  break;
    }
    assert(!"this cannot happen");
    return 0;
}

// pre-evaluate a top-level declaration, definition, or constant expression

oop preval(oop exp)
{
    if (opt_v > 2) { printf("PREVAL  "); println(exp); }
    switch (getType(exp)) {
	case Undefined:		break;
	case Input:		break;
	case Integer:		return exp;
	case Float:		return exp;
	case Pointer:		return exp;
	case Symbol:		break;
	case Pair:		break;
	case String:		break;
	case Array:		break;
	case Memory:		break;
	case Primitive:		return exp;
	case Reference:		break;
	case Closure:		break;
	case Call:		break;
	case Block:		break;
	case Addressof:		break;
	case Dereference:	break;
	case Sizeof:		return get(exp, Sizeof,size);
	case Unary:		break;
	case Binary:		break;
	case Assign:		break;
	case Cast:		break;
	case While:		break;
	case For:		break;
	case If:		break;
	case Return:		break;
	case Continue:		break;
	case Break:		break;
	case Tvoid:		break;
	case Tchar:		break;
	case Tshort:		break;
	case Tint:		break;
	case Tlong:		break;
	case Tfloat:		break;
	case Tdouble:		break;
	case Tpointer:		break;
	case Tarray:		break;
	case Tstruct:		break;
	case Tfunction:		break;
	case Tetc:		break;
	case VarDecls: {
	    oop vars = get(exp, VarDecls,variables);
	    Array_do(vars, var) {
		assert(Scope_lookup(get(var, Variable,name)));
		oop init = get(var, Variable,value);
		if (!isNil(init)) assign(var, preval(init));
	    }
	    return nil;
	}
	case TypeDecls: {
	    oop types = get(exp, TypeDecls,typenames);
	    Array_do(types, type) {
		assert(Scope_lookup(get(type, TypeName,name)));
	    }
	    return nil;
	}
	case Scope:	break;
	case TypeName:	break;
	case Variable:	break;
	case Constant:	break;
	case Function: {
	    assert(Scope_lookup(get(exp, Function,name)));
	    return exp;
	}
    }
    println(exp);
    assert(!"this cannot happen");
    return 0;
}

enum opcode_t { iHALT = 0, iPUSH, iPOP,
    iNOT, iCOM, iNEG, iDEREF, iINDEX,
    iMUL, iDIV, iMOD, iADD, iSUB, iSHL, iSHR,
    iLT, iLE, iGE, iGT, iEQ, iNE,
    iAND, iXOR, iOR,
    iGETGVAR, iSETGVAR,
    iCLOSE,
    iCALL, iRETURN,
    iJMP, iJMPF,
};

oop stackError(char *reason)
{
    printf("stack %s\n", reason);
    exit(1);
    return nil;
}

void disassemble(oop program)
{
    oop *code = get(program, Array,elements);
    int      size = get(program, Array,size);
    int      pc   = 0;
    while (pc < size) {
	printf("%04d", pc);
	int opcode = _integerValue(code[pc++]);
	printf(" %02d\t", opcode);
	switch (opcode) {
	    case iHALT:		printf("HALT\n");				break;
	    case iPUSH:		printf("PUSH\t");	println(code[pc++]);	break;
	    case iPOP:		printf("POP\n");				break;
	    case iNOT:		printf("NOT\n");				break;
	    case iCOM:		printf("COM\n");				break;
	    case iNEG:		printf("NEG\n");				break;
	    case iDEREF:	printf("DEREF\n");				break;
	    case iINDEX:	printf("INDEX\n");				break;
	    case iMUL:		printf("MUL\n");				break;
	    case iDIV:		printf("DIV\n");				break;
	    case iMOD:		printf("MOD\n");				break;
	    case iADD:		printf("ADD\n");				break;
	    case iSUB:		printf("SUB\n");				break;
	    case iSHL:		printf("SHL\n");				break;
	    case iSHR:		printf("SHR\n");				break;
	    case iLT:		printf("LT\n");					break;
	    case iLE:		printf("LE\n");					break;
	    case iGE:		printf("GE\n");					break;
	    case iGT:		printf("GT\n");					break;
	    case iEQ:		printf("EQ\n");					break;
	    case iNE:		printf("NE\n");					break;
	    case iAND:		printf("AND\n");				break;
	    case iXOR:		printf("XOR\n");				break;
	    case iOR:		printf("OR\n");					break;
	    case iGETGVAR:	printf("GETGVAR\t");  	println(code[pc++]);	break;
	    case iSETGVAR:	printf("SETGVAR\t");  	println(code[pc++]);	break;
	    case iCLOSE:	printf("CLOSE\t");	println(code[pc++]);	break;
	    case iCALL:		printf("CALL\t");	println(code[pc++]);	break;
	    case iRETURN:	printf("RETURN\n");				break;
	    case iJMP:		printf("JMP\t");	println(code[pc++]);	break;
	    case iJMPF:		printf("JMPF\t");	println(code[pc++]);	break;
	}
    }
}


oop execute(oop program)
{
    oop *code = get(program, Array,elements);
    int pc = 0;

    oop stack[32];
    int sp = 32; // clear the stack

    oop env = nil;

    struct Frame {
	Object  *env;
	oop *code;
	int      pc;
    } frames[32];
    int fp = 32;

# define push(O)	(sp >  0 ? stack[--sp] = (O) : stackError("overflow"))
# define pop()		(sp < 32 ? stack[sp++] : stackError("underflow"))
# define top		(stack[sp])

    for (;;) {
	oop insn = code[pc++];
	switch ((enum opcode_t)_integerValue(insn)) {
	    case iHALT: {
		if (sp < 31) fatal("%d items on stack at end of execution", 32-sp);
		if (sp < 32) return stack[sp];
		fatal("stack empty at end of execution");
		return nil;
	    }
	    case iPUSH: {
		oop operand = code[pc++];
		push(operand);
		continue;
	    }
	    case iPOP: {
		pop();
		continue;
	    }
	    case iNOT: {
		top = (isFalse(top) ? true : false);
		continue;
	    }
	    case iCOM: {
		top = newInteger(~integerValue(top));
		continue;
	    }
	    case iNEG: {
		top = is(Float, top) ? newFloat(-floatValue(top)) : newInteger(-integerValue(top));
		continue;
	    }
	    case iDEREF: {
		assert(!"unimplemented");
		continue;
	    }
	    case iINDEX: {
		assert(!"unimplemented");
		continue;
	    }
#          define BINOP(OP) {									\
		    oop rhs = pop(), lhs = pop();						\
		    if (is(Float, lhs) || is(Float, rhs))	push(FBINOP(lhs, OP, rhs));	\
		    else					push(IBINOP(lhs, OP, rhs));	\
		    continue;									\
		}
	    case iMUL: BINOP(*);
	    case iDIV: BINOP(/);
	    case iMOD: {
		oop rhs = pop(), lhs = pop();
		if (is(Float, lhs) || is(Float, rhs))
		    push(newFloat(fmod(floatValue(lhs), floatValue(rhs))));
		else
		    push(IBINOP(lhs, %, rhs));
		continue;
	    }
	    case iADD: BINOP(+);
	    case iSUB: BINOP(-);
#          undef BINOP
#          define BINOP(OP) {				\
		    oop rhs = pop(), lhs = pop();	\
		    push(IBINOP(lhs, OP, rhs));		\
		    continue;				\
		}
	    case iSHL:	BINOP(<<);
	    case iSHR:	BINOP(>>);
	    case iAND:	BINOP(&);
	    case iXOR:	BINOP(^);
	    case iOR:	BINOP(|);
#          undef BINOP
#          define BINOP(OP) {									\
		    oop rhs = pop(), lhs = pop();						\
		    if (is(Float, lhs) || is(Float, rhs))					\
			push(floatValue(lhs) OP floatValue(rhs) ? true : false);		\
		    else									\
			push(integerValue(lhs) OP integerValue(rhs) ? true : false);		\
		    continue;									\
		}
	    case iLT:	BINOP(< );
	    case iLE:	BINOP(<=);
	    case iGE:	BINOP(>=);
	    case iGT:	BINOP(> );
	    case iEQ:	BINOP(==);
	    case iNE:	BINOP(!=);
#          undef BINOP
	    case iGETGVAR: {
		oop operand = code[pc++];
		oop keyval  = assoc(env, operand);
		if (nil != keyval) {
		    push(get(keyval, Pair,tail));
		    continue;
		}
		push(get(operand, Symbol,value));
		continue;
	    }
	    case iSETGVAR: {
		oop operand = code[pc++];
		oop keyval  = assoc(env, operand);
		if (nil != keyval) {
		    set(keyval, Pair,tail, top);
		    continue;
		}
		set(operand, Symbol,value, top);
		continue;
	    }
	    case iCLOSE: {
		oop func = code[pc++];
		push(newClosure(func, env));
		continue;
	    }
	    case iCALL: {
		int     argc = _integerValue(code[pc++]);
		oop func = pop();
		switch (getType(func)) {
		    case Primitive: {
			oop result = get(func, Primitive,function)(argc, stack + sp, nil);
			sp += argc; // pop all arguments
			push(result);
			continue; // next instruction
		    }
		    case Closure: {
			Object  *function    = get(func, Closure,function);
			Object  *environment = get(func, Closure,environment);
			Object  *parameters  = get(function, Function,parameters);
			int      parc        = get(parameters, Array,size);
			oop *parv        = get(parameters, Array,elements);
			int      parn        = 0;
			while (parn < parc && argc > 0) {
			    environment = newPair(newPair(parv[parn++], pop()), environment);
			    --argc;
			}
			while (parn < parc)
			    environment = newPair(newPair(parv[parn++], nil), environment);
			sp += argc;
			if (fp < 1) fatal("too many function calls");
			--fp;
			frames[fp].env  = env;   env  = environment;
			frames[fp].code = code;  code = get(function, Function,code);
			frames[fp].pc   = pc;    pc   = 0;
			assert(code != 0);
			continue;
		    }
		    default:
			fatal("cannot call value of type %d", getType(func));
		}
		continue;
	    }
	    case iRETURN: {
		assert(fp < 32);
		env  = frames[fp].env;
		code = frames[fp].code;
		pc   = frames[fp].pc;
		++fp;
		continue;
	    }
	    case iJMP: {
		int dest = _integerValue(code[pc++]);
		pc = dest;
		continue;
	    }
	    case iJMPF:	{
		int dest = _integerValue(code[pc++]);
		oop cond = pop();
		if (nil == cond) pc = dest;
		continue;
	    }
	}
    }
    assert(!"this cannot happen");
    return 0;
}

#define EMITo(O)	Array_append(program, (O))
#define EMITi(I)	EMITo(newInteger(I))

#define EMIToo(O, P)	(( EMITo(O), EMITo(P) ))
#define EMITio(I, P)	EMIToo(newInteger(I), P)
#define EMITii(I, J)	EMIToo(newInteger(I), newInteger(J))

oop compileFunction(oop exp);

void compileOn(oop exp, oop program, oop cs, oop bs)
{
    switch (getType(exp)) {
	case Undefined:	EMITio(iPUSH, exp);	return;
	case Input:	EMITio(iPUSH, exp);	return;
	case Integer:	EMITio(iPUSH, exp);	return;
	case Float:	EMITio(iPUSH, exp);	return;
	case Pointer:	assert(!"unimplemented");
	case Symbol:	EMITio(iGETGVAR, exp);	return;
	case Pair:	EMITio(iPUSH, exp);	return;
	case String:	EMITio(iPUSH, exp);	return;
	case Array:	assert(!"unimplemented");
	case Memory:	assert(!"unimplemented");
	case Primitive:	EMITio(iPUSH, exp);	return;
	case Reference: assert(!"unimplemented");
	case Closure:	EMITio(iPUSH, exp);	return;
	case Call: {
	    Object  *args = get(exp, Call,arguments);
	    int      argc = get(args, Array,size);
	    oop *argv = get(args, Array,elements);
	    for (int n = argc; n--;) compileOn(argv[n], program, cs, bs);
	    compileOn(get(exp, Call,function), program, cs, bs);	    // GETVAR	print
	    EMITii(iCALL, argc);
	    return;
	}
	case Block: {
	    oop statements = get(exp, Block,statements);
	    int      size = get(statements, Array,size);
	    if (0 == size) {
		EMITio(iPUSH, nil);
		return;
	    }
	    oop *exps = get(statements, Array,elements);
	    for (int i = 0;  i < size - 1;  ++i) {
		compileOn(exps[i], program, cs, bs);
		EMITi(iPOP);
	    }
	    compileOn(exps[size - 1], program, cs, bs);
	    return;
	}
	case Addressof:		assert(0);
	case Dereference:	assert(0);
	case Sizeof:		assert(0);
	case Unary: {
	    compileOn(get(exp, Unary,rhs), program, cs, bs);
	    switch (get(exp, Unary,operator)) {
		case NEG:	EMITi(iNEG);	return;
		case NOT:	EMITi(iNOT);	return;
		case COM:	EMITi(iCOM);	return;
		case PREINC:	assert(!"unimplemented");
		case PREDEC:	assert(!"unimplemented");
		case POSTINC:	assert(!"unimplemented");
		case POSTDEC:	assert(!"unimplemented");
	    }
	    break;
	}
	case Binary: { // MUL{op, lhs, rhs}
	    switch (get(exp, Binary,operator)) {
		case LAND:	assert(!"unimplemented");
		case LOR:	assert(!"unimplemented");
		default:	break;
	    }
	    compileOn(get(exp, Binary,lhs), program, cs, bs);
	    compileOn(get(exp, Binary,rhs), program, cs, bs);
	    switch (get(exp, Binary,operator)) {
		case INDEX:	assert(!"unimplemented");
		case MUL:	EMITi(iMUL);	return;
		case DIV:	EMITi(iDIV);	return;
		case MOD:	EMITi(iMOD);	return;
		case ADD:	EMITi(iADD);	return;
		case SUB:	EMITi(iSUB);	return;
		case SHL:	EMITi(iSHL);	return;
		case SHR:	EMITi(iSHR);	return;
		case LT:	EMITi(iLT);	return;
		case LE:	EMITi(iLE);	return;
		case GE:	EMITi(iGE);	return;
		case GT:	EMITi(iGT);	return;
		case EQ:	EMITi(iEQ);	return;
		case NE:	EMITi(iNE);	return;
		case BAND:	EMITi(iAND);	return;
		case BXOR:	EMITi(iXOR);	return;
		case BOR:	EMITi(iOR);	return;
		case LAND:
		case LOR:
		    assert(!"unimplemented");
	    }
	}

	case Assign: {
	    oop symbol = get(exp, Assign,lhs);
	    oop expr   = get(exp, Assign,rhs);
	    compileOn(expr, program, cs, bs);
	    EMITio(iSETGVAR, symbol);
	    return;
	}

	case Cast: {
	    assert(!"unimplemented");
	    return;
	}

# define LABEL(NAME)	int NAME = get(program, Array,size)
# define PATCH(J, L)    Array_set(program, J+1, newInteger(L))

	case While: {
	    oop continues = newArray();
	    oop breaks    = newArray();
	    oop cond = get(exp, While,condition);
	    oop body = get(exp, While,expression);
	    EMITio(iPUSH, nil);
	    LABEL(L1);
	    compileOn(cond, program, cs, bs); // break/continue apply to enclosing loop
	    LABEL(J1);
	    EMITio(iJMPF, nil);
	    EMITi(iPOP);
	    compileOn(body, program, continues, breaks);
	    EMITii(iJMP, L1);
	    LABEL(L2);
	    PATCH(J1, L2);
	    for (int i = get(continues, Array,size);  i--;)
		PATCH(_integerValue(get(continues, Array,elements)[i]), L1);
	    for (int i = get(breaks, Array,size);  i--;)
		PATCH(_integerValue(get(breaks, Array,elements)[i]), L2);
	    return;
	}
	case For: {
	    assert(!"unimplemented");
	    return;
	}
	case If: {
	    oop cond   = get(exp, If,condition);
	    oop conseq = get(exp, If,consequent);
	    oop altern = get(exp, If,alternate);
	    compileOn(cond, program, cs, bs);
	    LABEL(J1);
	    EMITio(iJMPF, nil); // L1
	    compileOn(conseq, program, cs, bs);
	    LABEL(J2);
	    EMITio(iJMP, nil); // L2
	    LABEL(L1);
	    compileOn(altern, program, cs, bs);
	    LABEL(L2);
	    PATCH(J1, L1);
	    PATCH(J2, L2);
	    return;
	}
	case Return:	assert(!"unimplemented");
	case Continue: {
	    if (nil == cs) fatal("continue outside loop");
	    EMITio(iPUSH, nil);
	    LABEL(L1);
	    EMITio(iJMP, nil);
	    Array_append(cs, newInteger(L1));
	    return;
	}
	case Break: {
	    if (nil == bs) fatal("continue outside loop");
	    EMITio(iPUSH, nil);
	    LABEL(L1);
	    EMITio(iJMP, nil);
	    Array_append(bs, newInteger(L1));
	    return;
	}
	case Tvoid:	assert(!"unimplemented");    	return;
	case Tchar:	assert(!"unimplemented");    	return;
	case Tshort:	assert(!"unimplemented");    	return;
	case Tint:	assert(!"unimplemented");    	return;
	case Tlong:	assert(!"unimplemented");    	return;
	case Tfloat:	assert(!"unimplemented");    	return;
	case Tdouble:	assert(!"unimplemented");    	return;
	case Tpointer:	assert(!"unimplemented");    	return;
	case Tarray:	assert(!"unimplemented");    	return;
	case Tstruct:	assert(!"unimplemented");    	return;
	case Tfunction:	assert(!"unimplemented");    	return;
	case Tetc:	assert(!"unimplemented");    	return;
	case VarDecls:	assert(!"unimplemented");    	return;
	case TypeDecls:	assert(!"unimplemented");    	return;
	case Scope:	assert(!"this cannot happen");	return;
	case TypeName:	assert(!"unimplemented");    	return;
	case Variable:	assert(!"unimplemented");    	return;
	case Constant:	assert(!"unimplemented");    	return;
	case Function: {
	    assert(0 == get(exp, Function,code));
	    oop prog2 = compileFunction(get(exp, Function,body));
	    set(exp, Function,code, get(prog2, Array,elements));
	    EMITio(iCLOSE, exp);
	    return;
	}
    }
}

oop compileFunction(oop exp)
{
    oop program = newArray();
    compileOn(exp, program, nil, nil);
    EMITi(iRETURN);
    if (opt_v > 2) disassemble(program);
    return program;
}

oop compile(oop exp) // 6*7
{
    oop program = newArray();
    compileOn(exp, program, nil, nil);
    EMITi(iHALT);
    if (opt_v > 2) disassemble(program);
    return program;
}
void replFile(char *name, FILE *file)
{
    input = pushInput(name, file);

    while (input) {
	if (yyparse() && yysval) {
	    if (opt_v > 1) println(yysval);
	    if (!opt_x) {
		oop result = nil;
		if (opt_O) {
		    oop program = compile(yysval);
		    result = execute(program);
		}
		else {
		    switch (nlrPush()) {
			case NLR_INIT:     break;
			case NLR_RETURN:   fatal("return outside function");
			case NLR_CONTINUE: fatal("continue outside loop");
			case NLR_BREAK:    fatal("break outside loop");
		    }
		    if (opt_v > 1) printf("---------------- typecheck\n");
		    assert(1 == Array_size(scopes));
		    typeCheck(yysval, nil);
		    assert(1 == Array_size(scopes));
		    if (opt_v > 1) printf("---------------- declare\n");
		    result = preval(yysval);
		    assert(1 == Array_size(scopes));
		    nlrPop();
		}
		if (opt_v > 0) {
		    printf("=> %s\n", toString(result));
		}
	    }
	}
    }
}

void replPath(char *path)
{
    FILE *file = fopen(path, "r");
    if (!file) fatal("%s: %s", path, strerror(errno));
    replFile(path, file);
}

int main(int argc, char **argv)
{
    false    = newInteger(0);
    true     = newInteger(1);
    s_etc    = newSymbol("...");

# define _(X) s_##X = intern(#X);
    _do_primitives(_);
# undef _

    t_void   = newTvoid();
    t_char   = newTchar();
    t_short  = newTshort();
    t_int    = newTint();
    t_long   = newTlong();
    t_float  = newTfloat();
    t_double = newTdouble();
    t_pvoid  = newTpointer(t_void);
    t_pchar  = newTpointer(t_char);
    t_ppchar = newTpointer(t_pchar);
    t_etc    = newTetc();

    scopes = newArray();

    Scope_begin(); // the global scope

#if 0
    declarePrimitive(intern("printf"),
		     newTfunction(t_int, newArray2(t_pchar, t_etc)),
		     prim_printf);
#endif

#if 0
    declarePrimitive(intern("assert"),
		     newTfunction(t_void, newArray1(t_etc)),
		     prim_assert);
#endif

    int repls = 0;

    for (int argn = 1;  argn < argc;) {
	char *arg = argv[argn++];
	if (*arg != '-') {
	    replPath(arg);
	    ++repls;
	}
	else {
	    while (*++arg) {
		switch (*arg) {
		    case 'O':	++opt_O;  continue;
		    case 'v':	++opt_v;  continue;
		    case 'x':	++opt_x;  continue;
		    default:	fatal("uknown option '%c'", *arg);
		}
	    }
	}
    }

    if (!repls) replFile("stdin", stdin);

    oop args = newArray();
    Array_append(args, newInteger(1));
    Array_append(args, newStringWith("main"));

    oop entry = Scope_lookup(intern("main"));
    if (!entry || isNil(entry)) fatal("main is not defined");
    if (!is(Function, entry))	fatal("main is not a function");
    oop params = get(get(entry, Function,type), Tfunction, parameters);
    switch (Array_size(params)) {
	default:
	    fatal("main has too many parameters");
	case 3:
	    if (Array_get(params, 2) != t_ppchar)
		fatal("third parameter of main should be 'char **'");
	case 2:
	    if (Array_get(params, 1) != t_ppchar)
		fatal("second parameter of main should be 'char **'");
	case 1:
	    if (Array_get(params, 0) != t_int)
		fatal("first parameter of main should be 'int'");
	case 0:
	    break;
    }

    set(entry, Function,variadic, 1);

    if (opt_v > 1) printf("---------------- execute\n");
    oop result = apply(entry, args, nil);

    if (!is(Integer, result)) {
	printf("\n=> ");
	println(result);
	fatal("main did not return an integer");
    }

    assert(1 == Array_size(scopes));

    return _integerValue(result);
}