# minproto.leg -- minimal prototype langauge for semantic experiments
#
# last edited: 2024-07-10 11:28:02 by piumarta on zora-1034.local

%{
;
//#define YY_DEBUG 1

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

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

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

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

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

#ifndef BINOPT          // store pointer to implemention function in Binop nodes
# define BINOPT 0       // (approx. 1% performance decrease due to lookup + indirect call)
#endif

#ifndef NONLOCAL        // support non-local control flow (return, break, continue)
# define NONLOCAL 1     // (approx. 5% [loop] to 55% [call] performance decrease, because of jmp_buf initialisations)
#endif

#ifndef EXCEPTIONS      // report errors by raising an exception
# define EXCEPTIONS 1
#endif

#ifndef FOLDCONST       // fold constant expressions during parsing
# define FOLDCONST 1
#endif

#ifndef PROFILE         // include profiling support
# define PROFILE 0
#endif

#ifndef PEGVM           // include parsing expression grammar VM
# define PEGVM 1
#endif

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

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

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

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

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

union object;
typedef union object *oop;

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

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

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

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

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

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

#if PRIMCLOSURE
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure)_(Raise)_(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal)
#else
#define doProtos(_) _(Object) _(RefLocal) _(GetLocal) _(SetLocal) _(RefGlobal) _(GetGlobal) _(SetGlobal) _(RefVar) _(GetVar) _(SetVar) _(RefProp) _(GetProp) _(SetProp) _(RefArray) _(GetArray) _(SetArray) _(GetSlice) _(Call) _(Invoke) _(Super) _(Continue) _(Break) _(Return) _(TryCatch) _(TryEnsure) _(Raise) _(Binop) _(Unyop) _(If) _(While) _(Block) _(For) _(ForIn) _(ForFromTo) _(Literal) _(Lambda) _(Closure)
#endif

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

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

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

#define doProperties(_) _(name) _(eval) _(delegate) _(codeon) _(function) _(message) _(kind) _(owner) _(profile)

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

#define doSymbols(_) _(t) _(name) _(expr) _(function) _(arguments) _(object) _(index) _(key) _(value) _(self) _(method) _(parameters) _(body) _(lambda) _(environment) _(operation) _(full) _(condition) _(consequent) _(alternate) _(expression) _(identifier) _(initialise) _(update) _(first) _(last) _(fixed) _(keyvals) _(__namespaces__) _(O) _(d) _(p) _(v) _(statement) _(handler) _(kind) _(message) _(operand1) _(operand2) _(profile) _(parent) _(count) _(stamp) _(time) _(start) _(stop) _($$) _(yytext) _(yyleng) _(env)

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

#if NONLOCAL

#include <setjmp.h>

enum {
    NLR_INIT = 0,    // initialisation, no non-local flow
    NLR_CONTINUE,    // non-local jump back to the start of active loop
    NLR_BREAK,       // non-local jump out of the active loop
    NLR_RETURN,      // non-local return from the active function
    NLR_RAISE,       // exception
};

struct NLR {
    int     ntrace;
    jmp_buf env;
};

struct NLR *nlrs = 0;

int     nnlrs = 0;
int   maxnlrs = 0;
oop   valnlr  = 0;

#define nlrPush() ({                                                                            \
        if (++nnlrs >= maxnlrs) nlrs = realloc(nlrs, sizeof(struct NLR) * (maxnlrs += 32));     \
        nlrs[nnlrs - 1].ntrace = _get(trace, Object,isize);                                     \
        setjmp(nlrs[nnlrs - 1].env);                                                            \
    })

#define nlrReturn(VAL, TYPE) {                  \
        valnlr = VAL;                           \
        longjmp(nlrs[nnlrs-1].env, TYPE);       \
    }

#define nlrPop() (_set(trace, Object,isize, nlrs[--nnlrs].ntrace), valnlr)

#endif

struct property  { oop key, val; };

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

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

union object _nil = { Undefined };

#define nil (&_nil)

oop namespaces = nil;

#define UNDEFINED 0


void typeError(char *who, char *msg, oop value);
void typeError2(char *who, char *msg, oop lhs, oop rhs);
void rangeError(char *who, char *msg, oop object, int index);
void valueError(char *who, char *msg, oop value);
void keyError(char *who, char *msg, oop object, oop key);
void undefinedError(oop name);
void syntaxError(char *message);
void unknownError(char *message);
void keyboardInterrupt(void);


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

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

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

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

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

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

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

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

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

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

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

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

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

#define isFloat(obj)  is(Float, obj)

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

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

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

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

#define isString(obj)   is(String, obj)

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

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

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

oop String_appendAllLen(oop str, char *s, int len)
{
    if (len < 1) return str;
    int  length = get(str, String,length);
    char *value = get(str, String,value);
    char *copy  = xmalloc(length + len);
    memcpy(copy, value, length);
    memcpy(copy + length, s, len);
    set(str, String,value,  copy);
    set(str, String,length, length+len);
    return str;
}

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

oop String_appendString(oop str, oop val)
{
    return String_appendAllLen(str, _get(val, String,value), _get(val, String,length));
}

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

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

oop String_concat(oop a, oop b)
{
    oop result = newStringLen(_get(a, String,value), _get(a, String,length));
    String_appendAllLen(result, _get(b, String,value), _get(b, String,length));
    return result;
}

oop String_repeat(oop s, int n)
{                                               assert(is(String, s));
    char *chars  = _get(s, String,value);
    int   length = _get(s, String,length);
    oop   result = newStringLen(0, 0);
    while (n-- > 0) String_appendAllLen(result, chars, length);
    return result;
}

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

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

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

oop String_escaped(oop obj)
{                                               assert(is(String, obj));
    oop   buf = newStringLen(0, 0);
    char *str = _get(obj, String,value);
    int   len = _get(obj, String,length);
    while (len--) {
        int c = *str++;
        if      (c == '"')                    String_appendAll(buf, "\\\"");
        else if (c == '\\')                   String_appendAll(buf, "\\\\");
        else if (c >= ' ' && c <= '~')        String_append(buf, c);
        else {
            switch (c) {
                case '\a': c = 'a';  break;
                case '\b': c = 'b';  break;
                case '\f': c = 'f';  break;
                case '\n': c = 'n';  break;
                case '\r': c = 'r';  break;
                case '\t': c = 't';  break;
                case '\v': c = 'v';  break;
                default:
                    String_format(buf, "\\%03o", c);
                    continue;
            }
            String_format(buf, "\\%c", c);
        }
    }
    return buf;
}

char *codeString(oop obj, int indent);
char *printString(oop obj, int indent);

oop String_push(oop obj, oop val) // val is String OR Integer
{
    if      (isInteger(val))  String_append(obj, _integerValue(val));
    else if (is(String, val)) String_appendAllLen(obj, _get(val, String,value), _get(val, String,length));
    else if (is(Symbol, val)) String_appendAllLen(obj, _get(val, Symbol,name),  strlen(_get(val, Symbol,name)));
    else                      typeError("String.push", "value is not integer, string, or symbol", val);
    return val;
}

void getSliceRange(oop obj, oop ostart, oop ostop, int len, int *pstart, int *pstop)
{
    int start = (nil == ostart) ?   0 : integerValue(ostart, "[:]");
    int stop  = (nil == ostop ) ? len : integerValue(ostop,  "[:]");
    if (start < 0) start += len;
    if (start < 0 || start >= len) rangeError("[:]", "start index out of bounds", obj, start);
    if (stop  < 0) stop += len;
    if (stop  < 0 || stop  >  len) rangeError("[:]", "end index out of bounds", obj, stop);
    *pstart = start;
    *pstop  = stop;
}

void print(oop obj, int indent);

oop String_slice(oop obj, oop ostart, oop ostop)
{
    int len = _get(obj, String,length), start, stop;
    getSliceRange(obj, ostart, ostop, len, &start, &stop);
    if (start >= stop) return newStringLen(0, 0);
    return newStringLen(_get(obj, String,value) + start, stop - start);
}

oop newSymbol(char *name)
{
    oop obj = make(Symbol);
    _set(obj, Symbol,name,  strdup(name));
    _set(obj, Symbol,value, UNDEFINED);
# if TYPECODES
    _set(obj, Symbol,typecode, UNDEFINED_TYPECODE);
# endif
    return obj;
}

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

int stringLength(oop obj, char *who)
{
    int type = getType(obj);
    if (type == String) return _get(obj, String,length);
    if (type == Symbol) return strlen(_get(obj, Symbol,name));
    typeError(who, "non-string operand", obj);
    return 0;
}

oop intern(char *name);

oop Symbol_slice(oop obj, oop ostart, oop ostop)
{
    char *name = _get(obj, Symbol,name);
    int len = strlen(name), start, stop;
    getSliceRange(obj, ostart, ostop, len, &start, &stop);
    if (start >= stop) return intern(""); // ?!?
    char buf[stop - start + 1];
    strncpy(buf, name + start, stop - start);
    buf[stop - start] = 0;
    return intern(buf);
}

oop Object_put(oop obj, oop key, oop val);
oop Object_push(oop obj, oop val);

oop primitives = 0;

oop newPrimitive(prim_t function, oop name)
{
    oop obj = make(Primitive);
    _set(obj, Primitive,name,     name);
    _set(obj, Primitive,function, function);
    _set(obj, Primitive,cookie,   0);
# if PROFILE
    _set(obj, Primitive,profile,  nil);
# endif
    _set(obj, Primitive,index,    _get(primitives, Object,isize));
    Object_put(primitives, obj, newInteger(_get(primitives, Object,isize)));
    Object_push(primitives, obj);
    return obj;
}

#if PRIMCLOSURE

oop newLambda(oop parameters, oop body, oop parent, oop name)
{
    oop obj = make(Lambda);
    _set(obj, Lambda,parameters, parameters);
    _set(obj, Lambda,body,       body);
# if PROFILE
    _set(obj, Lambda,profile,    0);
# endif
    _set(obj, Lambda,parent,     parent);
    _set(obj, Lambda,name,       name);
    return obj;
}

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

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

#endif

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

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

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

oop Object_atPut(oop obj, size_t index, oop val)
{
    size_t size = get(obj, Object,isize);
    if (index >= size) rangeError("Object.[]=", "index out of bounds", obj, index);
    return _get(obj, Object,indexed)[index] = val;
}

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

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

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

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

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

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

char *storeString(oop obj, int indent);

oop *Object_ref(oop obj, oop key)
{
    oop o = nil;
    switch (getType(obj)) {
        case Undefined: o = pUndefined;  break;
        case Integer:   o = pInteger;    break;
        case Float:     o = pFloat;      break;
        case String:    o = pString;     break;
        case Symbol:    o = pSymbol;     break;
        case Primitive: o = pPrimitive;  break;
#     if PRIMCLOSURE
        case Lambda:
            if (key == sym_parameters) return &_get(obj, Lambda,parameters);
            if (key == sym_body      ) return &_get(obj, Lambda,body      );
            if (key == sym_parent    ) return &_get(obj, Lambda,parent    );
            if (key == sym_name      ) return &_get(obj, Lambda,name      );
            o = pLambda;
            break;
        case Closure:
            if (key == sym_function   ) return &_get(obj, Closure,function   );
            if (key == sym_environment) return &_get(obj, Closure,environment);
            if (key == sym_fixed      ) return &_get(obj, Closure,fixed);
            o = pClosure;
            break;
#     endif
        case Object: {
            ssize_t ind = Object_find(obj, key);
            if (ind >= 0) return &_get(obj, Object,properties)[ind].val;
            o = _getDelegate(obj);
            if (nil == o) o = pObject;
            break;
        }
    }
    if (key == prop_delegate) keyError("Object.", "__delegate__ is inaccessible", obj, prop_delegate);
    while (is(Object, o)) {
        ssize_t ind = Object_find(o, key);
        if (ind >= 0) return &_get(o, Object,properties)[ind].val;
        o = _getDelegate(o);
    }
    keyError("Object.", "undefined property", obj, key);
    return 0;
}

oop Object_getOwner(oop obj, oop key, oop *ownerp)
{
    oop o = nil;
    switch (getType(obj)) {
        case Undefined: o = pUndefined;  break;
        case Integer:   o = pInteger;    break;
        case Float:     o = pFloat;      break;
        case String:    o = pString;     break;
        case Symbol:    o = pSymbol;     break;
        case Primitive: o = pPrimitive;  break;
#     if PRIMCLOSURE
        case Lambda:
            if (key == sym_parameters) return _get(obj, Lambda,parameters);
            if (key == sym_body      ) return _get(obj, Lambda,body      );
            if (key == sym_parent    ) return _get(obj, Lambda,parent    );
            if (key == sym_name      ) return _get(obj, Lambda,name      );
            o = pLambda;
            break;
        case Closure:
            if (key == sym_function   ) return _get(obj, Closure,function   );
            if (key == sym_environment) return _get(obj, Closure,environment);
            if (key == sym_fixed      ) return _get(obj, Closure,fixed      );
            o = pClosure;
            break;
#     endif
        case Object: {
            ssize_t ind = Object_find(obj, key);
            if (ind >= 0) { *ownerp = obj;  return _get(obj, Object,properties)[ind].val; }
            o = _getDelegate(obj);
            if (nil == o) o = pObject;
            break;
        }
    }
    if (key == prop_delegate) return o;
    while (is(Object, o)) {
        ssize_t ind = Object_find(o, key);
        if (ind >= 0) { *ownerp = o;  return _get(o, Object,properties)[ind].val; }
        o = _getDelegate(o);
    }
    keyError("Object.", "undefined property", obj, key);
    return nil;
}

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

oop *_refvar(oop obj, oop key)
{
    while (is(Object, obj)) { // look for a binding of key in the local scopes
        ssize_t ind = Object_find(obj, key);
        if (ind >= 0) return &_get(obj, Object,properties)[ind].val;
        obj = _getDelegate(obj);
    }
    int numspaces  = _get(namespaces, Object,isize);
    if (numspaces) { // look for a binding of key in the namespace stack
        oop *nss = _get(namespaces, Object,indexed);
        for (int i = numspaces;  i--;) {
            oop ns = nss[i];
            ssize_t ind = Object_find(ns, key);
            if (ind >= 0) return &_get(ns, Object,properties)[ind].val;
        }
    }
    oop *ref = &_get(key, Symbol,value); // use the global binding
    return ref;
}

oop *refvar(oop obj, oop key)
{
    oop *ref = _refvar(obj, key);
    if (UNDEFINED == *ref) undefinedError(key);
    return ref;
}

oop getvar(oop obj, oop key)
{
    return *refvar(obj, key);
}

oop Object_put(oop obj, oop key, oop val);

oop setvar(oop obj, oop key, oop val)
{
    oop env = obj;
    while (is(Object, env)) { // look for a binding of key in the local scopes
        ssize_t ind = Object_find(env, key);
        if (ind >= 0) return _get(env, Object,properties)[ind].val = val; // set it
        env = _getDelegate(env);
    }
    if (nil != obj) return Object_put(obj, key, val); // create a new local variable
    int numspaces  = _get(namespaces, Object,isize);
    if (numspaces) {
        oop *nss = _get(namespaces, Object,indexed);
        oop  ns  = nss[numspaces - 1];
        if (is(Object, ns)) return Object_put(ns, key, val); // define a namespace variable
    }
    return _get(key, Symbol,value) = val; // set a global variable
}

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

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

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

oop Object_slice(oop obj, oop ostart, oop ostop)
{
    oop *indexed = _get(obj, Object,indexed);
    int  len     = _get(obj, Object,isize), start, stop;
    getSliceRange(obj, ostart, ostop, len, &start, &stop);
    oop result = new(_getDelegate(obj));
    for (int i = start;  i < stop;  ++i) Object_push(result, indexed[i]);
    return result;
}

#if EXCEPTIONS

void genericError(char *who, char *message, char *kind, ...);

#define END (oop)0

void typeError(char *who, char *msg, oop value)                 { genericError(who, msg, "type error",
                                                                               sym_value, value, END); }

void typeError2(char *who, char *msg, oop lhs, oop rhs)         { genericError(who, msg, "type error",
                                                                               sym_operand1, lhs, sym_operand2, rhs, END); }

void rangeError(char *who, char *msg, oop obj, int index)       { genericError(who, msg, "index error",
                                                                               sym_object, obj, sym_index, newInteger(index), END); }

void valueError(char *who, char *msg, oop value)                { genericError(who, msg, "value error",
                                                                               sym_value, value, END); }

void keyError(char *who, char *msg, oop object, oop key)        { genericError(who, msg, "key error",
                                                                               sym_object, object, sym_key, key, END); }

void undefinedError(oop name)                                   { genericError(  0,   0, "undefined name",
                                                                               sym_name, name, END); }

void syntaxError(char *msg)                                     { genericError(  0, msg, "syntax error", END); }

void unknownError(char *msg)                                    { genericError(  0, msg, "error", END); }

void keyboardInterrupt(void)                                    { genericError(  0,   0, "keyboard interrupt", END); }

#undef END

#else

void typeError(char *who, char *msg, oop value)                 { fatal("%s: %s: %s",        who, msg, getTypeName(value)); }
void typeError2(char *who, char *msg, oop lhs, oop rhs)         { fatal("%s: %s: %s and %s", who, msg, getTypeName(lhs), getTypeName(rhs)); }
void rangeError(char *who, char *msg, oop obj, int index)       { fatal("%s: %s: %s[%d]",    who, msg, codeString(obj, 0), index); }
void valueError(char *who, char *msg, oop value)                { fatal("%s: %s: %s",        who, msg, codeString(value, 0)); }
void keyError(char *who, char *msg, oop object, oop key)        { fatal("%s: %s: %s.%s",     who, msg, codeString(object, 0), printString(key, 0)); }
void undefinedError(oop name)                                   { fatal("undefined: %s",     printString(name, 0)); }
void syntaxError(char *msg)                                     { fatal("syntax error: %s",  msg); }
void unknownError(char *msg)                                    { fatal("%s",                msg); }
void keyboardInterrupt(void)                                    { fatal("keyboard interrupt"); }

#endif


int isSpecial(oop key)
{
    return is(Symbol, key) && !strncmp("__", _get(key, Symbol,name), 2);
}

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

intptr_t cmp(oop l, oop r, char *who)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr) return _integerValue(l)   - _integerValue(r);
    if (Float   == tl || Float   == tr) {
        double ll = floatValue(l, who), rr = floatValue(r, who);
        return ll < rr ? -1 : (ll > rr ? 1 : 0);
    }
    if (String  == tl && String  == tr) {
        int ll = _get(l, String,length), rr = _get(r, String,length);
        if (ll == rr) return strncmp(_get(l, String,value), _get(r, String,value), ll);
        return ll - rr;
    }
    if (Symbol  == tl && Symbol  == tr) return strcmp(stringValue(l, who), stringValue(r, who));
    return (intptr_t)l - (intptr_t)r;
}

#if defined (__linux__)
int objcmp(const void *a, const void *b, void *who) { return cmp(*(oop *)a, *(oop *)b, who); }
#else
int objcmp(void *who, const void *a, const void *b) { return cmp(*(oop *)a, *(oop *)b, who); }
#endif

oop sortObject(oop obj, char *who)
{                                                       assert(is(Object, obj));
# if defined(__linux__)
    qsort_r(_get(obj, Object,indexed), _get(obj, Object,isize), sizeof(oop), objcmp, "sort");
# else
    qsort_r(_get(obj, Object,indexed), _get(obj, Object,isize), sizeof(oop), "sort", objcmp);
# endif
    return obj;
}

int chrcmp(const void *a, const void *b) { return *(char *)a - *(char *)b; }

oop sortString(oop obj)
{                                                                       assert(is(String, obj));
    qsort(_get(obj, String,value), _get(obj, String,length), 1, chrcmp);
    return obj;
}

oop clone(oop obj) // shallow copy
{
    switch (getType(obj)) {
        case String: return newStringLen(_get(obj, String,value), _get(obj, String,length));
        case Primitive: {
            oop clone = make(Primitive);
            _set(clone, Primitive,name,     _get(obj, Primitive,name    ));
            _set(clone, Primitive,function, _get(obj, Primitive,function));
            _set(clone, Primitive,cookie,   _get(obj, Primitive,cookie  ));
            _set(clone, Primitive,index,    _get(obj, Primitive,index   ));
            return clone;
        }
        case Object: {
            oop  clone = new(_getDelegate(obj));
            oop *elts  = _get(obj, Object,indexed);
            int  size  = _get(obj, Object,isize);
            for (int i = 0;  i < size;  ++i) Object_push(clone, elts[i]);
            struct property *kvs = _get(obj, Object,properties);
            size = _get(obj, Object,psize);
            for (int i = 0;  i < size;  ++i) {
                oop key = kvs[i].key;
                if (prop_delegate == key) continue;
                Object_put(clone, key, kvs[i].val);
            }
            return clone;
        }
        default: break;
    }
    return obj;
}


oop sorted(oop obj, char *who)
{
    switch (getType(obj)) {
        case String: return sortString(clone(obj));
        case Object: return sortObject(clone(obj), who);
        default:     break;
    }
    typeError("sort", "unsortable type", obj);
    return 0;
}

oop reverseString(oop obj, char *who)
{                                                       assert(is(String, obj));
    char *elts = _get(obj, String,value);
    int  size = _get(obj, String,length), middle = size / 2;
    int  left = 0, right = size;
    while (left <= middle) {
        int tmp = elts[left];
        elts[left++] = elts[--right];
        elts[right] = tmp;
    }
    return obj;
}

oop reverseObject(oop obj, char *who)
{                                                       assert(is(Object, obj));
    oop *elts = _get(obj, Object,indexed);
    int  size = _get(obj, Object,isize), middle = size / 2;
    int  left = 0, right = size;
    while (left <= middle) {
        oop tmp = elts[left];
        elts[left++] = elts[--right];
        elts[right] = tmp;
    }
    return obj;
}

oop reversed(oop obj, char *who)
{
    switch (getType(obj)) {
        case String: return reverseString(clone(obj), who);
        case Object: return reverseObject(clone(obj), who);
        default:     break;
    }
    typeError("reverse", "unreversible type", obj);
    return 0;
}

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

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

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

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

void indentOn(oop buf, int indent)
{
    if (indent < 1) return;
    String_append(buf, '\n');
    for (int i = indent;  i--;) String_appendAll(buf, "  | ");
    String_appendAll(buf, "  ");
}

void printObjectNameOn(oop buf, oop obj, int indent)
{
    int level = 0;
    oop proto = obj;
    oop name  = nil;
    do {
        ++level;
        name = Object_getLocal(proto, prop_name);
        if (nil != name) break;
        proto = _getDelegate(proto);
    } while (is(Object, proto));
    for (int i = level;  i--;) String_append(buf, '<');
    if (name != nil) printOn(buf, name, 0);
    else String_appendAll(buf, "?");
    for (int i = level;  i--;) String_append(buf, '>');
}

enum {
    NO_DELEGATE = -1,
    NO_SPECIALS = -2,
};

int printObjectPropertiesOn(oop buf, oop obj, int indent)
{
    oop names = sortObject(keys(obj, indent > 0), "print");
    int nkeys = _get(names, Object,isize);
    oop *elts = _get(names, Object,indexed);
    int  i    = 0;
    for (i = 0; i < nkeys;  ++i) {
        if (i && indent < 1) String_appendAll(buf, ", ");
        oop key = elts[i];
        if (prop_delegate == key) continue;
        indentOn(buf, indent);
        printOn(buf, key, 0);
        String_appendAll(buf, ": ");
        printOn(buf, Object_getLocal(obj, key), indent + (indent >= 0));
    }
    return i;
}

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

            indentOn(buf, indent);
            String_appendAll(buf, "  body: ");
            printOn(buf, _get(obj, Lambda,body), indent + 1);

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

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

            String_append(buf, '\n');
            for (int j = indent;  j--;) String_appendAll(buf, "  | ");
            String_appendAll(buf, "  function: ");
            printOn(buf, _get(obj, Closure,function), indent + 1);
            break;
        }
#endif
        case Object: {
            printObjectNameOn(buf, obj, indent);
            if (!indent) break;
            for (;;) {
                printObjectPropertiesOn(buf, obj, indent);
                int isize = _get(obj, Object,isize);
                oop *indexed = _get(obj, Object,indexed);
                for (int i = 0; i < isize;  ++i) {
                    String_append(buf, '\n');
                    for (int j = indent;  j--;) String_appendAll(buf, "  | ");
                    String_format(buf, "  %d: ", i);
                    printOn(buf, indexed[i], indent+1);
                }
                oop delegate = _getDelegate(obj);
                if (nil == delegate) break;
                if (nil != Object_getLocal(delegate, prop_name)) break;
                obj = delegate;
                // ++indent;
                String_appendAll(buf, " =>");
            }
            break;
        }
        default:
            assert(!"this cannot happen");
    }
    return buf;
}

oop storeOn(oop buf, oop obj, int indent)
{
    switch (getType(obj)) {
        case String: {
            String_append(buf, '"');
            char *str = _get(obj, String,value);
            int   len = _get(obj, String,length);
            for (int i = 0;  i < len;  ++i) {
                int c = (unsigned char)str[i];
                switch (c) {
                    case '\a': String_appendAll(buf,  "\\a");   break;
                    case '\b': String_appendAll(buf,  "\\b");   break;
                    case '\f': String_appendAll(buf,  "\\f");   break;
                    case '\n': String_appendAll(buf,  "\\n");   break;
                    case '\r': String_appendAll(buf,  "\\r");   break;
                    case '\t': String_appendAll(buf,  "\\t");   break;
                    case '\v': String_appendAll(buf,  "\\v");   break;
                    case  '"': String_appendAll(buf, "\\\"");   break;
                    case '\\': String_appendAll(buf, "\\\\");   break;
                    default:
                        if (c < ' ' || c > '~') String_format(buf, "\\%03o", c);
                        else                    String_append(buf, c);
                        break;
                }
            }
            String_append(buf, '"');
            break;
        }
        case Object: {
            String_appendAll(buf, "[");
            oop *elts = _get(obj, Object,indexed);
            int  size = _get(obj, Object,isize);
            int  i = 0;
            while (i < size) {
                if (i) String_appendAll(buf, ", ");
                codeOn(buf, elts[i], indent);
                ++i;
            }
            oop names = sortObject(keys(obj, indent > 0), "print");
            size = _get(names, Object,isize);
            elts = _get(names, Object,indexed);
            for (int j = 0;  j < size;  ++j) {
                oop key = elts[j];
                oop val = Object_getLocal(obj, key);
                if (key == prop_delegate && val == pObject) continue;
                if (i++) String_appendAll(buf, ", ");
                codeOn(buf, key, indent);
                String_appendAll(buf, ": ");
                codeOn(buf, val, indent);
            }
            String_append(buf, ']');
            break;
        }
        default:        printOn(buf, obj, indent);
    }
    return buf;
}

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

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

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

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

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

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

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

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

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

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

oop trace = nil;

void vwarning(char *fmt, va_list ap)
{
    fflush(stdout);
    fprintf(stderr, "\n%s:%d: ", filename, lineno);
    vfprintf(stderr, fmt, ap);
    fprintf(stderr, "\n");
}

void warning(char *fmt, ...)
{
    va_list ap;
    va_start(ap, fmt);
    vwarning(fmt, ap);
    va_end(ap);
}

void fatal(char *fmt, ...)
{
    va_list ap;
    va_start(ap, fmt);
    vwarning(fmt, ap);
    va_end(ap);
    if (is(Object, trace)) {
        int w = 1 + log10(_get(trace, Object,isize));
        for (int i = _get(trace, Object,isize);  i--;) {
            printf("%*d: ", w, i);
            codeln(_get(trace, Object,indexed)[i], 1);
        }
    }
    exit(1);
}


#if EXCEPTIONS

void genericError(char *who, char *message, char *kind, ...)
{                                               assert(kind);
    oop err = new(pObject);
    if (who)     Object_put(err, prop_function, newString(who));
    if (message) Object_put(err, prop_message,  newString(message));
    Object_put(err, prop_kind, newString(kind));
    va_list ap;
    va_start(ap, kind);
    oop sym = 0;
    while ((sym = va_arg(ap, oop))) {           assert(is(Symbol, sym));
        oop arg = va_arg(ap, oop);              assert(arg);
        Object_put(err, sym, arg);
    }
    va_end(ap);
    if (is(Object, trace)) {
        int  size = _get(trace, Object,isize);
        oop *elts = _get(trace, Object,indexed);
        for (int i = 0;  i < size;  ++i) Object_push(err, elts[i]);
    }
    nlrReturn(err, NLR_RAISE);
}

#endif


#include <signal.h>

void sigint(int sig)
{
    keyboardInterrupt();
}

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

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

Input *input = 0;

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

#define YYSTYPE oop

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

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

YYSTYPE yysval = 0;

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

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

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

extern inline oop mkptr(void *address)
{
    // top 7 bits of virtual addresses are guaranteed to be the same,
    // at least until Apple decides to break that and call it a "feature"
    intptr_t p = (intptr_t)address;
    oop      o = newInteger(p);                 assert(p == _integerValue(o));
    return o;
}

oop newRefLocal(oop name)
{
    oop o = new(pRefLocal);
    Object_put(o, sym_name, name);
    return o;
}

oop RefLocal_eval(oop exp, oop env)
{
    if (!is(Object, env)) valueError("local", "not in a local scope", exp);
    oop  sym = Object_get(exp, sym_name);
    oop *ref = Object_refLocal(env, sym);
    if (!ref) undefinedError(sym);
    return mkptr(ref);
}

void RefLocal_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "local ");
    printOn(str, Object_get(exp, sym_name), 0);
}

oop newGetLocal(oop name)
{
    oop o = new(pGetLocal);
    Object_put(o, sym_name, name);
    return o;
}

oop  GetLocal_eval(oop exp, oop env)
{
    if (!is(Object, env)) valueError("local", "not in a local scope", exp);
    oop  sym = Object_get(exp, sym_name);
    oop *ref = Object_refLocal(env, sym);
    if (!ref) undefinedError(sym);
    return *ref;
}

void GetLocal_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "local ");
    printOn(str, Object_get(exp, sym_name), 0);
}

oop newSetLocal(oop name, oop value)
{
    oop o = new(pSetLocal);
    Object_put(o, sym_name,  name);
    Object_put(o, sym_value, value);
    return o;
}

oop SetLocal_eval(oop exp, oop env)
{
    if (!is(Object, env)) valueError("local", "not in a local scope", exp);
    oop sym =      Object_get(exp, sym_name );
    oop val = eval(Object_get(exp, sym_value), env);
    return Object_put(env, sym, val);
}

void SetLocal_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "local ");
    printOn(str, Object_get(exp, sym_name), 0);
    String_appendAll(str, " = ");
    codeOn(str, Object_get(exp, sym_value), 0);
}

oop newRefGlobal(oop name)
{
    oop o = new(pRefGlobal);
    Object_put(o, sym_name, name);
    return o;
}

oop RefGlobal_eval(oop exp, oop env)
{
    oop sym = Object_get(exp, sym_name);
    return mkptr(&_get(sym, Symbol,value));
}

void RefGlobal_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "global ");
    printOn(str, Object_get(exp, sym_name), 0);
}

oop newGetGlobal(oop name)
{
    oop o = new(pGetGlobal);
    Object_put(o, sym_name, name);
    return o;
}

oop  GetGlobal_eval(oop exp, oop env)
{
    oop sym = Object_get(exp, sym_name);
    oop val = _get(sym, Symbol,value);
    if (UNDEFINED == val) undefinedError(sym);
    return val;
}

void GetGlobal_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "global ");
    printOn(str, Object_get(exp, sym_name), 0);
}

oop newSetGlobal(oop name, oop value)
{
    oop o = new(pSetGlobal);
    Object_put(o, sym_name,  name);
    Object_put(o, sym_value, value);
    return o;
}

oop SetGlobal_eval(oop exp, oop env)
{
    oop sym =      Object_get(exp, sym_name )      ;
    oop val = eval(Object_get(exp, sym_value), env);
    return _set(sym, Symbol,value, val);
}

void SetGlobal_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "global ");
    printOn(str, Object_get(exp, sym_name), 0);
    String_appendAll(str, " = ");
    codeOn(str, Object_get(exp, sym_value), 0);
}

oop newRefVar(oop name)
{
    oop o = new(pRefVar);
    Object_put(o, sym_name, name);
    return o;
}

oop RefVar_eval(oop exp, oop env)
{
    return mkptr(refvar(env, Object_get(exp, sym_name)));
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

void oob(oop obj, int index)
{
    rangeError("[]", "index out of bounds", obj, index);
}

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

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

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

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

oop RefArray_eval(oop exp, oop env)
{
    oop obj = eval(Object_get(exp, sym_object), env);
    oop ind = eval(Object_get(exp, sym_index ), env);
    if (isInteger(ind)) {
        int index = _integerValue(ind);
        switch (getType(obj)) {
            case String: goto error;
            case Symbol: goto error;
            case Object: return mkptr(Object_aref(obj, index));
            default:     goto error;
        }
    }
    if (is(Object, obj)) {
        oop *ref = Object_refLocal(obj, ind);
        if (ref) return mkptr(ref);
    }
  error:
    typeError("[]", "not an object", obj);
    return 0;
}

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

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

oop GetArray_eval(oop exp, oop env)
{
    oop obj = eval(Object_get(exp, sym_object), env);
    oop ind = eval(Object_get(exp, sym_index ), env);
    if (isInteger(ind)) {
        int index = _integerValue(ind);
        switch (getType(obj)) {
            case String: return newInteger(*(unsigned char *)String_aref(obj, index));
            case Symbol: return newInteger(*(unsigned char *)Symbol_aref(obj, index));
            case Object: return *Object_aref(obj, index);
            default:     typeError("[]", "non-indexable object", obj);
        }
    }
    if (!is(Object, obj)) typeError("[]", "non-associative object", obj);
    return Object_getLocal(obj, ind);
}

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

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

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

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

oop newGetSlice(oop object, oop start, oop stop)
{
    oop o = new(pGetSlice);
    Object_put(o, sym_object, object);
    Object_put(o, sym_start,  start );
    Object_put(o, sym_stop,   stop  );
    return o;
}

oop GetSlice_eval(oop exp, oop env)
{
    oop obj    = eval(Object_get(exp, sym_object), env);
    oop start  = eval(Object_get(exp, sym_start ), env);
    oop stop   = eval(Object_get(exp, sym_stop  ), env);
    switch (getType(obj)) {
        case String: return String_slice(obj, start, stop);
        case Symbol: return Symbol_slice(obj, start, stop);
        case Object: return Object_slice(obj, start, stop);
        default:     typeError("[:]", "non-indexable object", obj);
    }
    return nil;
}

void GetSlice_codeOn(oop exp, oop str, oop env)
{
    codeOn(str, Object_get(exp, sym_object), 0);
    String_appendAll(str, "[");
    codeOn(str, Object_get(exp, sym_start ), 0);
    String_appendAll(str, ":");
    codeOn(str, Object_get(exp, sym_stop  ), 0);
    String_appendAll(str, "]");
}

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

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

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

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

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

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

oop newSuper(oop method, oop arguments)
{
    oop o = new(pSuper);
    Object_put(o, sym_method   , method   );
    Object_put(o, sym_arguments, arguments);
    return o;
}

oop Super_eval(oop exp, oop env)
{
    oop meth  = Object_get(exp, sym_method);
    oop args  = Object_get(exp, sym_arguments);
    oop self  = Object_get(env, sym_self);
    oop owner = Object_get(env, prop_owner);
    oop iargs = evargs(args, env);
    oop ifunc = Object_getOwner(_getDelegate(owner), meth, &owner); // fails if property not defined
    return apply(ifunc, self, iargs, env, owner);
}

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

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

oop Invoke_eval(oop exp, oop env)
{
    oop self  = eval  (Object_get(exp, sym_self     ), env);
    oop meth  = Object_get(exp, sym_method);
    oop iargs = evargs(Object_get(exp, sym_arguments), env);
    oop owner = nil;
    oop ifunc = Object_getOwner(self, meth, &owner); // fails if property not defined
    return apply(ifunc, self, iargs, env, owner);
}

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

oop newContinue(void)
{
    return new(pContinue);
}

oop Continue_eval(oop exp, oop env)
{
# if NONLOCAL
    nlrReturn(nil, NLR_CONTINUE);
    assert(!"this cannot happen");
# endif
    return nil;
}

void Continue_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "continue");
}

oop newBreak(oop value)
{
    oop o = new(pBreak);
    Object_put(o, sym_value, value);
    return o;
}

oop Break_eval(oop exp, oop env)
{
    oop value = eval(Object_get(exp, sym_value), env);
# if NONLOCAL
    nlrReturn(value, NLR_BREAK);
    assert(!"this cannot happen");
# endif
    return value;
}

void Break_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "break");
    oop value = Object_get(exp, sym_value);
    if (nil != value) {
        String_appendAll(str, " ");
        codeOn(str, value, 0);
    }
}

oop newReturn(oop value)
{
    oop o = new(pReturn);
    Object_put(o, sym_value, value);
    return o;
}

oop Return_eval(oop exp, oop env)
{
    oop value = eval(Object_get(exp, sym_value), env);
# if NONLOCAL
    nlrReturn(value, NLR_RETURN);
    assert(!"this cannot happen");
# endif
    return value;
}

void Return_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "return ");
    codeOn(str, Object_get(exp, sym_value), 0);
}

oop newTryCatch(oop statement, oop identifier, oop handler)
{
    oop o = new(pTryCatch);
    Object_put(o, sym_statement,  statement);
    Object_put(o, sym_identifier, identifier);
    Object_put(o, sym_handler,    handler);
    return o;
}

oop TryCatch_eval(oop exp, oop env)
{
    oop statement = Object_get(exp, sym_statement);
# if NONLOCAL
    switch (nlrPush()) {
        case NLR_CONTINUE:      nlrReturn(nlrPop(), NLR_CONTINUE);
        case NLR_BREAK:         nlrReturn(nlrPop(), NLR_BREAK);
        case NLR_RETURN:        nlrReturn(nlrPop(), NLR_RETURN);
        case NLR_RAISE: {
            oop exception = nlrPop();
            oop env2 = new(pObject);
            _setDelegate(env2, env);
            Object_put(env2, Object_get(exp, sym_identifier), exception);
            return eval(Object_get(exp, sym_handler), env2);
        }
    }
# endif
    oop result = eval(Object_get(exp, sym_statement), env);
# if NONLOCAL
    nlrPop();
# endif
    return result;
}

void TryCatch_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "try ");
    codeOn(str, Object_get(exp, sym_statement), 0);
    String_appendAll(str, " catch (");
    printOn(str, Object_get(exp, sym_identifier), 0);
    String_appendAll(str, ") ");
    codeOn(str, Object_get(exp, sym_handler), 0);
}

oop newTryEnsure(oop statement, oop handler)
{
    oop o = new(pTryEnsure);
    Object_put(o, sym_statement,  statement);
    Object_put(o, sym_handler,    handler);
    return o;
}

oop TryEnsure_eval(oop exp, oop env)
{
    oop statement = Object_get(exp, sym_statement);
    oop handler   = Object_get(exp, sym_handler);
    oop result    = nil;
    int nlreason  = 0;
# if NONLOCAL
    if (NLR_INIT != (nlreason = nlrPush())) {
        result = nlrPop();
        eval(handler, env);
        nlrReturn(result, nlreason);
    }
# endif
    result = eval(Object_get(exp, sym_statement), env);
# if NONLOCAL
    nlrPop();
# endif
    eval(handler, env);
    return result;
}

void TryEnsure_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "try ");
    codeOn(str, Object_get(exp, sym_statement), 0);
    String_appendAll(str, " catch (");
    printOn(str, Object_get(exp, sym_identifier), 0);
    String_appendAll(str, ") ");
    codeOn(str, Object_get(exp, sym_handler), 0);
}

oop newRaise(oop value)
{
    oop o = new(pRaise);
    Object_put(o, sym_value, value);
    return o;
}

oop Raise_eval(oop exp, oop env)
{
    oop value = eval(Object_get(exp, sym_value), env);
# if NONLOCAL
    nlrReturn(value, NLR_RAISE);
    assert(!"this cannot happen");
# endif
    return value;
}

void Raise_codeOn(oop exp, oop str, oop env)
{
    String_appendAll(str, "raise ");
    codeOn(str, Object_get(exp, sym_value), 0);
}

#if !PRIMCLOSURE

oop newLambda(oop parameters, oop body, oop parent, oop name)
{
    oop o = new(pLambda);
    Object_put(o, sym_parameters, parameters    );
    Object_put(o, sym_body      , body          );
# if PROFILE
    Object_put(o, sym_profile   , nil           );
# endif
    Object_put(o, sym_parent    , parent        );
    Object_put(o, sym_name      , name          );
    return o;
}

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

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

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

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

void Closure_codeOn(oop exp, oop str, oop env)
{
    printOn(str, Object_getLocal(exp, sym_function), 0);
}

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

#endif // !PRIMCLOSURE

#define doBinops(_)                                             \
    _(LogOr,    ||)                                             \
    _(LogAnd,   &&)                                             \
    _(BitOr,     |)                                             \
    _(BitXor,    ^)                                             \
    _(BitAnd,    &)                                             \
    _(Eq,       ==) _(NotEq,    !=)                             \
    _(Less,     < ) _(LessEq,   <=) _(Grtr,   >=) _(GrtrEq, > ) \
    _(Shl,      <<) _(Shr,      >>)                             \
    _(Add,       +) _(Sub,       -)                             \
    _(Mul,       *) _(Div,       /) _(Mod,     %)               \
    _(PostAdd,  ++) _(PostDec,  --)                             \
    _(PreSet,    =)                                             \
    _(PreOr,    |=) _(PreXor,   ^=) _(PreAnd, &=)               \
    _(PreShl,  >>=) _(PreShr,  <<=)                             \
    _(PreAdd,   +=) _(PreSub,   -=)                             \
    _(PreMul,   *=) _(PreDiv,   /=) _(PreMod, %=)

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

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

#if BINOPT

typedef oop (*binop_t)(oop lhs, oop rhs);

#define declBinop(NAME, OP) oop bin##NAME(oop, oop);
doBinops(declBinop)
#undef declBinop

#define implBinop(NAME, OP) bin##NAME,
binop_t binops[] = {
    doBinops(implBinop)
};
#undef implBinop

#endif // BINOPT

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

#define binop(NAME, OP)                                                         \
    oop NAME(oop lhs, oop rhs)                                                  \
    {                                                                           \
        return newInteger(integerValue(lhs, #OP) OP integerValue(rhs, #OP));    \
    }

binop(binBitOr,  |);
binop(binBitXor, ^);
binop(binBitAnd, &);

#undef binop

#define binop(NAME, OP)                                 \
    oop NAME(oop lhs, oop rhs)                          \
    {                                                   \
        return newBoolean(cmp(lhs, rhs, #OP) OP 0);     \
    }

binop(binEq,     ==);
binop(binNotEq,  !=);
binop(binLess,   < );
binop(binLessEq, <=);
binop(binGrtrEq, >=);
binop(binGrtr,   > );

#undef binop

oop binLogOr (oop lhs, oop rhs) { abort();  return 0; }
oop binLogAnd(oop lhs, oop rhs) { abort();  return 0; }

oop binPostAdd(oop lhs, oop rhs)
{                                                       assert(isInteger(lhs)); // lval ref
    oop *ref   = (oop *)(intptr_t)_integerValue(lhs);   assert(isInteger(rhs)); // X++ -> X+=1
    oop value  = *ref;
    int amount = _integerValue(rhs);
    switch (getType(value)) {
        case Integer:   *ref = newInteger(_integerValue(value) + amount);       break;
        case Float:     *ref = newFloat  (_floatValue  (value) + amount);       break;
        default:        typeError("++", "non-numeric value", value);
    }
    return value;
}

oop binPostDec(oop lhs, oop rhs)
{                                                       assert(isInteger(lhs)); // lval ref
    oop *ref   = (oop *)(intptr_t)_integerValue(lhs);   assert(isInteger(rhs)); // X-- -> X-=1
    oop value  = *ref;
    int amount = _integerValue(rhs);
    switch (getType(value)) {
        case Integer:   *ref = newInteger(_integerValue(value) - amount);       break;
        case Float:     *ref = newFloat  (_floatValue  (value) - amount);       break;
        default:        typeError("++", "non-numeric value", value);
    }
    return value;
}

oop binPreSet(oop lhs, oop rhs)
{                                                       assert(isInteger(lhs));
    oop *ref = (oop *)(intptr_t)_integerValue(lhs);     assert(isInteger(rhs));
    return *ref = rhs;
}

#define binop(NAME, OP)                                                                 \
    oop NAME(oop lhs, oop rhs)                                                          \
    {                                                       assert(isInteger(lhs));     \
        oop *ref = (oop *)(intptr_t)_integerValue(lhs);     assert(isInteger(rhs));     \
        oop val  = *ref;                                                                \
        if (isInteger(val) && isInteger(rhs)) {                                         \
            long l = _integerValue(val), r = _integerValue(rhs);                        \
            l OP r;                                                                     \
            return *ref = newInteger(l);                                                \
        }                                                                               \
        double l = floatValue(val, #OP);                                                \
        double r = floatValue(rhs, #OP);                                                \
        l OP r;                                                                         \
        return *ref = newFloat(l);                                                      \
    }

binop(binPreAdd, +=);
binop(binPreSub, -=);
binop(binPreMul, *=);

#undef binop

oop binPreDiv(oop lhs, oop rhs)
{                                                       assert(isInteger(lhs));
    oop *ref = (oop *)(intptr_t)_integerValue(lhs);     assert(isInteger(rhs));
    oop val  = *ref;
    if (isInteger(val) && isInteger(rhs)) {
        long l = _integerValue(val), r = _integerValue(rhs);
        if (!r) valueError("/=", "division by zero", rhs);
        l /= r;
        return *ref = newInteger(l);
    }
    double l = floatValue(val, "/=");
    double r = floatValue(rhs, "/=");
    if (!r) valueError("/=", "division by zero", rhs);
    l /= r;
    return *ref = newFloat(l);
}

oop binPreMod(oop lhs, oop rhs)
{                                                       assert(isInteger(lhs));
    oop *ref = (oop *)(intptr_t)_integerValue(lhs);     assert(isInteger(rhs));
    oop val  = *ref;
    if (isInteger(val) && isInteger(rhs)) {
        long l = _integerValue(val), r = _integerValue(rhs);
        if (!r) valueError("%%=", "division by zero", rhs);
        l /= r;
        return *ref = newInteger(l);
    }
    double l = floatValue(val, "%=");
    double r = floatValue(rhs, "%=");
    if (!r) valueError("%%=", "division by zero", rhs);
    return *ref = newFloat(fmod(l, r));
}

#define binop(NAME, OP)                                                                 \
    oop NAME(oop lhs, oop rhs)                                                          \
    {                                                       assert(isInteger(lhs));     \
        oop *ref = (oop *)(intptr_t)_integerValue(lhs);     assert(isInteger(rhs));     \
        oop val  = *ref;                                                                \
        long l = integerValue(val, #OP);                                                \
        long r = integerValue(rhs, #OP);                                                \
        l OP r;                                                                         \
        return *ref = newInteger(l);                                                    \
    }

binop(binPreOr,   |=);
binop(binPreXor,  ^=);
binop(binPreAnd,  &=);
binop(binPreShl, <<=);
binop(binPreShr, >>=);

#undef binop

oop binShl(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr)
        return newInteger(_integerValue(l) << _integerValue(r));
    typeError2("<<", "non-integer operand", l, r);
    return 0;
}

oop binShr(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr)
        return newInteger(_integerValue(l) >> _integerValue(r));
    typeError2(">>", "non-integer operand", l, r);
    return 0;
}

oop binAdd(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr) return newInteger(_integerValue(l     ) + _integerValue(r     ));
    if (Float   == tl || Float   == tr) return newFloat  ( floatValue  (l, "+") +  floatValue  (r, "+"));
    if (String  == tl && String  == tr) return String_concat(l, r);
    typeError2("+", "illegal operand types", l, r);
    return 0;
}

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

binop(binSub, -);

#undef binop

oop binMul(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr) return newInteger(_integerValue(l     ) * _integerValue(r     ));
    if (Float   == tl || Float   == tr) return newFloat  ( floatValue  (l, "*") *  floatValue  (r, "*"));
    if (String  == tl && Integer == tr) return String_repeat(l, _integerValue(r));
    if (Integer == tl && String  == tr) return String_repeat(r, _integerValue(l));
    typeError2("*", "illegal operand types", l, r);
    return 0;
}

oop binDiv(oop l, oop r)
{
    int tl = getType(l), tr = getType(r);
    if (Integer == tl && Integer == tr) {
        long   vl = _integerValue(l), vr = _integerValue(r);
        ldiv_t qr = ldiv(vl, vr);
        if (!qr.rem) return newInteger(qr.quot);   // division was exact
        return newFloat((double)vl / (double)vr);
    }
    if (Float == tl || Float == tr) return newFloat  (floatValue(l, "/") / floatValue(r, "/"));
    typeError2("/", "illegal operand type", l, r);
    return 0;
}

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

int isNumber(oop obj)   { return isInteger(obj) || isFloat(obj); }
int isAtom(oop obj)     { return nil == obj || isNumber(obj) || isString(obj) || is(Symbol, obj); }

oop newBinop(enum binop operation, oop lhs, oop rhs)
{
# if FOLDCONST
    if (isAtom(lhs) && isAtom(rhs)) {
        switch (operation) {
            case opLogOr:       return newBoolean((lhs != nil) || (rhs != nil));
            case opLogAnd:      return newBoolean((lhs != nil) && (rhs != nil));
            case opEq:          return binEq   (lhs, rhs);
            case opNotEq:       return binNotEq(lhs, rhs);
            default:            break;
        }
    }
    if (isInteger(lhs) && isInteger(rhs)) {
        switch (operation) {
            case opBitOr:       return binBitOr (lhs, rhs);
            case opBitXor:      return binBitXor(lhs, rhs);
            case opBitAnd:      return binBitAnd(lhs, rhs);
            case opShl:         return binShl   (lhs, rhs);
            case opShr:         return binShr   (lhs, rhs);
            default:            break;
        }
    }
    if (isNumber(lhs) && isNumber(rhs)) {
        switch (operation) {
            case opLess:        return binLess  (lhs, rhs);
            case opLessEq:      return binLessEq(lhs, rhs);
            case opGrtr:        return binGrtr  (lhs, rhs);
            case opGrtrEq:      return binGrtrEq(lhs, rhs);
            case opAdd:         return binAdd   (lhs, rhs);
            case opSub:         return binSub   (lhs, rhs);
            case opMul:         return binMul   (lhs, rhs);
            case opDiv:         return binDiv   (lhs, rhs);
            case opMod:         return binMod   (lhs, rhs);
            default:            break;
        }
    }
# endif
    oop o = new(pBinop);
    Object_put(o, sym_operation, newInteger(operation));
# if BINOPT
    Object_put(o, prop_function, mkptr(binops[operation]));
# endif
    Object_push(o, lhs);
    Object_push(o, rhs);
    return o;
}

oop Binop_eval(oop exp, oop env)
{                                                       assert(_get(exp, Object,isize) == 2);
    oop op   = Object_get(exp, sym_operation);
    oop lhs  = _get(exp, Object,indexed)[0];
    oop rhs  = _get(exp, Object,indexed)[1];
    enum binop code = integerValue(op, "Binop.operation");
    lhs = eval(lhs, env);
    switch (code) {
        case opLogOr:   return nil != lhs ? lhs : eval(rhs, env);
        case opLogAnd:  return nil == lhs ? lhs : eval(rhs, env);
        default:        break;
    }
    rhs = eval(rhs, env);
# if BINOPT
    return (binop_t)_integerValue(Object_get(exp, prop_function))(lhs, rhs);
# else
    switch (code) {
        case opLogOr:   break;
        case opLogAnd:  break;
        case opBitOr:   return newInteger(integerValue(lhs, "|") | integerValue(rhs, "|"));
        case opBitXor:  return newInteger(integerValue(lhs, "^") ^ integerValue(rhs, "^"));
        case opBitAnd:  return newInteger(integerValue(lhs, "&") & integerValue(rhs, "&"));
        case opEq:      return newBoolean(cmp(lhs, rhs, "==") == 0);
        case opNotEq:   return newBoolean(cmp(lhs, rhs, "!=") != 0);
        case opLess:    return newBoolean(cmp(lhs, rhs, "<" ) <  0);
        case opLessEq:  return newBoolean(cmp(lhs, rhs, "<=") <= 0);
        case opGrtrEq:  return newBoolean(cmp(lhs, rhs, ">=") >= 0);
        case opGrtr:    return newBoolean(cmp(lhs, rhs, ">" ) >  0);
        case opShl:     return binShl(lhs, rhs);
        case opShr:     return binShr(lhs, rhs);
        case opAdd:     return binAdd(lhs, rhs);
        case opSub:     return binSub(lhs, rhs);
        case opMul:     return binMul(lhs, rhs);
        case opDiv:     return binDiv(lhs, rhs);
        case opMod:     return binMod(lhs, rhs);
        case opPostAdd:
        case opPostDec: {                                       assert(isInteger(lhs)); // ref
            oop *ref = (oop *)(intptr_t)_integerValue(lhs);
            oop value = *ref;                                   assert(isInteger(rhs)); // delta
            int amount = _integerValue(rhs);
            if (code == opPostDec) amount = -amount;
            switch (getType(value)) {
                case Integer:   *ref = newInteger(_integerValue(value) + amount);       break;
                case Float:     *ref = newFloat  (_floatValue  (value) + amount);       break;
                default:        typeError("++", "non-numeric value", value);
            }
            return value;
        }
        case opPreSet: {                                        assert(isInteger(lhs)); // ref
            oop *ref = (oop *)(intptr_t)_integerValue(lhs);
            return *ref = rhs;
        }
        case opPreOr ... opPreMod: {
            oop *ref = (oop *)(intptr_t)_integerValue(lhs);
            oop val = *ref;
            switch (code) {
                case opPreOr ... opPreShr: {
                    long l = integerValue(val, binopNames[code]);
                    long r = integerValue(rhs, binopNames[code]);
                    switch (code) {
                        case opPreOr:   l  |= r;  break;
                        case opPreXor:  l  ^= r;  break;
                        case opPreAnd:  l  &= r;  break;
                        case opPreShl:  l <<= r;  break;
                        case opPreShr:  l >>= r;  break;
                        default:        assert(!"this cannot happen");
                    }
                    return *ref = newInteger(l);
                }
                case opPreAdd ... opPreMod: {
                    if (isInteger(val) && isInteger(rhs)) {
                        long l = _integerValue(val), r = _integerValue(rhs);
                        switch (code) {
                            case opPreAdd: l += r;  break;
                            case opPreSub: l -= r;  break;
                            case opPreMul: l *= r;  break;
                            case opPreDiv:
                                if (!r) valueError("/=", "division by zero", rhs);
                                l /= r;
                                break;
                            case opPreMod:
                                if (!r) valueError("%=", "division by zero", rhs);
                                l %= r;
                                break;
                            default:    assert(!"this cannot happen");
                        }
                        return *ref = newInteger(l);
                    }
                    double l = floatValue(val, binopNames[code]);
                    double r = floatValue(rhs, binopNames[code]);
                    switch (code) {
                        case opPreAdd: l += r;  break;
                        case opPreSub: l -= r;  break;
                        case opPreMul: l *= r;  break;
                        case opPreDiv:
                            if (!r) valueError("/=", "division by zero", rhs);
                            l /= r;
                            break;
                        case opPreMod:
                            if (!r) valueError("%=", "division by zero", rhs);
                            l = fmod(l, r);
                            break;
                        default: assert(!"this cannot happen");
                    }
                    return *ref = newFloat(l);
                }
                default: assert(!"this cannot happen");
            }
        }
    }
    fatal("illegal binary operation %d", code);
    return 0;
# endif
}

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

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

#define defineUnyop(NAME, OP_) NAME,

enum unyop {
    doUnyops(defineUnyop)
};

#undef defineUnyop

#define nameUnyop(NAME, OP) #OP,

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

#undef nameUnyop

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

oop neg(oop n)
{
    int tn = getType(n);
    switch (tn) {
        case Integer:   return newInteger(-_integerValue(n));
        case Float:     return newFloat  (-_floatValue  (n));
        default:        break;
    }
    typeError("-", "non-numeric operand", n);
    return 0;
}

oop com(oop n)
{
    int tn = getType(n);
    switch (tn) {
        case Integer:   return newInteger(~_integerValue(n));
        default:        break;
    }
    typeError("~", "non-numeric operand", n);
    return 0;
}

oop newUnyop(int operation, oop value)
{
# if FOLDCONST
    if (operation == opNot && isAtom   (value)) return newBoolean(nil == value);
    if (operation == opNeg && isNumber (value)) return neg(value);
    if (operation == opCom && isInteger(value)) return com(value);
# endif
    oop o = new(pUnyop);
    Object_put(o, sym_operation, newInteger(operation));
    Object_push(o, value);
    return o;
}

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

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

oop newIf(oop condition, oop consequent, oop alternate)
{
# if FOLDCONST
    if (isAtom(condition)) return nil == condition ? alternate : consequent;
# endif
    oop o = new(pIf);
    Object_put(o, sym_condition,  condition );
    Object_put(o, sym_consequent, consequent);
    Object_put(o, sym_alternate,  alternate );
    return o;
}

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

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

#define _PASTE(A, B) A##B
#define  PASTE(A, B) _PASTE(A,B)

#if NONLOCAL

# define LOOP()                                                                 \
  PASTE(continue,__LINE__):                                                     \
    switch (nlrPush()) {                                                        \
        case NLR_CONTINUE:      nlrPop();  goto PASTE(continue, __LINE__);      \
        case NLR_BREAK:         return nlrPop();                                \
        case NLR_RETURN:        nlrReturn(nlrPop(), NLR_RETURN);                \
        case NLR_RAISE:         nlrReturn(nlrPop(), NLR_RAISE );                \
    }

# define DONE() nlrPop()
#else
# define LOOP()
# define DONE()
#endif

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

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

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

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

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

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

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

oop For_eval(oop exp, oop env)
{
    oop initialise = Object_get(exp, sym_initialise);
    oop condition  = Object_get(exp, sym_condition);
    oop update     = Object_get(exp, sym_update);
    oop body       = Object_get(exp, sym_body);
    oop env2 = new(pObject);
    _setDelegate(env2, env);
    oop result     = eval(initialise, env2);
    int n          = 0;
    LOOP();
    if (n) goto doContinue;
    n = 1;
    for (;;) {
        if (nil == eval(condition, env2)) break;
        result = eval(body, env2);
      doContinue:
        eval(update, env2);
    }
    DONE();
    return result;
}

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

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

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

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

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

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

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

#undef LOOP
#undef DONE

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

#if DELOPT

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

#else // !DELOPT

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

#endif // !DELOPT

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

oop lvalue(oop rval)
{
    if (!is(Object,rval)) valueError("=", "non-assignable value", rval);
    oop kind = _getDelegate(rval);
    if      (kind == pGetVar   ) kind = pRefVar;
    else if (kind == pGetProp  ) kind = pRefProp;
    else if (kind == pGetArray ) kind = pRefArray;
    else if (kind == pGetLocal ) kind = pRefLocal;
    else if (kind == pGetGlobal) kind = pRefGlobal;
    else valueError("=", "non-assignable value", rval);
    _setDelegate(rval, kind);
    return rval;
}

oop assign(oop rval, oop value)
{
    if (!is(Object,rval)) valueError("=", "non-assignable value", rval);
    oop kind = _getDelegate(rval);
    if      (kind == pGetVar  ) kind = pSetVar;
    else if (kind == pGetProp ) kind = pSetProp;
    else if (kind == pGetArray) kind = pSetArray;
    else valueError("=", "non-assignable value", rval);
    _setDelegate(rval, kind);
    Object_put(rval, sym_value, value);
    return rval;
}

void expected(char *what, char *where)
{
    fatal("syntax error: %s expected near: %s", what, where);
}

%}

start   = - ( s:stmt                            { yysval = s }
            | !.                                { yysval = 0 }
            | < (!EOL .)* >                     { syntaxError(yytext) }
            )

stmt    = WHILE LPAREN c:expr RPAREN s:stmt     { $$ = newWhile(c, s) }
        | IF LPAREN c:expr RPAREN s:stmt
          ( ELSE t:stmt                         { $$ = newIf(c, s, t  ) }
          |                                     { $$ = newIf(c, s, nil) }
          )
        | CONT EOS                              { $$ = newContinue() }
        | BREAK e:expr EOS                      { $$ = newBreak(e) }
        | BREAK EOS                             { $$ = newBreak(nil) }
        | RETURN e:expr EOS                     { $$ = newReturn(e) }
        | RETURN EOS                            { $$ = newReturn(nil) }
        | FOR LPAREN i:id IN e:expr RPAREN
              s:stmt                            { $$ = newForIn(i, e, s) }
        | FOR LPAREN i:id FROM a:expr
                 TO  b:expr RPAREN s:stmt       { $$ = newForFromTo(i, a, b, s) }
        | FOR LPAREN i:expr SEMI c:expr SEMI
                     u:expr RPAREN s:stmt       { $$ = newFor(i, c, u, s) }
        | TRY t:stmt
          ( CATCH LPAREN i:id RPAREN c:stmt     { $$ = newTryCatch(t, i, c) }
          | ENSURE e:stmt                       { $$ = newTryEnsure(t, e) }
          )
        | RAISE e:expr EOS                      { $$ = newRaise(e) }
        | LOCAL       i:id p:params b:block     { $$ = newSetLocal (i, newLambda(p, b, nil, i)) }
        | GLOBAL      i:id p:params b:block     { $$ = newSetGlobal(i, newLambda(p, b, nil, i)) }
        |             i:id p:params b:block     { $$ = newSetVar   (i, newLambda(p, b, nil, i)) }
        | v:proto DOT i:id p:params b:block     { $$ = newSetProp(v, i, newLambda(p, b, v, i)) }
        | b:block                               { $$ = newBlock(b) }
        | e:expr EOS                            { $$ = e }

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

EOS     = SEMI+ | &RBRACE | &ELSE | &CATCH

expr    = LOCAL  i:id ASSIGN e:expr                    { $$ = newSetLocal (i, e) }
        | GLOBAL i:id ASSIGN e:expr                    { $$ = newSetGlobal(i, e) }
        |        i:id ASSIGN e:expr                    { $$ = newSetVar   (i, e) }
        | l:logor ( ASSIGN   r:expr             { l  = assign(l, r) }
                  | PLUSEQ   r:expr             { l  = newBinop(opPreAdd, lvalue(l), r) }
                  | MINUSEQ  r:expr             { l  = newBinop(opPreSub, lvalue(l), r) }
                  | STAREQ   r:expr             { l  = newBinop(opPreMul, lvalue(l), r) }
                  | SLASHEQ  r:expr             { l  = newBinop(opPreDiv, lvalue(l), r) }
                  | PCENTEQ  r:expr             { l  = newBinop(opPreMod, lvalue(l), r) }
                  | SHLEQ    r:expr             { l  = newBinop(opPreShl, lvalue(l), r) }
                  | SHREQ    r:expr             { l  = newBinop(opPreShr, lvalue(l), r) }
                  | ANDEQ    r:expr             { l  = newBinop(opPreAnd, lvalue(l), r) }
                  | XOREQ    r:expr             { l  = newBinop(opPreXor, lvalue(l), r) }
                  | OREQ     r:expr             { l  = newBinop(opPreOr,  lvalue(l), r) }
                  )?                            { $$ = l }

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

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

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

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

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

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

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

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

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

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

prefix  = PPLUS  p:prefix                       { $$ = newBinop(opPreAdd, lvalue(p), newInteger(1)) }
        | MMINUS p:prefix                       { $$ = newBinop(opPreSub, lvalue(p), newInteger(1)) }
        | PLING  p:prefix                       { $$ = newUnyop(opNot, p) }
        | MINUS  p:prefix                       { $$ = newUnyop(opNeg, p) }
        | TILDE  p:prefix                       { $$ = newUnyop(opCom, p) }
        | BQUOTE s:stmt                         { $$ = newUnyop(opQuasiquote, s) }
        | COMMAT e:expr                         { $$ = newUnyop(opUnquote, e) }
        | postfix

postfix = SUPER DOT i:id a:args                 { $$ = newSuper(i, a) }
        | p:primary
          ( LBRAK
            (           COLON (         RBRAK   { p = newGetSlice(p, nil, nil) }
                              | e:xexpr RBRAK   { p = newGetSlice(p, nil, e) }
                              )
            | s:xexpr ( COLON (         RBRAK   { p = newGetSlice(p, s, nil) }
                              | e:xexpr RBRAK   { p = newGetSlice(p, s, e) }
                              )
                      |                 RBRAK   { p = newGetArray(p, s) }
                      )
            )
          | DOT   i:id ( a:args !LBRACE         { p = newInvoke(p, i, a) }
                       |                        { p = newGetProp(p, i) }
                       )
          |              a:args !LBRACE         { p = newApply(p, a) }
          )*
          ( PPLUS                               { p  = newBinop(opPostAdd, lvalue(p), newInteger( 1)) }
          | MMINUS                              { p  = newBinop(opPostAdd, lvalue(p), newInteger(-1)) }
          )?                                    { $$ = p }

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

params  = LPAREN p:mkobj
          ( RPAREN
          | i:id ( COLON e:expr                 { Object_put(p, i, e) }
                 |                              { Object_push(p, i) }
                 )
            ( COMMA i:id ( COLON e:expr         { Object_put(p, i, e) }
                         |                      { Object_push(p, i) }
                         )
            )* RPAREN )                         { $$ = p }

mkobj   =                                       { $$ = new(pObject) }

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

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

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

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

block   = LBRACE b:mkobj
            (  e:stmt                           { Object_push(b, e) }
            )* ( RBRACE                         { $$ = b }
               | error                         @{ expected("statement or \x7D", yytext) }
               )

nil     = NIL                                   { $$ = nil }

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

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

string  = '"' < ( !'"' char )* > '"' -          { $$ = newStringUnescaped(yytext) }

char    = "\\" ( ["'\\abfnrtv]
               | [xX] HIGIT*
               | [0-7][0-7]?[0-7]?
               )
        | .

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

var     = LOCAL  i:id                           { $$ = newGetLocal (i) }
        | GLOBAL i:id                           { $$ = newGetGlobal(i) }
        |        i:id                           { $$ = newGetVar   (i) }

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

# regex   = SLASH a:alts SLASH                    { $$ = a }

# alts    = s:seq ( OR t:seq                      { s = Alt_append(t) }
#                 )*                              { $$ = s }

# seq     = p:pre ( q:pre                         { s = Seq_append(t) }
#                 )*                              { $$ = s }

# elt     = action | pre

# action  = b:block                               { $$ = newAction(b) }

# pre     = PLING p:pre                           { $$ = newNot(p) }
#         | AND   p:pre                           { $$ = newAnd(p) }
#         | post

# post    = a:atom ( STAR                         { a = newMany(a) }
#                  | PLUS                         { a = newMore(a) }
#                  | QUERY                        { a = newMore(a) }
#                  )?                             { $$ = a }

# atom    = DOT                                   { $$ = newDot() }
#         | "[" ( !"]" "\\"? . )* "]" -           { $$ = newClass(yytext) }
#         | '"' xxxxxx

# class   = LBRAK 

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

-       = SPACE*

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

NIL     = "nil"      !ALNUM  -
WHILE   = "while"    !ALNUM  -
IF      = "if"       !ALNUM  -
ELSE    = "else"     !ALNUM  -
FOR     = "for"      !ALNUM  -
IN      = "in"       !ALNUM  -
FROM    = "from"     !ALNUM  -
TO      = "to"       !ALNUM  -
CONT    = "continue" !ALNUM  -
BREAK   = "break"    !ALNUM  -
RETURN  = "return"   !ALNUM  -
TRY     = "try"      !ALNUM  -
CATCH   = "catch"    !ALNUM  -
ENSURE  = "ensure"   !ALNUM  -
RAISE   = "raise"    !ALNUM  -
GLOBAL  = "global"   !ALNUM  -
LOCAL   = "local"    !ALNUM  -
SUPER   = "super"    !ALNUM  -

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

error   = - < (!EOL .)* >

xexpr   = expr | error @{ expected("expression", yytext) }

%%
;

#if PROFILE

oop *profiles = 0;
int nprofiles = 0;

oop profileInit(oop function)
{
    profiles = xrealloc(profiles, sizeof(*profiles) * (nprofiles + 1));
    oop p = profiles[nprofiles++] = new(pObject);
    Object_put(p, sym_function,  function);
    Object_put(p, sym_count,     newInteger(0));
    Object_put(p, sym_stamp,     newInteger(0));
    Object_put(p, sym_time,      newInteger(0));
    return p;
}

#include <time.h>

long uclock(void)
{
    struct rusage ru;
    getrusage(RUSAGE_SELF, &ru);
    return ru.ru_utime.tv_sec * 1000000 + ru.ru_utime.tv_usec;
}

void profileTick(oop p)
{
    oop *ref   = Object_refLocal(p, sym_count);         if (!ref) fatal("profile data lost: count");
    long count = _integerValue(*ref);
    *ref = newInteger(count + 1);
    ref  = Object_refLocal(p, sym_stamp);               if (!ref) fatal("profile data lost: stamp");
    //*ref = newInteger(clock());
    *ref = newInteger(uclock());
}

void profileTock(oop p)
{
    //long  ticks = clock() - _integerValue(Object_getLocal(p, sym_stamp));
    long  ticks = uclock() - _integerValue(Object_getLocal(p, sym_stamp));
    oop  *timep = Object_refLocal(p, sym_time );        if (!timep) fatal("profile data lost: time");
    ticks      += _integerValue(*timep);
    *timep      = newInteger(ticks);
}

void profileReport(void)
{
    printf("%7s %7s function\n", "count", "msecs");
    for (int i = 0;  i < nprofiles;  ++i) {
        oop  prof   = profiles[i];
        oop  func   =               Object_getLocal(prof, sym_function);
        long count  = _integerValue(Object_getLocal(prof, sym_count   ));
        long ticks  = _integerValue(Object_getLocal(prof, sym_time    ));
        printf("%7ld ", count);
        //printf("%7ld ", (long)(1000. * ticks / CLOCKS_PER_SEC));
        printf("%7ld ", ticks);
        if (is(Primitive, func)) {
            printf("%s\n", printString(func, 0));
            continue;
        }
        oop  parent = Object_getLocal(func, sym_parent);
        oop  name   = Object_getLocal(func, sym_name);
        if (nil != parent) printf("%s.", codeString (parent, 0));
        if (nil != name  ) printf("%s",  printString(name,   0));
        else               printf("[anonymous function]");
        printf("\n");
    }
}

#endif

oop apply(oop func, oop self, oop args, oop env, oop owner)
{
    int functype = getType(func);
    if (Primitive == functype) {
#     if PROFILE
        oop profile = nil;
        if (opt_p) {
            profile = _get(func, Primitive,profile);
            if (nil == profile) profile = _set(func, Primitive,profile, profileInit(func));
            profileTick(profile);
        }
#     endif
        oop result = _get(func, Primitive,function)(func, self, args, env);
#     if PROFILE
        if (opt_p) profileTock(profile);
#     endif
        return result;
    }
#if PRIMCLOSURE
    if (Closure != functype)
        valueError(nil == self ? "()" : ".()", "cannot apply", func);
    oop  lambda      = _get(func, Closure,function);
    oop  environment = _get(func, Closure,environment);
    oop  parameters  = _get(lambda, Lambda,parameters);
    oop  body        = _get(lambda, Lambda,body);
#else
    if (Object != functype || pClosure  != _getDelegate(func))
        valueError(nil == self ? "()" : ".()", "cannot apply", func);
    oop  lambda      = Object_get(func,   sym_function);
    oop  environment = Object_get(func,   sym_environment);
    oop  parameters  = Object_get(lambda, sym_parameters);
    oop  body        = Object_get(lambda, sym_body);
# if PROFILE
    oop  profile     = nil;
    if (opt_p) {
        profile      = Object_getLocal(lambda, sym_profile);
        if (nil == profile) profile = Object_put(lambda, sym_profile, profileInit(lambda));
        profileTick(profile);
    }
# endif
#endif
    oop *exprs       =  get(body, Object,indexed);
    int  size        = _get(body, Object,isize);
    oop  result      = nil;
    assert(is(Object, args));
    // inherit from closure's captured environment
    _setDelegate(args, environment);
    Object_put(args, sym_self, self);
    Object_put(args, prop_owner, owner);
    int  nparam = _get(parameters, Object,isize);
    oop *pparam = _get(parameters, Object,indexed);
    int  nargs  = _get(args,       Object,isize);
    oop *pargs  = _get(args,       Object,indexed);
# if NONLOCAL
    switch (nlrPush()) {
        case NLR_CONTINUE:      syntaxError("continue outside loop");
        case NLR_BREAK:         syntaxError("break outside loop");
        case NLR_RETURN:        return nlrPop();
        case NLR_RAISE:         nlrReturn(nlrPop(), NLR_RAISE);
    }
# endif
    // positional args -> named parameters
    for (int i = 0;  i < nparam;  ++i)
        Object_put(args, pparam[i], i < nargs ? pargs[i] : nil);
    // keyword defaults
    int              nkeywd = _get(parameters, Object,psize);
    struct property *pkeywd = _get(parameters, Object,properties);
    for (int i = 0;  i < nkeywd;  ++i)
        if (Object_find(args, pkeywd[i].key) < 0)
            Object_put(args, pkeywd[i].key, eval(pkeywd[i].val, args));
    for (int i = 0;  i < size;  ++i)
        result = eval(exprs[i], args);
# if NONLOCAL
    nlrPop();
# endif
# if PROFILE
    if (opt_p) profileTock(profile);
# endif
    return result;
}

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

oop getArgType(oop args, int index, int type, char *who)
{                                                                                       assert(is(Object, args));
    oop arg = getArg(args, index, who);
    if (type != getType(arg)) typeError(who, "illegal argument type", arg);
    return arg;
}

#if TYPECODES

enum typecode getTypecode(oop exp)
{
    oop delegate       = _getDelegate(exp);
    oop name           = Object_getLocal(delegate, prop_name);
    return is(Symbol, name) ? _get(name, Symbol,typecode) : UNDEFINED_TYPECODE;
}

#endif // !TYPECODES

#define defineEval(NAME)                                                                \
    static inline oop prim_##NAME##_eval(oop func, oop exp, oop args, oop env) {        \
        if (_get(args,Object,isize) >= 1) env = Object_at(args, 0);                     \
        return NAME##_eval(exp, env);                                                   \
    }

doProtos(defineEval)

#undef defineEval

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

doProtos(defineCodeOn)

#undef defineCodeOn

static inline oop evalobj(oop exp, oop env)
{
# if TYPECODES
    switch (getTypecode(exp)) {
        case UNDEFINED_TYPECODE:
            break;
#       define defineEval(NAME) case t##NAME: return NAME##_eval(exp, env);
        doProtos(defineEval);
#       undef defineEval
    }
# endif // TYPECODES

    oop owner     = nil;
    oop evaluator = Object_getOwner(exp, prop_eval, &owner);
    oop args      = new(pObject);
    Object_push(args, env);
    return apply(evaluator, exp, args, env, owner);
}

long evaluations = 0;

oop eval(oop exp, oop env)
{
    ++evaluations;
    enum type type = getType(exp);
# if PRIMCLOSURE
    if (Lambda == type) return newClosure(exp, env);
# endif
    if (Object != type) {
        if (String == type) return newStringLen(_get(exp, String,value), _get(exp, String,length));
        return exp;
    }
    if (!opt_O) {
        Object_push(trace, exp);
        if (opt_d && opt_v) {
            printf("@@@ ");
            codeln(exp, 0);
        }
    }
    oop result = evalobj(exp, env);
    if (!opt_O) Object_pop(trace);
    return result;
}

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

oop prim_Object_new(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    _setDelegate(args, self);
    oop owner = nil;
    oop ifunc = Object_getOwner(args, sym_initialise, &owner);
    apply(ifunc, args, new(pObject), env, owner);
    return args;
}

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

oop prim_Object_push(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    int argc     = _get(args, Object,isize);            assert(is(Object, self));
    oop *indexed = _get(args, Object,indexed);
    for (int i = 0;  i < argc;  ++i) Object_push(self, indexed[i]);
    return self;
}

oop prim_Object_pop(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, self));
    int size = _get(self, Object,isize);
    if (size < 1) rangeError("Object.pop", "object is empty", self, 0);
    --size;
    _set(self, Object,isize, size);
    return _get(self, Object,indexed)[size];
}

oop prim_String_new(oop func, oop self, oop args, oop env)
{
    int  nargs = _get(args, Object,isize);
    if (nargs == 0) return newStringLen(0, 0);
    int len = _integerValue(getArgType(args, 0, Integer, "String.new"));
    return newStringLen(0, len);
}

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

oop prim_String_unescaped(oop func, oop self, oop args, oop env)
{
    return newStringUnescaped(String_content(self));
}

oop prim_String_push(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    int argc     = _get(args, Object,isize);            assert(is(String, self));
    oop *indexed = _get(args, Object,indexed);
    for (int i = 0;  i < argc;  ++i) String_push(self, indexed[i]);
    return self;
}

oop prim_String_pop(oop func, oop self, oop args, oop env)
{                                                       assert(is(String, self));
    int size = _get(self, String,length);
    if (size < 1) rangeError("String.pop", "string is empty", self, 0);
    --size;
    _set(self, String,length, size);
    return newInteger(_get(self, String,value)[size]);
}

oop prim_String_asInteger(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    int argc     = _get(args, Object,isize);            assert(is(String, self));
    if (argc > 1) fatal("String.asInteger: expected either 0 or 1 arguments, got %d\n", argc);

    char *str = String_content(self); // ensure nul terminator
    char *end = 0;
    long value;

    if (argc == 1) {
        oop base = _get(args, Object,indexed)[0];
        value = strtol(str, &end, integerValue(base, "String.asInteger"));
    } else {
        value = strtol(str, &end, 0);
    }

    if (*end) return nil;
    return newInteger(value);
}

oop prim_String_asFloat(oop func, oop self, oop args, oop env)
{                                                       assert(is(String, self));
    char *str = String_content(self); // ensure nul terminator
    char *end = 0;
    double value = strtod(str, &end);
    if (*end) return nil;
    return newFloat(value);
}

oop prim_String_asSymbol(oop func, oop self, oop args, oop env)
{                                                       assert(is(String, self));
    return intern(String_content(self));
}

char *strnchr(char *s, int len, int c)
{
    while (len--) if (c == *s++) return s-1;
    return 0;
}

#if !defined(__MACH__) // BSD has this in libc

char *strnstr(char *s, char *t, int slen)
{
    int tlen  = strlen(t);
    int limit = slen - tlen;
    for (int i = 0;  i <= limit;  ++i)
        if (!strncmp(s + i, t, tlen))
            return s+i;
    return 0;
}

#endif

oop String_bitSet(oop string, int bit)
{
    int index  = bit / 8, shift  = bit % 8;
    while (index >= _get(string, String,length)) String_append(string, 0);
    _get(string, String,value)[index] |= (1 << shift);
    return string;
}

oop prim_String_bitSet(oop func, oop self, oop args, oop env)
{
    return String_bitSet(self, _integerValue(getArgType(args, 0, Integer, "String.bitSet")));
}

oop String_bitClear(oop string, int bit)
{
    int index  = bit / 8, shift  = bit % 8;
    while (index >= _get(string, String,length)) String_append(string, 0);
    _get(string, String,value)[index] &= ~(1 << shift);
    return string;
}

oop prim_String_bitClear(oop func, oop self, oop args, oop env)
{
    return String_bitClear(self, _integerValue(getArgType(args, 0, Integer, "String.bitClear")));
}

oop String_bitInvert(oop string, int bit)
{
    int index  = bit / 8, shift  = bit % 8;
    while (index >= _get(string, String,length)) String_append(string, 0);
    _get(string, String,value)[index] ^ (1 << shift);
    return string;
}

oop prim_String_bitInvert(oop func, oop self, oop args, oop env)
{
    return String_bitInvert(self, _integerValue(getArgType(args, 0, Integer, "String.bitInvert")));
}

int String_bitTest(oop string, int bit)
{
    int index  = bit / 8, shift  = bit % 8;
    if (index >= _get(string, String,length)) return 0;
    return (_get(string, String,value)[index] >> shift) & 1;
}

oop prim_String_bitTest(oop func, oop self, oop args, oop env)
{
    return newBoolean(String_bitTest(self, _integerValue(getArgType(args, 0, Integer, "String.bitTest"))));
}

// a bit silly having this as a primitive...

int charClassNext(char **ppc)
{
    int c = *(*ppc)++;
    if ('\\' == c && **ppc) {
        c = *(*ppc)++;
        switch (c) {
            case 'a': return '\a';
            case 'b': return '\b';
            case 'f': return '\f';
            case 'n': return '\n';
            case 'r': return '\r';
            case 't': return '\t';
            case 'v': return '\v';
            case '0'...'7': {
                c &= 7;
                if ('0' <= **ppc && **ppc <= '7') c = (c << 3) | (*(*ppc)++ & 7);
                if ('0' <= **ppc && **ppc <= '7') c = (c << 3) | (*(*ppc)++ & 7);
                return c;
            }
            case 'x': {
                c = 0;
                int d;
                while ((d = digitValue(**ppc, 16)) >= 0) c = (c << 4) | d, ++*ppc;
                return c;
            }
        }
    }
    return c;
}

oop prim_String_charClass(oop func, oop self, oop args, oop env)
{
    oop   bits = newStringLen(0, 0);
    char *spec = String_content(self);
    int invert = 0;
    if ((invert = ('^' == spec[0]))) ++spec;
    while (*spec) {
        int c = charClassNext(&spec);
        if ('-' == spec[0] && spec[1]) {
            ++spec;
            int d = charClassNext(&spec);
            for (int i = c;  i <= d;  ++i) String_bitSet(bits, i);
            continue;
        }
        String_bitSet(bits, c);
    }
    if (invert) {
        int length = _get(bits, String,length);
        while (length < 16) String_append(bits, 0), ++length;
        char  *value = _get(bits, String,value);
        for (int i = 0;  i < length;  ++i) value[i] ^= 0xff;
    }
    return bits;
}

oop prim_String_compareFrom(oop func, oop self, oop args, oop env)
{
    int     off = _integerValue(getArgType(args, 0, Integer, "String.compareFrom"));
    oop     str =               getArgType(args, 1, String,  "String.compareFrom");
    char *myval = _get(self, String,value);
    int   mylen = _get(self, String,length);
    char *qqval = _get(str, String,value);
    int   qqlen = _get(str, String,length);
    if (off + qqlen > mylen) return nil;
    return newInteger(strncmp(myval + off, qqval, qqlen));
}

oop prim_String_intAt(oop func, oop self, oop args, oop env)
{
    int index = _integerValue(getArgType(args, 0, Integer, "String.intAt"));
    int size  = _get(self, String,length);
    if (index < 0 || index + sizeof(int) > size)
        rangeError("String.intAt", "index out of bounds", self, index);
    return newInteger(*(int *)(_get(self, String,value) + index));
}

oop prim_Object_includes(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    if (!is(Object, self)) return nil;
    int     argc = _get(args, Object,isize);
    oop    *argv = _get(args, Object,indexed);
    int     size = _get(self, Object,isize);
    oop    *elts = _get(self, Object,indexed);
    for (int i = 0;  i < argc;  ++i) {
        oop arg = argv[i];
        int found = 0;
        for (int j = 0;  j < size;  ++j)
            if ((found = (elts[j] == arg)))
                break;
        if (!found) return nil;
    }
    return sym_t;
}

oop prim_String_includes(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    int     size = _get(args, Object,isize);            assert(is(String, self));
    oop    *elts = _get(args, Object,indexed);
    char  *value = _get(self, String,value);
    int   length = _get(self, String,length);
    for (int i = 0;  i < size;  ++i) {
        oop arg = elts[i];
        switch (getType(arg)) {
            case Integer:
                if (!strnchr(value, length, _integerValue(arg))) return nil;
                continue;
            case String:
                if (!strnstr(value, String_content(arg), length)) return nil;
                continue;
            default:
                typeError("String.includes", "non-string/integer argument", arg);
                break;
        }
    }
    return sym_t;
}

oop prim_String_sliced(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    int     argc = _get(args, Object,isize);            assert(is(String, self));
    if (argc != 2) valueError("String.sliced", "two arguments expected", args);
    oop    *argv = _get(args, Object,indexed);
    char  *value = _get(self, String,value);
    int   length = _get(self, String,length);
    int    start = integerValue(argv[0], "String.sliced");
    int      end = integerValue(argv[1], "String.sliced");
    if (start < 0) start += length;
    if (start < 0 || start >= length) rangeError("String.sliced", "start index out of bounds", self, start);
    if (end < 0) end += length;
    if (end < 0 || end >= length) rangeError("String.sliced", "end index out of bounds", self, end);
    oop result = newStringLen(0, 0);
    String_appendAllLen(result, value + start, end - start + 1);
    return result;
}

oop prim_Symbol_asString(oop func, oop self, oop args, oop env)
{                                                       assert(is(Symbol, self));
    return newString(_get(self, Symbol,name));
}

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

oop prim_keys(oop func, oop self, oop args, oop env)
{
    return keys(self, 0);
}

oop prim_allKeys(oop func, oop self, oop args, oop env)
{
    return keys(self, 1);
}

oop prim_findKey(oop func, oop self, oop args, oop env)
{
    if (is(Object, self)) {
        if (_get(args, Object,isize) != 1) valueError("Object.findKey", "one argument expected", args);
        oop key = _get(args, Object,indexed)[0];
        int index = Object_find(self, key);
        return newInteger(index);
    }
    return nil;
}

oop prim_sorted(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    if (self == nil) {
        if (_get(args, Object,isize) != 1) valueError("sorted", "one argument expected", args);
        self = _get(args, Object,indexed)[0];
    }
    return sorted(self, "sorted");
}

oop prim_reversed(oop func, oop self, oop args, oop env)
{                                                       assert(is(Object, args));
    if (self == nil) {
        if (_get(args, Object,isize) != 1) valueError("reversed", "one argument expected", args);
        self = _get(args, Object,indexed)[0];
    }
    return reversed(self, "reversed");
}

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

oop prim_eval(oop func, oop self, oop args, oop env)
{
    int argc     = _get(args, Object,isize);
    oop *indexed = _get(args, Object,indexed);
    oop result   = nil;

    if (nil != Object_getLocal(args, sym_env)) {
        env = Object_getLocal(args, sym_env);
    }

    for (int i = 0;  i < argc;  ++i) result = eval(indexed[i], env);
    return result;
}

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

oop prim_intern(oop func, oop self, oop args, oop env)
{
    int argc     = _get(args, Object,isize);
    oop *indexed = _get(args, Object,indexed);
    oop result   = nil;

    if (argc != 1) {
        fatal("intern: invalid number of arguments");
    }
    if (getType(indexed[0]) != String) {
        fatal("intern: argument is not of type String, got %s instead", getTypeName(indexed[0]));
    }

    return intern(String_content(indexed[0]));
}

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

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

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

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

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

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

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

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

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

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

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

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

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

oop prim_error(oop func, oop self, oop args, oop env)
{
    int argc = _get(args, Object,isize);
    if (argc != 1) valueError("error", "one argument expected", args);
    oop arg  = _get(args, Object,indexed)[0];
    if (!is(String, arg)) typeError("error", "non-string argument", arg);
    unknownError(String_content(arg));
    return 0;
}

oop prim_Symbol_setopt(oop func, oop self, oop args, oop env)
{                                                                       assert(is(Symbol, self));
    int argc = _get(args, Object,isize);
    if (argc != 1) valueError("Symbol.setopt", "one argument expected", args);
    oop val  = _get(args, Object,indexed)[0];
    if (!isInteger(val))  typeError("Symbol.setopt", "non-integer agument", val);
    int optval = _integerValue(val);
    if      (sym_O == self) opt_O = optval;
    else if (sym_d == self) opt_d = optval;
    else if (sym_p == self) opt_p = optval;
    else if (sym_v == self) opt_v = optval;
    else                    valueError("Symbol.setopt", "unknown option", val);
    return val;
}

oop prim_Symbol_getopt(oop func, oop self, oop args, oop env)
{                                                                       assert(is(Symbol, self));
    if      (sym_O == self) return newInteger(opt_O);
    else if (sym_d == self) return newInteger(opt_d);
    else if (sym_p == self) return newInteger(opt_p);
    else if (sym_v == self) return newInteger(opt_v);
    else                    valueError("Symbol.getopt", "unknown option", self);
    return 0;
}

oop prim_defined(oop func, oop self, oop args, oop env)
{                                                               assert(is(Object, args));
    if (1 != _get(args, Object,isize)) valueError("defined", "one argument expected", args);
    oop arg = _get(args, Object,indexed)[0];
    return UNDEFINED == *_refvar(env, arg) ? nil : sym_t;       // looks in locals too
}

oop prim_Symbol_defined(oop func, oop self, oop args, oop env)
{                                                               assert(is(Symbol, self));
    return UNDEFINED == _get(self, Symbol,value) ? nil : sym_t; // looks only at global
}

oop prim_Symbol_define(oop func, oop self, oop args, oop env)
{                                                               assert(is(Object, args));
    int argc = _get(args, Object,isize);                        assert(is(Symbol, self));
    if (argc != 1) valueError("Symbol.define", "one argument expected", args);
    _set(self, Symbol,value, _get(args, Object,indexed)[0]);
    return self;
}

oop prim_Symbol_value(oop func, oop self, oop args, oop env)
{                                                               assert(is(Symbol, self));
    oop value = _get(self, Symbol,value);
    return value ? value : nil;
}

oop prim_Symbol_allInstances(oop func, oop self, oop args, oop env)
{
    oop result = new(pObject);
    for (int i = 0;  i < nsymbols;  ++i) Object_push(result, symbols[i]);
    return result;
}

#include <dlfcn.h>
#include <ffi.h>

void *pointerValue(oop obj, char *who)
{
    switch (getType(obj)) {
        case Integer: return (void *)(intptr_t)_integerValue(obj);
        case String:  return String_content(obj), _get(obj, String,value);
        case Symbol:  return &_get(obj, Symbol,name);
        default:      valueError(who, "cannot convert to pointer", obj);
    }
    return 0;
}

ffi_type *sig2type(int sig)
{
    switch (sig) {
        case 'v': return &ffi_type_void;
        case 'c': return &ffi_type_schar;
        case 'C': return &ffi_type_uchar;
        case 's': return &ffi_type_sshort;
        case 'S': return &ffi_type_ushort;
        case 'i': return &ffi_type_sint;
        case 'I': return &ffi_type_uint;
        case 'l': return &ffi_type_slong;
        case 'L': return &ffi_type_ulong;
        case 'z': return &ffi_type_slong;
        case 'Z': return &ffi_type_ulong;
        case 'f': return &ffi_type_float;
        case 'd': return &ffi_type_double;
        case 'p':
        case '*': return &ffi_type_pointer;
    }
    valueError("__extern__", "illegal type code", newInteger(sig));
    return 0;
}

struct ffi_t {
    char    *name;
    ffi_cif *cif;
    char    *signature;
    void    *function;
    int      arity;
};

oop primitiveExternalCall = 0;

void *dlprobe(char *dir, char *prefix, char *name, char *suffix, int mode)
{
    oop path = newStringLen(0, 0);
    String_appendAll(path, dir);
    String_appendAll(path, prefix);
    String_appendAll(path, name);
    String_appendAll(path, suffix);
    char *cpath = String_content(path);
    if (opt_d) printf("dlprobe %s\n", cpath);
    return dlopen(cpath, mode);
}

void *dlfind(char *name, int mode)
{
    static char *dirs[]    = { "", "/usr/lib/", "/lib/", "/usr/local/lib/", "/opt/local/lib/", 0 };
    static char *prefixes[] = { "lib", "", 0 };
    static char *suffixes[] = { ".so", ".dylib", ".dll", 0 };
    for (char **dir = dirs;  *dir;  ++dir)
        for (char **prefix = prefixes;  *prefix;  ++prefix)
            for (char **suffix = suffixes;  *suffix;  ++suffix) {
                void *hnd = dlprobe(*dir, *prefix, name, *suffix, mode);
                if (hnd) {
                    if (opt_d) printf("-> %p\n", hnd);
                    return hnd;
                }
            }
    return 0;
}

void *xdlopen(oop obj)
{
    if (nil == obj) return dlopen(0, RTLD_GLOBAL | RTLD_LAZY);
    void *hnd = dlfind(stringValue(obj, "__extern__"), RTLD_GLOBAL | RTLD_LAZY);
    if (!hnd) valueError("__extern__", "library not found", obj);
    return hnd;
}

void *xdlsym(void *handle, char *name)
{
    void *addr = dlsym(handle, name);
    if (!addr) valueError("__extern__", dlerror(), newString(name));
    return addr;
}

oop prim_extern(oop func, oop self, oop args, oop env)
{
    int  nargs = _get(args, Object,isize);
    oop *pargs = _get(args, Object,indexed);
    switch (nargs) {
        case 0: {
            return mkptr(xdlopen(nil));
        }
        case 1: { // extern("libname")
            return mkptr(xdlopen(pargs[0]));
        }
        case 2: { // extern("libname"/handle, "name")
            void *hnd = 0;
            if (isInteger(pargs[0])) hnd = (void *)(intptr_t)_integerValue(pargs[0]);
            else                     hnd = xdlopen(pargs[0]);
            return mkptr(xdlsym(hnd, stringValue(pargs[1], "__extern__")));
        }
    }
    // extern("libname"/handle", "name", "signature")
    void *hnd = 0;
    if (isInteger(pargs[0])) hnd = (void *)(intptr_t)_integerValue(pargs[0]);
    else                     hnd = xdlopen(pargs[0]);
    char *sym = stringValue(pargs[1], "__extern__");
    void *adr = xdlsym(hnd, sym);
    char *sig = stringValue(pargs[2], "__extern__");
    int  argc = strlen(sig);
    ffi_cif *cif = xcalloc(1, sizeof(ffi_cif));
    ffi_type **argv = xcalloc(argc, sizeof(*argv));
    for (int i = 0;  i < argc;  ++i) argv[i] = sig2type(sig[i]);
    ffi_prep_cif(cif, FFI_DEFAULT_ABI, argc - 1, argv[0], argv + 1);
    struct ffi_t *ffi = xmalloc(sizeof(*ffi));
    ffi->name      = sym;
    ffi->cif       = cif;
    ffi->signature = sig;
    ffi->function  = adr;
    ffi->arity     = argc;
    oop result = clone(primitiveExternalCall);
    _set(result, Primitive,cookie, ffi);
    return result;
}

union arg_t {
    signed   char  c;
    unsigned char  C;
    signed   short s;
    unsigned short S;
    signed   int   i;
    unsigned int   I;
    signed   long  l;
    unsigned long  L;
    ssize_t        z;
    size_t         Z;
    float          f;
    double         d;
    void          *p;
    intptr_t       P;
};

oop prim_externalCall(oop func, oop self, oop args, oop env)
{
    struct ffi_t *ffi  = _get(func, Primitive,cookie);          assert(ffi);
    int           argc = ffi->arity;
    union arg_t   vals[argc];
    void         *argv[argc];
    for (int i = 1;  i < argc;  ++i) {
        switch (ffi->signature[i]) {
            case 'c': vals[i].c = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'C': vals[i].C = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 's': vals[i].s = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'S': vals[i].S = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'i': vals[i].i = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'I': vals[i].I = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'l': vals[i].l = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'L': vals[i].L = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'z': vals[i].z = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'Z': vals[i].Z = integerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'f': vals[i].f =   floatValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'd': vals[i].d =   floatValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            case 'p':
            case '*': vals[i].p = pointerValue(getArg(args, i-1, ffi->name), ffi->name);  break;
            default:  valueError(ffi->name, "illegal argument type code", newInteger(ffi->signature[i]));
        }
        argv[i] = vals + i;
    }
    ffi_call(ffi->cif, FFI_FN(ffi->function), vals, argv+1);
    switch (ffi->signature[0]) {
        case 'v': return nil;
        case 'c': return newInteger(vals[0].c);
        case 'C': return newInteger(vals[0].C);
        case 's': return newInteger(vals[0].s);
        case 'S': return newInteger(vals[0].S);
        case 'i': return newInteger(vals[0].i);
        case 'I': return newInteger(vals[0].I);
        case 'l': return newInteger(vals[0].l);
        case 'L': return newInteger(vals[0].L);
        case 'z': return newInteger(vals[0].z);
        case 'Z': return newInteger(vals[0].Z);
        case 'f': return newFloat  (vals[0].f);
        case 'd': return newFloat  (vals[0].d);
        case 'p':
        case '*': return mkptr     (vals[0].p);
    }
    valueError(ffi->name, "illegal return type code", newInteger(ffi->signature[0]));
    return 0;
}

#if PEGVM

oop applyThunkIn(oop func, oop env)
{
    int functype = getType(func);
    if (Primitive == functype) {
#     if PROFILE
        oop profile = nil;
        if (opt_p) {
            profile = _get(func, Primitive,profile);
            if (nil == profile) profile = _set(func, Primitive,profile, profileInit(func));
            profileTick(profile);
        }
#     endif
        oop result = _get(func, Primitive,function)(func, nil, nil, env);
#     if PROFILE
        if (opt_p) profileTock(profile);
#     endif
        return result;
    }
#if PRIMCLOSURE
    if (Closure != functype) valueError("()", "cannot apply", func);
    oop  lambda      = _get(func, Closure,function);
    oop  body        = _get(lambda, Lambda,body);
#else
    if (Object != functype || pClosure  != _getDelegate(func)) valueError("()", "cannot apply", func);
    oop  lambda      = Object_get(func,   sym_function);
    oop  body        = Object_get(lambda, sym_body);
    oop  parameters  = Object_get(lambda, sym_parameters);
# if PROFILE
    oop  profile     = nil;
    if (opt_p) {
        profile      = Object_getLocal(lambda, sym_profile);
        if (nil == profile) profile = Object_put(lambda, sym_profile, profileInit(lambda));
        profileTick(profile);
    }
# endif
#endif
    oop *exprs       =  get(body, Object,indexed);
    int  size        = _get(body, Object,isize);
    oop  result      = nil;
    oop  args        = new(pObject);
    // inherit from closure's captured environment
    _setDelegate(args, env);
# if NONLOCAL
    switch (nlrPush()) {
        case NLR_CONTINUE:      syntaxError("continue outside loop");
        case NLR_BREAK:         syntaxError("break outside loop");
        case NLR_RETURN:        return nlrPop();
        case NLR_RAISE:         nlrReturn(nlrPop(), NLR_RAISE);
    }
# endif
    for (int i = 0;  i < size;  ++i)
        result = eval(exprs[i], args);
# if NONLOCAL
    nlrPop();
# endif
# if PROFILE
    if (opt_p) profileTock(profile);
# endif
    return result;
}

typedef unsigned char byte;

typedef enum op_t {
     PUSH,      DROP,   POP,      DOT,     CLASS,   STRING,   TEST,   RULE2,   RULE,   CALL,   CALL2,
     SUCCEED,   FAIL,   ACTION,   BEGIN,   END,     UNEND,    SET,
} op_t;

char *op_n[] = {
    "PUSH",    "DROP", "POP",    "DOT",   "CLASS", "STRING", "TEST", "RULE2", "RULE", "CALL", "CALL2",
    "SUCCEED", "FAIL", "ACTION", "BEGIN", "END",   "UNEND",  "SET",
};

typedef struct vmInsn vmInsn;

struct vmInsn {
    union {
        char   *str;
        oop     obj;
        vmInsn *code;
        int     len;
    } arg, arg2;
    unsigned short op, ok, ko;
};

typedef struct vmState
{
    oop    result;
    oop    variables;
} vmState;

#define VM_STATE_INITIALISER { nil, nil }

void vmEnter(vmState *state, oop obj, char *yytext, int yyleng)
{
    state->variables = new(state->variables);
    Object_put(state->variables, sym_$$, state->result);
}

void vmSet(vmState *state, oop obj, char *yytext, int yyleng)
{
    Object_put(state->variables, obj, state->result);
}

void vmAction(vmState *state, oop obj, char *yytext, int yyleng)
{
    oop text = yyleng ? newStringLen(yytext, yyleng) : nil;
    Object_put(state->variables, sym_yytext, text);
    Object_put(state->variables, sym_yyleng, newInteger(yyleng));
    applyThunkIn(obj, state->variables);
}

void vmLeave(vmState *state, oop obj, char *yytext, int yyleng)
{
    state->result = Object_getLocal(state->variables, sym_$$);
    state->variables = _getDelegate(state->variables);
}

void vmDisassemble(vmInsn *code, int pc)
{
    vmInsn *i = &code[pc];
    printf("%p ", code);
    switch (i->op) {
        case CLASS:
        case STRING:
            printf("%03d %-7s \"%s\" %2d %2d %2d\n",
                   pc, op_n[i->op], i->arg.str, i->arg2.len, i->ok, i->ko);
            break;
        case CALL:
            printf("%03d %-7s %p %2d %2d %2d\n",
                   pc, op_n[i->op], i->arg.code, i->arg2.len, i->ok, i->ko);
            break;
        case CALL2:
            printf("%03d %-7s %p %2d %2d %2d\n",
                   pc, op_n[i->op], i->arg.code, i->arg2.len, i->ok, i->ko);
            break;
        default:
            printf("%03d %-7s %s %2d %2d %2d\n",
                   pc, op_n[i->op], codeString(i->arg.obj, 0), i->arg2.len, i->ok, i->ko);
            break;
    }
}

oop vmCache = 0;

void vmCachePut(oop grammar, oop symbol, vmInsn *code)
{
    oop *ref = Object_refLocal(vmCache, grammar);
    if (UNDEFINED == ref) {
        Object_put(vmCache, grammar, new(pObject));
        ref = _refvar(vmCache, grammar);
    }
    oop line = *ref;
    ref = Object_refLocal(line, symbol);
    if (UNDEFINED != ref) fatal("vm cache collision");
    Object_put(line, symbol, mkptr(code));
}

vmInsn *vmCompile(oop grammar, oop symbol)
{
    oop   program = Object_get(grammar, symbol);
    if (!is(Object, program)) valueError("__match__", "program is not an object", program);
    oop  *prog  = _get(program, Object,indexed);
    int   plen  = _get(program, Object,isize);
    if (plen % 5 != 0) valueError("__match__", "program length is not a multiple of five", program);
    int   clen  = plen / 5;
    vmInsn *code = xcalloc(clen, sizeof(*code));
    vmCachePut(grammar, symbol, code);
    oop     env  = nil;
    int     ppc  = 0;
    int     cpc  = 0;
    while (ppc < plen) {
        int op     = integerValue(prog[ppc++], "__match__");
        oop arg    =              prog[ppc++];                          assert(arg);
        oop arg2   =              prog[ppc++];                          assert(arg2);
        int ok     = integerValue(prog[ppc++], "__match__");
        int ko     = integerValue(prog[ppc++], "__match__");
        if (ok < 0 || ok >= clen) valueError("__match__", "OK destination out of range", program);
        if (ko < 0 || ko >= clen) valueError("__match__", "KO destination out of range", program);
        code[cpc]  = (vmInsn){ .arg.obj = arg, .arg2.obj = arg2, .op = op, .ok = ok, .ko = ko };
        switch (op) {
            case CLASS:
            case STRING: {
                code[cpc].arg2.len = stringLength(code[cpc].arg.obj, "__match__");
                code[cpc].arg.str  = stringValue (code[cpc].arg.obj, "__match__");
                break;
            }
            case TEST: {
                if (!isClosure(code[cpc].arg.obj)) valueError("__match__", "TEST argument must be a closure", program);
                break;
            }
            case RULE2: {
                if (!is(Symbol, code[cpc].arg.obj )) valueError("__match__", "RULE2 argument must be a symbol", program);
                if (!is(Object, code[cpc].arg2.obj)) valueError("__match__", "RULE2 argument2 must be an object", program);
                break;
            }
            case RULE: {
                if (!is(Symbol, code[cpc].arg.obj)) valueError("__match__", "RULE argument must be a  symbol", program);
                break;
            }
            case CALL: {
                valueError("__match__", "program contains explicit CALL opcode", program);
                break;
            }
            case CALL2: {
                valueError("__match__", "program contains explicit CALL2 opcode", program);
                break;
            }
            case ACTION: {
                if (!isClosure(code[cpc].arg.obj)) valueError("__match__", "ACTION argument must be a closure", program);
                break;
            }
            case SET: {
                if (!is(Symbol, code[cpc].arg.obj)) valueError("__match__", "SET argument must be a symbol", program);
                if (nil == env) env = new(pObject);
                Object_put(env, code[cpc].arg.obj, nil);
                break;
            }
            default: {
                break;
            }
        }
        ++cpc;
    }

    if (opt_d) {
        printf("---- BEGIN ");  println(symbol, 0);
        for (int pc = 0;  pc < cpc;  ++pc) vmDisassemble(code, pc);
        printf("---- END ");  println(symbol, 0);
    }

    return code;
}

vmInsn *vmCacheGet(oop grammar, oop symbol)
{
    oop *ref = Object_refLocal(vmCache, grammar);
    if (UNDEFINED != ref) {
        oop line = *ref;
        ref = Object_refLocal(line, symbol);
        if (UNDEFINED != ref)
            return (vmInsn *)(intptr_t)_integerValue(*ref);
    }
    return vmCompile(grammar, symbol);
}

int vmRun(oop grammar0, oop symbol, char *text, int start, int length)
{
    vmCache = new(pObject);

    int maxactions = 32;

    struct Action {
        void (*function)(vmState *state, oop object, char *yytext, int yyleng);
        oop    object;
        int    textbeg, textlen;
    } *actions = xcalloc(maxactions, sizeof(*actions));

    struct Context { // for back-tracking
        int position;
        int nactions;
    } *cstack, context;

    int csp = 0, ncstack = 32;
    cstack = xmalloc(sizeof(*cstack) * ncstack);
    context.position = start;
    context.nactions = 0;

    vmState state = VM_STATE_INITIALISER;
    state.variables = new(pObject);

# define saveAction(ACT, OBJ, BEG, LEN) {                                       \
        if (context.nactions >= maxactions)                                     \
            actions = xrealloc(actions, sizeof(*actions) * (maxactions *= 2));  \
        actions[context.nactions++] = (struct Action){ ACT, OBJ, BEG, LEN };    \
    }

    //vmInsn *code = vmCacheGet(frame.grammar, symbol);

    struct Frame {
        oop     grammar;
        oop     symbol;
        vmInsn *code;
        int     pc;
        int     nactions;
    } *rstack, frame;

    int rsp = 0, nrstack = 32;
    rstack = xmalloc(sizeof(*rstack) * nrstack);
    frame.grammar  = grammar0;
    frame.symbol   = symbol;
    frame.code     = vmCacheGet(grammar0, symbol);
    frame.pc       = 0;
    frame.nactions = context.nactions;

    int textbeg = 0, textend = 0;
    int result = 0;

#define push(C, X) {                                                                                    \
        if (C##sp >= n##C##stack) C##stack = xrealloc(C##stack, sizeof(*C##stack) * (n##C##stack *= 2)); \
        C##stack[C##sp++] = (X);                                                                        \
    }

#define drop(C) {                               \
        assert(C##sp);                          \
        --C##sp;                                \
    }

#define pop(C) ({                               \
        assert(C##sp);                          \
        C##stack[--C##sp];                      \
    })

    for (;;) {
        if (opt_d) vmDisassemble(frame.code, frame.pc);
        vmInsn *i = frame.code + frame.pc++;
        switch (i->op) {
            case PUSH:          push(c, context);  frame.pc = i->ok;  continue;
            case DROP:          drop(c);           frame.pc = i->ok;  continue;
            case POP:           context = pop(c);  frame.pc = i->ok;  continue;
            case DOT: {
                if (context.position < length) {
                    context.position++;
                    frame.pc = i->ok;
                    continue;
                }
                frame.pc = i->ko;
                continue;
            }
            case CLASS: {
                if (context.position < length) {
                    byte c = text[context.position];
                    if ((((byte *)i->arg.str)[c/8] >> (c % 8)) & 1) {
                        context.position++;
                        frame.pc = i->ok;
                        continue;
                    }
                }
                frame.pc = i->ko;
                continue;
            }
            case STRING: {
                if (context.position + i->arg2.len <= length) {
                    if (0 == memcmp(text + context.position, i->arg.str, i->arg2.len)) {
                        context.position += i->arg2.len;
                        frame.pc = i->ok;
                        continue;
                    }
                }
                frame.pc = i->ko;
                continue;
            }
            case TEST: {
                oop result = apply(i->arg.obj, nil, new(pObject), nil, nil);
                frame.pc = (nil == result) ? i->ko : i->ok;
                continue;
            }
            case RULE2: {
                i->op = CALL2;
                i->arg.code = vmCacheGet(i->arg2.obj, i->arg.obj);
                goto doCall2; // (just in case they are not consecutive ;-))
            case CALL2: { doCall2:
                frame.pc--; // save pc of call insn
                push(r, frame);
                frame.grammar = i->arg2.obj;
                frame.code = i->arg.code;
                frame.pc = 0;
                saveAction(vmEnter, nil, 0, 0);
                frame.nactions = context.nactions;
                continue;
            }
                goto doCall;
            }
            case RULE: {
                // frame.pc--; // save pc of call insn
                // push(r, frame);
                // frame.code = vmCacheGet(grammar, i->arg.obj);
                // frame.pc = 0;
                // if (((Node *)(i->arg))->Symbol.nvars) {
                //     saveAction(enter, i->arg, 0, 0);
                //     frame.nactions = context.nactions;
                // }
                // continue;
                //i->op = CALL;
                //i->arglen = ((Node *)i->arg)->Symbol.nvars;
                //i->arg    = ((Node *)i->arg)->Symbol.code;                            assert(i->arg);
                i->op = CALL;
                i->arg.code = vmCacheGet(frame.grammar, i->arg.obj);
                goto doCall; // (just in case they are not consecutive ;-))
            }
            case CALL: { doCall:
                frame.pc--; // save pc of call insn
                push(r, frame);
                frame.code = i->arg.code;
                frame.pc = 0;
                saveAction(vmEnter, nil, 0, 0);
                frame.nactions = context.nactions;
                continue;
            }
            case SUCCEED: {
                if (frame.nactions == context.nactions) // no actions were added
                    context.nactions--;                 // remove the enter action
                else
                    saveAction(vmLeave, nil, 0, 0);
                if (rsp) {
                    frame = pop(r);
                    i = frame.code + frame.pc;
                    frame.pc = i->ok;
                    continue;
                }
                result = context.position - start;
                break;
            }
            case FAIL: {
                if (rsp) {
                    context.nactions = frame.nactions - 1; // remove all actions added by this rule
                    frame = pop(r);
                    i = frame.code + frame.pc;
                    frame.pc = i->ko;
                    continue;
                }
                else {
                    context.nactions = 0;
                }
                result = -1;
                break;
            }
            case ACTION: {
                // printf("--> ACTION %d [%d %d]\n", context.nactions, textbeg, textend);
                saveAction(vmAction, i->arg.obj, textbeg, textend - textbeg);
                frame.pc = i->ok;
                continue;
            }
            case BEGIN: {
                textbeg = textend = context.position;
                frame.pc = i->ok;
                continue;
            }
            case END: {
                textend = context.position;
                frame.pc = i->ok;
                continue;
            }
            case UNEND: {
                textbeg = textend = 0;
                frame.pc = i->ok;
                continue;
            }
            case SET: {
                saveAction(vmSet, i->arg.obj, 0, 0);
                frame.pc = i->ok;
                continue;
            }
            default: {
                fatal("this cannot happen %d", i->op);
                break;
            }
        }
        break;
    }

    saveAction(vmLeave, nil, 0, 0);

#undef pop
#undef drop
#undef push

    xfree(cstack);
    xfree(rstack);

    for (int i = 0;  i < context.nactions;  ++i) {
        char *yytext = text + actions[i].textbeg;
        int   yyleng = actions[i].textlen;
        // printf("==> ACTION %d [%d %d]\n", i, actions[i].textbeg, actions[i].textbeg + actions[i].textlen);
        actions[i].function(&state, actions[i].object, yytext, yyleng);
    }

    vmCache = nil;
    return result;
}

oop prim_match(oop func, oop self, oop args, oop env)
{
    oop   grammar  =               getArg    (args, 0,          "__match__");
    oop   symbol   =               getArgType(args, 1, Symbol,  "__match__");
    oop   string   =               getArgType(args, 2, String,  "__match__");
    int   start    = _integerValue(getArgType(args, 3, Integer, "__match__"));

    char *text     = get(string, String,value);
    int   length   = get(string, String,length);
    oop   program  = Object_get(grammar, symbol);

    int   result   = vmRun(grammar, symbol, text, start, length);

    return newInteger(result);
}

#endif // PEGVM

oop replFile(FILE *in)
{
    int oldline = lineno;
    lineno = 1;
    input = newInput();
    readFile(in, &input->text, &input->size);
    oop result = nil;
# if NONLOCAL
    switch (nlrPush()) {
        case NLR_CONTINUE:      syntaxError("continue outside loop");
        case NLR_BREAK:         syntaxError("break outside loop");
        case NLR_RETURN:        syntaxError("return outside function");
        case NLR_RAISE: {
            if (!is(Object, valnlr)) fatal("%s%s",
                                           is(String, valnlr) ? "" : "unhandled exception: ",
                                           printString(valnlr, 1));
            oop msg = newStringLen(0, 0);
            if (Object_find(valnlr, prop_function) >= 0) {
                String_push(msg, Object_get(valnlr, prop_function));
                String_appendAll(msg, ": ");
            }
            if (Object_find(valnlr, prop_kind) >= 0)
                String_push(msg, Object_get(valnlr, prop_kind));
            else
                String_appendAll(msg, "unhandled exception");
            if (Object_find(valnlr, prop_message) >= 0) {
                String_appendAll(msg, ": ");
                String_push(msg, Object_get(valnlr, prop_message));
            }
            int              size = _get(valnlr, Object,psize);
            struct property *kvs  = _get(valnlr, Object,properties);
            if (size) String_appendAll(msg, ": ");
            int n = 0;
            for (int i = 0;  i < size;  ++i) {
                if (isSpecial(kvs[i].key)) continue;
                if (n++) String_appendAll(msg, ", ");
                String_push(msg, kvs[i].key);
                String_appendAll(msg, " = ");
                storeOn(msg, kvs[i].val, 0);
            }
            String_appendAll(msg, ":");
            if (Object_find(valnlr, sym_message) >= 0) {
                String_append(msg, ' ');
                String_push(msg, Object_get(valnlr, sym_message));
            }
            size = _get(valnlr, Object,isize);
            oop *elts = _get(valnlr, Object,indexed);
            int w = 2 + log10(size);
            for (int i = size;  i--;) {
                String_format(msg, "\n%*d: ", w, i);
                codeOn(msg, elts[i], 0);
            }
            trace = nil;
            fatal(String_content(msg));
        }
    }
# endif
    while (yyparse() && yysval) {
        if (opt_v) {
            printf(">>> ");
            (opt_d ? println : codeln)(yysval, opt_v >2);
        }
        result = eval(yysval, nil);
        if (opt_v) {
            printf("==> ");
            if      (opt_v >= 3) storeln(result, 1);
            else if (opt_v >= 1) storeln(result, 0);
        }
    }
# if NONLOCAL
    nlrPop();
# endif
    lineno = oldline;
    return result;
}

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

void cleanup(void)
{
# if PROFILE
    if (opt_p) profileReport();
# endif
}

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

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

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

    pObject = nil;

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

    doProtos(defineProto);
    doTypes(defineProto);

# undef defineProto

    primitives = new(pObject);

    _set(intern("__primitives__"), Symbol,value, primitives);

    Object_put(pObject, prop_eval, newPrimitive(prim___eval__, newString("Object.__eval__")));        // inherited by all objects

#if TYPECODES

# define defineEvaluator(NAME)                                          \
    _set(intern(#NAME), Symbol,typecode, t##NAME);

# undef defineEvaluator

#endif // !TYPECODES

# define defineEvaluator(NAME)                                          \
    Object_put(p##NAME, prop_eval, newPrimitive(prim_##NAME##_eval, newString(#NAME".__eval__")));

    doProtos(defineEvaluator);

# undef defineEvaluator

# define defineCodeOn(NAME)                                                     \
    Object_put(p##NAME, prop_codeon, newPrimitive(prim_##NAME##_codeOn, newString(#NAME".codeOn")));

    doProtos(defineCodeOn);

# undef  defineCodeOn

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

# define prim(NAME, FUNC) _set(intern(#NAME), Symbol,value, newPrimitive(FUNC, newString(#NAME)))

    prim(__env__    , prim_env);
    prim(eval       , prim_eval);
    prim(print      , prim_print);
    prim(codeString , prim_codeString);
    prim(sqrt       , prim_sqrt);
    prim(round      , prim_round);
    prim(truncate   , prim_truncate);
    prim(cputime    , prim_cputime);
    prim(evaluations, prim_evaluations);
    prim(len        , prim_len);
    prim(ord        , prim_ord);
    prim(chr        , prim_chr);
    prim(readfile   , prim_readfile);
    prim(exit       , prim_exit);
    prim(error      , prim_error);
    prim(defined    , prim_defined);
    prim(__extern__ , prim_extern);
    prim(__match__  , prim_match);
    prim(intern     , prim_intern);

# undef prim

    primitiveExternalCall = newPrimitive(prim_externalCall, newString("externalCall"));

# define method(CLASS, NAME, FUNC) Object_put(p##CLASS, intern(#NAME), newPrimitive(FUNC, newString(#CLASS"."#NAME)))

    method(Object,new,          prim_Object_new         );
    method(Object,initialise,   prim_Object_initialise  );
    method(Object,push,         prim_Object_push        );
    method(Object,pop,          prim_Object_pop         );
    method(Object,length,       prim_length             );
    method(Object,keys,         prim_keys               );
    method(Object,allKeys,      prim_allKeys            );
    method(Object,findKey,      prim_findKey            );
    method(Object,sorted,       prim_sorted             );
    method(Object,reversed,     prim_reversed           );
    method(Object,includes,     prim_Object_includes    );
    method(String,new,          prim_String_new         );
    method(String,escaped,      prim_String_escaped     );
    method(String,unescaped,    prim_String_unescaped   );
    method(String,push,         prim_String_push        );
    method(String,pop,          prim_String_pop         );
    method(String,asInteger,    prim_String_asInteger   );
    method(String,asFloat,      prim_String_asFloat     );
    method(String,asSymbol,     prim_String_asSymbol    );
    method(String,includes,     prim_String_includes    );
    method(String,sliced,       prim_String_sliced      );
    method(String,bitSet,       prim_String_bitSet      );
    method(String,bitClear,     prim_String_bitClear    );
    method(String,bitInvert,    prim_String_bitInvert   );
    method(String,bitTest,      prim_String_bitTest     );
    method(String,charClass,    prim_String_charClass   );
    method(String,compareFrom,  prim_String_compareFrom );
    method(String,intAt,        prim_String_intAt       );
    method(Symbol,asString,     prim_Symbol_asString    );
    method(Symbol,setopt,       prim_Symbol_setopt      );
    method(Symbol,getopt,       prim_Symbol_getopt      );
    method(Symbol,defined,      prim_Symbol_defined     );
    method(Symbol,define,       prim_Symbol_define      );
    method(Symbol,value,        prim_Symbol_value       );
    method(Symbol,allInstances, prim_Symbol_allInstances);

# undef method

    namespaces = _set(sym___namespaces__, Symbol,value, new(pObject));

    trace = new(pObject);

    oop args = new(pObject);
    _set(intern("__argv__"), Symbol,value, args);

    signal(SIGINT, sigint);

    int argn = 1;

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

    for (int i = argn;  i < argc;  ++i)
        Object_push(args, newString(argv[i]));

    atexit(cleanup);

    if (argn == argc)
        replFile(stdin);
    else
        replPath(argv[argn]);

    return 0;
}

// Local Variables:
// eval: (setq indent-tabs-mode nil)
// eval: (untabify (point-min) (point-max))
// End: