key.c

/* ********************************************************************** */
/* KeyLang: A Scripting Language in the Key of C */
/* ********************************************************************** */
#include "key.h"

#include <string.h>
#include <stdlib.h>
#include <stdio.h>
#include <limits.h>
#include <stdarg.h>
#include <ctype.h>
#include <errno.h>

#define TRACK_USAGES   (1)          /* boolean; record usage statistics */
#define ERROR_BUFLEN   (128)        /* length of error message buffer */
#define TOKEN_BUFLEN   (1024)       /* max length of a token */
#define INTERN_BUFLEN  (16 * 1024)  /* interned string storage */
#define GLOBAL_MAX     (1024)       /* max number of global variables */
#define OPER_DEPTH     (128)        /* operand stack size */
#define SCOPE_DEPTH    (512)        /* local scope stack size */
#define EXEC_DEPTH     (380)        /* exec stack size (make keyenv ~16384 bytes) */

#define Q(EX) do{ keyret rv_ = (EX); if (rv_ != KEY_OK) return rv_; }while(0)

#define keyval_end()        ((keyval){ .type=(KEY_END)                 })
#define keyval_mark()       ((keyval){ .type=(KEY_MARK)                })
#define keyval_bcode(V)     ((keyval){ .type=(KEY_BCODE), .bval=(V)    })
#define keyval_native(V)    ((keyval){ .type=(KEY_NAT),   .eval=(V)    })
#define keyval_func(V)      ((keyval){ .type=(KEY_FUNC),  .fval=(V)    })

#define STREQ(A,B)  ( (A) == (B) || !strcmp((A),(B)) )

/* ********************************************************************** */
/* ********************************************************************** */

typedef enum token_e {
  TOK_EOF = 0,
  /* lexical only */
  TOK_ADD_A, TOK_AND_A, TOK_COAL_A, TOK_CBRACE, TOK_CBRACK, TOK_COLON,
  TOK_CPAREN, TOK_DEC, TOK_DIV_A, TOK_DOT, TOK_ELSE, TOK_INC, TOK_LOGAND_A,
  TOK_LOGOR_A, TOK_LSH_A, TOK_MOD_A, TOK_MUL_A, TOK_OBRACE, TOK_OPAREN,
  TOK_OR_A, TOK_RSH_A, TOK_SEMI, TOK_SUB_A, TOK_USH_A, TOK_XOR_A,
  /* lexical and ast */
  TOK_ADD, TOK_AND, TOK_ASSIGN, TOK_BREAK, TOK_COAL, TOK_COMMA, TOK_CONT,
  TOK_DIV, TOK_DO, TOK_EQ, TOK_FOR, TOK_FUNC, TOK_GE, TOK_GT, TOK_IDENT,
  TOK_IF, TOK_IS, TOK_ISNOT, TOK_INT, TOK_LOGAND, TOK_LOGNOT, TOK_LOGOR,
  TOK_LE, TOK_LSH, TOK_LT, TOK_MOD, TOK_MUL, TOK_OBRACK, TOK_OR, TOK_NE,
  TOK_NOT, TOK_QUEST, TOK_RETURN, TOK_RSH, TOK_SUB, TOK_STRING, TOK_TYPEOF,
  TOK_UNDEF, TOK_USH, TOK_VAR, TOK_VARARGS, TOK_WHILE, TOK_XOR,
  /* ast only */
  TOK_LIST, TOK_NEG, TOK_FUNCX, TOK_M_ASSIGN, TOK_M_CALL, TOK_POSTCOMMA,
  TOK_OBJECT, TOK_ARRAY
} token_t;

static char *
tok_name(token_t tk)
{
  static char * names[] = {
    "eof",
    "+=", "&=", "?\?=", "}", "]", ":",
    ")", "--", "/=", ".", "else", "++", "&&=",
    "||=", "<<=", "%=", "*=", "{", "(",
    "|=", ">>=", ";", "-=", ">>>=", "^=",
    "+", "&", "=", "break", "?\?", ",", "continue",
    "/", "do", "==", "for", "fn", ">=", ">", "identifier",
    "if", "is", "isnot", "integer", "&&", "!", "||",
    "<=", "<<", "<", "%", "*", "[", "|", "!=",
    "~", "?", "return", ">>", "-", "string", "typeof",
    "undef", ">>>", "var", "...", "while", "^",
    "list", "-", "fn", ".=", ".()", ",,",
    "object", "array"
  };
  return names[tk];
}

typedef struct node node;
struct node {
  token_t type;
  union {
    int ival;
    const char * sval;
  };
  node * first;
  node * second;
  node * third;
  node * fourth;
  node * chain;
};

typedef struct stack stack;
struct stack {
  int cap;
  int len;
#if TRACK_USAGES
  int max;
#endif
  keyval * buf;
};
struct keyenv {
  stack oper;
  stack scope;
  stack exec;
  keyval * root; /* bytecode allocation pointer */
  keyval buf[]; /* all the stack space */
};

static keyret bcode_load(keyenv * e);
static keyret bcode_assign(keyenv * e);
static keyret bcode_dup(keyenv * e);
static keyret bcode_index(keyenv * e);
static keyret bcode_pop(keyenv * e);
static keyret bcode_if(keyenv * e);
static keyret bcode_ifelse(keyenv * e);
static keyret bcode_doloop(keyenv * e);
static keyret bcode_loop(keyenv * e);
static keyret bcode_break(keyenv * e);
static keyret bcode_continue(keyenv * e);
static keyret bcode_call(keyenv * e);
static keyret bcode_return(keyenv * e);
static keyret bcode_var(keyenv * e);
static keyret bcode_defargs(keyenv * e);
static keyret bcode_varargs(keyenv * e);
static keyret bcode_add(keyenv * e);
static keyret bcode_sub(keyenv * e);
static keyret bcode_mul(keyenv * e);
static keyret bcode_div(keyenv * e);
static keyret bcode_mod(keyenv * e);
static keyret bcode_and(keyenv * e);
static keyret bcode_or(keyenv * e);
static keyret bcode_xor(keyenv * e);
static keyret bcode_lsh(keyenv * e);
static keyret bcode_rsh(keyenv * e);
static keyret bcode_ush(keyenv * e);
static keyret bcode_eq(keyenv * e);
static keyret bcode_ne(keyenv * e);
static keyret bcode_gt(keyenv * e);
static keyret bcode_lt(keyenv * e);
static keyret bcode_ge(keyenv * e);
static keyret bcode_le(keyenv * e);
static keyret bcode_is(keyenv * e);
static keyret bcode_isnot(keyenv * e);
static keyret bcode_not(keyenv * e);
static keyret bcode_lognot(keyenv * e);
static keyret bcode_neg(keyenv * e);
static keyret bcode_isdef(keyenv * e);
static keyret bcode_typeof(keyenv * e);
static keyret bcode_coal(keyenv * e);
static keyret bcode_logand(keyenv * e);
static keyret bcode_logor(keyenv * e);

/* ********************************************************************** */
/* Errors */
/* ********************************************************************** */

char key_errmsg[ERROR_BUFLEN] = "";
#define ERRMSG_LIMIT  (key_errmsg + ERROR_BUFLEN)

keyret
key_error(const char * fmt, ...)
{
  va_list ap;
  va_start(ap, fmt);
  vsnprintf(key_errmsg, ERROR_BUFLEN, fmt, ap);
  va_end(ap);
  return KEY_ERROR;
}

keyret
key_type_error(keyval a)
{
  if (a.type == KEY_STR) return key_error("unexpected string: '%s'", a.sval);
  if (a.type == KEY_INT) return key_error("unexpected integer: '%d'", a.ival);
  return key_error("unexpected type: %s", keyval_typename(a.type));
}

keyret
key_type_require(keyval a, keytype type)
{
  if (a.type == type) return KEY_OK;
  return key_error("unexpected type: have %s, expected %s",
                   keyval_typename(a.type), keyval_typename(type));
}

keyret
key_type_require_fn(keyval a)
{
  if (a.type == KEY_FUNC || a.type == KEY_NAT) return KEY_OK;
  return key_type_require(a, KEY_FUNC);
}

/* ********************************************************************** */
/* String Internment */
/* ********************************************************************** */

#if TRACK_USAGES
static size_t intern_max;
#endif

static char internbuf[INTERN_BUFLEN];
#define INTERN_LIMIT  (internbuf + INTERN_BUFLEN)

keyret
key_intern(const char ** dst, const char * src)
{
  char * p = internbuf;
  size_t n;
  if (!src || !*src) { *dst = ""; return KEY_OK; }
  if (src >= internbuf && src < INTERN_LIMIT) { *dst = src; return KEY_OK; }
  while (*p) {
    if (!strcmp(p, src)) { *dst = p; return KEY_OK; }
    p += strlen(p) + 1;
  }
  n = strlen(src) + 1;
  if ((size_t)(INTERN_LIMIT - p) <= n)
    return key_error("out of internment room for '%s'", src);
  strcpy(p, src);
  *(p + n) = '\0'; /* double zero at end makes it all work */
  *dst = p;
#if TRACK_USAGES
  n = (size_t)((p + n) - internbuf);
  if (intern_max < n) intern_max = n;
#endif
  return KEY_OK;
}

/* ********************************************************************** */
/* Tokenizer */
/* ********************************************************************** */

size_t
key_escape(char * dst, size_t dstlen, const char * src)
{
  size_t i = 0;
  const char * p;
#define OUT(C)  do{ if (i < dstlen) dst[i] = (C); ++i; }while(0)
  for (p = src; *p; ++p) {
    switch (*p) {
      case '\\': OUT('\\'); OUT('\\'); break;
      case '\n': OUT('\\'); OUT('n'); break;
      case '\r': OUT('\\'); OUT('r'); break;
      case '\t': OUT('\\'); OUT('t'); break;
      case '\"': OUT('\\'); OUT('\"'); break;
      case '\'': OUT('\\'); OUT('\''); break;
      default: OUT(*p); break;
    }
  }
#undef OUT
  if (i < dstlen) dst[i] = '\0'; else dst[dstlen - 1] = '\0';
  return i;
}

static int isword(int c) {
  return isalnum(c) || c == '_' || c == '$' || c == '@' || c >= 0x80;
}

struct lexer {
  const char * input; /* source text */
  const char * inp;   /* read pointer into input */
  const char * fname; /* name of input 'file' */
  int line;           /* line currently being tokenized */
  char * tokp;        /* write pointer into token buffer */
  char * buf;         /* caller-supplied token buffer */
  char * limit;       /* one-past-end of token buffer */
};
static struct lexer lexer;
#define APPEND(c)   (*(lexer.tokp)++ = (char)(c))
#define ZERO()      (*(lexer.tokp) = '\0')
#define OUTOFROOM() (lexer.tokp >= lexer.limit)

static keyret tokerror(const char * fmt, ...) KEY_FORMAT(1, 2);
static keyret
tokerror(const char * fmt, ...)
{
  va_list ap;
  char * p = key_errmsg;
  if (lexer.fname)
    p += snprintf(p, ERROR_BUFLEN, "%s:%d: ", lexer.fname, lexer.line);
  va_start(ap, fmt);
  vsnprintf(p, (size_t)(ERRMSG_LIMIT - p), fmt, ap);
  va_end(ap);
  return KEY_ERROR;
}

static void
lexer_init(const char * src, const char * fname, int line)
{
  lexer.input = lexer.inp = src;
  lexer.fname = fname;
  lexer.line = line;
  lexer.buf = lexer.limit = lexer.tokp = NULL;
}

static int nextChar(void) {
  int c = *lexer.inp;
  if (!c) return EOF;
  if (c == '\n') lexer.line++;
  lexer.inp++;
  return c;
}
static void ungetChar(void) {
  if (*--lexer.inp == '\n') lexer.line--;
}

static keyret
gatherString(int quote)
{
  int sawslashcr = 0;
  int c;
  while ((c = nextChar()) != quote) {
    if (c == '\\') {
      switch (c = nextChar()) {
        case EOF: return tokerror("unexpected end of file");
        case 'n': APPEND('\n'); break;
        case 'r': APPEND('\r'); break;
        case 't': APPEND('\t'); break;
        case '\r': sawslashcr = 1; break;
        case '\n': break;
        default: APPEND(c); break;
      }
    } else if (sawslashcr) {
      if (c != '\n') APPEND(c);
      sawslashcr = 0;
    } else if (c == EOF) {
      return tokerror("unexpected end of file");
    } else {
      APPEND(c);
    }
    if (OUTOFROOM()) return tokerror("string too long");
  }
  ZERO();
  return KEY_OK;
}

static keyret
gatherWord(int c)
{
  APPEND(c);
  while ((c = nextChar()) != EOF) {
    if (!isword(c)) { ungetChar(); break; }
    APPEND(c);
    if (OUTOFROOM()) return tokerror("token too long");
  }
  ZERO();
  return KEY_OK;
}

static void
skipComment(int type)
{
  int c;
  if (type == '*') {
    int sawstar = 0;
    while ((c = nextChar()) != EOF) {
      if (sawstar && c == '/') break;
      sawstar = (c == '*');
    }
  } else { /* / */
    while ((c = nextChar()) != EOF && c != '\n') /**/;
  }
}

static keyret
lexer_next(token_t * type, char * buf, size_t buflen)
{
  int c;
  lexer.buf = lexer.tokp = buf;
  lexer.limit = buf + buflen;
#define EQ(S)  ( !strcmp(lexer.buf, (S)) )
  while ((c = nextChar()) != EOF) {
    int d;
    if (c <= ' ' || isspace(c)) continue;
    if (c != '/') break;
    d = nextChar();
    if (d == '/' || d == '*') { skipComment(d); continue; }
    ungetChar();
    break;
  }
  if (c == EOF) { *type = TOK_EOF; return KEY_OK; }

  if (isdigit(c)) { Q(gatherWord(c)); *type = TOK_INT; return KEY_OK; }
  if (isword(c)) {
    Q(gatherWord(c));
    if      (EQ("break")) *type = TOK_BREAK;
    else if (EQ("continue")) *type = TOK_CONT;
    else if (EQ("do")) *type = TOK_DO;
    else if (EQ("else")) *type = TOK_ELSE;
    else if (EQ("fn")) *type = TOK_FUNC;
    else if (EQ("for")) *type = TOK_FOR;
    else if (EQ("if")) *type = TOK_IF;
    else if (EQ("is")) *type = TOK_IS;
    else if (EQ("isnot")) *type = TOK_ISNOT;
    else if (EQ("return")) *type = TOK_RETURN;
    else if (EQ("typeof")) *type = TOK_TYPEOF;
    else if (EQ("undef")) *type = TOK_UNDEF;
    else if (EQ("var")) *type = TOK_VAR;
    else if (EQ("while")) *type = TOK_WHILE;
    else *type = TOK_IDENT;
    return KEY_OK;
  }
  if (c == '\'' || c == '\"') {
    Q(gatherString(c));
    *type = TOK_STRING;
    return KEY_OK;
  }
  switch (c) {
    case ',': *type = TOK_COMMA; break;
    case '(': *type = TOK_OPAREN; break;
    case ')': *type = TOK_CPAREN; break;
    case '[': *type = TOK_OBRACK; break;
    case ']': *type = TOK_CBRACK; break;
    case '{': *type = TOK_OBRACE; break;
    case '}': *type = TOK_CBRACE; break;
    case ';': *type = TOK_SEMI; break;
    case ':': *type = TOK_COLON; break;
    case '~': *type = TOK_NOT; break;
    case '.': {
      c = nextChar();
      if (c == '.') {
        c = nextChar();
        if (c == '.') { *type = TOK_VARARGS; break; }
        ungetChar();
      }
      ungetChar();
      *type = TOK_DOT;
      break;
    }
#define MAYBE(C,T)  if (c == (C)) { *type = (T); break; }
#define ONEOREQ(EQ,NE) do{ \
  c = nextChar(); MAYBE('=', (EQ)); ungetChar(); *type = (NE); \
}while(0)
    case '+': {
      c = nextChar();
      MAYBE('+', TOK_INC);
      MAYBE('=', TOK_ADD_A);
      ungetChar(); *type = TOK_ADD;
      break;
    }
    case '-': {
      c = nextChar();
      MAYBE('-', TOK_DEC);
      MAYBE('=', TOK_SUB_A);
      ungetChar(); *type = TOK_SUB;
      break;
    }
    case '*': { ONEOREQ(TOK_MUL_A, TOK_MUL); break; }
    case '/': { ONEOREQ(TOK_DIV_A, TOK_DIV); break; }
    case '%': { ONEOREQ(TOK_MOD_A, TOK_MOD); break; }
    case '!': { ONEOREQ(TOK_NE, TOK_LOGNOT); break; }
    case '=': { ONEOREQ(TOK_EQ, TOK_ASSIGN); break; }
    case '^': { ONEOREQ(TOK_XOR_A, TOK_XOR); break; }
    case '&': {
      c = nextChar();
      if (c == '&') { ONEOREQ(TOK_LOGAND_A, TOK_LOGAND); break; }
      MAYBE('=', TOK_AND_A);
      ungetChar(); *type = TOK_AND;
      break;
    }
    case '|': {
      c = nextChar();
      if (c == '|') { ONEOREQ(TOK_LOGOR_A, TOK_LOGOR); break; }
      MAYBE('=', TOK_OR_A);
      ungetChar(); *type = TOK_OR;
      break;
    }
    case '<': {
      c = nextChar();
      if (c == '<') { ONEOREQ(TOK_LSH_A, TOK_LSH); break; }
      MAYBE('=', TOK_LE);
      ungetChar(); *type = TOK_LT;
      break;
    }
    case '>': {
      c = nextChar();
      if (c == '>') {
        c = nextChar();
        if (c == '>') { ONEOREQ(TOK_USH_A, TOK_USH); break; }
        MAYBE('=', TOK_RSH_A);
        ungetChar(); *type = TOK_RSH;
        break;
      }
      MAYBE('=', TOK_GE);
      ungetChar(); *type = TOK_GT;
      break;
    }
    case '?': {
      c = nextChar();
      if (c == '?') { ONEOREQ(TOK_COAL_A, TOK_COAL); break; }
      ungetChar(); *type = TOK_QUEST;
      break;
    }
    default: { return tokerror("unexpected character '%c'", c); }
  }
  strcpy(lexer.buf, tok_name(*type));
#undef EQ
#undef MAYBE
#undef ONEOREQ
  return KEY_OK;
}

/* ********************************************************************** */
/* AST Node */
/* ********************************************************************** */

struct parser {
  token_t type;            /* type of look-ahead token */
  char buf[TOKEN_BUFLEN];  /* text of look-ahead token */
  int loopDepth;           /* break/continue only allowed inside while */
  int funcDepth;           /* return only allowed inside functions */
  node * chain;            /* for cleanup on error */
};
static struct parser parser;

static void
node_delete_chain(node * n)
{
  if (n) {
    node * m = n->chain;
    free(n);
    node_delete_chain(m);
  }
}

static node *
node_new(token_t t, node * k0, node * k1, node * k2, node * k3)
{
  node * n = malloc(sizeof(node));
  if (!n) { perror("node_new"); exit(2); }
  n->type = t;
  n->sval = NULL;
  n->first = k0;
  n->second = k1;
  n->third = k2;
  n->fourth = k3;
  n->chain = parser.chain;
  parser.chain = n;
  return n;
}
#define node_new0(T)          node_new((T), NULL, NULL, NULL, NULL)
#define node_new1(T,A)        node_new((T), (A),  NULL, NULL, NULL)
#define node_new2(T,A,B)      node_new((T), (A),  (B),  NULL, NULL)
#define node_new3(T,A,B,C)    node_new((T), (A),  (B),  (C),  NULL)
#define node_new4(T,A,B,C,D)  node_new((T), (A),  (B),  (C),  (D) )

#define node_new_undef()      node_new0(TOK_UNDEF)
static node * node_new_int(int i) {
  node * n = node_new0(TOK_INT);
  n->ival = i;
  return n;
}
static node * node_new_string(token_t t, const char * s) {
  node * n = node_new0(t);
  n->sval = s;
  return n;
}

static keyret
convert_int(int * n, const char * txt)
{
  char * endp = NULL;
  long int i;
  errno = 0;
  i = strtol(txt, &endp, 0);
  if (errno || !endp || *endp) return tokerror("invalid integer");
#if LONG_MAX > INT_MAX
  if (i > INT_MAX || i < INT_MIN) return tokerror("invalid integer");
#endif
  *n = (int)i;
  return KEY_OK;
}

/* ********************************************************************** */
/* Parse into AST */
/* ********************************************************************** */

#define NEXT()  lexer_next(&parser.type, parser.buf, TOKEN_BUFLEN)
#define isType(T)  (parser.type == T)
#define MATCH(T)   int found_ = 0; Q(consume((T), &found_)); if (found_)

static keyret parseExpr(node ** n);
static keyret parseAssign(node ** n);
static keyret parseStatement(node ** n);
static keyret parseStatements(node ** n);
static keyret parseFunction(node ** n, int isexpr);

static keyret consume(token_t tk, int * found) {
  *found = (parser.type == tk);
  if (*found) return NEXT();
  return KEY_OK;
}
static keyret expect(token_t tk) {
  if (parser.type == tk) return NEXT();
  return tokerror("unexpected '%s', expected '%s'", parser.buf, tok_name(tk));
}
static keyret require(node * n, const char * name) {
  if (!n) return tokerror("missing %s", name);
  return KEY_OK;
}
static keyret requireIdent(node * n) {
  if (!n || n->type != TOK_IDENT) return tokerror("missing identifier");
  return KEY_OK;
}

static keyret checkAssign(node * n) {
  if (n->first->type == TOK_OBRACK) n->type = TOK_M_ASSIGN;
  else return requireIdent(n->first);
  return KEY_OK;
}

static keyret newIntern(node ** n, token_t t) {
  const char * p = NULL;
  Q(key_intern(&p, parser.buf));
  *n = node_new_string(t, p);
  return NEXT();
}
static keyret newInt(node ** n) {
  int v = 0;
  Q(convert_int(&v, parser.buf));
  *n = node_new_int(v);
  return NEXT();
}

static keyret parseIdent(node ** n) {
  if (isType(TOK_IDENT)) return newIntern(n, TOK_IDENT);
  return KEY_OK;
}
static keyret parseObjectLit(node ** n) {
  for (;;) { /* ident : expr ,} */
    node * m = NULL;
    Q(parseAssign(&m)); if (!m) break;
    if (m->type == TOK_IDENT) m->type = TOK_STRING;
    *n = node_new2(TOK_LIST, *n, m);
    Q(expect(TOK_COLON));
    m = NULL;
    Q(parseAssign(&m)); Q(require(m, "expression"));
    *n = node_new2(TOK_LIST, *n, m);
    if (isType(TOK_CBRACE)) break;
    Q(expect(TOK_COMMA));
  }
  *n = node_new1(TOK_OBJECT, *n);
  return expect(TOK_CBRACE);
}
static keyret parseArrayLit(node ** n) {
  for (;;) { /* expr ,] */
    node * m = NULL;
    Q(parseAssign(&m)); if (!m) break;
    *n = node_new2(TOK_LIST, *n, m);
    if (isType(TOK_CBRACK)) break;
    Q(expect(TOK_COMMA));
  }
  *n = node_new1(TOK_ARRAY, *n);
  return expect(TOK_CBRACK);
}
static keyret parsePrimary(node ** n) {
  if      (isType(TOK_IDENT))  { return newIntern(n, TOK_IDENT); }
  else if (isType(TOK_INT))    { return newInt(n); }
  else if (isType(TOK_STRING)) { return newIntern(n, TOK_STRING); }
  else if (isType(TOK_UNDEF))  { *n = node_new_undef(); return NEXT(); }
  else if (isType(TOK_FUNC))   { Q(NEXT()); return parseFunction(n, 1); }
  else if (isType(TOK_OBRACE)) { Q(NEXT()); return parseObjectLit(n); }
  else if (isType(TOK_OBRACK)) { Q(NEXT()); return parseArrayLit(n); }
  else if (isType(TOK_OPAREN)) {
    Q(NEXT());
    Q(parseExpr(n));
    return expect(TOK_CPAREN);
  }
  return KEY_OK;
}
static keyret parseCallArgs(node ** n) {
  Q(parseAssign(n));
  while (*n) {
    MATCH(TOK_COMMA) {
      node * m = NULL;
      Q(parseAssign(&m)); Q(require(m, "argument"));
      *n = node_new2(TOK_LIST, *n, m);
      continue;
    }
    break;
  }
  return KEY_OK;
}
static keyret parseMember(node ** n) {
  Q(parsePrimary(n));
  while (*n) {
    { MATCH(TOK_DOT) {
      node * m = NULL;
      Q(parseIdent(&m));
      m->type = TOK_STRING;
      *n = node_new2(TOK_OBRACK, *n, m);
      continue;
    } }
    { MATCH(TOK_OBRACK) {
      node * m = NULL;
      Q(parseExpr(&m)); Q(require(m, "expression"));
      Q(expect(TOK_CBRACK));
      *n = node_new2(TOK_OBRACK, *n, m);
      continue;
    } }
    break;
  }
  return KEY_OK;
}
static keyret parsePostfix(node ** n) {
  Q(parseMember(n));
  while (*n) {
    { MATCH(TOK_INC) { /* expr++ -> expr ,, expr += 1 */
      node * m = *n;
      Q(require(*n, "expression"));
      *n = node_new2(TOK_ASSIGN, *n, node_new2(TOK_ADD, *n, node_new_int(1)));
      Q(checkAssign(*n));
      *n = node_new2(TOK_POSTCOMMA, m, *n);
      continue;
    } }
    { MATCH(TOK_DEC) { /* expr-- -> expr ,, expr -= 1 */
      node * m = *n;
      Q(require(*n, "expression"));
      *n = node_new2(TOK_ASSIGN, *n, node_new2(TOK_SUB, *n, node_new_int(1)));
      Q(checkAssign(*n));
      *n = node_new2(TOK_POSTCOMMA, m, *n);
      continue;
    } }
    { MATCH(TOK_OPAREN) {
      node * m = NULL;
      Q(parseCallArgs(&m));
      Q(expect(TOK_CPAREN));
      if ((*n)->type == TOK_OBRACK) {
        *n = node_new2(TOK_M_CALL, *n, m);
      } else {
        *n = node_new2(TOK_OPAREN, *n, m);
      }
      continue;
    } }
    break;
  }
  return KEY_OK;
}
static keyret parsePrefix(node ** n) {
  if (isType(TOK_INC)) { /* ++expr -> expr += 1 */
    Q(NEXT());
    Q(parsePrefix(n)); Q(require(*n, "expression"));
    *n = node_new2(TOK_ASSIGN, *n, node_new2(TOK_ADD, *n, node_new_int(1)));
    Q(checkAssign(*n));

  } else if (isType(TOK_DEC)) { /* --expr -> expr -= 1 */
    Q(NEXT());
    Q(parsePrefix(n)); Q(require(*n, "expression"));
    *n = node_new2(TOK_ASSIGN, *n, node_new2(TOK_SUB, *n, node_new_int(1)));
    Q(checkAssign(*n));

  } else if (isType(TOK_TYPEOF) || isType(TOK_NOT) || isType(TOK_LOGNOT) ||
             isType(TOK_QUEST) || isType(TOK_SUB) || isType(TOK_ADD)) {
    token_t type = parser.type;
    if (type == TOK_SUB) type = TOK_NEG;
    Q(NEXT());
    Q(parsePrefix(n)); Q(require(*n, "expression"));
    if (type != TOK_ADD) *n = node_new1(type, *n);

  } else {
    Q(parsePostfix(n));
  }
  return KEY_OK;
}
static keyret parseInfixMul(node ** n) {
  Q(parsePrefix(n));
  while (*n) {
    if (isType(TOK_MUL) || isType(TOK_DIV) || isType(TOK_MOD)) {
      token_t type = parser.type;
      node * m = NULL;
      Q(NEXT());
      Q(parsePrefix(&m)); Q(require(m, "expression"));
      *n = node_new2(type, *n, m);
      continue;
    }
    break;
  }
  return KEY_OK;
}
static keyret parseInfixAdd(node ** n) {
  Q(parseInfixMul(n));
  while (*n) {
    if (isType(TOK_ADD) || isType(TOK_SUB)) {
      token_t type = parser.type;
      node * m = NULL;
      Q(NEXT());
      Q(parseInfixMul(&m)); Q(require(m, "expression"));
      *n = node_new2(type, *n, m);
      continue;
    }
    break;
  }
  return KEY_OK;
}
static keyret parseInfixBit(node ** n) {
  Q(parseInfixAdd(n));
  while (*n) {
    if (isType(TOK_LSH) || isType(TOK_RSH) || isType(TOK_USH) ||
        isType(TOK_AND) || isType(TOK_OR) || isType(TOK_XOR)) {
      token_t type = parser.type;
      node * m = NULL;
      Q(NEXT());
      Q(parseInfixAdd(&m)); Q(require(m, "expression"));
      *n = node_new2(type, *n, m);
      continue;
    }
    break;
  }
  return KEY_OK;
}
static keyret parseInfixCmp(node ** n) {
  Q(parseInfixBit(n));
  while (*n) {
    if (isType(TOK_LT) || isType(TOK_LE) || isType(TOK_GT) ||
        isType(TOK_GE) || isType(TOK_EQ) || isType(TOK_NE) ||
        isType(TOK_IS) || isType(TOK_ISNOT)) {
      token_t type = parser.type;
      node * m = NULL;
      Q(NEXT());
      Q(parseInfixBit(&m)); Q(require(m, "expression"));
      *n = node_new2(type, *n, m);
      continue;
    }
    break;
  }
  return KEY_OK;
}
static keyret parseShortfix(node ** n) {
  Q(parseInfixCmp(n));
  while (*n) {
    if (isType(TOK_LOGAND) || isType(TOK_LOGOR) || isType(TOK_COAL)) {
      token_t type = parser.type;
      node * m = NULL;
      Q(NEXT());
      Q(parseInfixCmp(&m)); Q(require(m, "expression"));
      *n = node_new2(type, *n, m);
      continue;
    }
    break;
  }
  return KEY_OK;
}
static keyret parseCond(node ** n) {
  Q(parseShortfix(n));
  if (*n && isType(TOK_QUEST)) {
    node * t = NULL;
    node * f = NULL;
    Q(NEXT());
    Q(parseAssign(&t)); Q(require(t, "expression"));
    Q(expect(TOK_COLON));
    Q(parseAssign(&f)); Q(require(f, "expression"));
    *n = node_new3(TOK_IF, *n, t, f);
  }
  return KEY_OK;
}
static keyret parseAssign(node ** n) {
  Q(parseCond(n));
  if (*n) {
    if (isType(TOK_ASSIGN)) {
      node * m = NULL;
      Q(NEXT());
      Q(parseAssign(&m)); Q(require(m, "expression"));
      *n = node_new2(TOK_ASSIGN, *n, m);
    } else if (isType(TOK_ADD_A) || isType(TOK_SUB_A) ||
      isType(TOK_MUL_A) || isType(TOK_DIV_A) || isType(TOK_MOD_A) ||
      isType(TOK_AND_A) || isType(TOK_OR_A) || isType(TOK_XOR_A) ||
      isType(TOK_LSH_A) || isType(TOK_RSH_A) || isType(TOK_USH_A) ||
      isType(TOK_LOGAND_A) || isType(TOK_LOGOR_A) || isType(TOK_COAL_A)) {
      token_t type = parser.type;
      node * m = NULL;
      Q(NEXT());
      Q(parseAssign(&m)); Q(require(m, "expression"));
      switch (type) {
        case TOK_ADD_A: type = TOK_ADD; break;
        case TOK_SUB_A: type = TOK_SUB; break;
        case TOK_MUL_A: type = TOK_MUL; break;
        case TOK_DIV_A: type = TOK_DIV; break;
        case TOK_MOD_A: type = TOK_MOD; break;
        case TOK_AND_A: type = TOK_AND; break;
        case TOK_OR_A:  type = TOK_OR; break;
        case TOK_XOR_A: type = TOK_XOR; break;
        case TOK_LSH_A: type = TOK_LSH; break;
        case TOK_RSH_A: type = TOK_RSH; break;
        case TOK_USH_A: type = TOK_USH; break;
        case TOK_LOGAND_A: type = TOK_LOGAND; break;
        case TOK_LOGOR_A: type = TOK_LOGOR; break;
        case TOK_COAL_A: type = TOK_COAL; break;
        default: type = TOK_EOF; break;
      }
      /* n op= m -> n = n op m */
      *n = node_new2(TOK_ASSIGN, *n, node_new2(type, *n, m));
    }
    if ((*n)->type == TOK_ASSIGN) Q(checkAssign(*n));
  }
  return KEY_OK;
}
static keyret parseExpr(node ** n) {
  Q(parseAssign(n));
  while (*n) {
    { MATCH(TOK_COMMA) {
      node * m = NULL;
      Q(parseAssign(&m)); Q(require(m, "expression"));
      *n = node_new2(TOK_COMMA, *n, m);
      continue;
    } }
    break;
  }
  return KEY_OK;
}
static keyret parseVarOne(node ** n) {
  node * name = NULL;
  node * value = NULL;
  Q(parseIdent(&name)); Q(requireIdent(name));
  { MATCH(TOK_ASSIGN) {
    Q(parseAssign(&value));
    Q(require(value, "expression"));
  } }
  *n = node_new2(TOK_VAR, name, value);
  return KEY_OK;
}
static keyret parseVar(node ** n) {
  Q(parseVarOne(n));
  while (*n) {
    { MATCH(TOK_COMMA) {
      node * m = NULL;
      Q(parseVarOne(&m)); Q(require(m, "declaration"));
      *n = node_new2(TOK_LIST, *n, m);
      continue;
    } }
    break;
  }
  return expect(TOK_SEMI);
}
static keyret parseIf(node ** n) {
  node * cond = NULL;
  node * body = NULL;
  Q(expect(TOK_OPAREN));
  Q(parseExpr(&cond)); Q(require(cond, "condition"));
  Q(expect(TOK_CPAREN));
  Q(parseStatement(&body)); Q(require(body, "statement"));
  *n = node_new2(TOK_IF, cond, body);
  { MATCH(TOK_ELSE) {
    Q(parseStatement(&((*n)->third)));
    Q(require((*n)->third, "statement"));
  } }
  return KEY_OK;
}
static keyret parseFunctionArglistOne(node ** n, int * va) {
  node * m = NULL;
  Q(parseIdent(&m));
  if (!m && !*n) return KEY_OK; /* empty list */
  Q(requireIdent(m));
  m->type = TOK_STRING;
  *n = node_new2(TOK_LIST, *n, m);
  { MATCH(TOK_VARARGS) {
    *n = node_new1(TOK_VARARGS, *n);
    *va = 1; /* '...' must be last in list */
  } }
  return KEY_OK;
}
static keyret parseFunctionArglist(node ** n) {
  int va = 0;
  Q(parseFunctionArglistOne(n, &va));
  while (*n && !va) {
    { MATCH(TOK_COMMA) {
      Q(parseFunctionArglistOne(n, &va));
      continue;
    } }
    break;
  }
  return KEY_OK;
}
static keyret makeName(node ** n) {
  static unsigned int anon_id = 0;
  char buf[64];
  const char * p;
  snprintf(buf, sizeof(buf), "__anon_%u__", ++anon_id);
  Q(key_intern(&p, buf));
  *n = node_new_string(TOK_IDENT, p);
  return KEY_OK;
}
static keyret parseFunction(node ** n, int isexpr) {
  node * name = NULL;
  node * args = NULL;
  node * body = NULL;
  Q(parseIdent(&name));
  if (!isexpr) Q(requireIdent(name));
  else if (!name) Q(makeName(&name));
  Q(expect(TOK_OPAREN));
  Q(parseFunctionArglist(&args));
  Q(expect(TOK_CPAREN));
  parser.funcDepth++;
  Q(parseStatement(&body)); Q(require(body, "statement"));
  parser.funcDepth--;
  token_t type = isexpr ? TOK_FUNCX : TOK_FUNC;
  *n = node_new3(type, name, args, body);
  return KEY_OK;
}
static keyret parseDo(node ** n) {
  node * body = NULL;
  node * cond = NULL;
  parser.loopDepth++;
  Q(parseStatement(&body)); Q(require(body, "statement"));
  parser.loopDepth--;
  Q(expect(TOK_WHILE));
  Q(expect(TOK_OPAREN));
  Q(parseExpr(&cond)); Q(require(cond, "condition"));
  Q(expect(TOK_CPAREN));
  *n = node_new2(TOK_DO, cond, body);
  return KEY_OK;
}
static keyret parseWhile(node ** n) {
  node * cond = NULL;
  node * body = NULL;
  Q(expect(TOK_OPAREN));
  Q(parseExpr(&cond)); Q(require(cond, "condition"));
  Q(expect(TOK_CPAREN));
  parser.loopDepth++;
  Q(parseStatement(&body)); Q(require(body, "statement"));
  parser.loopDepth--;
  *n = node_new2(TOK_WHILE, cond, body);
  return KEY_OK;
}
static keyret parseFor(node ** n) {
  node * init = NULL;
  node * cond = NULL;
  node * inc = NULL;
  node * body = NULL;
  Q(expect(TOK_OPAREN));
  Q(parseExpr(&init));
  if (init) init = node_new1(TOK_COMMA, init); /* 'pop' the result */
  Q(expect(TOK_SEMI));
  Q(parseExpr(&cond));
  if (!cond) cond = node_new_int(1); /* empty cond is always true */
  Q(expect(TOK_SEMI));
  Q(parseExpr(&inc));
  if (inc) inc = node_new1(TOK_COMMA, inc); /* 'pop' the result */
  Q(expect(TOK_CPAREN));
  parser.loopDepth++;
  Q(parseStatement(&body)); Q(require(body, "statement"));
  parser.loopDepth--;
  *n = node_new4(TOK_FOR, init, cond, inc, body);
  return KEY_OK;
}
static keyret parseBlock(node ** n) {
  Q(parseStatements(n));
  if (!*n) *n = node_new0(TOK_LIST); /* nop; can't return NULL */
  return expect(TOK_CBRACE);
}
static keyret parseReturn(node ** n) {
  if (parser.funcDepth == 0) return tokerror("invalid return statement");
  Q(parseExpr(n));
  *n = node_new1(TOK_RETURN, *n);
  return expect(TOK_SEMI);
}
static keyret parseBranch(node ** n, token_t tk) {
  if (parser.loopDepth == 0) return tokerror("invalid branch statement");
  *n = node_new0(tk);
  return expect(TOK_SEMI);
}
static keyret parseStatement(node ** n) {
  { MATCH(TOK_BREAK)  { return parseBranch(n, TOK_BREAK); } }
  { MATCH(TOK_CONT)   { return parseBranch(n, TOK_CONT); } }
  { MATCH(TOK_DO)     { return parseDo(n); } }
  { MATCH(TOK_FOR)    { return parseFor(n); } }
  { MATCH(TOK_IF)     { return parseIf(n); } }
  { MATCH(TOK_OBRACE) { return parseBlock(n); } }
  { MATCH(TOK_RETURN) { return parseReturn(n); } }
  { MATCH(TOK_VAR)    { return parseVar(n); } }
  { MATCH(TOK_WHILE)  { return parseWhile(n); } }
  { MATCH(TOK_SEMI)   { *n = node_new0(TOK_LIST); return KEY_OK; } }
  { MATCH(TOK_FUNC)   { return parseFunction(n, 0); } }
  { MATCH(TOK_VAR)    { return parseVar(n); } }
  Q(parseExpr(n));
  if (*n) {
    *n = node_new1(TOK_COMMA, *n); /* 'pop' the result */
    return expect(TOK_SEMI);
  }
  return KEY_OK;
}
static keyret parseStatements(node ** n) {
  Q(parseStatement(n));
  while (*n) {
    node * m = NULL;
    Q(parseStatement(&m));
    if (!m) break;
    *n = node_new2(TOK_LIST, *n, m);
  }
  return KEY_OK;
}

static keyret
parser_parse(node ** n, const char * src, const char * fname, int line)
{
  keyret err;
  lexer_init(src, fname, line);
  parser.loopDepth = 0;
  parser.funcDepth = 0;
  *n = parser.chain = NULL;
  Q(NEXT()); /* initialize look-ahead */
  err = parseStatements(n);
  if (!err) err = expect(TOK_EOF);
  if (err) {
    node_delete_chain(parser.chain);
    *n = parser.chain = NULL;
  }
  return err;
}

/* ********************************************************************** */
/* Compile AST to Bytecode */
/* ********************************************************************** */

/* work buffer:  mark proc1... mark proc2...
 * final buffer: proc2... end proc1... end
 * proc:         &(proc1)
 */
struct compiler {
  keyval * work;
  keyval * final;
  keyval * proc;
  int wlen;
  int flen;
  int counting;
};
static struct compiler comp;

static void compPush(keyval v) {
  if (comp.counting) {
    comp.wlen++;
  } else {
    comp.work[comp.wlen++] = v;
  }
}

static int compCountList(const node * n, token_t tk) {
  /* n: null || expr || list(expr expr) || list(list(... expr) expr) */
  int cnt = 0;
  while (n) { ++cnt; if (n->type == tk) n = n->first; else break; }
  return cnt;
}

#define procBegin()   compPush(keyval_mark())
#define procEnd()     compProc()
#define compCode(C)   compPush(keyval_bcode(C))
#define compString(N) compPush(keyval_str((N)->sval))

static int findMark(void) {
  int i;
  for (i = comp.wlen; i--; ) {
    if (comp.work[i].type == KEY_MARK) return i;
  }
  return -1; /* should never happen */
}
static void compProc(void) { /* mark body... -> func */
  if (comp.counting) {
    comp.wlen++;
  } else { /* move from 'work' to 'final' */
    int i = findMark();
    int len = comp.wlen - i - 1;
    comp.proc = comp.final + comp.flen;
    memcpy(comp.proc, comp.work + i + 1, (size_t)len * sizeof(keyval));
    comp.proc[len] = keyval_end();
    comp.flen += len + 1;
    comp.work[i] = keyval_func(comp.proc);
    comp.wlen = i + 1;
  }
}

static void compOne(const node * n) {
  if (!n) return;
  switch (n->type) {
    case TOK_UNDEF:  { compPush(keyval_undef()); break; }
    case TOK_INT:    { compPush(keyval_int(n->ival)); break; }
    case TOK_STRING: { compString(n); break; }
    case TOK_IDENT:  { compString(n); compCode(bcode_load); break; }

    case TOK_NOT:    { compOne(n->first); compCode(bcode_not); break; }
    case TOK_LOGNOT: { compOne(n->first); compCode(bcode_lognot); break; }
    case TOK_NEG:    { compOne(n->first); compCode(bcode_neg); break; }
    case TOK_QUEST:  { compOne(n->first); compCode(bcode_isdef); break; }
    case TOK_TYPEOF: { compOne(n->first); compCode(bcode_typeof); break; }

    case TOK_ADD: { compOne(n->first); compOne(n->second); compCode(bcode_add); break; }
    case TOK_SUB: { compOne(n->first); compOne(n->second); compCode(bcode_sub); break; }
    case TOK_MUL: { compOne(n->first); compOne(n->second); compCode(bcode_mul); break; }
    case TOK_DIV: { compOne(n->first); compOne(n->second); compCode(bcode_div); break; }
    case TOK_MOD: { compOne(n->first); compOne(n->second); compCode(bcode_mod); break; }
    case TOK_AND: { compOne(n->first); compOne(n->second); compCode(bcode_and); break; }
    case TOK_OR:  { compOne(n->first); compOne(n->second); compCode(bcode_or); break; }
    case TOK_XOR: { compOne(n->first); compOne(n->second); compCode(bcode_xor); break; }
    case TOK_LSH: { compOne(n->first); compOne(n->second); compCode(bcode_lsh); break; }
    case TOK_RSH: { compOne(n->first); compOne(n->second); compCode(bcode_rsh); break; }
    case TOK_USH: { compOne(n->first); compOne(n->second); compCode(bcode_ush); break; }
    case TOK_EQ:  { compOne(n->first); compOne(n->second); compCode(bcode_eq); break; }
    case TOK_NE:  { compOne(n->first); compOne(n->second); compCode(bcode_ne); break; }
    case TOK_GT:  { compOne(n->first); compOne(n->second); compCode(bcode_gt); break; }
    case TOK_LT:  { compOne(n->first); compOne(n->second); compCode(bcode_lt); break; }
    case TOK_GE:  { compOne(n->first); compOne(n->second); compCode(bcode_ge); break; }
    case TOK_LE:  { compOne(n->first); compOne(n->second); compCode(bcode_le); break; }
    case TOK_IS:  { compOne(n->first); compOne(n->second); compCode(bcode_is); break; }
    case TOK_ISNOT: { compOne(n->first); compOne(n->second); compCode(bcode_isnot); break; }

    case TOK_COAL: { /* expr expr -> expr { expr } op */
      compOne(n->first);
      procBegin(); compOne(n->second); procEnd();
      compCode(bcode_coal);
      break;
    }
    case TOK_LOGAND: { /* expr expr -> expr { expr } op */
      compOne(n->first);
      procBegin(); compOne(n->second); procEnd();
      compCode(bcode_logand);
      break;
    }
    case TOK_LOGOR: { /* expr expr -> expr { expr } op */
      compOne(n->first);
      procBegin(); compOne(n->second); procEnd();
      compCode(bcode_logor);
      break;
    }

    case TOK_ASSIGN: { /* ident expr -> expr str assign */
      compOne(n->second);
      compString(n->first);
      compCode(bcode_assign);
      break;
    }
    case TOK_M_ASSIGN: { /* expr expr -> expr expr expr member */
      const node * m = n->first;
      compOne(m->first);
      compOne(m->second);
      compOne(n->second);
      compPush(keyval_int(3));
      compPush(keyval_str("__member__"));
      compCode(bcode_load);
      compCode(bcode_call);
      break;
    }
    case TOK_OBRACK: { /* expr expr -> expr expr member */
      compOne(n->first);
      compOne(n->second);
      compPush(keyval_int(2));
      compPush(keyval_str("__member__"));
      compCode(bcode_load);
      compCode(bcode_call);
      break;
    }
    case TOK_ARRAY:
    case TOK_OBJECT: { /* list -> list N literal */
      compOne(n->first);
      compPush(keyval_int(compCountList(n->first, TOK_LIST)));
      compPush(keyval_str(n->type == TOK_ARRAY ? "__array__" : "__object__"));
      compCode(bcode_load);
      compCode(bcode_call);
      break;
    }

    case TOK_LIST: { /* expr|stmt? expr|stmt? -> expr|stmt expr|stmt */
      compOne(n->first);
      compOne(n->second);
      break;
    }
    case TOK_COMMA: { /* expr expr? -> expr pop expr */
      compOne(n->first);
      compCode(bcode_pop);
      compOne(n->second);
      break;
    }
    case TOK_POSTCOMMA: { /* expr expr -> expr expr pop */
      compOne(n->first);
      compOne(n->second);
      compCode(bcode_pop);
      break;
    }

    case TOK_IF: { /* expr stmt?|expr stmt?|expr -> expr {} {} ifelse */
      compOne(n->first);
      procBegin(); compOne(n->second); procEnd();
      if (n->third) {
        procBegin(); compOne(n->third); procEnd();
        compCode(bcode_ifelse);
      } else {
        compCode(bcode_if);
      }
      break;
    }

    case TOK_DO: { /* expr stmt? -> {expr} {} {stmt} dowhile */
      procBegin(); compOne(n->first); procEnd();
      procBegin(); procEnd();
      procBegin(); compOne(n->second); procEnd();
      compCode(bcode_doloop);
      break;
    }
    case TOK_WHILE: { /* expr stmt? -> {expr} {} {stmt} while */
      procBegin(); compOne(n->first); procEnd();
      procBegin(); procEnd();
      procBegin(); compOne(n->second); procEnd();
      compCode(bcode_loop);
      break;
    }
    case TOK_FOR: { /* init cond inc stmt? -> init; {cond} {inc} {stmt} for */
      compOne(n->first);
      procBegin(); compOne(n->second); procEnd();
      procBegin(); compOne(n->third); procEnd();
      procBegin(); compOne(n->fourth); procEnd();
      compCode(bcode_loop);
      break;
    }
    case TOK_BREAK: { compCode(bcode_break); break; }
    case TOK_CONT:  { compCode(bcode_continue); break; }

    case TOK_OPAREN: { /* expr call-list -> call-list N expr call */
      compOne(n->second);
      compPush(keyval_int(compCountList(n->second, TOK_LIST)));
      compOne(n->first);
      compCode(bcode_call);
      break;
    }
    case TOK_M_CALL: { /* expr call-list -> object call-list N+1 index expr member call */
      const node * m = n->first;
      compOne(m->first);
      compOne(n->second);
      compPush(keyval_int(compCountList(n->second, TOK_LIST) + 1));
      compCode(bcode_index); /* don't twice-compile/eval an expr */
      compOne(m->second);
      compPush(keyval_int(2));
      compPush(keyval_str("__member__"));
      compCode(bcode_load);  /* load __member__ to get the method-getter */
      compCode(bcode_call);  /* call the method-getter to get the method */
      compCode(bcode_call);  /* call the method */
      break;
    }
    case TOK_RETURN: { /* expr? -> expr|undef return */
      if (n->first) compOne(n->first); else compPush(keyval_undef());
      compCode(bcode_return);
      break;
    }

    case TOK_VAR: { /* ident expr? -> expr|undef str var */
      if (n->second) { compOne(n->second); } else { compPush(keyval_undef()); }
      compString(n->first);
      compCode(bcode_var);
      break;
    }
    case TOK_FUNCX:
    case TOK_FUNC: { /* name args body -> proc dup? name var */
      /* proc: name pop arg-names... arg-name-count defargs body */
      int va = n->second && n->second->type == TOK_VARARGS;
      node * args = va ? n->second->first : n->second;
      procBegin();
      compString(n->first);
      compCode(bcode_pop);
      compOne(args);
      compPush(keyval_int(compCountList(args, TOK_LIST)));
      compCode(va ? bcode_varargs : bcode_defargs);
      compOne(n->third);
      procEnd();
      if (n->type == TOK_FUNCX) compCode(bcode_dup);
      compString(n->first);
      compCode(bcode_var);
      break;
    }
    default: break; /* noisy compiler */
  }
}

static keyret
compiler_compile(keyval ** proot, keyval * proc,
                 const char * src, const char * fname, int line)
{
  node * n = NULL;
  Q(parser_parse(&n, src, fname, line));
  comp.work = NULL;
  comp.final = NULL;
  comp.proc = NULL;
  comp.wlen = 0;
  comp.flen = 0;
  comp.counting = 1;
  compOne(n);
  comp.counting = 0;
  comp.wlen += 2;
  comp.work = malloc((size_t)comp.wlen * sizeof(keyval));
  comp.final = malloc((size_t)comp.wlen * sizeof(keyval));
  if (!comp.work || !comp.final) { perror("compiler_compile"); exit(2); }
  comp.wlen = 0;
  procBegin();
  compOne(n);
  procEnd();
  node_delete_chain(parser.chain);
  *proc = keyval_func(comp.proc);
  *proot = comp.final;
  free(comp.work);
  return KEY_OK;
}

/* ********************************************************************** */
/* Key Value Type */
/* ********************************************************************** */

static keytype custom = KEY_CUSTOM;
static const char * custom_names[KEY_CUSTOM_MAX_] = {
  "@end",
  "undef",
  "int",
  "string",
  "mark",
  "bytecode",
  "native",
  "function",
  NULL
};

keytype
keyval_custom_type(const char * name)
{
  keytype i;
  for (i = 0; i < custom; ++i) {
    if (STREQ(name, custom_names[i])) {
      key_error("duplicate type name");
      return 0;
    }
  }
  if (custom >= KEY_CUSTOM_MAX_) {
    key_error("too many types");
    return 0;
  }
  if (key_intern(&name, name)) return 0;
  custom_names[custom] = name;
  return custom++;
}

const char *
keyval_typename(keytype a)
{
  if (a >= custom) return "bad-handle";
  return custom_names[a];
}

int
keyval_tobool(keyval a)
{
  switch (a.type) {
    case KEY_END: break;
    case KEY_MARK: return 0;
    case KEY_UNDEF: return 0;
    case KEY_INT: return a.ival != 0;
    case KEY_STR: return a.sval && *a.sval != '\0';
    case KEY_NAT: return 1;
    case KEY_FUNC: return 1;
    case KEY_BCODE: return 1;
    default: return a.pval != NULL;
  }
  return 0;
}

int
keyval_equal(keyval a, keyval b)
{
  if (a.type == b.type) {
    switch (a.type) {
      case KEY_END: return 1;
      case KEY_MARK: return 1;
      case KEY_UNDEF: return 1;
      case KEY_INT: return a.ival == b.ival;
      case KEY_STR: return STREQ(a.sval, b.sval);
      case KEY_NAT: return a.eval == b.eval;
      case KEY_FUNC: return a.fval == b.fval;
      case KEY_BCODE: return a.bval == b.bval;
      default: return a.pval == b.pval;
    }
  }
  return 0;
}

/* ********************************************************************** */
/* Stack */
/* ********************************************************************** */

static keyret stk_push(stack * s, keyval a) {
  if (s->len >= s->cap) return key_error("stack overflow");
  s->buf[s->len++] = a;
#if TRACK_USAGES
  if (s->max < s->len) s->max = s->len;
#endif
  return KEY_OK;
}
static int stk_length(stack * s) { return s->len; }
static void stk_set_length(stack * s, int n) { s->len = n; }
static void stk_drop(stack * s, int n) { s->len -= n; }
static keyval stk_pop(stack * s) { return s->buf[--s->len]; }
static keyval stk_peek(stack * s) { return s->buf[s->len - 1]; }
static keyval stk_get(stack * s, int n) { return s->buf[s->len - n]; }
static keyval stk_set(stack * s, int n, keyval a) {
  return s->buf[s->len - n] = a;
}
static keyval * stk_ptr(stack * s, int n) {
  return &s->buf[s->len - n];
}
static int stk_find_mark(stack * s) {
  int i;
  for (i = s->len; i--; ) {
    if (s->buf[i].type == KEY_MARK) return i;
  }
  return -1;
}
static int stk_find(stack * s, keyval a) {
  int i;
  for (i = s->len; i--; ) {
    if (keyval_equal(a, s->buf[i])) return i;
  }
  return -1;
}

/* ********************************************************************** */
/* Global Environment */
/* ********************************************************************** */

#if TRACK_USAGES
static int global_max;
#endif

static keyval globalbuf[GLOBAL_MAX*2];
#if TRACK_USAGES
static stack global = { GLOBAL_MAX*2, 0, 0, globalbuf };
#else
static stack global = { GLOBAL_MAX*2, 0, globalbuf };
#endif

#define OPER   (&e->oper)
#define SCOPE  (&e->scope)
#define EXEC   (&e->exec)
#define GLOBAL (&global)

/* ********************************************************************** */
/* Scope Stack */
/* ********************************************************************** */

static keyret scope_push(keyenv * e) {
  Q(stk_push(SCOPE, keyval_mark()));
  return stk_push(SCOPE, keyval_mark());
}
static void scope_pop(keyenv * e) {
  stk_set_length(SCOPE, stk_find_mark(SCOPE));
  stk_pop(SCOPE);
}

static int scope_find(const stack * s, const char * name, keyval ** valp) {
  int i;
  for (i = s->len - 2; i >= 0 && s->buf[i].type != KEY_MARK; i -= 2) {
    if (STREQ(s->buf[i].sval, name)) { *valp = &s->buf[i+1]; return 1; }
  }
  if (i > 0) { /* if scanning multi-scoped stack, check file scope */
    for (i = 2; i < s->len && s->buf[i].type != KEY_MARK; i += 2) {
      if (STREQ(s->buf[i].sval, name)) { *valp = &s->buf[i+1]; return 1; }
    }
  }
  return 0;
}
static int scope_find_full(const keyenv * e, const char * name, keyval ** valp) {
  return scope_find(SCOPE, name, valp) || scope_find(GLOBAL, name, valp);
}

static keyret scope_load(const keyenv * e, const char * name, keyval * valp) {
  keyval * p;
  if (!scope_find_full(e, name, &p)) return key_error("'%s' not defined", name);
  *valp = *p;
  return KEY_OK;
}
static keyret scope_store(keyenv * e, const char * name, keyval val) {
  keyval * p;
  if (!scope_find_full(e, name, &p)) return key_error("'%s' not defined", name);
  *p = val;
  return KEY_OK;
}

static keyret scope_make_(stack * s, const char * name, keyval val) {
  Q(stk_push(s, keyval_str(name)));
  return stk_push(s, val);
}
static keyret scope_gdef(const char * name, keyval val) {
  keyval * valp;
  if (scope_find(GLOBAL, name, &valp)) return key_error("'%s' redeclared", name);
#if TRACK_USAGES
  global_max++;
#endif
  return scope_make_(GLOBAL, name, val);
}
static keyret scope_def(keyenv * e, const char * name, keyval val) {
  keyval * valp;
  if (scope_find_full(e, name, &valp)) return key_error("'%s' redeclared", name);
  return scope_make_(SCOPE, name, val);
}

/* ********************************************************************** */
/* Bytecode Function to Execute a Bytecode Array */
/* ********************************************************************** */

static keyret
bcode_proc_next(keyenv * e)
{
  int i = stk_get(EXEC, 2).ival; /* 1:body, 2:idx */
  keyval * proc = stk_get(EXEC, 1).fval;
  keyval elem = proc[i++];
  if (elem.type == KEY_END || proc[i].type == KEY_END) {
    stk_drop(EXEC, 2);
  } else {
    stk_set(EXEC, 2, keyval_int(i));
    Q(stk_push(EXEC, keyval_bcode(bcode_proc_next)));
  }
  return stk_push(EXEC, elem);
}

/* both fn(){} and conditional expressions/statements */
static keyret
exec_func(keyenv * e, keyval t) /* t.type == KEY_FUNC */
{
  Q(stk_push(EXEC, keyval_int(0)));
  Q(stk_push(EXEC, t));
  return stk_push(EXEC, keyval_bcode(bcode_proc_next));
}

/* ********************************************************************** */
/* Bytecode Functions */
/* ********************************************************************** */

#define BCODE_INFIX(NAME,EXPR) \
static keyret NAME (keyenv * e) { /* val val -> val */ \
  keyval b = stk_pop(OPER); \
  keyval a = stk_pop(OPER); \
  Q(key_type_require(a, KEY_INT)); \
  Q(key_type_require(b, KEY_INT)); \
  return stk_push(OPER, keyval_int(EXPR)); \
}
BCODE_INFIX(bcode_add, a.ival + b.ival)
BCODE_INFIX(bcode_sub, a.ival - b.ival)
BCODE_INFIX(bcode_mul, a.ival * b.ival)
BCODE_INFIX(bcode_div, a.ival / b.ival)
BCODE_INFIX(bcode_mod, a.ival % b.ival)
BCODE_INFIX(bcode_and, a.ival & b.ival)
BCODE_INFIX(bcode_or,  a.ival | b.ival)
BCODE_INFIX(bcode_xor, a.ival ^ b.ival)
BCODE_INFIX(bcode_lsh, a.ival << b.ival)
BCODE_INFIX(bcode_rsh, (int)(((signed)a.ival) >> b.ival))
BCODE_INFIX(bcode_ush, (int)(((unsigned)a.ival) >> b.ival))

#define BCODE_CMP(NAME,OP) \
static keyret NAME (keyenv * e) { /* val val -> val */ \
  keyval b = stk_pop(OPER); \
  keyval a = stk_pop(OPER); \
  int r = 0; \
  if (a.type == KEY_INT) { \
    if (b.type == KEY_INT) r = a.ival OP b.ival; \
    else return key_type_error(b); \
  } else if (a.type == KEY_STR) { \
    if (b.type == KEY_STR) r = strcmp(a.sval, b.sval) OP 0; \
    else return key_type_error(b); \
  } else { \
    return key_type_error(a); \
  } \
  return stk_push(OPER, keyval_int(r)); \
}
BCODE_CMP(bcode_gt, > )
BCODE_CMP(bcode_lt, < )
BCODE_CMP(bcode_ge, >= )
BCODE_CMP(bcode_le, <= )

#define BCODE_EQUAL(NAME,OP) \
static keyret NAME (keyenv * e) { /* val val -> val */ \
  keyval b = stk_pop(OPER); \
  keyval a = stk_pop(OPER); \
  return stk_push(OPER, keyval_int(keyval_equal(a, b) OP 1)); \
}
BCODE_EQUAL(bcode_eq, ==)
BCODE_EQUAL(bcode_ne, !=)

#define BCODE_TYPEIS(NAME,OP) \
static keyret NAME (keyenv * e) { /* val val -> int */ \
  keyval b = stk_pop(OPER); \
  const char * type = keyval_typename(stk_pop(OPER).type); \
  int r; \
  Q(key_type_require(b, KEY_STR)); \
  r = STREQ(type, b.sval) OP 1; \
  return stk_push(OPER, keyval_int(r)); \
}
BCODE_TYPEIS(bcode_is, ==)
BCODE_TYPEIS(bcode_isnot, !=)

#define BCODE_PREFIX(NAME,EXPR) \
static keyret NAME (keyenv * e) { /* val -> val */ \
  keyval a = stk_pop(OPER); \
  Q(key_type_require(a, KEY_INT)); \
  return stk_push(OPER, keyval_int(EXPR)); \
}
BCODE_PREFIX(bcode_not, ~a.ival)
BCODE_PREFIX(bcode_neg, -a.ival)

static keyret bcode_lognot(keyenv * e) { /* val -> int */
  keyval a = stk_pop(OPER);
  return stk_push(OPER, keyval_int(!keyval_tobool(a)));
}
static keyret bcode_isdef(keyenv * e) { /* val -> int */
  keyval a = stk_pop(OPER);
  return stk_push(OPER, keyval_int(a.type != KEY_UNDEF));
}
static keyret bcode_typeof(keyenv * e) { /* val -> str */
  keytype type = stk_pop(OPER).type;
  return stk_push(OPER, keyval_str(keyval_typename(type)));
}

#define BCODE_SHORTFIX(NAME,EXPR) \
static keyret NAME (keyenv * e) { /* val proc -> val */ \
  keyval b = stk_pop(OPER); \
  keyval a = stk_pop(OPER); \
  if (EXPR) return exec_func(e, b); \
  return stk_push(OPER, a); \
}
BCODE_SHORTFIX(bcode_logand, keyval_tobool(a) )
BCODE_SHORTFIX(bcode_logor,  !keyval_tobool(a) )
BCODE_SHORTFIX(bcode_coal,   a.type == KEY_UNDEF )

static keyret bcode_load(keyenv * e) { /* str -> val */
  keyval a;
  Q(scope_load(e, stk_pop(OPER).sval, &a));
  return stk_push(OPER, a);
}
static keyret bcode_assign(keyenv * e) { /* val str -> val */
  const char * name = stk_pop(OPER).sval;
  keyval val = stk_peek(OPER);
  return scope_store(e, name, val);
}
static keyret bcode_var(keyenv * e) { /* val|proc str -> - */
  const char * name = stk_pop(OPER).sval;
  keyval val = stk_pop(OPER);
  return scope_def(e, name, val);
}

static keyret bcode_dup(keyenv * e) { /* any -> any any */
  return stk_push(OPER, stk_peek(OPER));
}
static keyret bcode_index(keyenv * e) { /* any ... n -> any ... n any */
  return stk_push(OPER, stk_get(OPER, stk_peek(OPER).ival + 1));
}
static keyret bcode_pop(keyenv * e) { /* any -> - */
  stk_drop(OPER, 1);
  return KEY_OK;
}
static keyret bcode_popexec(keyenv * e) { /* - -> - */
  /* used for storing function names on the exec stack */
  stk_drop(EXEC, 1);
  return KEY_OK;
}

static keyret bcode_if(keyenv * e) { /* val proc -> - */
  keyval t = stk_pop(OPER);
  keyval c = stk_pop(OPER);
  if (keyval_tobool(c)) return exec_func(e, t);
  return KEY_OK;
}
static keyret bcode_ifelse(keyenv * e) { /* val proc proc -> - */
  keyval f = stk_pop(OPER);
  keyval t = stk_pop(OPER);
  keyval c = stk_pop(OPER);
  if (keyval_tobool(c)) return exec_func(e, t);
  return exec_func(e, f);
}

static keyret bcode_endcall(keyenv * e) { /* - -> undef */
  /* mark end-of-function on stack, or return without a 'return' */
  scope_pop(e);
  return stk_push(OPER, keyval_undef());
}
static keyret bcode_return(keyenv * e) { /* val -> val */
  /* pop exec stack up to and including endcall */
  int i = stk_find(EXEC, keyval_bcode(bcode_endcall));
  stk_set_length(EXEC, i);
  scope_pop(e);
  return KEY_OK;
}
static keyret bcode_call(keyenv * e) { /* vals...N fn -> vals...N || rv */
  keyval proc = stk_pop(OPER);
  if (proc.type == KEY_NAT) {
    int argc = stk_pop(OPER).ival;
    keyval rv = keyval_undef();
    keyret err = proc.eval(e, &rv, argc, stk_ptr(OPER, argc));
    stk_drop(OPER, argc);
    stk_push(OPER, rv);
    return err;
  }
  if (proc.type == KEY_FUNC) {
    Q(stk_push(EXEC, proc.fval[0])); /* name, for stack tracing */
    Q(stk_push(EXEC, keyval_bcode(bcode_popexec)));
    Q(stk_push(EXEC, keyval_bcode(bcode_endcall)));
    Q(scope_push(e));
    return exec_func(e, proc);
  }
  return key_type_error(proc);
}
static keyret bcode_varargs(keyenv * e) { /* vals...N names...N -> - */
  int nlen = stk_get(OPER, 1).ival;
  keyval * names = stk_ptr(OPER, nlen + 1);
  int vlen = stk_get(OPER, nlen + 2).ival;
  keyval * vals = stk_ptr(OPER, nlen + 2 + vlen);
  keyval rname = names[nlen - 1];
  int rlen = vlen >= nlen ? vlen - (nlen - 1) : 0;
  int i;
  for (i = 0; i < nlen - 1 && i < vlen; ++i) {
    Q(scope_def(e, names[i].sval, vals[i]));
  }
  for ( ; i < nlen - 1; ++i) {
    Q(scope_def(e, names[i].sval, keyval_undef()));
  }
  stk_drop(OPER, nlen + 2); /* stack: vals... rvals... */
  if (rlen) memmove(vals, vals + vlen - rlen, (size_t)rlen * sizeof(keyval));
  stk_drop(OPER, (vlen - rlen));
  Q(stk_push(OPER, keyval_int(rlen))); /* stack: rvals... rlen */
  /* var rname = __array__(rlen, rvals); */
  Q(stk_push(OPER, keyval_str("__array__")));
  Q(stk_push(EXEC, keyval_bcode(bcode_var)));
  Q(stk_push(EXEC, rname));
  Q(stk_push(EXEC, keyval_bcode(bcode_call)));
  return bcode_load(e);
}
static keyret bcode_defargs(keyenv * e) { /* vals...N names...N -> - */
  int nlen = stk_get(OPER, 1).ival;
  keyval * names = stk_ptr(OPER, nlen + 1);
  int vlen = stk_get(OPER, nlen + 2).ival;
  keyval * vals = stk_ptr(OPER, nlen + 2 + vlen);
  int i;
  for (i = 0; i < nlen && i < vlen; ++i) {
    Q(scope_def(e, names[i].sval, vals[i]));
  }
  for ( ; i < nlen; ++i) {
    Q(scope_def(e, names[i].sval, keyval_undef()));
  }
  stk_drop(OPER, nlen + 2 + vlen);
  return KEY_OK;
}

static keyret bcode_break_mark(keyenv * e) { e = e; return KEY_OK; }
static keyret bcode_continue_mark(keyenv * e) { e = e; return KEY_OK; }
static keyret bcode_loop_cond(keyenv * e);
static keyret bcode_loop_inc(keyenv * e);
static keyret bcode_break(keyenv * e) {
  stk_set_length(EXEC, stk_find(EXEC, keyval_bcode(bcode_break_mark)));
  return KEY_OK;
}
static keyret bcode_continue(keyenv * e) {
  /* pop until the loop, keep the continue-mark, continue with the cond */
  stk_set_length(EXEC, stk_find(EXEC, keyval_bcode(bcode_continue_mark)) + 1);
  return stk_push(EXEC, keyval_bcode(bcode_loop_inc));
}
static keyret bcode_loop_inc(keyenv * e) {
  /* queue inc,cond for exec */
  keyval inc = stk_get(EXEC, 3); /* 1: continue, 2:cond, 3:inc, 4:body, 5:break */
  Q(stk_push(EXEC, keyval_bcode(bcode_loop_cond)));
  return exec_func(e, inc);
}
static keyret bcode_loop_body(keyenv * e) { /* val -> - */
  /* queue body,inc for exec */
  keyval body = stk_get(EXEC, 4); /* 1: continue, 2:cond, 3:inc, 4:body, 5:break */
  int pred = keyval_tobool(stk_pop(OPER));
  if (pred) {
    Q(stk_push(EXEC, keyval_bcode(bcode_loop_inc)));
    return exec_func(e, body);
  }
  stk_drop(EXEC, 4);
  return KEY_OK;
}
static keyret bcode_loop_cond(keyenv * e) { /* - -> val */
  /* queue cond,body for exec */
  keyval cond = stk_get(EXEC, 2); /* 1: continue, 2:cond, 3:inc, 4:body, 5:break */
  Q(stk_push(EXEC, keyval_bcode(bcode_loop_body)));
  return exec_func(e, cond);
}
static keyret bcode_doloop(keyenv * e) {
  Q(stk_push(EXEC, keyval_bcode(bcode_break_mark)));
  Q(stk_push(EXEC, stk_pop(OPER))); /* body */
  Q(stk_push(EXEC, stk_pop(OPER))); /* inc */
  Q(stk_push(EXEC, stk_pop(OPER))); /* cond */
  Q(stk_push(EXEC, keyval_bcode(bcode_continue_mark)));
  Q(stk_push(EXEC, keyval_bcode(bcode_loop_inc)));
  return exec_func(e, stk_get(EXEC, 5));
}
static keyret bcode_loop(keyenv * e) {
  Q(stk_push(EXEC, keyval_bcode(bcode_break_mark)));
  Q(stk_push(EXEC, stk_pop(OPER))); /* body */
  Q(stk_push(EXEC, stk_pop(OPER))); /* inc */
  Q(stk_push(EXEC, stk_pop(OPER))); /* cond */
  Q(stk_push(EXEC, keyval_bcode(bcode_continue_mark)));
  return stk_push(EXEC, keyval_bcode(bcode_loop_cond));
}

/* ********************************************************************** */
/* Script Environment */
/* ********************************************************************** */

void
keyenv_reset(keyenv * e)
{
  stack * s = SCOPE;
  int i;
  for (i = 2; i < s->len && s->buf[i].type != KEY_MARK; i += 2) {
    if (s->buf[i].type == KEY_MARK) { s->len = i; break; }
  }
  OPER->len = 0;
  EXEC->len = 0;
}

int
keyenv_running(const keyenv * e)
{
  return e->exec.len > 0;
}

keyret
keyenv_run(keyenv * e)
{
  keyret err = KEY_OK;
  while (stk_length(EXEC) && err == KEY_OK) {
    keyval a = stk_pop(EXEC);
    if (a.type == KEY_BCODE) {
      err = a.bval(e);
    } else {
      err = stk_push(OPER, a);
    }
  }
  return err;
}

void
keyenv_resume(keyenv * e, keyval rv)
{
  stk_set(OPER, 1, rv);
}

keyret
keyenv_pop(keyenv * e, keyval * rv)
{
  if (stk_length(OPER) == 0) *rv = keyval_undef();
  else *rv = stk_pop(OPER);
  return KEY_OK;
}

keyret
keyenv_push(keyenv * e, const char * name, int argc, const keyval * argv)
{
  int i;
  Q(key_intern(&name, name));
  for (i = 0; i < argc; ++i) Q(stk_push(OPER, argv[i]));
  Q(stk_push(OPER, keyval_int(argc)));
  Q(stk_push(OPER, keyval_str(name)));
  Q(stk_push(EXEC, keyval_bcode(bcode_call)));
  return stk_push(EXEC, keyval_bcode(bcode_load));
}

keyret
keyenv_interrupt(keyenv * e, const char * name, int argc, const keyval * argv)
{
  /* interrupts don't have return values */
  Q(stk_push(EXEC, keyval_bcode(bcode_pop)));
  return keyenv_push(e, name, argc, argv);
}

static keyret
bcode_pause(keyenv * e)
{
  e = e; return KEY_PAUSE;
}

keyret
keyenv_callback(keyenv * e, keyval * rv, keyval func, int argc, const keyval * argv)
{
  /* call immediately, stop when done, and pop retval */
  keyret err;
  int i;
  for (i = 0; i < argc; ++i) Q(stk_push(OPER, argv[i]));
  Q(stk_push(OPER, keyval_int(argc)));
  Q(stk_push(OPER, func));
  Q(stk_push(EXEC, keyval_bcode(bcode_pause)));
  Q(stk_push(EXEC, keyval_bcode(bcode_call)));
  err = keyenv_run(e);
  if (err != KEY_PAUSE) return err;
  return keyenv_pop(e, rv);
}

#define SIZEOF_KEYENV  (sizeof(keyenv) + ( \
    (OPER_DEPTH + SCOPE_DEPTH + EXEC_DEPTH) * sizeof(keyval) ))

keyret
keyenv_new(keyenv ** ep, const char * src, const char * fname, int line)
{
  keyenv * e;
  keyval proc;
  e = *ep = calloc(1, SIZEOF_KEYENV);
  if (!e) { perror("keyenv_new"); exit(2); }
  e->oper.buf = e->buf; e->oper.cap = OPER_DEPTH;
  e->scope.buf = e->oper.buf + OPER_DEPTH; e->scope.cap = SCOPE_DEPTH;
  e->exec.buf = e->scope.buf + SCOPE_DEPTH; e->exec.cap = EXEC_DEPTH;
  Q(compiler_compile(&e->root, &proc, src, fname, line));
  Q(scope_push(e));
  return exec_func(e, proc);
}

#if TRACK_USAGES
static int oper_max;
static int scope_max;
static int exec_max;
#endif

void
keyenv_delete(keyenv * e)
{
  if (e) {
#if TRACK_USAGES
    if (oper_max < OPER->max) oper_max = OPER->max;
    if (scope_max < SCOPE->max) scope_max = SCOPE->max;
    if (exec_max < EXEC->max) exec_max = EXEC->max;
#endif
    if (e->root) {
      free(e->root);
      e->root = NULL;
    }
    free(e);
  }
}

size_t
keyenv_stack_trace(const keyenv * e, char * buf, size_t buflen)
{
  keyval mark = keyval_bcode(bcode_popexec);
  const stack * s = EXEC;
  size_t n = 0;
  int i;
#define BUF     (buf ? buf + n : buf)
#define BUFLEN  (buflen > n ? buflen - n : 0)
  for (i = 0; i < s->len; ++i) {
    if (keyval_equal(s->buf[i], mark)) {
      keyval name = s->buf[i - 1];
      if (name.type == KEY_STR) {
        n += (size_t)snprintf(BUF, BUFLEN, "in %s:\n", name.sval);
      } else {
        n += (size_t)snprintf(BUF, BUFLEN, "in <unknown>:\n");
      }
    }
  }
  if (buflen) buf[buflen - 1] = '\0';
  return n;
#undef BUFLEN
#undef BUF
}

int
keyenv_has(const keyenv * e, const char * name)
{
  keyval * p;
  return scope_find(SCOPE, name, &p);
}

keyret
keyenv_get(const keyenv * e, const char * name, keyval * valp)
{
  keyval * p;
  if (!scope_find(SCOPE, name, &p)) return key_error("'%s' not defined", name);
  *valp = *p;
  return KEY_OK;
}

keyret
keyenv_set(keyenv * e, const char * name, keyval val)
{
  keyval * p;
  if (!scope_find(SCOPE, name, &p)) return key_error("'%s' not defined", name);
  *p = val;
  return KEY_OK;
}

keyret
keyenv_def(keyenv * e, const char * name, keyval val)
{
  Q(key_intern(&name, name));
  return scope_def(e, name, val);
}

/* ********************************************************************** */
/* Global Environment */
/* ********************************************************************** */

int
key_global_has(const char * name)
{
  keyval * p;
  return scope_find(GLOBAL, name, &p);
}

keyret
key_global_get(const char * name, keyval * valp)
{
  keyval * p;
  if (!scope_find(GLOBAL, name, &p)) return key_error("'%s' not defined", name);
  *valp = *p;
  return KEY_OK;
}

keyret
key_global_set(const char * name, keyval val)
{
  keyval * p;
  if (!scope_find(GLOBAL, name, &p)) return key_error("'%s' not defined", name);
  *p = val;
  return KEY_OK;
}

keyret
key_global_def(const char * name, keyval val)
{
  Q(key_intern(&name, name));
  return scope_gdef(name, val);
}

keyret
key_global_fndef(const char * name, key_native_fn eval)
{
  Q(key_intern(&name, name));
  return scope_gdef(name, keyval_native(eval));
}

/* ********************************************************************** */
/* Default Functions */
/* ********************************************************************** */

keyret
key_default_fail(keyenv * e, keyval * rv, int argc, const keyval * argv)
{
  char * p = key_errmsg;
  char * endp = ERRMSG_LIMIT;
  int i;
  for (i = 0; i < argc; ++i) {
    keyval a = argv[i];
    if (a.type == KEY_INT) {
      p += snprintf(p, (size_t)(endp - p), "%d", a.ival);
    } else if (a.type == KEY_STR) {
      p += snprintf(p, (size_t)(endp - p), "%s", a.sval);
    } else if (a.type == KEY_UNDEF) {
      p += snprintf(p, (size_t)(endp - p), "undef");
    } else {
      p += snprintf(p, (size_t)(endp - p), "<%s:%p>",
                    keyval_typename(a.type), a.pval);
    }
  }
  *(endp - 1) = '\0';
  e = e; rv = rv; return KEY_ERROR;
}

keyret
key_default_debug(keyenv * e, keyval * rv, int argc, const keyval * argv)
{
  int i;
  for (i = 0; i < argc; ++i) {
    keyval a = argv[i];
    if (a.type == KEY_INT) fprintf(stderr, "%d", a.ival);
    else if (a.type == KEY_STR) fprintf(stderr, "%s", a.sval);
    else if (a.type == KEY_UNDEF) fprintf(stderr, "<undef>");
    else fprintf(stderr, "<%s:%p>", keyval_typename(a.type), a.pval);
  }
  fprintf(stderr, "\n");
  fflush(stderr);
  e = e; rv = rv; return KEY_OK;
}

keyret
key_default_trace(keyenv * e, keyval * rv, int argc, const keyval * argv)
{
  char buf[1024];
  keyenv_stack_trace(e, buf, sizeof(buf));
  fprintf(stderr, "%s", buf);
  fflush(stderr);
  rv = rv; argc = argc; argv = argv; return KEY_OK;
}

keyret
key_default_pause(keyenv * e, keyval * rv, int argc, const keyval * argv)
{
  e = e; rv = rv; argc = argc; argv = argv;
  return KEY_PAUSE;
}

keyret
key_global_defaults(void)
{
  static int inited = 0;
  if (inited) return KEY_OK;
  Q(key_global_fndef("debug", key_default_debug));
  Q(key_global_fndef("fail", key_default_fail));
  Q(key_global_fndef("trace", key_default_trace));
  Q(key_global_fndef("pause", key_default_pause));
  inited = 1;
  return KEY_OK;
}

/* ********************************************************************** */
/* Debugging Functions */
/* ********************************************************************** */

void
key_print_stats(void)
{
  printf("sizeof keyenv: %zu\n", SIZEOF_KEYENV);
#if TRACK_USAGES
  printf("internment room: %zu bytes (%zu KB)\n", intern_max, (intern_max + 1023) / 1024);
  printf("global variable count: %d\n", global_max);
  printf("oper stack length: %d\n", oper_max);
  printf("scope stack length: %d\n", scope_max);
  printf("exec stack length: %d\n", exec_max);
#endif
}

/* ********************************************************************** */
/* Basic Interpreter (Test Harness) */
/* ********************************************************************** */

#ifdef TEST

static void print_proc(keyval * proc);
static void print_one(keyval a) {
  switch (a.type) {
    case KEY_END:   printf("$"); break;
    case KEY_MARK:  printf("@"); break;
    case KEY_UNDEF: printf("undef"); break;
    case KEY_INT:   printf("(%d)", a.ival); break;
    case KEY_STR: {
      char ebuf[512];
      key_escape(ebuf, 512, a.sval);
      printf("\"%s\"", ebuf);
      break;
    }
    case KEY_FUNC:  printf("{ "); print_proc(a.fval); printf("}"); break;
    case KEY_NAT:   printf("<native:%p>", a.pval); break; /* can't cast ptr-to-func, so we cheat */
    case KEY_BCODE: printf("<bcode:%p>", a.pval); break;
    default: {
      printf("<%s:%p>", keyval_typename(a.type), a.pval);
      break;
    }
  }
}
static void
print_proc(keyval * proc)
{
  int i;
  if (!proc) { printf("<nullproc>"); return; }
  for (i = 0; proc[i].type != KEY_END && i < 9999; ++i) {
    print_one(proc[i]);
    printf(" ");
  }
  if (i >= 9999) printf("\nerror: end not found\n");
  fflush(stdout);
}

#define SCRIPT_LEN  (32 * 1024)
static char scriptbuf[SCRIPT_LEN];

static void
freadall(FILE * fp)
{
  size_t len = fread(scriptbuf, sizeof(char), SCRIPT_LEN - 1, fp);
  scriptbuf[len] = '\0';
}

static keyret
runall(keyenv * e)
{
  int i = 0;
  keyret err;
  while ((err = keyenv_run(e)) == KEY_PAUSE) {
    keyenv_resume(e, keyval_int(i++));
  }
  return err;
}

#define arrlength  (32)
static keytype arrtype;
static int arrvalue[arrlength];

static keyret
cb_member(keyenv * e, keyval * rv, int argc, const keyval * argv)
{
  int idx;
  int * arr;

#if 0
  printf("member:");
  if (argc > 0) { printf(" "); print_one(argv[0]); }
  if (argc > 1) { printf(" "); print_one(argv[1]); }
  if (argc > 2) { printf(" "); print_one(argv[2]); }
  if (argc > 3) { printf(" "); print_one(argv[3]); }
  printf("\n");
#endif

  Q(key_type_require(argv[0], arrtype));
  arr = argv[0].pval;

  if (argv[1].type == KEY_STR) {
    if (!strcmp(argv[1].sval, "memberfunc") ||
        !strcmp(argv[1].sval, "sort")) {
      if (keyenv_get(e, argv[1].sval, rv) == KEY_OK) return KEY_OK;
      return key_global_get(argv[1].sval, rv);
    }
  }

  if (argv[1].type == KEY_INT) idx = argv[1].ival;
  else if (argv[1].type == KEY_STR) idx = argv[1].sval[0] - 'a';
  else return key_type_error(argv[1]);

  if (argc == 3) {
    Q(key_type_require(argv[2], KEY_INT));
    arr[idx] = argv[2].ival;
  }
  *rv = keyval_int(arr[idx]);
  return KEY_OK;
}

static keyret
cb_sort(keyenv * e, keyval * rv, int argc, const keyval * argv)
{
  /* test callbacks by sorting an array */
  keyval cmp;
  int * arr;
  int len;
  int i;
  int j;

#if 0
  printf("sort:");
  if (argc > 0) { printf(" "); print_one(argv[0]); }
  if (argc > 1) { printf(" "); print_one(argv[1]); }
  if (argc > 2) { printf(" "); print_one(argv[2]); }
  if (argc > 3) { printf(" "); print_one(argv[3]); }
  printf("\n");
#endif

#define SWAP(A,I,J) do{ \
  int t_ = (A)[(I)]; \
  (A)[(I)] = (A)[(J)]; \
  (A)[(J)] = t_; \
}while(0)
  if (argc < 3) return key_error("missing argument to sort\n");

  Q(key_type_require(argv[0], arrtype));
  arr = argv[0].pval;
  Q(key_type_require(argv[1], KEY_INT));
  len = argv[1].ival;
  Q(key_type_require_fn(argv[2]));
  cmp = argv[2];

  for (i = 1; i < len; ++i) { /* simple insertion sort */
    for (j = i; j > 0; --j) {
      keyval ab[2] = { keyval_int(arr[j - 1]), keyval_int(arr[j]) };
      keyval crv;
      Q(keyenv_callback(e, &crv, cmp, 2, ab));
      if (crv.ival <= 0) break;
      SWAP(arr, j, j - 1);
    }
  }
#undef SWAP
  rv = rv; return KEY_OK;
}

#define QE(EX) do{ if ((EX) != KEY_OK) goto errorL; }while(0)

static void
run(const char * src, const char * fname)
{
  keyret err;
  keyval a;
  keyenv * e = NULL;

  arrtype = keyval_custom_type("array");
  QE(key_global_fndef("__member__", cb_member));
  QE(key_global_fndef("sort", cb_sort));
  QE(key_global_def("ARRAY", keyval_custom(arrtype, arrvalue)));
  QE(key_global_defaults());

  QE(keyenv_new(&e, src, fname, 1));
  while ((err = keyenv_run(e)) == KEY_PAUSE) /**/;
  QE(err);

  QE(keyenv_push(e, "main", 0, NULL));
  if ((err = runall(e)) == KEY_OK) {
    QE(keyenv_pop(e, &a));
    print_one(a);
    printf("\n");
    fflush(stdout);
  } else {
errorL:;
    char buf[1024] = "";
    if (e) keyenv_stack_trace(e, buf, sizeof(buf));
    fprintf(stderr, "%serror: %s\n", buf, key_errmsg);
    fflush(stderr);
  }
  if (e) keyenv_delete(e);
}

int
main(int argc, char ** argv)
{
  const char * fname = "<stdin>";
  FILE * fp;
  if (argc > 1) {
    fname = argv[1];
    fp = fopen(fname, "r");
    if (!fp) { perror("main"); exit(2); }
    freadall(fp);
    fclose(fp);
  } else {
    freadall(stdin);
  }
  run(scriptbuf, fname);
  key_print_stats();
  return 0;
}

#endif /* TEST */

/* ********************************************************************** */
/* ********************************************************************** */