implement bytecode interpreter and compiler

.gitignore

@@ -1,6 +1,3 @@
-wscm
+/.cache
-*.o
+/build
-compile_commands.json
+/.envrc
-.cache
-.envrc
-test.lisp

README.md

@@ -1,2 +1,5 @@
 # wolflisp
-a lisp but wolfy.  right now it's very minimal... :^)
+a lisp but wolfy.  right now it's very minimal... :^)
+
+## todo
+- [ ] macros in the new bytecode interpreter/compiler

include/wolflisp.h

@@ -14,6 +14,7 @@ typedef intptr_t I;
 typedef uintptr_t U;
 typedef char C;
 typedef uint8_t U8;
+typedef uint16_t U16;
 typedef uint32_t U32;
 typedef int32_t I32;
 typedef size_t Z;
@@ -26,7 +27,7 @@ typedef U O;
 #define NUM(x) (((O)((I)(x) << 1)) | (O)1)
 #define ORD(x) ((I)(x) >> 1)
 
-// Pair
+// Cons pair
 typedef struct Pa {
   O head, tail;
 } Pa;
@@ -48,11 +49,21 @@ typedef struct Cl {
   O args, body, env;
 } Cl;
 
+// Bytecode
+typedef struct Bc {
+  Z len;
+  U8 *data;
+  Z constant_count;
+  O *constants;
+} Bc;
+
 // Primitive
 typedef struct In In;
 typedef struct Pr {
   const char *name;
-  O (*fn)(In *, O, O);
+  O (*fn)(In *, O *, int, O);  // fn(interp, args_array, argc, env)
+  int min_args;  // Minimum number of arguments (-1 for no check)
+  int max_args;  // Maximum number of arguments (-1 for variadic)
 } Pr;
 
 // Symbol table
@@ -62,7 +73,7 @@ typedef struct St {
   Sy **data;
 } St;
 
-#define HEAP_BYTES (1024 * 1024)
+#define HEAP_BYTES (4 * 1024 * 1024)
 #define TYPE_MASK 7
 
 enum {
@@ -81,6 +92,7 @@ enum {
   TYPE_STR,
   TYPE_CLOS,
   TYPE_MAC,
+  TYPE_CODE,
   TYPE_FWD,
   TYPE__MAX,
 };
@@ -125,6 +137,14 @@ typedef struct Er {
   } stack;
 } Er;
 
+// Call frame
+typedef struct Fr {
+  U8 *ip;
+  O env;
+} Fr;
+
+#define VM_STACK_SIZE 4096
+
 // Interpreter context
 typedef struct In {
   Gc gc;
@@ -132,8 +152,64 @@ typedef struct In {
   O env;
   Er err;
   O t; // the T symbol
+  O stack[VM_STACK_SIZE];
+  O *sp;
 } In;
 
+// Opcodes
+enum {
+  OP_HALT,
+  OP_CONST,
+  OP_GET,
+  OP_SET,
+  OP_JUMP,
+  OP_JUMP_IF_NIL,
+  OP_CALL,
+  OP_RET,
+  OP_POP,
+  OP_CLOS,
+  OP_TAIL_CALL,
+  OP_BIND,
+  OP_BIND_REST,
+  OP_PEEK,
+  OP_GET_LOCAL,    // Get local variable from stack frame
+  OP_SET_LOCAL,    // Set local variable in stack frame
+  OP_RESERVE,      // Reserve space for local variables
+};
+
+// Local variable info
+typedef struct Lv {
+  O name;      // Symbol name
+  U16 index;   // Stack slot index
+  int captured; // Is this variable captured by a closure?
+} Lv;
+
+// Compiler context
+typedef struct Cm {
+  In *in;
+  U8 *code;
+  Z count;
+  Z capacity;
+  struct {
+    O *data;
+    Z count;
+    Z capacity;
+  } constants;
+  struct {
+    O quote;
+    O iff;
+    O fn;
+    O progn;
+    O def;
+  } specials;
+  struct {
+    Lv *data;
+    Z count;
+    Z capacity;
+  } locals;
+  int use_stack_locals; // Use stack-based locals instead of env
+} Cm;
+
 enum {
   TOK_EOF = 0,
   TOK_COMMENT = ';',
@@ -180,8 +256,6 @@ V gc_finalize(Gc *gc);
 
 void error_init(Er *err);
 void error_throw(In *in, const char *fmt, ...);
-void error_push_frame(In *in, const char *frame);
-void error_pop_frame(In *in);
 void error_print(In *in);
 
 // Initialize an interpreter context.
@@ -189,12 +263,6 @@ V interp_init(In *in);
 // Finalize an interpreter context.
 V interp_finalize(In *in);
 
-// Evaluate a list of values.
-O interp_eval_list(In *in, O list, O env);
-
-// Evaluate an expression.
-O interp_eval(In *in, O obj, O env);
-
 // Intern a string
 Sy *intern(St *tab, const char *str, Z len);
 
@@ -209,10 +277,15 @@ V print(O obj);
 V println(O obj);
 
 O symbol_make(In *in, const char *str);
-O prim_make(In *in, const char *name, O (*fn)(In *, O, O));
+O prim_make(In *in, const char *name, O (*fn)(In *, O *, int, O), int min_args, int max_args);
 
 O list_assoc(In *in, O key, O alist);
 O list_reverse(In *in, O list);
+O list_next(In *in, O *list);
+
+V compile(Cm *co, O expr, I toplevel);
+V disassemble(Cm *co);
+O vm_run(Cm *c);
 
 int nexttoken(Lx *lex);
 

meson.build

@@ -8,6 +8,8 @@ project(
 
 inc = include_directories('include', 'src')
 src = [
+  'src/compile.c',
+  'src/disasm.c',
   'src/error.c',
   'src/gc.c',
   'src/interp.c',
@@ -21,6 +23,7 @@ src = [
   'src/string.c',
   'src/symbol.c',
   'src/type.c',
+  'src/vm.c',
 ]
 
 exe = executable(

shell.nix

@@ -1,6 +1,8 @@
-{ pkgs ? import <nixpkgs> {} }:
+{
+  pkgs ? import <nixpkgs> { },
+}:
 pkgs.mkShell {
-  name = "rufus";
+  name = "wl";
   packages = with pkgs; [
     rlwrap
     clang-tools

src/compile.c

@@ -0,0 +1,338 @@
+#include <stdlib.h>
+#include <string.h>
+#include <wolflisp.h>
+
+static int find_local(Cm *co, O sym) {
+  for (Z i = 0; i < co->locals.count; i++) {
+    if (co->locals.data[i].name == sym) {
+      return (int)i;
+    }
+  }
+  return -1;
+}
+
+static void add_local(Cm *co, O sym) {
+  if (co->locals.count >= co->locals.capacity) {
+    Z newcap = co->locals.capacity == 0 ? 16 : co->locals.capacity * 2;
+    Lv *newdata = realloc(co->locals.data, newcap * sizeof(Lv));
+    if (!newdata)
+      abort();
+    co->locals.capacity = newcap;
+    co->locals.data = newdata;
+  }
+  co->locals.data[co->locals.count].name = sym;
+  co->locals.data[co->locals.count].index = (U16)co->locals.count;
+  co->locals.count++;
+}
+
+static V emit(Cm *co, U8 byte) {
+  if (co->count >= co->capacity) {
+    Z newcap = co->capacity == 0 ? 16 : co->capacity * 2;
+    U8 *newdata = realloc(co->code, newcap);
+    if (!newdata)
+      abort();
+    co->capacity = newcap;
+    co->code = newdata;
+  }
+  co->code[co->count++] = byte;
+}
+
+static V emit16(Cm *co, U16 word) {
+  emit(co, word >> 8);
+  emit(co, word & 0xff);
+}
+
+O code_make(In *in, const U8 *code, Z len, O *constants, Z clen) {
+  Z size = sizeof(Gh) + sizeof(Bc);
+  Gh *hdr = gc_alloc(&in->gc, size);
+  hdr->type = TYPE_CODE;
+  Bc *s = (Bc *)(hdr + 1);
+  s->len = len;
+  s->data = malloc(len + 1);
+  if (!s->data)
+    abort();
+  s->constants = constants;
+  s->constant_count = clen;
+  memcpy(s->data, code, len);
+  s->data[len] = 0;
+  return BOX(hdr);
+}
+
+static Z add_constant(Cm *co, O obj) {
+  for (Z i = 0; i < co->constants.count; i++) {
+    if (co->constants.data[i] == obj)
+      return i;
+  }
+
+  if (co->constants.count >= co->constants.capacity) {
+    Z newcap = co->constants.capacity == 0 ? 16 : co->constants.capacity * 2;
+    O *newdata = realloc(co->constants.data, newcap * sizeof(O *));
+    if (!newdata)
+      abort();
+    co->constants.capacity = newcap;
+    co->constants.data = newdata;
+  }
+  co->constants.data[co->constants.count++] = obj;
+  return co->constants.count - 1;
+}
+
+V compile(Cm *co, O expr, I tail);
+
+// Compile a (potentially tail-)call to `fn` with `args`.
+static V compile_call(Cm *co, O fn, O args, I tail) {
+  I argc = 0;
+
+  // Compile each argument expression for the function.
+  for (O next = list_next(co->in, &args); next != NIL;
+       next = list_next(co->in, &args)) {
+    compile(co, next, 0);
+    argc++;
+  }
+
+  // Compile the function reference itself
+  compile(co, fn, 0);
+
+  // Compile the call (opcode followed by number of arguments as a byte)
+  emit(co, tail ? OP_TAIL_CALL : OP_CALL);
+  emit(co, (U8)argc);
+}
+
+// Compile the `(if cond then else?)` special form.
+static V compile_if(Cm *c, O form, I tail) {
+  O cond_expr = list_next(c->in, &form);
+  O then_expr = list_next(c->in, &form);
+  O else_expr = list_next(c->in, &form);
+
+  if (cond_expr == NIL || then_expr == NIL)
+    error_throw(c->in, "expected at least two arguments for if");
+
+  // Compile the condition expression
+  compile(c, cond_expr, 0);
+
+  // Prepare the jump to the else-expression
+  emit(c, OP_JUMP_IF_NIL);
+  Z jump_else = c->count;
+  emit16(c, 0);
+
+  // Compile the then-expression
+  compile(c, then_expr, tail);
+  Z jump_then = 0;
+  if (!tail) {
+    // If the expression is not on a tail-position, compile a jump to the code
+    // following the else-expression
+    emit(c, OP_JUMP);
+    jump_then = c->count;
+    emit16(c, 0);
+  }
+
+  // Patch the first jump (to the else-expression)
+  Z else_offset = c->count;
+  c->code[jump_else] = (U8)(else_offset >> 8);
+  c->code[jump_else + 1] = (U8)(else_offset & 0xff);
+
+  // Compile the else-expression
+  compile(c, else_expr, tail);
+  Z end = c->count;
+
+  if (!tail) {
+    // Patch the second jump (to the end of the else-expression) if we're not
+    // on a tail-position
+    c->code[jump_then] = (U8)(end >> 8);
+    c->code[jump_then + 1] = (U8)(end & 0xff);
+  }
+}
+
+// Compile the `(progn expr...)` special form.
+static V compile_progn(Cm *co, O forms, I tail) {
+  // If there are no forms to compile, simply compile NIL.
+  if (forms == NIL) {
+    emit(co, OP_CONST);
+    emit16(co, add_constant(co, NIL));
+    if (tail)
+      emit(co, OP_RET);
+    return;
+  }
+
+  // Compile all forms, discarding intermediate results.
+  while (forms != NIL) {
+    O expr = list_next(co->in, &forms);
+    compile(co, expr, forms == NIL ? tail : 0);
+    if (forms != NIL)
+      emit(co, OP_POP);
+  }
+}
+
+static int nested_p(Cm *c, O body) {
+  while (body != NIL) {
+    O expr = list_next(c->in, &body);
+    if (type(expr) == TYPE_PAIR) {
+      Pa *p = pair_unwrap(c->in, expr);
+      if (p->head == c->specials.fn)
+        return 1;
+      if (nested_p(c, expr))
+        return 1;
+    }
+  }
+  return 0;
+}
+
+// Compile a closure with `args` and `body`.
+static V compile_fn(Cm *c, O args, O body) {
+  // Create an inner compiler context for compiling the closure's body.
+  Cm ic;
+  memset(&ic, 0, sizeof(Cm));
+  ic.in = c->in;
+  ic.specials = c->specials;
+
+  O curr = args;
+  O fixed[256];
+  int fixed_count = 0;
+  O rest = NIL;
+
+  // Count fixed arguments, and if the function has a rest argument
+  while (curr != NIL) {
+    if (type(curr) == TYPE_SYM) {
+      rest = curr;
+      break;
+    }
+    Pa *p = pair_unwrap(c->in, curr);
+    fixed[fixed_count++] = p->head;
+    curr = p->tail;
+  }
+
+  int nested = nested_p(c, body);
+  if (rest == NIL && !nested) {
+    // If the function has no rest argument, and has no nested closures inside
+    // it, compile using stack locals as an optimization for tail-calls
+    ic.use_stack_locals = 1;
+    curr = args;
+    for (O next = list_next(c->in, &curr); next != NIL;
+         next = list_next(c->in, &curr))
+      add_local(&ic, next);
+  } else {
+    // Otherwise, fallback to using environment bindings for locals
+    ic.use_stack_locals = 0;
+    if (rest != NIL) {
+      emit(&ic, OP_BIND_REST);
+      emit16(&ic, add_constant(&ic, rest));
+      emit16(&ic, fixed_count);
+    }
+    for (int i = fixed_count - 1; i >= 0; i--) {
+      emit(&ic, OP_BIND);
+      emit16(&ic, add_constant(&ic, fixed[i]));
+    }
+  }
+
+  // Compile the function's body (as a `progn` form)
+  compile_progn(&ic, body, 1);
+  O code = code_make(c->in, ic.code, ic.count, ic.constants.data,
+                     ic.constants.count);
+  Z code_idx = add_constant(c, code);
+  Z args_idx = add_constant(c, args);
+
+  // Compile pushing the closure to the stack.
+  emit(c, OP_CLOS);
+  emit16(c, code_idx);
+  emit16(c, args_idx);
+
+  // Free the inner compiler context.
+  free(ic.code);
+  if (ic.locals.data)
+    free(ic.locals.data);
+}
+
+// Compile the `(def name value)` special form
+static V compile_def(Cm *c, O args, I tail) {
+  O sym = list_next(c->in, &args);
+  if (type(sym) != TYPE_SYM)
+    error_throw(c->in, "def: expected symbol");
+  O val = list_next(c->in, &args);
+  compile(c, val, 0);
+  emit(c, OP_SET);
+  emit16(c, add_constant(c, sym));
+  emit(c, OP_CONST);
+  emit16(c, add_constant(c, sym));
+  if (tail)
+    emit(c, OP_RET);
+}
+
+// Compile a function application/special form
+static V compile_apply(Cm *co, O expr, I tail) {
+  Pa *p = pair_unwrap(co->in, expr);
+  O head = p->head;
+
+  // Compile special forms
+  if (type(head) == TYPE_SYM) {
+    if (head == co->specials.quote) {
+      Pa *args = pair_unwrap(co->in, p->tail);
+      emit(co, OP_CONST);
+      emit16(co, add_constant(co, args->head));
+      if (tail)
+        emit(co, OP_RET);
+      return;
+    } else if (head == co->specials.iff) {
+      compile_if(co, p->tail, tail);
+      return;
+    } else if (head == co->specials.progn) {
+      compile_progn(co, p->tail, tail);
+      return;
+    } else if (head == co->specials.fn) {
+      Pa *args = pair_unwrap(co->in, p->tail);
+      compile_fn(co, args->head, args->tail);
+      if (tail)
+        emit(co, OP_RET);
+      return;
+    } else if (head == co->specials.def) {
+      compile_def(co, p->tail, tail);
+      return;
+    }
+  }
+  compile_call(co, head, p->tail, tail);
+}
+
+V compile(Cm *co, O expr, I tail) {
+  I ty = type(expr);
+
+  if (co->specials.quote == NIL)
+    co->specials.quote = symbol_make(co->in, "quote");
+  if (co->specials.iff == NIL)
+    co->specials.iff = symbol_make(co->in, "if");
+  if (co->specials.progn == NIL)
+    co->specials.progn = symbol_make(co->in, "progn");
+  if (co->specials.fn == NIL)
+    co->specials.fn = symbol_make(co->in, "fn");
+  if (co->specials.def == NIL)
+    co->specials.def = symbol_make(co->in, "def");
+
+  switch (ty) {
+  case TYPE_NIL:
+  case TYPE_NUM:
+  case TYPE_STR:
+    emit(co, OP_CONST);
+    emit16(co, add_constant(co, expr));
+    if (tail)
+      emit(co, OP_RET);
+    break;
+  case TYPE_SYM:
+    if (co->use_stack_locals) {
+      int idx = find_local(co, expr);
+      if (idx >= 0) {
+        emit(co, OP_GET_LOCAL);
+        emit16(co, idx);
+        if (tail)
+          emit(co, OP_RET);
+        return;
+      }
+    }
+    emit(co, OP_GET);
+    emit16(co, add_constant(co, expr));
+    if (tail)
+      emit(co, OP_RET);
+    break;
+  case TYPE_PAIR:
+    compile_apply(co, expr, tail);
+    break;
+  default:
+    error_throw(co->in, "compile: cannot compile type %s", typename(ty));
+  }
+}

src/disasm.c

@@ -0,0 +1,109 @@
+#include <wolflisp.h>
+
+V disassemble(Cm *co) {
+  for (Z ofs = 0; ofs < co->count; ofs++) {
+    printf("%04zx: ", ofs);
+    switch (co->code[ofs]) {
+    case OP_CONST: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("CONST %d (", idx);
+      print(co->constants.data[idx]);
+      printf(")\n");
+      ofs += 2;
+      break;
+    }
+    case OP_GET: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("GET %d (", idx);
+      print(co->constants.data[idx]);
+      printf(")\n");
+      ofs += 2;
+      break;
+    }
+    case OP_SET: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("SET %d (", idx);
+      print(co->constants.data[idx]);
+      printf(")\n");
+      ofs += 2;
+      break;
+    }
+    case OP_CALL: {
+      U8 argc = co->code[ofs + 1];
+      printf("CALL %d\n", argc);
+      ofs += 1;
+      break;
+    }
+    case OP_TAIL_CALL: {
+      U8 argc = co->code[ofs + 1];
+      printf("TAIL_CALL %d\n", argc);
+      ofs += 1;
+      break;
+    }
+    case OP_JUMP: {
+      U16 o = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("JUMP %04x\n", o);
+      ofs += 2;
+      break;
+    }
+    case OP_JUMP_IF_NIL: {
+      U16 o = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("JUMP_IF_NIL %04x\n", o);
+      ofs += 2;
+      break;
+    }
+    case OP_RET:
+      printf("RET\n");
+      break;
+    case OP_POP:
+      printf("POP\n");
+      break;
+    case OP_CLOS: {
+      U16 b = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      U16 a = (co->code[ofs + 3] << 8) | co->code[ofs + 4];
+      printf("CLOS %04x %04x\n", b, a);
+      ofs += 4;
+      break;
+    }
+    case OP_BIND: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("BIND %d\n", idx);
+      ofs += 2;
+      break;
+    }
+    case OP_BIND_REST: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      U16 cnt = (co->code[ofs + 3] << 8) | co->code[ofs + 4];
+      printf("BIND_REST %d %d\n", idx, cnt);
+      ofs += 4;
+      break;
+    }
+    case OP_PEEK: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("PEEK %d\n", idx);
+      ofs += 2;
+      break;
+    }
+    case OP_GET_LOCAL: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("GET_LOCAL %d\n", idx);
+      ofs += 2;
+      break;
+    }
+    case OP_SET_LOCAL: {
+      U16 idx = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("SET_LOCAL %d\n", idx);
+      ofs += 2;
+      break;
+    }
+    case OP_RESERVE: {
+      U16 cnt = (co->code[ofs + 1] << 8) | co->code[ofs + 2];
+      printf("RESERVE %d\n", cnt);
+      ofs += 2;
+      break;
+    }
+    default:
+      printf("%02x\n", co->code[ofs]);
+    }
+  }
+}

src/error.c

@@ -6,53 +6,23 @@
 void error_init(Er *err) {
   err->active = 0;
   err->message[0] = '\0';
-  err->stack.count = 0;
 }
 
 void error_throw(In *in, const char *fmt, ...) {
   if (!in->err.active) {
-    // No error handler active, fall back to abort
+    fprintf(stderr, "error: ");
-    fprintf(stderr, "fatal error: ");
     va_list args;
     va_start(args, fmt);
     vfprintf(stderr, fmt, args);
     va_end(args);
     fprintf(stderr, "\n");
-    abort();
+    exit(1);
   }
-
-  // Format error message
   va_list args;
   va_start(args, fmt);
   vsnprintf(in->err.message, 512, fmt, args);
   va_end(args);
-
-  // Jump back to error handler
   longjmp(in->err.handler, 1);
 }
 
-void error_push_frame(In *in, const char *frame) {
+void error_print(In *in) { fprintf(stderr, "error: %s\n", in->err.message); }
-  if (in->err.stack.count < 32) {
-    in->err.stack.frames[in->err.stack.count++] = frame;
-  }
-}
-
-void error_pop_frame(In *in) {
-  if (in->err.stack.count > 0) {
-    in->err.stack.count--;
-  }
-}
-
-void error_print(In *in) {
-  fprintf(stderr, "error: %s\n", in->err.message);
-
-  if (in->err.stack.count > 0) {
-    fprintf(stderr, "stack trace:\n");
-    for (int i = in->err.stack.count - 1; i >= 0; i--) {
-      fprintf(stderr, "  %s\n", in->err.stack.frames[i]);
-    }
-  }
-
-  // Reset stack for next error
-  in->err.stack.count = 0;
-}

src/gc.c

@@ -91,6 +91,11 @@ V gc_collect(Gc *gc) {
 
   // Scan to-space for objects to forward (breadth-first iteration)
   while (scan < gc->to.free) {
+    if (scan >= gc->to.end) {
+      fprintf(stderr, "fatal GC error: out of memory\n");
+      abort();
+    }
+
     Gh *hdr = (Gh *)scan;
     switch (hdr->type) {
     case TYPE_PAIR: {
@@ -107,8 +112,18 @@ V gc_collect(Gc *gc) {
       obj->env = forward(gc, obj->env);
       break;
     }
-    case TYPE_STR:
+    case TYPE_CODE: {
+      Bc *obj = (Bc *)(hdr + 1);
+      for (Z i = 0; i < obj->constant_count; i++) {
+        obj->constants[i] = forward(gc, obj->constants[i]);
+      }
       break;
+    }
+    case TYPE_STR: {
+      Ss *obj = (Ss *)(hdr + 1);
+      obj->data = (char *)(obj + 1);
+      break;
+    }
     case TYPE_FWD:
       fprintf(stderr, "fatal GC error: forwarding pointer in to-space\n");
       abort();

src/interp.c

@@ -11,34 +11,34 @@ V interp_init(In *in) {
   in->t = symbol_make(in, "t");
   in->env = NIL;
 
+  // Initialize and root the VM stack
+  for (int i = 0; i < VM_STACK_SIZE; i++) {
+    in->stack[i] = NIL;
+    gc_addroot(&in->gc, &in->stack[i]);
+  }
+  in->sp = in->stack;
+
   // Add T symbol
   in->env = pair_make(in, pair_make(in, in->t, in->t), in->env);
 
-#define PRIM(name, prim) \
+#define PRIM(name, prim, min, max) \
-  in->env = pair_make(in, prim_make(in, name, prim), in->env)
+  in->env = pair_make(in, prim_make(in, name, prim, min, max), in->env)
 
-  PRIM("progn", prim_progn);
+  PRIM("cons", prim_cons, 2, 2);
-  PRIM("def", prim_def);
+  PRIM("head", prim_head, 1, 1);
-  PRIM("defn", prim_defn);
+  PRIM("tail", prim_tail, 1, 1);
-  PRIM("cons", prim_cons);
+  PRIM("list", prim_list, 0, -1);  // variadic
-  PRIM("head", prim_head);
+  PRIM("print", prim_print, 1, 1);
-  PRIM("tail", prim_tail);
+  PRIM("println", prim_println, 1, 1);
-  PRIM("list", prim_list);
+  PRIM("write", prim_write, 1, 1);
-  PRIM("quote", prim_quote);
+  PRIM("+", prim_add, 0, -1);  // variadic
-  PRIM("print", prim_print);
+  PRIM("-", prim_sub, 0, -1);  // variadic
-  PRIM("println", prim_println);
+  PRIM("*", prim_mul, 0, -1);  // variadic
-  PRIM("if", prim_if);
+  PRIM("/", prim_div, 0, -1);  // variadic
-  PRIM("+", prim_add);
+  PRIM("<", prim_lt, 2, 2);
-  PRIM("-", prim_sub);
+  PRIM(">", prim_gt, 2, 2);
-  PRIM("*", prim_mul);
+  PRIM("=", prim_equal, 0, -1);  // variadic
-  PRIM("/", prim_div);
+  PRIM("gc", prim_gc, 0, 0);
-  PRIM("<", prim_lt);
-  PRIM(">", prim_gt);
-
-  PRIM("=", prim_equal);
-  PRIM("fn", prim_fn);
-  PRIM("mac", prim_mac);
-  PRIM("gc", prim_gc);
 #undef PRIM
 }
 
@@ -46,157 +46,3 @@ V interp_finalize(In *in) {
   free(in->symtab.data);
   gc_finalize(&in->gc);
 }
-
-static O bind(In *in, O params, O args, O env) {
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &params);
-  gc_addroot(&in->gc, &args);
-  gc_addroot(&in->gc, &env);
-
-  O res = env;
-  gc_addroot(&in->gc, &res);
-
-  while (params != NIL) {
-    if (type(params) == TYPE_SYM) {
-      O pair = pair_make(in, params, args);
-      gc_addroot(&in->gc, &pair);
-      res = pair_make(in, pair, res);
-      break;
-    }
-
-    if (type(params) != TYPE_PAIR) {
-      error_throw(in, "expected proper list or symbol for parameters");
-    }
-
-    Pa *p = pair_unwrap(in, params);
-    O sym = p->head;
-
-    O val = NIL;
-    if (args != NIL) {
-      if (type(args) != TYPE_PAIR) {
-        error_throw(in, "too many parameters for arguments");
-      }
-      Pa *a = pair_unwrap(in, args);
-      val = a->head;
-      args = a->tail;
-    }
-
-    O pair = pair_make(in, sym, val);
-    gc_addroot(&in->gc, &pair);
-    res = pair_make(in, pair, res);
-
-    params = p->tail;
-  }
-
-  gc_rootreset(&in->gc, mark);
-  return res;
-}
-
-static O eval(In *in, O obj, O env);
-
-static O eval_list(In *in, O list, O env) {
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &list);
-  gc_addroot(&in->gc, &env);
-
-  O head = NIL;
-  O curr = list;
-
-  gc_addroot(&in->gc, &head);
-  gc_addroot(&in->gc, &curr);
-
-  while (curr != NIL) {
-    Pa *p = pair_unwrap(in, curr);
-    O obj = eval(in, p->head, env);
-    head = pair_make(in, obj, head);
-    curr = p->tail;
-  }
-
-  O result = list_reverse(in, head);
-  gc_rootreset(&in->gc, mark);
-  return result;
-}
-
-static O apply(In *in, O fn, O args, O env) {
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &fn);
-  gc_addroot(&in->gc, &args);
-  gc_addroot(&in->gc, &env);
-
-  I ty = type(fn);
-  switch (ty) {
-  case TYPE_PRIM: {
-    Pr *pr = (Pr *)UNTAG(fn);
-    O res = pr->fn(in, args, env);
-    gc_rootreset(&in->gc, mark);
-    return res;
-  }
-  case TYPE_CLOS: {
-    args = eval_list(in, args, env);
-    Gh *hdr = UNBOX(fn);
-    Cl *cl = (Cl *)(hdr + 1);
-    O nenv = bind(in, cl->args, args, cl->env);
-    // `bind' may have moved the closure if a GC was triggered
-    cl = (Cl *)(UNBOX(fn) + 1);
-    O res = eval(in, cl->body, nenv);
-    gc_rootreset(&in->gc, mark);
-    return res;
-  }
-  case TYPE_MAC: {
-    Gh *hdr = UNBOX(fn);
-    Cl *cl = (Cl *)(hdr + 1);
-    O nenv = bind(in, cl->args, args, cl->env);
-    cl = (Cl *)(UNBOX(fn) + 1);
-    O exp = eval(in, cl->body, nenv);
-    gc_addroot(&in->gc, &exp);
-    O res = eval(in, exp, env);
-    gc_rootreset(&in->gc, mark);
-    return res;
-  }
-  default:
-    error_throw(in, "tried to call non-function value");
-    return NIL;
-  }
-}
-
-static O eval(In *in, O obj, O env) {
-  I ty = type(obj);
-
-  if (ty == TYPE_SYM) {
-    O pair = list_assoc(in, obj, env);
-    if (pair == NIL) {
-      pair = list_assoc(in, obj, in->env);
-    }
-    if (pair == NIL) {
-      Sy *s = (Sy *)UNTAG(obj);
-      error_throw(in, "undefined symbol '%.*s'", (int)s->len, s->data);
-    }
-    return pair_unwrap(in, pair)->tail;
-  } else if (ty != TYPE_PAIR) {
-    return obj;
-  }
-
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &obj);
-  gc_addroot(&in->gc, &env);
-
-  Pa *c = pair_unwrap(in, obj);
-  O fn = eval(in, c->head, env);
-  gc_addroot(&in->gc, &fn);
-
-  O res = apply(in, fn, c->tail, env);
-  gc_rootreset(&in->gc, mark);
-  return res;
-}
-
-O interp_eval_list(In *in, O list, O env) {
-  if (env == NIL)
-    env = in->env;
-  return eval_list(in, list, env);
-}
-
-O interp_eval(In *in, O obj, O env) {
-  if (env == NIL)
-    env = in->env;
-  return eval(in, obj, env);
-}

src/list.c

@@ -35,3 +35,11 @@ O list_reverse(In *in, O list) {
 
   return prev;
 }
+
+O list_next(In *in, O *list) {
+  if (*list == NIL)
+    return NIL;
+  O arg = pair_unwrap(in, *list)->head;
+  *list = pair_unwrap(in, *list)->tail;
+  return arg;
+}

src/main.c

@@ -1,32 +1,87 @@
 #include <setjmp.h>
+#include <stdlib.h>
+#include <string.h>
 #include <wolflisp.h>
 
 // TODO: here til I figure out a better interface for this
 int read_expr(In *in, Lx *lex, O *result);
 
-int main(void) {
+void repl(void) {
-  In interp;
+  In in;
-  interp_init(&interp);
+  interp_init(&in);
-
   Lx lex = {0, 0, stdin, {0}};
+  printf("λ> ");
   nexttoken(&lex);
-
+  O result = NIL;
+  I mark = gc_rootmark(&in.gc);
+  gc_addroot(&in.gc, &result);
   while (lex.kind != TOK_EOF) {
     O expr = NIL;
-    I mark = gc_rootmark(&interp.gc);
+    Cm compiler;
-    gc_addroot(&interp.gc, &expr);
+    memset(&compiler, 0, sizeof(Cm));
-    if (read_expr(&interp, &lex, &expr) == -1)
+    compiler.in = &in;
+
+    if (read_expr(&in, &lex, &expr) == -1)
       break;
-    if (setjmp(interp.err.handler) == 0) {
+    if (setjmp(in.err.handler) == 0) {
-      interp.err.active = 1;
+      in.err.active = 1;
-      (void)interp_eval(&interp, expr, NIL);
+      compile(&compiler, expr, 1);
+      disassemble(&compiler);
+      result = vm_run(&compiler);
+      println(result);
     } else {
-      error_print(&interp);
+      error_print(&in);
+      exit(1);
     }
-    gc_rootreset(&interp.gc, mark);
+    printf("λ> ");
-    gc_collect(&interp.gc);
     nexttoken(&lex);
   }
 
-  interp_finalize(&interp);
+  gc_rootreset(&in.gc, mark);
+  gc_collect(&in.gc);
+
+  interp_finalize(&in);
+}
+
+void load(char *fname) {
+  In in;
+  interp_init(&in);
+
+  FILE *fp = fopen(fname, "r");
+  if (!fp) {
+    perror("fopen");
+    exit(1);
+  }
+  Lx lex = {0, 0, fp, {0}};
+
+  nexttoken(&lex);
+  O result = NIL;
+  I mark = gc_rootmark(&in.gc);
+  gc_addroot(&in.gc, &result);
+  while (lex.kind != TOK_EOF) {
+    O expr = NIL;
+    Cm compiler;
+    memset(&compiler, 0, sizeof(Cm));
+    compiler.in = &in;
+    if (read_expr(&in, &lex, &expr) == -1)
+      break;
+    in.err.active = 0;
+    compile(&compiler, expr, 1);
+    result = vm_run(&compiler);
+    nexttoken(&lex);
+  }
+
+  gc_rootreset(&in.gc, mark);
+  gc_collect(&in.gc);
+
+  interp_finalize(&in);
+  fclose(fp);
+}
+
+int main(int argc, char *argv[]) {
+  if (argc == 1) {
+    repl();
+  } else {
+    load(argv[1]);
+  }
 }

src/pair.c

@@ -1,5 +1,3 @@
-#include "stdlib.h"
-#include <stdio.h>
 #include <wolflisp.h>
 
 O pair_make(In *in, O head, O tail) {

src/prim.c

@@ -2,317 +2,176 @@
 #include <stdlib.h>
 #include <wolflisp.h>
 
-static O nextarg(In *in, O *list) {
+#define BOOL(x) ((x) ? in->t : NIL)
-  if (*list == NIL)
-    return NIL;
-  O arg = pair_unwrap(in, *list)->head;
-  *list = pair_unwrap(in, *list)->tail;
-  return arg;
-}
 
-static O bool(In *in, I i) {
+O prim_make(In *in, const char *name, O (*fn)(In *, O *, int, O), int min_args,
-  if (i)
+            int max_args) {
-    return in->t;
-  else
-    return NIL;
-}
-
-O prim_make(In *in, const char *name, O (*fn)(In *, O, O)) {
   Pr *pr = malloc(sizeof(Pr));
   pr->name = name;
   pr->fn = fn;
+  pr->min_args = min_args;
+  pr->max_args = max_args;
   O sym = BOX(TAG(intern(&in->symtab, name, 0), TAG_SYM));
   O prim = BOX(TAG(pr, TAG_PRIM));
   return pair_make(in, sym, prim);
 }
 
-O prim_cons(In *in, O args, O env) {
+O prim_cons(In *in, O *args, int argc, O env) {
-  args = interp_eval_list(in, args, env);
-  O head = nextarg(in, &args);
-  O tail = nextarg(in, &args);
-  return pair_make(in, head, tail);
-}
-
-O prim_list(In *in, O args, O env) { return interp_eval_list(in, args, env); }
-
-O prim_head(In *in, O args, O env) {
-  args = interp_eval_list(in, args, env);
-  return pair_unwrap(in, nextarg(in, &args))->head;
-}
-
-O prim_tail(In *in, O args, O env) {
-  args = interp_eval_list(in, args, env);
-  return pair_unwrap(in, nextarg(in, &args))->tail;
-}
-
-O prim_print(In *in, O args, O env) {
-  args = interp_eval_list(in, args, env);
-  print(nextarg(in, &args));
-  return NIL;
-}
-
-O prim_println(In *in, O args, O env) {
-  args = interp_eval_list(in, args, env);
-  O arg = nextarg(in, &args);
-  println(arg);
-  return NIL;
-}
-
-O prim_quote(In *in, O args, O env) {
-  (void)in;
   (void)env;
-  return nextarg(in, &args);
+  if (argc != 2)
+    error_throw(in, "cons: expected 2 arguments, got %d", argc);
+  return pair_make(in, args[0], args[1]);
 }
 
-O prim_if(In *in, O args, O env) {
+O prim_list(In *in, O *args, int argc, O env) {
-  O cond_expr = nextarg(in, &args);
+  (void)env;
-  O then_expr = nextarg(in, &args);
-  O else_expr = nextarg(in, &args);
-
-  if (cond_expr == NIL || then_expr == NIL) {
-    fprintf(stderr, "if: expected at least 2 arguments\n");
-    abort();
-  }
-
-  if (interp_eval(in, cond_expr, env) != NIL) {
-    return interp_eval(in, then_expr, env);
-  } else {
-    return interp_eval(in, else_expr, env);
-  }
-}
-
-O prim_progn(In *in, O args, O env) {
   O result = NIL;
-  for (O expr = nextarg(in, &args); expr != NIL; expr = nextarg(in, &args))
+  I mark = gc_rootmark(&in->gc);
-    result = interp_eval(in, expr, env);
+  gc_addroot(&in->gc, &result);
+  for (int i = argc - 1; i >= 0; i--) {
+    result = pair_make(in, args[i], result);
+  }
+  gc_rootreset(&in->gc, mark);
   return result;
 }
 
-O prim_add(In *in, O args, O env) {
+O prim_head(In *in, O *args, int argc, O env) {
-  args = interp_eval_list(in, args, env);
+  (void)env;
-  I result = nextarg(in, &args);
+  if (argc != 1)
-  if (result == NIL) {
+    error_throw(in, "head: expected 1 argument, got %d", argc);
+  return pair_unwrap(in, args[0])->head;
+}
+
+O prim_tail(In *in, O *args, int argc, O env) {
+  (void)env;
+  if (argc != 1)
+    error_throw(in, "tail: expected 1 argument, got %d", argc);
+  return pair_unwrap(in, args[0])->tail;
+}
+
+O prim_print(In *in, O *args, int argc, O env) {
+  (void)env;
+  if (argc != 1)
+    error_throw(in, "print: expected 1 argument, got %d", argc);
+  print(args[0]);
+  return NIL;
+}
+
+O prim_println(In *in, O *args, int argc, O env) {
+  (void)env;
+  if (argc != 1)
+    error_throw(in, "println: expected 1 argument, got %d", argc);
+  println(args[0]);
+  return NIL;
+}
+
+O prim_write(In *in, O *args, int argc, O env) {
+  (void)env;
+  if (argc != 1)
+    error_throw(in, "write: expected 1 argument, got %d", argc);
+  if (type(args[0]) != TYPE_STR)
+    error_throw(in, "write: expected string argument, got %s", typename(type(args[0])));
+  Ss *s = (Ss *)(UNBOX(args[0]) + 1);
+  printf("%.*s", (int)s->len, s->data);
+  return NIL;
+}
+
+O prim_add(In *in, O *args, int argc, O env) {
+  (void)env;
+  I result = 0;
+  for (int i = 0; i < argc; i++) {
+    if (!IMM(args[i]))
+      error_throw(in, "+: non numeric argument at position %d", i);
+    result += ORD(args[i]);
+  }
+  return NUM(result);
+}
+
+O prim_sub(In *in, O *args, int argc, O env) {
+  (void)env;
+  if (argc == 0)
     return NUM(0);
-  } else {
+  if (!IMM(args[0]))
-    result = ORD(result);
+    error_throw(in, "-: non numeric argument at position 0");
-  }
+  I result = ORD(args[0]);
-  for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
+  if (argc == 1)
-    if (!IMM(arg)) {
+    return NUM(-result);
-      error_throw(in, "+: non numeric argument");
+  for (int i = 1; i < argc; i++) {
-    }
+    if (!IMM(args[i]))
-    result += ORD(arg);
+      error_throw(in, "-: non numeric argument at position %d", i);
+    result -= ORD(args[i]);
   }
   return NUM(result);
 }
 
-O prim_sub(In *in, O args, O env) {
+O prim_mul(In *in, O *args, int argc, O env) {
-  args = interp_eval_list(in, args, env);
+  (void)env;
-  I result = nextarg(in, &args);
+  I result = 1;
-  if (result == NIL) {
+  for (int i = 0; i < argc; i++) {
-    return NUM(0);
+    if (!IMM(args[i]))
-  } else {
+      error_throw(in, "*: non numeric argument at position %d", i);
-    result = ORD(result);
+    result *= ORD(args[i]);
-  }
-  for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
-    if (!IMM(arg)) {
-      error_throw(in, "-: non numeric argument");
-    }
-    result -= ORD(arg);
   }
   return NUM(result);
 }
 
-O prim_mul(In *in, O args, O env) {
+O prim_div(In *in, O *args, int argc, O env) {
-  args = interp_eval_list(in, args, env);
+  (void)env;
-  I result = nextarg(in, &args);
+  if (argc == 0)
-  if (result == NIL) {
     return NUM(1);
-  } else {
+  if (!IMM(args[0]))
-    result = ORD(result);
+    error_throw(in, "/: non numeric argument at position 0");
-  }
+  I result = ORD(args[0]);
-  for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
+  for (int i = 1; i < argc; i++) {
-    if (!IMM(arg)) {
+    if (!IMM(args[i]))
-      error_throw(in, "*: non numeric argument");
+      error_throw(in, "/: non numeric argument at position %d", i);
-    }
+    if (ORD(args[i]) == 0)
-    result *= ORD(arg);
+      error_throw(in, "/: division by zero at position %d", i);
+    result /= ORD(args[i]);
   }
   return NUM(result);
 }
 
-O prim_div(In *in, O args, O env) {
+O prim_equal(In *in, O *args, int argc, O env) {
-  args = interp_eval_list(in, args, env);
+  (void)env;
-  I result = nextarg(in, &args);
+  if (argc < 2)
-  if (result == NIL) {
+    return in->t;
-    return NUM(1);
+  O first = args[0];
-  } else {
+  for (int i = 1; i < argc; i++) {
-    result = ORD(result);
+    if (first != args[i])
-  }
-  for (O arg = nextarg(in, &args); arg != NIL; arg = nextarg(in, &args)) {
-    if (!IMM(arg)) {
-      error_throw(in, "/: non numeric argument");
-    }
-    if (ORD(arg) == 0) {
-      error_throw(in, "/: division by zero");
-    }
-    result /= ORD(arg);
-  }
-  return NUM(result);
-}
-
-O prim_equal(In *in, O args, O env) {
-  args = interp_eval_list(in, args, env);
-  I result = NIL;
-
-  O fst = nextarg(in, &args);
-  for (O next = nextarg(in, &args); next != NIL; next = nextarg(in, &args)) {
-    if (fst == next) {
-      result = in->t;
-    } else {
       return NIL;
-    }
-    fst = next;
   }
-  return result;
+  return in->t;
 }
 
-O prim_lt(In *in, O args, O env) {
+O prim_lt(In *in, O *args, int argc, O env) {
-  args = interp_eval_list(in, args, env);
+  (void)env;
-  O fst = nextarg(in, &args);
+  if (argc != 2)
-  O snd = nextarg(in, &args);
+    error_throw(in, "<: expected 2 arguments, got %d", argc);
-  if (IMM(fst) && IMM(snd)) {
+  if (IMM(args[0]) && IMM(args[1])) {
-    return bool(in, ORD(fst) < ORD(snd));
+    return BOOL(ORD(args[0]) < ORD(args[1]));
   } else {
     error_throw(in, "<: expected numeric arguments");
     return NIL;
-  };
+  }
 }
 
-O prim_gt(In *in, O args, O env) {
+O prim_gt(In *in, O *args, int argc, O env) {
-  args = interp_eval_list(in, args, env);
+  (void)env;
-  O fst = nextarg(in, &args);
+  if (argc != 2)
-  O snd = nextarg(in, &args);
+    error_throw(in, ">: expected 2 arguments, got %d", argc);
-  if (IMM(fst) && IMM(snd)) {
+  if (IMM(args[0]) && IMM(args[1])) {
-    return bool(in, ORD(fst) > ORD(snd));
+    return BOOL(ORD(args[0]) > ORD(args[1]));
   } else {
     error_throw(in, ">: expected numeric arguments");
     return NIL;
-  };
+  }
 }
 
-O prim_fn(In *in, O args, O env) {
+O prim_gc(In *in, O *args, int argc, O env) {
-  O params = nextarg(in, &args);
-  O body = args;
-
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &params);
-  gc_addroot(&in->gc, &env);
-  gc_addroot(&in->gc, &body);
-
-  O progn = symbol_make(in, "progn");
-  O body_form = pair_make(in, progn, body);
-  gc_addroot(&in->gc, &body_form);
-
-  Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
-  hdr->type = TYPE_CLOS;
-  Cl *cl = (Cl *)(hdr + 1);
-  cl->args = params;
-  cl->env = env;
-  cl->body = body_form;
-
-  gc_rootreset(&in->gc, mark);
-  return BOX(hdr);
-}
-
-O prim_mac(In *in, O args, O env) {
-  O params = nextarg(in, &args);
-  O body = args;
-
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &params);
-  gc_addroot(&in->gc, &env);
-  gc_addroot(&in->gc, &body);
-
-  O progn = symbol_make(in, "progn");
-  O body_form = pair_make(in, progn, body);
-  gc_addroot(&in->gc, &body_form);
-
-  Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
-  hdr->type = TYPE_MAC;
-  Cl *cl = (Cl *)(hdr + 1);
-  cl->args = params;
-  cl->env = env;
-  cl->body = body_form;
-
-  gc_rootreset(&in->gc, mark);
-  return BOX(hdr);
-}
-
-O prim_gc(In *in, O args, O env) {
-  (void)in;
   (void)args;
+  (void)argc;
   (void)env;
   gc_collect(&in->gc);
   return NIL;
 }
-
-O prim_def(In *in, O args, O env) {
-  O sym = nextarg(in, &args);
-  O val_expr = nextarg(in, &args);
-
-  if (type(sym) != TYPE_SYM) {
-    error_throw(in, "def: expected symbol");
-  }
-
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &sym);
-  gc_addroot(&in->gc, &env);
-
-  O val = interp_eval(in, val_expr, env);
-  gc_addroot(&in->gc, &val);
-
-  O pair = pair_make(in, sym, val);
-  gc_addroot(&in->gc, &pair);
-
-  in->env = pair_make(in, pair, in->env);
-
-  gc_rootreset(&in->gc, mark);
-  return sym;
-}
-
-O prim_defn(In *in, O args, O env) {
-  O sym = nextarg(in, &args);
-  O params = nextarg(in, &args);
-  O body = args;
-
-  if (type(sym) != TYPE_SYM) {
-    error_throw(in, "defn: expected symbol");
-  }
-
-  I mark = gc_rootmark(&in->gc);
-  gc_addroot(&in->gc, &sym);
-  gc_addroot(&in->gc, &params);
-  gc_addroot(&in->gc, &body);
-  gc_addroot(&in->gc, &env);
-
-  O progn = symbol_make(in, "progn");
-  O body_form = pair_make(in, progn, body);
-  gc_addroot(&in->gc, &body_form);
-
-  Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
-  hdr->type = TYPE_CLOS;
-  Cl *cl = (Cl *)(hdr + 1);
-  cl->args = params;
-  cl->env = env;
-  cl->body = body_form;
-
-  O fn = BOX(hdr);
-  gc_addroot(&in->gc, &fn);
-
-  O pair = pair_make(in, sym, fn);
-  gc_addroot(&in->gc, &pair);
-
-  in->env = pair_make(in, pair, in->env);
-
-  gc_rootreset(&in->gc, mark);
-  return sym;
-}

src/prim.h

@@ -1,23 +1,17 @@
 #include <wolflisp.h>
 
-O prim_progn(In *in, O args, O env);
+O prim_cons(In *in, O *args, int argc, O env);
-O prim_cons(In *in, O args, O env);
+O prim_head(In *in, O *args, int argc, O env);
-O prim_head(In *in, O args, O env);
+O prim_tail(In *in, O *args, int argc, O env);
-O prim_tail(In *in, O args, O env);
+O prim_list(In *in, O *args, int argc, O env);
-O prim_list(In *in, O args, O env);
+O prim_print(In *in, O *args, int argc, O env);
-O prim_quote(In *in, O args, O env);
+O prim_println(In *in, O *args, int argc, O env);
-O prim_print(In *in, O args, O env);
+O prim_write(In *in, O *args, int argc, O env);
-O prim_println(In *in, O args, O env);
+O prim_add(In *in, O *args, int argc, O env);
-O prim_if(In *in, O args, O env);
+O prim_sub(In *in, O *args, int argc, O env);
-O prim_add(In *in, O args, O env);
+O prim_mul(In *in, O *args, int argc, O env);
-O prim_sub(In *in, O args, O env);
+O prim_div(In *in, O *args, int argc, O env);
-O prim_mul(In *in, O args, O env);
+O prim_equal(In *in, O *args, int argc, O env);
-O prim_div(In *in, O args, O env);
+O prim_lt(In *in, O *args, int argc, O env);
-O prim_equal(In *in, O args, O env);
+O prim_gt(In *in, O *args, int argc, O env);
-O prim_lt(In *in, O args, O env);
+O prim_gc(In *in, O *args, int argc, O env);
-O prim_gt(In *in, O args, O env);
-O prim_fn(In *in, O args, O env);
-O prim_mac(In *in, O args, O env);
-O prim_gc(In *in, O args, O env);
-O prim_def(In *in, O args, O env);
-O prim_defn(In *in, O args, O env);

src/print.c

@@ -46,7 +46,7 @@ void print(O obj) {
     }
     case TAG_PRIM: {
       Pr *p = (Pr *)UNTAG(obj);
-      printf("<#primitive %s>", p->name);
+      printf("<#primitive \"%s\">", p->name);
       break;
     }
     default: {
@@ -57,18 +57,11 @@ void print(O obj) {
         break;
       case TYPE_STR: {
         Ss *s = (Ss *)(h + 1);
-        printf("%.*s", (int)s->len, s->data);
+        printf("\"%.*s\"", (int)s->len, s->data);
-        break;
-      }
-      case TYPE_CLOS: {
-        Cl *cl = (Cl *)(h + 1);
-        printf("<#fn ");
-        print(cl->args);
-        printf(">");
         break;
       }
       default:
-        printf("<#obj type=%" PRId32 " @ %p>", h->type, (void *)h);
+        printf("<#%s %p>", typename(h->type), (void *)h);
         break;
       }
     }

src/type.c

@@ -13,6 +13,7 @@ static const char *typenames[] = {
   [TYPE_STR] = "string",
   [TYPE_CLOS] = "closure",
   [TYPE_MAC] = "macro",
+  [TYPE_CODE] = "bytecode",
 };
 // clang-format on
 
@@ -40,6 +41,6 @@ I type(O obj) {
 
 const char *typename(I t) {
   if (t >= TYPE__MAX)
-    return "??";
+    return "?";
   return typenames[t];
 }

src/vm.c

@@ -0,0 +1,227 @@
+#include <wolflisp.h>
+
+#define PUSH(x) (*in->sp++ = (x))
+#define POP() (*--in->sp)
+#define PEEK() (*(in->sp - 1))
+#define READ16() (ip += 2, (U16)((ip[-2] << 8) | ip[-1]))
+
+static O vm_exec(Cm *co_in, O env_in, int argc_in) {
+  Cm co_struct = *co_in;
+  Cm *co = &co_struct;
+  O env = env_in;
+  In *in = co->in;
+  int argc = argc_in;
+  O *fp = in->sp - argc;
+
+  I env_mark = gc_rootmark(&in->gc);
+  gc_addroot(&in->gc, &env);
+
+  U8 *ip = co->code;
+  U8 *end = co->code + co->count;
+
+  while (ip < end) {
+    U8 op = *ip++;
+    switch (op) {
+    case OP_HALT:
+      gc_rootreset(&in->gc, env_mark);
+      return NIL;
+    case OP_CONST: {
+      U16 idx = READ16();
+      PUSH(co->constants.data[idx]);
+      break;
+    }
+    case OP_GET: {
+      U16 idx = READ16();
+      O sym = co->constants.data[idx];
+      O pair = list_assoc(in, sym, env);
+      if (pair == NIL)
+        pair = list_assoc(in, sym, in->env);
+      if (pair == NIL) {
+        Sy *s = (Sy *)UNTAG(sym);
+        error_throw(in, "undefined symbol '%.*s'", (int)s->len, s->data);
+      }
+      PUSH(pair_unwrap(in, pair)->tail);
+      break;
+    }
+    case OP_SET: {
+      U16 idx = READ16();
+      O sym = co->constants.data[idx];
+      O val = POP();
+      O binding = pair_make(in, sym, val);
+      in->env = pair_make(in, binding, in->env);
+      break;
+    }
+    case OP_JUMP: {
+      U16 offset = READ16();
+      ip = co->code + offset;
+      break;
+    }
+    case OP_JUMP_IF_NIL: {
+      U16 offset = READ16();
+      O val = POP();
+      if (val == NIL) {
+        ip = co->code + offset;
+      }
+      break;
+    }
+    case OP_CALL: {
+      U8 next_argc = *ip++;
+      O func = POP();
+      O res = NIL;
+      I ty = type(func);
+      if (ty == TYPE_PRIM) {
+        Pr *pr = (Pr *)UNTAG(func);
+        if (pr->min_args >= 0 && next_argc < pr->min_args) {
+          error_throw(in, "%s: expected at least %d arguments, got %d",
+                      pr->name, pr->min_args, next_argc);
+        }
+        if (pr->max_args >= 0 && next_argc > pr->max_args) {
+          error_throw(in, "%s: expected at most %d arguments, got %d", pr->name,
+                      pr->max_args, next_argc);
+        }
+        O *args = in->sp - next_argc;
+        res = pr->fn(in, args, next_argc, in->env);
+        in->sp -= next_argc;
+      } else if (ty == TYPE_CLOS) {
+        Gh *hdr = UNBOX(func);
+        Cl *cl = (Cl *)(hdr + 1);
+        O nenv = cl->env;
+        O body = cl->body;
+        Bc *bc = (Bc *)(UNBOX(body) + 1);
+        // clang-format off
+        Cm co2 = {
+          .in = in,
+          .code = bc->data,
+          .count = bc->len,
+          .constants = {
+            .data = bc->constants,
+            .count = bc->constant_count,
+            .capacity = bc->constant_count
+          }
+        };
+        // clang-format on
+        res = vm_exec(&co2, nenv, next_argc);
+      } else {
+        error_throw(in, "call to non-function object");
+      }
+      PUSH(res);
+      break;
+    }
+    case OP_TAIL_CALL: {
+      U8 next_argc = *ip++;
+      O func = POP();
+      I ty = type(func);
+      if (ty == TYPE_PRIM) {
+        Pr *pr = (Pr *)UNTAG(func);
+        if (pr->min_args >= 0 && next_argc < pr->min_args) {
+          error_throw(in, "%s: expected at least %d arguments, got %d",
+                      pr->name, pr->min_args, next_argc);
+        }
+        if (pr->max_args >= 0 && next_argc > pr->max_args) {
+          error_throw(in, "%s: expected at most %d arguments, got %d", pr->name,
+                      pr->max_args, next_argc);
+        }
+        O *args = in->sp - next_argc;
+        O res = pr->fn(in, args, next_argc, env);
+        in->sp -= argc + next_argc;
+        return res;
+      } else if (ty == TYPE_CLOS) {
+        Gh *hdr = UNBOX(func);
+        Cl *cl = (Cl *)(hdr + 1);
+        env = cl->env;
+        Bc *bc = (Bc *)(UNBOX(cl->body) + 1);
+        co->code = ip = bc->data;
+        co->count = bc->len;
+        end = ip + bc->len;
+        co->constants.data = bc->constants;
+        co->constants.count = bc->constant_count;
+        O *new_args = in->sp - next_argc;
+        for (int i = 0; i < next_argc; i++)
+          fp[i] = new_args[i];
+        in->sp = fp + next_argc;
+        argc = next_argc;
+      } else {
+        error_throw(in, "call to non-function object");
+      }
+      break;
+    }
+    case OP_BIND: {
+      U16 idx = READ16();
+      O sym = co->constants.data[idx];
+      O val = POP();
+      O binding = pair_make(in, sym, val);
+      env = pair_make(in, binding, env);
+      argc--;
+      break;
+    }
+    case OP_BIND_REST: {
+      U16 idx = READ16();
+      U16 fixed_cnt = READ16();
+      O sym = co->constants.data[idx];
+      O list = NIL;
+      I mark = gc_rootmark(&in->gc);
+      gc_addroot(&in->gc, &list);
+      while (argc > fixed_cnt) {
+        list = pair_make(in, POP(), list);
+        argc--;
+      }
+      gc_rootreset(&in->gc, mark);
+      O binding = pair_make(in, sym, list);
+      env = pair_make(in, binding, env);
+      break;
+    }
+    case OP_PEEK: {
+      U16 idx = READ16();
+      O val = fp[argc - 1 - idx];
+      PUSH(val);
+      break;
+    }
+    case OP_GET_LOCAL: {
+      U16 idx = READ16();
+      O val = fp[idx];
+      PUSH(val);
+      break;
+    }
+    case OP_SET_LOCAL: {
+      U16 idx = READ16();
+      O val = PEEK();
+      fp[idx] = val;
+      break;
+    }
+    case OP_RESERVE: {
+      U16 count = READ16();
+      for (U16 i = 0; i < count; i++) {
+        PUSH(NIL);
+      }
+      break;
+    }
+    case OP_RET: {
+      O ret = POP();
+      in->sp -= argc;
+      gc_rootreset(&in->gc, env_mark);
+      return ret;
+    }
+    case OP_POP:
+      (void)POP();
+      break;
+    case OP_CLOS: {
+      U16 code_idx = READ16();
+      U16 args_idx = READ16();
+      Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
+      hdr->type = TYPE_CLOS;
+      Cl *cl = (Cl *)(hdr + 1);
+      cl->args = co->constants.data[args_idx];
+      cl->body = co->constants.data[code_idx];
+      cl->env = env;
+      PUSH(BOX(hdr));
+      break;
+    }
+    default:
+      error_throw(in, "unknown opcode %d", op);
+    }
+  }
+  gc_rootreset(&in->gc, env_mark);
+  return NIL;
+}
+
+O vm_run(Cm *co) { return vm_exec(co, co->in->env, 0); }

test.lisp

@@ -0,0 +1,17 @@
+(def fib-iter (fn (n a b)
+  (if (= n 0)
+      a
+      (fib-iter (- n 1) b (+ a b)))))
+(def fib (fn (n) (fib-iter n 0 1)))
+
+(write "(fib 50) = ")
+(println (fib 50))
+
+(def sum
+  (fn (n acc)
+    (if (= n 0)
+      acc
+      (sum (- n 1) (+ n acc)))))
+
+(write "(sum 1000000) = ")
+(println (sum 1000000 0))