lisp.c

// part of https://github.com/Calvin-Xu/Allegorical-Lisp-Machine
// that does not disclose CS 107E assignment implementations

// based on The Roots of Lisp by Paul Graham that follows closely McCarthy's original paper
// Lisp in 99 lines of C and how to write one yourself by Robert van Engele

#include "lisp.h"
#include "printf.h"
#include "utils.h"
#include "strings.h"
#include "pi.h"
#include "math.h"
#include "malloc.h"
#include "ht.h"
#include "console.h"
#include "rand.h"

typedef void *jmp_buf[5];
#define setjmp __builtin_setjmp
#define longjmp __builtin_longjmp

volatile enum Operation op;

volatile enum Error err_code;

unsigned c_mem_free;

unsigned lisp_mem_free;

jmp_buf jb;

typedef double LispValue;

// return the tag bits of a NaN boxed Lisp value
static inline unsigned tagof(LispValue x) {
  return *(unsigned long long *)&x >> 48;
}

// return NaN boxed double with tag and val
LispValue box(unsigned tag, unsigned val) {
  LispValue x;
  *(unsigned long long *)&x = (unsigned long long)tag << 48 | val;
  return x;
}

// unbox Nan boxes double to unsigned int
unsigned ord(LispValue x) { return *(unsigned long long *)&x & 0xffffffffffff; }

#define N_ERRORS 10
const char *errors[N_ERRORS] = {
    "Syntax Error: List",                         // 1
    "Atom/String Internment Hashtable Not Found", // 2
    "Illegal Argument: Not Pair",                 // 3
    "Assoc: Cannot Resolve Symbol",               // 4
    "Cannot Apply: Illegal Operator",             // 5
    "Illegal Argument: Not String",               // 6
    "Illegal Argument: Bad Address",              // 7
    "Input Scan Error",                           // 8
    "Syntax Error: String",                       // 9
    "Out of Lisp Memory; Stack Overflow Likely"   // 10
};

LispValue error(int i) {
  err_code = i;
  longjmp(jb, 1);
}


// 2^16 * 64 bits = 512 KiB
// #define N_CELLS 65536

// 2^17
#define N_CELLS 131072

// 2^18
// #define N_CELLS 262144

// 2^18
// #define N_CELLS 262144

// 2^19
// #define N_CELLS 524288

// 2^20
// #define N_CELLS 1048576

// 2^23, 64 MiB
// #define N_CELLS 8388608

// 128 MiB
// #define N_CELLS 16777216

// 256 MiB
// #define N_CELLS 33554432

unsigned hp = 0, sp = N_CELLS;

unsigned PRIM=0x7ff9, ATOM=0x7ffa, STRG=0x7ffb, CONS=0x7ffc, CLOS=0x7ffe, MACR=0x7fff, NIL=0xffff;

LispValue cell[N_CELLS];

LispValue nil,tru,err,env;

#define heap (char*)cell

ht* atoms_ht;

ht* strings_ht;

size_t get_lisp_free_bytes() { return (sp << 3) - hp; }

size_t get_c_free_bytes() {
  void *c_sp;
  __asm__("mov %0, sp" : "=r"(c_sp));
  void *c_hp = malloc_return_heap_end();
  return ((c_sp - c_hp) << 2);
}

char *get_memory_status(void) {
  static char memory_status_buf[100];
  snprintf(
      memory_status_buf, sizeof(memory_status_buf),
      "L-C: %04f %06f MB",
      ((double)get_lisp_free_bytes()) / 1048576.0,
      ((double)get_c_free_bytes()) / 1048576.0);
  return memory_status_buf;
}


// check the value of n
// does nothing for now
LispValue num(LispValue n) { return n; }

unsigned equ(LispValue x, LispValue y) {
  return *(unsigned long long *)&x == *(unsigned long long *)&y;
}

LispValue alloc(const char *s, unsigned type) {
  ht *type_ht = type == ATOM ? atoms_ht : type == STRG ? strings_ht : NULL;
  if (!type_ht) {
    error(NULL_INTERN_HASHTABLE);
  }
  void *lookup = ht_get(type_ht, s);
  if (lookup) {
    return box(type, (char *)lookup - heap);
  }
  size_t len = strlen(s) + 1;
  if ((hp + len) > (sp << 3)) { // sp * 8 because it tracks doubles
    error(NO_MEMORY);
  }
  ht_set(type_ht, s, heap + hp);
  strcpy(heap + hp, s);
  unsigned heap_start = hp;
  hp += len;
  return box(type, heap_start);
}

LispValue atom(const char *s) { return alloc(s, ATOM); }

LispValue string(const char *s) { return alloc(s, STRG); }

LispValue cons(LispValue x, LispValue y) {
  cell[--sp] = x;
  cell[--sp] = y;
  if (hp > (sp << 3)) {
    error(NO_MEMORY);
  }
  return box(CONS, sp);
}

LispValue car(LispValue p) {
  return tagof(p) == CONS || tagof(p) == CLOS || tagof(p) == MACR
             ? cell[ord(p) + 1]
             : error(NOT_PAIR);
}

LispValue macro(LispValue v, LispValue x) { return box(MACR, ord(cons(v, x))); }

LispValue cdr(LispValue p) {
  return tagof(p) == CONS || tagof(p) == CLOS || tagof(p) == MACR
             ? cell[ord(p)]
             : error(NOT_PAIR);
}

LispValue pair(LispValue v, LispValue x, LispValue e) {
  return cons(cons(v, x), e);
}

LispValue closure(LispValue v, LispValue x, LispValue e) {
  // if e is the global environment env, set scope to nil
  return box(CLOS, ord(pair(v, x, equ(e, env) ? nil : e)));
}

LispValue assoc(LispValue v, LispValue e) {
  while (tagof(e) == CONS && !equ(v, car(car(e)))) {
    e = cdr(e);
  }
  return tagof(e) == CONS ? cdr(car(e)) : error(ASSOC_BAD_ENV);
}

unsigned is_nil(LispValue x) { return tagof(x) == NIL; }

// return nonzero if x is not an empty list '() and not a singleton list '(x)
unsigned is_list(LispValue x) { return tagof(x) != NIL && !is_nil(cdr(x)); }

LispValue eval(LispValue x, LispValue e);
// return a list of evaluated Lisp expressions t in environment e
LispValue evlis(LispValue t, LispValue e) {
  if (tagof(t) == CONS) {
    return cons(eval(car(t), e), evlis(cdr(t), e));
  }
  if (tagof(t) == ATOM) {
    return assoc(t, e);
  }
  return nil;
}

LispValue f_eval(LispValue t, LispValue *e) { return car(evlis(t, *e)); }

LispValue f_quote(LispValue t, LispValue *_) { return car(t); }

LispValue f_cons(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  return cons(car(t), car(cdr(t)));
}

LispValue f_car(LispValue t, LispValue *e) { return car(car(evlis(t, *e))); }

LispValue f_cdr(LispValue t, LispValue *e) { return cdr(car(evlis(t, *e))); }

LispValue f_add(LispValue t, LispValue *e) {
  LispValue n;
  t = evlis(t, *e);
  n = car(t);
  while (!is_nil(t = cdr(t))) {
    n += car(t);
  }
  return num(n);
}

LispValue f_sub(LispValue t, LispValue *e) {
  LispValue n;
  t = evlis(t, *e);
  n = car(t);
  if (is_nil(cdr(t))) {
    return -(num(n));
  }
  while (!is_nil(t = cdr(t))) {
    n -= car(t);
  }
  return num(n);
}

LispValue f_mul(LispValue t, LispValue *e) {
  LispValue n;
  t = evlis(t, *e);
  n = car(t);
  while (!is_nil(t = cdr(t))) {
    n *= car(t);
  }
  return num(n);
}

LispValue f_div(LispValue t, LispValue *e) {
  LispValue n;
  t = evlis(t, *e);
  n = car(t);
  while (!is_nil(t = cdr(t))) {
    n /= car(t);
  }
  return num(n);
}

LispValue f_int(LispValue t, LispValue *e) {
  LispValue n = car(evlis(t, *e));
  return n < 1e16 && n > -1e16 ? (long long)n : n;
}

LispValue f_lt(LispValue t, LispValue *e) {
  return t = evlis(t, *e), car(t) - car(cdr(t)) < 0 ? tru : nil;
}

LispValue f_gt(LispValue t, LispValue *e) {
  return t = evlis(t, *e), car(t) - car(cdr(t)) > 0 ? tru : nil;
}

LispValue f_lte(LispValue t, LispValue *e) {
  return t = evlis(t, *e), car(t) - car(cdr(t)) <= 0 ? tru : nil;
}

LispValue f_gte(LispValue t, LispValue *e) {
  return t = evlis(t, *e), car(t) - car(cdr(t)) >= 0 ? tru : nil;
}

LispValue f_eq(LispValue t, LispValue *e) {
  return t = evlis(t, *e), equ(car(t), car(cdr(t))) ? tru : nil;
}

LispValue f_is_nil(LispValue t, LispValue *e) {
  return is_nil(car(evlis(t, *e))) ? tru : nil;
}

LispValue f_or(LispValue t, LispValue *e) {
  LispValue x = nil;
  while (tagof(t) != NIL && is_nil(x = eval(car(t), *e))) {
    t = cdr(t);
  }
  return x;
}

LispValue f_and(LispValue t, LispValue *e) {
  LispValue x = nil;
  while (tagof(t) != NIL && !is_nil(x = eval(car(t), *e))) {
    t = cdr(t);
  }
  return x;
}

LispValue f_begin(LispValue t, LispValue *e) {
  for (; is_list(t); t = cdr(t)) {
    eval(car(t), *e);
  }
  return eval(car(t), *e);
}

LispValue f_cond(LispValue t, LispValue *e) {
  while (tagof(t) != NIL && is_nil(eval(car(car(t)), *e))) {
    t = cdr(t);
  }
  return car(cdr(car(t)));
}

LispValue f_if(LispValue t, LispValue *e) {
  return car(cdr(is_nil(eval(car(t), *e)) ? cdr(t) : t));
}

LispValue f_leta(LispValue t, LispValue *e) {
  for (; is_list(t); t = cdr(t)) {
    *e = pair(car(car(t)), eval(car(cdr(car(t))), *e), *e);
  }
  return car(t);
}

LispValue f_lambda(LispValue t, LispValue *e) {
  return closure(car(t), car(cdr(t)), *e);
}

LispValue f_define(LispValue t, LispValue *e) {
  env = pair(car(t), eval(car(cdr(t)), *e), env);
  return car(t);
}

LispValue f_assoc(LispValue t, LispValue *e) {
  return t = evlis(t, *e), assoc(car(t), car(cdr(t)));
}

LispValue f_env(LispValue _, LispValue *e) { return *e; }

LispValue f_let(LispValue t, LispValue *e) {
  LispValue d = *e;
  for (; is_list(t); t = cdr(t)) {
    d = pair(car(car(t)), eval(car(cdr(car(t))), *e), d);
  }
  return eval(car(t), d);
}

LispValue f_letreca(LispValue t, LispValue *e) {
  for (; is_list(t); t = cdr(t)) {
    *e = pair(car(car(t)), err, *e);
    cell[sp + 2] = eval(car(cdr(car(t))), *e);
  }
  return eval(car(t), *e);
}

// LispValue f_setq(LispValue t, LispValue *e) {
//   LispValue v = car(t), x = eval(car(cdr(t)), *e);
//   while (tagof(e) == CONS && !equ(v, car(car(e)))) {
//     e = cdr(e);
//   }
//   return tagof(e) == CONS ? cell[ord(car(e))] = x : error(NOT_PAIR);
// }

// LispValue f_setcar(LispValue t, LispValue *e) {
//   LispValue p = car(t = evlis(t, *e));
//   return (tagof(p) == CONS) ? cell[ord(p) + 1] = car(cdr(t)) :
//   error(NOT_PAIR);
// }

// LispValue f_setcdr(LispValue t, LispValue *e) {
//   LispValue p = car(t = evlis(t, *e));
//   return (tagof(p) == CONS) ? cell[ord(p)] = car(cdr(t)) : error(NOT_PAIR);
// }

LispValue f_macro(LispValue t, LispValue *e) {
  return macro(car(t), car(cdr(t)));
}

LispValue f_savebuf(LispValue t, LispValue *e) {
  op = SAVE_BUF;
  LispValue s = car(t);
  return (tagof(s) == STRG) ? s : error(ARG_NOT_STR);
}

LispValue f_loadfile(LispValue t, LispValue *e) {
  op = LOAD_FIL;
  LispValue s = car(t);
  return (tagof(s) == STRG) ? s : error(ARG_NOT_STR);
}

LispValue f_evalfile(LispValue t, LispValue *e) {
  op = EVAL_FIL;
  LispValue s = car(t);
  return (tagof(s) == STRG) ? s : error(ARG_NOT_STR);
}

LispValue f_peek(LispValue t, LispValue *e) {
  unsigned addr = (unsigned)car(evlis(t, *e));
  volatile unsigned val = *(unsigned *)addr;
  return (addr % 4 == 0 || addr <= 0x80000000) ? val : error(ILLEGAL_ADDR);
}

LispValue f_poke(LispValue t, LispValue *e) {
  unsigned addr = (unsigned)car(evlis(t, *e));
  unsigned val = (unsigned)car(cdr(evlis(t, *e)));
  *(unsigned *)addr = val;
  return car(cdr(t));
}

LispValue f_gpio(LispValue t, LispValue *e) {
  unsigned pin = (unsigned)car(evlis(t, *e));
  if (!is_nil(cdr(t))) {
    unsigned val = (unsigned)car(cdr(evlis(t, *e)));
    gpio_set_output(pin);
    gpio_write(pin, val);
  }
  return gpio_read(pin);
}

LispValue f_disassemble(LispValue t, LispValue *e) {
  char buf[200];
  unsigned addr = (unsigned)car(evlis(t, *e));
  snprintf(buf, sizeof(buf), "%pI", (unsigned *)addr);
  return string(buf);
}

LispValue f_sin(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(sin(x));
}

LispValue f_cos(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(cos(x));
}

LispValue f_tan(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(tan(x));
}

LispValue f_acos(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(acos(x));
}

LispValue f_asin(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(asin(x));
}

LispValue f_atan(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(atan(x));
}

LispValue f_cosh(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(cosh(x));
}

LispValue f_sinh(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(sinh(x));
}

LispValue f_tanh(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(tanh(x));
}

LispValue f_exp(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(exp(x));
}

LispValue f_log(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(log(x));
}

LispValue f_pow(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  LispValue y = car(cdr(t));
  return num(pow(x, y));
}

LispValue f_sqrt(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue x = car(t);
  return num(sqrt(x));
}

LispValue f_atan2(LispValue t, LispValue *e) {
  t = evlis(t, *e);
  LispValue y = car(t);
  LispValue x = car(cdr(t));
  return num(atan2(y, x));
}

LispValue f_rand(LispValue t, LispValue *e) { return num(rand()); }

LispValue f_reset(LispValue t, LispValue *e) {
  return lisp_reset() == 0 ? tru : err;
}

typedef struct {
  const char *s;
  LispValue (*f)(LispValue, LispValue *);
  short t;
} LispPrimitive;

LispPrimitive prim[] = {{"eval", f_eval, 1},
                        {"quote", f_quote, 0},
                        {"cons", f_cons, 0},
                        {"car", f_car, 0},
                        {"cdr", f_cdr, 0},
                        {"+", f_add, 0},
                        {"-", f_sub, 0},
                        {"*", f_mul, 0},
                        {"/", f_div, 0},
                        {"int", f_int, 0},
                        {"<", f_lt, 0},
                        {">", f_gt, 0},
                        {"<=", f_lte, 0},
                        {">=", f_gte, 0},
                        {"eq?", f_eq, 0},
                        {"or", f_or, 0},
                        {"and", f_and, 0},
                        {"not", f_is_nil, 0},
                        {"begin", f_begin, 0},
                        {"cond", f_cond, 1},
                        {"if", f_if, 1},
                        {"let*", f_leta, 1},
                        {"lambda", f_lambda, 0},
                        {"define", f_define, 0},
                        {"assoc", f_assoc, 0},
                        {"env", f_env, 0},
                        {"let", f_let, 0},
                        {"letrec*", f_letreca, 0},
                        /* {"set!", f_setq, 0}, */
                        /* {"set-car!", f_setcar, 0}, */
                        /* {"set-cdr!", f_setcdr, 0}, */
                        {"macro", f_macro, 0},
                        {"save-buf", f_savebuf, 0},
                        {"load-file", f_loadfile, 0},
                        {"eval-file", f_evalfile, 0},
                        {"peek", f_peek, 0},
                        {"poke", f_poke, 0},
                        {"gpio", f_gpio, 0},
			{"disassemble", f_disassemble, 0},
                        {"sin", f_sin, 0},
                        {"cos", f_cos, 0},
                        {"tan", f_tan, 0},
                        {"acos", f_acos, 0},
                        {"asin", f_asin, 0},
                        {"atan", f_atan, 0},
                        {"cosh", f_cosh, 0},
                        {"sinh", f_sinh, 0},
                        {"tanh", f_tanh, 0},
                        {"exp", f_exp, 0},
                        {"log", f_log, 0},
                        {"pow", f_pow, 0},
                        {"sqrt", f_sqrt, 0},
                        {"atan2", f_atan2, 0},
                        {"rand", f_rand, 0},
                        {"reset", f_reset, 0},
                        {0}};

// evaluate x and return its value in environment e
// tailcall optimized
static const int nth_every = 10000;
LispValue eval(LispValue x, LispValue e) {
  LispValue f = nil, v = nil, d = nil;
  static int counter = 0;
  while (true) {
    if (counter++ % nth_every == (nth_every - 1)) {
      console_status_print("Evaluating ...", get_memory_status());
    }
    if (tagof(x) == ATOM) {
      return assoc(x, e);
    }
    if (tagof(x) != CONS) {
      return x;
    }
    f = eval(car(x), e);
    x = cdr(x);
    if (tagof(f) == PRIM) {
      x = prim[ord(f)].f(x, &e);
      if (prim[ord(f)].t)
        continue;
      return x;
    }
    if (tagof(f) == CLOS) {
      v = car(car(f));
      d = cdr(f);
      if (tagof(d) == NIL) {
        d = env;
      }
      for (; tagof(v) == CONS && tagof(x) == CONS; v = cdr(v), x = cdr(x)) {
        d = pair(car(v), eval(car(x), e), d);
      }
      if (tagof(v) == CONS) {
        x = eval(x, e);
        for (; tagof(v) == CONS; v = cdr(v), x = cdr(x)) {
          d = pair(car(v), car(x), d);
        }
        if (tagof(x) == CONS) {
          x = evlis(x, e);
        }
      } else if (tagof(x) != NIL) {
        x = evlis(x, e); // TODO: why this fixes tail call for macros
      }
      if (tagof(v) != NIL) {
        d = pair(v, x, d);
      }
      x = cdr(car(f));
      e = d;
    } else if (tagof(f) == MACR) {
      d = env;
      v = car(f);
      for (; tagof(v) == CONS && tagof(x) == CONS; v = cdr(v), x = cdr(x)) {
        d = pair(car(v), car(x), d);
      }
      if (tagof(v) == CONS) {
        return error(APPLY_BAD_OP_TYPE);
      }
      if (tagof(v) != NIL) {
        d = pair(v, x, d);
      }
      x = eval(cdr(f), d);
    } else {
      return error(APPLY_BAD_OP_TYPE);
    }
  }
}

/*
// return environment alist by extending e with variables v bound to values t
LispValue bind(LispValue v, LispValue t, LispValue e) {
  if (tagof(v) == NIL) {
    return e;
  }
  if (tagof(v) == CONS) {
    return bind(cdr(v), cdr(t), pair(car(v), car(t), e));
  }
  return pair(v, t, e);
}

// apply closure f to arguments t in environent e
LispValue reduce(LispValue f, LispValue t, LispValue e) {
  return eval(cdr(car(f)),
              bind(car(car(f)), evlis(t, e), is_nil(cdr(f)) ? env : cdr(f)));
}

// macro expansion
LispValue expand(LispValue f, LispValue t, LispValue e) {
  return eval(eval(cdr(f), bind(car(f), t, env)), e);
}

// apply closure or primitive f to arguments t in environment e, or return ERR
LispValue apply(LispValue f, LispValue t, LispValue e) {
  if (tagof(f) == PRIM) {
    return prim[ord(f)].f(t, &e);
  }
  if (tagof(f) == CLOS) {
    return reduce(f, t, e);
  }
  if (tagof(f) == MACR) {
    return expand(f, t, e);
  }
  return error(APPLY_BAD_OP_TYPE);
}

static const int nth_every = 10000;
LispValue eval(LispValue x, LispValue e) {
  static int counter = 0;
  if (counter++ % nth_every == (nth_every - 1)) {
    console_status_print("Evaluating ...", get_memory_status());
  }
  if (tagof(x) == ATOM) {
    return assoc(x, e);
  }
  if (tagof(x) == CONS) {
    return apply(eval(car(x), e), cdr(x), e);
  }
  return x;
}
*/

// remove temporary cells on stack; keep global environment
void gc() {
  sp = ord(env);
}

#define MAX_TOKEN_LEN 40

extern const char PADDING_BYTE;

struct Scanner {
  const char *input;
  size_t input_len;
  int input_i;
  char curr;
  char token[MAX_TOKEN_LEN];
} scanner;

int advance_curr() {
  if (scanner.input_i < scanner.input_len) {
    scanner.curr = scanner.input[scanner.input_i++];
    return 0;
  } else if (scanner.input_i == scanner.input_len) {
    scanner.curr = '\0';
    return 0;
  } else {
    return error(SCAN_ERROR);
  }
  return 0;
}

// return nonzero if we are looking at character c
unsigned curr_is(char c) {
  if (c == ' ') {
    return (scanner.curr > 0 && scanner.curr <= c) ||
           scanner.curr == PADDING_BYTE;
  } else if (c == '(') {
    return (scanner.curr == '(' || scanner.curr == '[' || scanner.curr == '{');
  } else if (c == ')') {
    return (scanner.curr == ')' || scanner.curr == ']' || scanner.curr == '}');
  } else {
    return scanner.curr == c;
  }
}

// return the look ahead character from standard input, advance to the next
char get_curr() {
  char c = scanner.curr;
  advance_curr();
  return c;
}

// tokenize into scanner.token[], return first character of scanner.token[]
char scan() {
  unsigned i = 0;
  while (curr_is(' ') || curr_is(';')) {
    if (get_curr() == ';') {
      while (!curr_is('\n') && !curr_is('\0')) {
        advance_curr();
      }
    }
  }
  if (curr_is('"')) {
    do {
      scanner.token[i++] = get_curr();
    } while (i < sizeof(scanner.token) - 1 && !curr_is('"') && !curr_is('\n'));
    if (get_curr() != '"') {
      error(BAD_STR_SYNTAX);
    }
  } else if (curr_is('(') || curr_is(')') || curr_is('\'')) {
    scanner.token[i++] = get_curr();
  } else {
    do {
      scanner.token[i++] = get_curr();
    } while (i < (MAX_TOKEN_LEN - 1) && !curr_is('(') && !curr_is(')') &&
             !curr_is(' '));
  }
  scanner.token[i] = 0;
  // printf("token: %s\n", scanner.token);
  return *scanner.token;
}

LispValue parse();
LispValue read() {
  scan();
  return parse();
}

LispValue parse_list() {
  LispValue x;
  char start = scan();
  if (start == ')' || start == ']' || start == '}')
    return nil;
  if (!strcmp(scanner.token, ".")) {
    x = read();
    scan();
    return x;
  }
  if (start == '\0') {
    return error(SYNTAX_ERROR);
  }
  x = parse();
  return cons(x, parse_list());
}

LispValue parse_quote() { return cons(atom("quote"), cons(read(), nil)); }

// return a parsed atomic Lisp expression (a number or an atom)
LispValue atomic() {
  LispValue n;
  const char *endptr;
  n = strtonum(scanner.token, &endptr);
  if (*endptr == '.' || *endptr == '-') {
    n = strtod(scanner.token, &endptr);
  }
  return (!*endptr) ? n : atom(scanner.token);
}

LispValue parse() {
  return (*scanner.token == '(' || *scanner.token == '[' ||
          *scanner.token == '{')
             ? parse_list()
         : *scanner.token == '\'' ? parse_quote()
         : *scanner.token == '"'  ? string(scanner.token + 1)
                                  : atomic();
}

int output(char *, size_t, LispValue);
int outputlist(char *buf, size_t bufsize, LispValue t) {
  const char *start = buf;
  int n = 0;
  snprintf(buf++, bufsize--, "(");
  for (;; snprintf(buf++, bufsize--, " ")) {
    n = output(buf, bufsize, car(t));
    buf += n;
    bufsize -= n;
    t = cdr(t);
    if (tagof(t) == NIL) {
      break;
    }
    if (tagof(t) != CONS) {
      n = snprintf(buf, bufsize, " . ");
      buf += n;
      bufsize -= n;
      n = output(buf, bufsize, t);
      buf += n;
      bufsize -= n;
      break;
    }
  }
  snprintf(buf++, bufsize--, ")");
  return buf - start;
}

int output(char *buf, size_t bufsize, LispValue x) {
  int n = 0;
  if (tagof(x) == NIL) {
    n = snprintf(buf, bufsize, "()");
  } else if (tagof(x) == ATOM) {
    n = snprintf(buf, bufsize, "%s", heap + ord(x));
  } else if (tagof(x) == STRG) {
    n = snprintf(buf, bufsize, "\"%s\"", heap + ord(x));
  } else if (tagof(x) == PRIM) {
    n = snprintf(buf, bufsize, "<%s>", prim[ord(x)].s);
  } else if (tagof(x) == CLOS) {
    n = snprintf(buf, bufsize, "{%x}", ord(x));
  } else if (tagof(x) == CONS) {
    n = outputlist(buf, bufsize, x);
  } else if (ceil(x) == x) { // is integer
    n = snprintf(buf, bufsize, "%d", (int)x);
  } else if ((unsigned)x == x) {
    n = snprintf(buf, bufsize, "0x%x", (unsigned)x);
  } else {
    n = snprintf(buf, bufsize, "%f", x);
  }
  return n;
}

int lisp_init(void) {
  unsigned i;
  atoms_ht = ht_create();
  strings_ht = ht_create();
  if (!atoms_ht || !strings_ht) {
    return 1;
  }
  nil = box(NIL, 0);
  err = atom("ERR");
  tru = atom("#t");
  env = pair(tru, tru, nil);
  for (i = 0; prim[i].s; ++i) {
    env = pair(atom(prim[i].s), box(PRIM, i), env);
  }
  eval_file("init.lisp");
  return 0;
}

int lisp_reset(void) {
  hp = 0, sp = N_CELLS;
  ht_destroy(atoms_ht);
  ht_destroy(strings_ht);
  lisp_init();
  return 0;
}

int lisp_destroy(void) {
  ht_destroy(atoms_ht);
  ht_destroy(strings_ht);
  return 0;
}

enum Operation lisp_evaluate(const char *expr, char *buf, size_t bufsize) {
  int i = 1;
  if ((i = setjmp(jb)) != 0) {
    gc();
    snprintf(buf, bufsize, "%s", errors[err_code]);
    console_status_print("Caught Error; Restored Previous Interaction",
                         get_memory_status());
    return ERROR;
  }
  scanner.input = expr;
  scanner.input_len = strlen(expr);
  scanner.input_i = 0;
  scanner.curr = ' ';
  op = OTHER;
  LispValue sexp = read();
  output(buf, bufsize, eval(sexp, env));
  gc();
  console_status_print(expr, get_memory_status());
  return op;
}