text: /*
  ** Copyright (c) 2019 rxi
  **
  ** Permission is hereby granted, free of charge, to any person obtaining a copy
  ** of this software and associated documentation files (the "Software"), to
  ** deal in the Software without restriction, including without limitation the
  ** rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  ** sell copies of the Software, and to permit persons to whom the Software is
  ** furnished to do so, subject to the following conditions:
  **
  ** The above copyright notice and this permission notice shall be included in
  ** all copies or substantial portions of the Software.
  **
  ** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ** IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ** AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  ** FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
  ** IN THE SOFTWARE.
  */
  
  #include <string.h>
  #include "fe.h"
  
  #define unused(x)     ( (void) (x) )
  #define car(x)        ( (x)->car.o )
  #define cdr(x)        ( (x)->cdr.o )
  #define tag(x)        ( (x)->car.c )
  #define isnil(x)      ( (x) == &nil )
  #define type(x)       ( tag(x) & 0x1 ? tag(x) >> 2 : FE_TPAIR )
  #define settype(x,t)  ( tag(x) = (t) << 2 | 1 )
  #define number(x)     ( (x)->cdr.n )
  #define prim(x)       ( (x)->cdr.c )
  #define cfunc(x)      ( (x)->cdr.f )
  #define strbuf(x)     ( &(x)->car.c + 1 )
  
  #define STRBUFSIZE    ( (int) sizeof(fe_Object*) - 1 )
  #define GCMARKBIT     ( 0x2 )
  #define GCSTACKSIZE   ( 256 )
  
  
  enum {
   P_LET, P_SET, P_IF, P_FN, P_MAC, P_WHILE, P_QUOTE, P_AND, P_OR, P_DO, P_CONS,
   P_CAR, P_CDR, P_SETCAR, P_SETCDR, P_LIST, P_NOT, P_IS, P_ATOM, P_PRINT, P_LT,
   P_LTE, P_ADD, P_SUB, P_MUL, P_DIV, P_MAX
  };
  
  static const char *primnames[] = {
    "let", "=", "if", "fn", "mac", "while", "quote", "and", "or", "do", "cons",
    "car", "cdr", "setcar", "setcdr", "list", "not", "is", "atom", "print", "<",
    "<=", "+", "-", "*", "/"
  };
  
  static const char *typenames[] = {
    "pair", "free", "nil", "number", "symbol", "string",
    "func", "macro", "prim", "cfunc", "ptr"
  };
  
  typedef union { fe_Object *o; fe_CFunc f; fe_Number n; char c; } Value;
  
  struct fe_Object { Value car, cdr; };
  
  struct fe_Context {
    fe_Handlers handlers;
    fe_Object *gcstack[GCSTACKSIZE];
    int gcstack_idx;
    fe_Object *objects;
    int object_count;
    fe_Object *calllist;
    fe_Object *freelist;
    fe_Object *symlist;
    fe_Object *t;
    int nextchr;
  };
  
  static fe_Object nil = {{ (void*) (FE_TNIL << 2 | 1) }, { NULL }};
  
  
  fe_Handlers* fe_handlers(fe_Context *ctx) {
    return &ctx->handlers;
  }
  
  
  void fe_error(fe_Context *ctx, const char *msg) {
    fe_Object *cl = ctx->calllist;
    /* reset context state */
    ctx->calllist = &nil;
    /* do error handler */
    if (ctx->handlers.error) { ctx->handlers.error(ctx, msg, cl); }
    /* error handler returned -- print error and traceback, exit */
    fprintf(stderr, "error: %s\n", msg);
    for (; !isnil(cl); cl = cdr(cl)) {
      char buf[64];
      fe_tostring(ctx, car(cl), buf, sizeof(buf));
      fprintf(stderr, "=> %s\n", buf);
    }
    exit(EXIT_FAILURE);
  }
  
  
  fe_Object* fe_nextarg(fe_Context *ctx, fe_Object **arg) {
    fe_Object *a = *arg;
    if (type(a) != FE_TPAIR) {
      if (isnil(a)) { fe_error(ctx, "too few arguments"); }
      fe_error(ctx, "dotted pair in argument list");
    }
    *arg = cdr(a);
    return car(a);
  }
  
  
  static fe_Object* checktype(fe_Context *ctx, fe_Object *obj, int type) {
    char buf[64];
    if (type(obj) != type) {
      sprintf(buf, "expected %s, got %s", typenames[type], typenames[type(obj)]);
      fe_error(ctx, buf);
    }
    return obj;
  }
  
  
  int fe_type(fe_Context *ctx, fe_Object *obj) {
    unused(ctx);
    return type(obj);
  }
  
  
  int fe_isnil(fe_Context *ctx, fe_Object *obj) {
    unused(ctx);
    return isnil(obj);
  }
  
  
  void fe_pushgc(fe_Context *ctx, fe_Object *obj) {
    if (ctx->gcstack_idx == GCSTACKSIZE) {
      fe_error(ctx, "gc stack overflow");
    }
    ctx->gcstack[ctx->gcstack_idx++] = obj;
  }
  
  
  void fe_restoregc(fe_Context *ctx, int idx) {
    ctx->gcstack_idx = idx;
  }
  
  
  int fe_savegc(fe_Context *ctx) {
    return ctx->gcstack_idx;
  }
  
  
  void fe_mark(fe_Context *ctx, fe_Object *obj) {
    fe_Object *car;
  begin:
    if (tag(obj) & GCMARKBIT) { return; }
    car = car(obj); /* store car before modifying it with GCMARKBIT */
    tag(obj) |= GCMARKBIT;
  
    switch (type(obj)) {
      case FE_TPAIR:
        fe_mark(ctx, car);
        /* fall through */
      case FE_TFUNC: case FE_TMACRO: case FE_TSYMBOL: case FE_TSTRING:
        obj = cdr(obj);
        goto begin;
  
      case FE_TPTR:
        if (ctx->handlers.mark) { ctx->handlers.mark(ctx, obj); }
        break;
    }
  }
  
  
  static void collectgarbage(fe_Context *ctx) {
    int i;
    /* mark */
    for (i = 0; i < ctx->gcstack_idx; i++) {
      fe_mark(ctx, ctx->gcstack[i]);
    }
    fe_mark(ctx, ctx->symlist);
    /* sweep and unmark */
    for (i = 0; i < ctx->object_count; i++) {
      fe_Object *obj = &ctx->objects[i];
      if (type(obj) == FE_TFREE) { continue; }
      if (~tag(obj) & GCMARKBIT) {
        if (type(obj) == FE_TPTR && ctx->handlers.gc) {
          ctx->handlers.gc(ctx, obj);
        }
        settype(obj, FE_TFREE);
        cdr(obj) = ctx->freelist;
        ctx->freelist = obj;
      } else {
        tag(obj) &= ~GCMARKBIT;
      }
    }
  }
  
  
  static int equal(fe_Object *a, fe_Object *b) {
    if (a == b) { return 1; }
    if (type(a) != type(b)) { return 0; }
    if (type(a) == FE_TNUMBER) { return number(a) == number(b); }
    if (type(a) == FE_TSTRING) {
      for (; !isnil(a) && !isnil(b); a = cdr(a), b = cdr(b)) {
        if (car(a) != car(b)) { return 0; }
      }
      return isnil(a) && isnil(b);
    }
    return 0;
  }
  
  
  static int streq(fe_Object *obj, const char *str) {
    while (!isnil(obj)) {
      int i;
      for (i = 0; i < STRBUFSIZE; i++) {
        if (strbuf(obj)[i] != *str) { return 0; }
        if (*str) { str++; }
      }
      obj = cdr(obj);
    }
    return *str == '\0';
  }
  
  
  static fe_Object* object(fe_Context *ctx) {
    fe_Object *obj;
    /* do gc if freelist has no more objects */
    if (isnil(ctx->freelist)) {
      collectgarbage(ctx);
      if (isnil(ctx->freelist)) { fe_error(ctx, "out of memory"); }
    }
    /* get object from freelist and push to the gcstack */
    obj = ctx->freelist;
    ctx->freelist = cdr(obj);
    fe_pushgc(ctx, obj);
    return obj;
  }
  
  
  fe_Object* fe_cons(fe_Context *ctx, fe_Object *car, fe_Object *cdr) {
    fe_Object *obj = object(ctx);
    car(obj) = car;
    cdr(obj) = cdr;
    return obj;
  }
  
  
  fe_Object* fe_bool(fe_Context *ctx, int b) {
    return b ? ctx->t : &nil;
  }
  
  
  fe_Object* fe_number(fe_Context *ctx, fe_Number n) {
    fe_Object *obj = object(ctx);
    settype(obj, FE_TNUMBER);
    number(obj) = n;
    return obj;
  }
  
  
  static fe_Object* buildstring(fe_Context *ctx, fe_Object *tail, int chr) {
    if (!tail || strbuf(tail)[STRBUFSIZE - 1] != '\0') {
      fe_Object *obj = fe_cons(ctx, NULL, &nil);
      settype(obj, FE_TSTRING);
      if (tail) {
        cdr(tail) = obj;
        ctx->gcstack_idx--;
      }
      tail = obj;
    }
    strbuf(tail)[strlen(strbuf(tail))] = chr;
    return tail;
  }
  
  
  fe_Object* fe_string(fe_Context *ctx, const char *str) {
    fe_Object *obj = buildstring(ctx, NULL, '\0');
    fe_Object *tail = obj;
    while (*str) {
      tail = buildstring(ctx, tail, *str++);
    }
    return obj;
  }
  
  
  fe_Object* fe_symbol(fe_Context *ctx, const char *name) {
    fe_Object *obj;
    /* try to find in symlist */
    for (obj = ctx->symlist; !isnil(obj); obj = cdr(obj)) {
      if (streq(car(cdr(car(obj))), name)) {
        return car(obj);
      }
    }
    /* create new object, push to symlist and return */
    obj = object(ctx);
    settype(obj, FE_TSYMBOL);
    cdr(obj) = fe_cons(ctx, fe_string(ctx, name), &nil);
    ctx->symlist = fe_cons(ctx, obj, ctx->symlist);
    return obj;
  }
  
  
  fe_Object* fe_cfunc(fe_Context *ctx, fe_CFunc fn) {
    fe_Object *obj = object(ctx);
    settype(obj, FE_TCFUNC);
    cfunc(obj) = fn;
    return obj;
  }
  
  
  fe_Object* fe_ptr(fe_Context *ctx, void *ptr) {
    fe_Object *obj = object(ctx);
    settype(obj, FE_TPTR);
    cdr(obj) = ptr;
    return obj;
  }
  
  
  fe_Object* fe_list(fe_Context *ctx, fe_Object **objs, int n) {
    fe_Object *res = &nil;
    while (n--) {
      res = fe_cons(ctx, objs[n], res);
    }
    return res;
  }
  
  
  fe_Object* fe_car(fe_Context *ctx, fe_Object *obj) {
    if (isnil(obj)) { return obj; }
    return car(checktype(ctx, obj, FE_TPAIR));
  }
  
  
  fe_Object* fe_cdr(fe_Context *ctx, fe_Object *obj) {
    if (isnil(obj)) { return obj; }
    return cdr(checktype(ctx, obj, FE_TPAIR));
  }
  
  
  static void writestr(fe_Context *ctx, fe_WriteFn fn, void *udata, const char *s) {
    while (*s) { fn(ctx, udata, *s++); }
  }
  
  void fe_write(fe_Context *ctx, fe_Object *obj, fe_WriteFn fn, void *udata, int qt) {
    char buf[32];
  
    switch (type(obj)) {
      case FE_TNIL:
        writestr(ctx, fn, udata, "nil");
        break;
  
      case FE_TNUMBER:
        sprintf(buf, "%.7g", number(obj));
        writestr(ctx, fn, udata, buf);
        break;
  
      case FE_TPAIR:
        fn(ctx, udata, '(');
        for (;;) {
          fe_write(ctx, car(obj), fn, udata, 1);
          obj = cdr(obj);
          if (type(obj) != FE_TPAIR) { break; }
          fn(ctx, udata, ' ');
        }
        if (!isnil(obj)) {
          writestr(ctx, fn, udata, " . ");
          fe_write(ctx, obj, fn, udata, 1);
        }
        fn(ctx, udata, ')');
        break;
  
      case FE_TSYMBOL:
        fe_write(ctx, car(cdr(obj)), fn, udata, 0);
        break;
  
      case FE_TSTRING:
        if (qt) { fn(ctx, udata, '"'); }
        while (!isnil(obj)) {
          int i;
          for (i = 0; i < STRBUFSIZE && strbuf(obj)[i]; i++) {
            if (qt && strbuf(obj)[i] == '"') { fn(ctx, udata, '\\'); }
            fn(ctx, udata, strbuf(obj)[i]);
          }
          obj = cdr(obj);
        }
        if (qt) { fn(ctx, udata, '"'); }
        break;
  
      default:
        sprintf(buf, "[%s %p]", typenames[type(obj)], (void*) obj);
        writestr(ctx, fn, udata, buf);
        break;
    }
  }
  
  
  static void writefp(fe_Context *ctx, void *udata, char chr) {
    unused(ctx);
    fputc(chr, udata);
  }
  
  void fe_writefp(fe_Context *ctx, fe_Object *obj, FILE *fp) {
    fe_write(ctx, obj, writefp, fp, 0);
  }
  
  
  typedef struct { char *p; int n; } CharPtrInt;
  
  static void writebuf(fe_Context *ctx, void *udata, char chr) {
    CharPtrInt *x = udata;
    unused(ctx);
    if (x->n) { *x->p++ = chr; x->n--; }
  }
  
  int fe_tostring(fe_Context *ctx, fe_Object *obj, char *dst, int size) {
    CharPtrInt x;
    x.p = dst;
    x.n = size - 1;
    fe_write(ctx, obj, writebuf, &x, 0);
    *x.p = '\0';
    return size - x.n - 1;
  }
  
  
  fe_Number fe_tonumber(fe_Context *ctx, fe_Object *obj) {
    return number(checktype(ctx, obj, FE_TNUMBER));
  }
  
  
  void* fe_toptr(fe_Context *ctx, fe_Object *obj) {
    return cdr(checktype(ctx, obj, FE_TPTR));
  }
  
  
  static fe_Object* getbound(fe_Object *sym, fe_Object *env) {
    /* try to find in environment */
    for (; !isnil(env); env = cdr(env)) {
      fe_Object *x = car(env);
      if (car(x) == sym) { return x; }
    }
    /* return global */
    return cdr(sym);
  }
  
  
  void fe_set(fe_Context *ctx, fe_Object *sym, fe_Object *v) {
    unused(ctx);
    cdr(getbound(sym, &nil)) = v;
  }
  
  
  static fe_Object rparen;
  
  static fe_Object* read_(fe_Context *ctx, fe_ReadFn fn, void *udata) {
    const char *delimiter = " \n\t\r();";
    fe_Object *v, *res, **tail;
    fe_Number n;
    int chr, gc;
    char buf[64], *p;
  
    /* get next character */
    chr = ctx->nextchr ? ctx->nextchr : fn(ctx, udata);
    ctx->nextchr = '\0';
  
    /* skip whitespace */
    while (chr && strchr(" \n\t\r", chr)) {
      chr = fn(ctx, udata);
    }
  
    switch (chr) {
      case '\0':
        return NULL;
  
      case ';':
        while (chr && chr != '\n') { chr = fn(ctx, udata); }
        return read_(ctx, fn, udata);
  
      case ')':
        return &rparen;
  
      case '(':
        res = &nil;
        tail = &res;
        gc = fe_savegc(ctx);
        fe_pushgc(ctx, res); /* to cause error on too-deep nesting */
        while ( (v = read_(ctx, fn, udata)) != &rparen ) {
          if (v == NULL) { fe_error(ctx, "unclosed list"); }
          if (type(v) == FE_TSYMBOL && streq(car(cdr(v)), ".")) {
            /* dotted pair */
            *tail = fe_read(ctx, fn, udata);
          } else {
            /* proper pair */
            *tail = fe_cons(ctx, v, &nil);
            tail = &cdr(*tail);
          }
          fe_restoregc(ctx, gc);
          fe_pushgc(ctx, res);
        }
        return res;
  
      case '\'':
        v = fe_read(ctx, fn, udata);
        if (!v) { fe_error(ctx, "stray '''"); }
        return fe_cons(ctx, fe_symbol(ctx, "quote"), fe_cons(ctx, v, &nil));
  
      case '"':
        res = buildstring(ctx, NULL, '\0');
        v = res;
        chr = fn(ctx, udata);
        while (chr != '"') {
          if (chr == '\0') { fe_error(ctx, "unclosed string"); }
          if (chr == '\\') {
            chr = fn(ctx, udata);
            if (strchr("nrt", chr)) { chr = strchr("n\nr\rt\t", chr)[1]; }
          }
          v = buildstring(ctx, v, chr);
          chr = fn(ctx, udata);
        }
        return res;
  
      default:
        p = buf;
        do {
          if (p == buf + sizeof(buf) - 1) { fe_error(ctx, "symbol too long"); }
          *p++ = chr;
          chr = fn(ctx, udata);
        } while (chr && !strchr(delimiter, chr));
        *p = '\0';
        ctx->nextchr = chr;
        n = strtod(buf, &p);  /* try to read as number */
        if (p != buf && strchr(delimiter, *p)) { return fe_number(ctx, n); }
        if (!strcmp(buf, "nil")) { return &nil; }
        return fe_symbol(ctx, buf);
    }
  }
  
  
  fe_Object* fe_read(fe_Context *ctx, fe_ReadFn fn, void *udata) {
    fe_Object* obj = read_(ctx, fn, udata);
    if (obj == &rparen) { fe_error(ctx, "stray ')'"); }
    return obj;
  }
  
  
  static char readfp(fe_Context *ctx, void *udata) {
    int chr;
    unused(ctx);
    return (chr = fgetc(udata)) == EOF ? '\0' : chr;
  }
  
  fe_Object* fe_readfp(fe_Context *ctx, FILE *fp) {
    return fe_read(ctx, readfp, fp);
  }
  
  
  static fe_Object* eval(fe_Context *ctx, fe_Object *obj, fe_Object *env, fe_Object **bind);
  
  static fe_Object* evallist(fe_Context *ctx, fe_Object *lst, fe_Object *env) {
    fe_Object *res = &nil;
    fe_Object **tail = &res;
    while (!isnil(lst)) {
      *tail = fe_cons(ctx, eval(ctx, fe_nextarg(ctx, &lst), env, NULL), &nil);
      tail = &cdr(*tail);
    }
    return res;
  }
  
  
  static fe_Object* dolist(fe_Context *ctx, fe_Object *lst, fe_Object *env) {
    fe_Object *res = &nil;
    int save = fe_savegc(ctx);
    while (!isnil(lst)) {
      fe_restoregc(ctx, save);
      fe_pushgc(ctx, lst);
      fe_pushgc(ctx, env);
      res = eval(ctx, fe_nextarg(ctx, &lst), env, &env);
    }
    return res;
  }
  
  
  static fe_Object* argstoenv(fe_Context *ctx, fe_Object *prm, fe_Object *arg, fe_Object *env) {
    while (!isnil(prm)) {
      if (type(prm) != FE_TPAIR) {
        env = fe_cons(ctx, fe_cons(ctx, prm, arg), env);
        break;
      }
      env = fe_cons(ctx, fe_cons(ctx, car(prm), fe_car(ctx, arg)), env);
      prm = cdr(prm);
      arg = fe_cdr(ctx, arg);
    }
    return env;
  }
  
  
  #define evalarg() eval(ctx, fe_nextarg(ctx, &arg), env, NULL)
  
  #define arithop(op) {                             \
      fe_Number x = fe_tonumber(ctx, evalarg());    \
      while (!isnil(arg)) {                         \
        x = x op fe_tonumber(ctx, evalarg());       \
      }                                             \
      res = fe_number(ctx, x);                      \
    }
  
  #define numcmpop(op) {                            \
      va = checktype(ctx, evalarg(), FE_TNUMBER);   \
      vb = checktype(ctx, evalarg(), FE_TNUMBER);   \
      res = fe_bool(ctx, number(va) op number(vb)); \
    }
  
  
  static fe_Object* eval(fe_Context *ctx, fe_Object *obj, fe_Object *env, fe_Object **newenv) {
    fe_Object *fn, *arg, *res;
    fe_Object cl, *va, *vb;
    int n, gc;
  
    switch (type(obj)) {
      case FE_TSYMBOL: return cdr(getbound(obj, env));
      case FE_TPAIR: break;
      default: return obj;
    }
  
    car(&cl) = obj, cdr(&cl) = ctx->calllist;
    ctx->calllist = &cl;
  
    gc = fe_savegc(ctx);
    fn = eval(ctx, car(obj), env, NULL);
    arg = cdr(obj);
    res = &nil;
  
    switch (type(fn)) {
      case FE_TPRIM:
        switch (prim(fn)) {
          case P_LET:
            va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL);
            if (newenv) {
              *newenv = fe_cons(ctx, fe_cons(ctx, va, evalarg()), env);
            }
            break;
  
          case P_SET:
            va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL);
            cdr(getbound(va, env)) = evalarg();
            break;
  
          case P_IF:
            while (!isnil(arg)) {
              va = evalarg();
              if (!isnil(va)) {
                res = isnil(arg) ? va : evalarg();
                break;
              }
              if (isnil(arg)) { break; }
              arg = cdr(arg);
            }
            break;
  
          case P_FN: case P_MAC:
            va = fe_cons(ctx, env, arg);
            fe_nextarg(ctx, &arg);
            res = object(ctx);
            settype(res, prim(fn) == P_FN ? FE_TFUNC : FE_TMACRO);
            cdr(res) = va;
            break;
  
          case P_WHILE:
            va = fe_nextarg(ctx, &arg);
            n = fe_savegc(ctx);
            while (!isnil(eval(ctx, va, env, NULL))) {
              dolist(ctx, arg, env);
              fe_restoregc(ctx, n);
            }
            break;
  
          case P_QUOTE:
            res = fe_nextarg(ctx, &arg);
            break;
  
          case P_AND:
            while (!isnil(arg) && !isnil(res = evalarg()));
            break;
  
          case P_OR:
            while (!isnil(arg) && isnil(res = evalarg()));
            break;
  
          case P_DO:
            res = dolist(ctx, arg, env);
            break;
  
          case P_CONS:
            va = evalarg();
            res = fe_cons(ctx, va, evalarg());
            break;
  
          case P_CAR:
            res = fe_car(ctx, evalarg());
            break;
  
          case P_CDR:
            res = fe_cdr(ctx, evalarg());
            break;
  
          case P_SETCAR:
            va = checktype(ctx, evalarg(), FE_TPAIR);
            car(va) = evalarg();
            break;
  
          case P_SETCDR:
            va = checktype(ctx, evalarg(), FE_TPAIR);
            cdr(va) = evalarg();
            break;
  
          case P_LIST:
            res = evallist(ctx, arg, env);
            break;
  
          case P_NOT:
            res = fe_bool(ctx, isnil(evalarg()));
            break;
  
          case P_IS:
            va = evalarg();
            res = fe_bool(ctx, equal(va, evalarg()));
            break;
  
          case P_ATOM:
            res = fe_bool(ctx, fe_type(ctx, evalarg()) != FE_TPAIR);
            break;
  
          case P_PRINT:
            while (!isnil(arg)) {
              fe_writefp(ctx, evalarg(), stdout);
              if (!isnil(arg)) { printf(" "); }
            }
            printf("\n");
            break;
  
          case P_LT: numcmpop(<); break;
          case P_LTE: numcmpop(<=); break;
          case P_ADD: arithop(+); break;
          case P_SUB: arithop(-); break;
          case P_MUL: arithop(*); break;
          case P_DIV: arithop(/); break;
        }
        break;
  
      case FE_TCFUNC:
        res = cfunc(fn)(ctx, evallist(ctx, arg, env));
        break;
  
      case FE_TFUNC:
        arg = evallist(ctx, arg, env);
        va = cdr(fn); /* (env params ...) */
        vb = cdr(va); /* (params ...) */
        res = dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va)));
        break;
  
      case FE_TMACRO:
        va = cdr(fn); /* (env params ...) */
        vb = cdr(va); /* (params ...) */
        /* replace caller object with code generated by macro and re-eval */
        *obj = *dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va)));
        fe_restoregc(ctx, gc);
        ctx->calllist = cdr(&cl);
        return eval(ctx, obj, env, NULL);
  
      default:
        fe_error(ctx, "tried to call non-callable value");
    }
  
    fe_restoregc(ctx, gc);
    fe_pushgc(ctx, res);
    ctx->calllist = cdr(&cl);
    return res;
  }
  
  
  fe_Object* fe_eval(fe_Context *ctx, fe_Object *obj) {
    return eval(ctx, obj, &nil, NULL);
  }
  
  
  fe_Context* fe_open(void *ptr, int size) {
    int i, save;
    fe_Context *ctx;
  
    /* init context struct */
    ctx = ptr;
    memset(ctx, 0, sizeof(fe_Context));
    ptr = (char*) ptr + sizeof(fe_Context);
    size -= sizeof(fe_Context);
  
    /* make sure object memory region is 32bit aligned */
    while ((size_t) ptr & 0x3) { ptr = (char*) ptr + 1; size--; }
  
    /* init objects memory region */
    ctx->objects = (fe_Object*) ptr;
    ctx->object_count = size / sizeof(fe_Object);
  
    /* init lists */
    ctx->calllist = &nil;
    ctx->freelist = &nil;
    ctx->symlist = &nil;
  
    /* populate freelist */
    for (i = 0; i < ctx->object_count; i++) {
      fe_Object *obj = &ctx->objects[i];
      settype(obj, FE_TFREE);
      cdr(obj) = ctx->freelist;
      ctx->freelist = obj;
    }
  
    /* init objects */
    ctx->t = fe_symbol(ctx, "t");
    fe_set(ctx, ctx->t, ctx->t);
  
    /* register built in primitives */
    save = fe_savegc(ctx);
    for (i = 0; i < P_MAX; i++) {
      fe_Object *v = object(ctx);
      settype(v, FE_TPRIM);
      prim(v) = i;
      fe_set(ctx, fe_symbol(ctx, primnames[i]), v);
      fe_restoregc(ctx, save);
    }
  
    return ctx;
  }
  
  
  void fe_close(fe_Context *ctx) {
    /* clear gcstack and symlist; makes all objects unreachable */
    ctx->gcstack_idx = 0;
    ctx->symlist = &nil;
    collectgarbage(ctx);
  }
  
  
  #ifdef FE_STANDALONE
  
  #include <setjmp.h>
  
  static jmp_buf toplevel;
  static char buf[64000];
  
  static void onerror(fe_Context *ctx, const char *msg, fe_Object *cl) {
    unused(ctx), unused(cl);
    fprintf(stderr, "error: %s\n", msg);
    longjmp(toplevel, -1);
  }
  
  
  int main(int argc, char **argv) {
    int gc;
    fe_Object *obj;
    FILE *volatile fp = stdin;
    fe_Context *ctx = fe_open(buf, sizeof(buf));
  
    /* init input file */
    if (argc > 1) {
      fp = fopen(argv[1], "rb");
      if (!fp) { fe_error(ctx, "could not open input file"); }
    }
  
    if (fp == stdin) { fe_handlers(ctx)->error = onerror; }
    gc = fe_savegc(ctx);
    setjmp(toplevel);
  
    /* re(p)l */
    for (;;) {
      fe_restoregc(ctx, gc);
      if (fp == stdin) { printf("> "); }
      if (!(obj = fe_readfp(ctx, fp))) { break; }
      obj = fe_eval(ctx, obj);
      if (fp == stdin) { fe_writefp(ctx, obj, stdout); printf("\n"); }
    }
  
    return EXIT_SUCCESS;
  }
  
  #endif
  