sdkhjfdsv

README.md

@@ -1,3 +1,2 @@
 # wolflisp
-
+a lisp but wolfy.  right now it's very minimal... :^)
-a lisp but wolfy

include/wolflisp.h

@@ -1,6 +1,7 @@
 #ifndef WOLFLISP_H
 #define WOLFLISP_H
 
+#include <setjmp.h>
 #include <stddef.h>
 #include <stdint.h>
 
@@ -107,13 +108,48 @@ typedef struct Gc {
   } roots;
 } Gc;
 
+// Error context
+typedef struct Er {
+  jmp_buf handler;
+  int active;
+  char message[512];
+  struct {
+    const char *frames[32];
+    int count;
+  } stack;
+} Er;
+
 // Interpreter context
 typedef struct In {
   Gc gc;
   St symtab;
   O env;
+  Er err;
+  O t; // the T symbol
 } In;
 
+enum {
+  TOK_EOF = 0,
+  TOK_COMMENT = ';',
+  TOK_WORD = 'a',
+  TOK_LPAREN = '(',
+  TOK_RPAREN = ')',
+  TOK_STRING = '"',
+  TOK_QUOTE = '\'',
+  TOK_DOT = '.',
+};
+
+#include <stdio.h>
+
+#define LEXER_CAP 1024
+
+typedef struct Lx {
+  int kind;
+  int cursor;
+  FILE *input;
+  char buffer[1024];
+} Lx;
+
 /// * Function declarations
 
 // Get the type of an object
@@ -136,6 +172,12 @@ V gc_init(Gc *gc);
 // Finalize a GC context.
 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.
 V interp_init(In *in);
 // Finalize an interpreter context.
@@ -151,7 +193,7 @@ O interp_eval(In *in, O obj, O env);
 Sy *intern(St *tab, const char *str, Z len);
 
 // Create a pair
-O pair_make(Gc *gc, O head, O tail);
+O pair_make(In *in, O head, O tail);
 // Unwrap a pair
 Pa *pair_unwrap(O obj);
 
@@ -164,4 +206,6 @@ O prim_make(In *in, const char *name, O (*fn)(In *, O, O));
 O list_assoc(O key, O alist);
 O list_reverse(O list);
 
+int nexttoken(Lx *lex);
+
 #endif

meson.build

@@ -3,18 +3,21 @@ project(
   'c',
   meson_version : '>= 1.3.0',
   version : '0.1',
-  default_options : ['c_std=gnu11', 'buildtype=debugoptimized', 'warning_level=3'],
+  default_options : ['c_std=c11', 'buildtype=debugoptimized', 'warning_level=3'],
 )
 
 inc = include_directories('include', 'src')
 src = [
+  'src/error.c',
   'src/gc.c',
   'src/interp.c',
+  'src/lex.c',
   'src/list.c',
   'src/main.c',
   'src/pair.c',
   'src/prim.c',
   'src/print.c',
+  'src/read.c',
   'src/symbol.c',
   'src/type.c',
 ]

src/error.c

@@ -0,0 +1,58 @@
+#include <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <wolflisp.h>
+
+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, "fatal error: ");
+    va_list args;
+    va_start(args, fmt);
+    vfprintf(stderr, fmt, args);
+    va_end(args);
+    fprintf(stderr, "\n");
+    abort();
+  }
+
+  // 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) {
+  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/interp.c

@@ -1,4 +1,3 @@
-#include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
 
@@ -8,14 +7,36 @@
 V interp_init(In *in) {
   memset(&in->symtab, 0, sizeof(St));
   gc_init(&in->gc);
-
+  gc_addroot(&in->gc, &in->env);
+  in->t = symbol_make(in, "t");
   in->env = NIL;
-  in->env = pair_make(&in->gc, prim_make(in, "cons", prim_cons), in->env);
+  in->env = pair_make(in, pair_make(in, in->t, in->t), in->env);
-  in->env = pair_make(&in->gc, prim_make(in, "head", prim_head), in->env);
+
-  in->env = pair_make(&in->gc, prim_make(in, "tail", prim_tail), in->env);
+#define PRIM(name, prim)                                                       \
-  in->env = pair_make(&in->gc, prim_make(in, "quote", prim_quote), in->env);
+  in->env = pair_make(in, prim_make(in, name, prim), in->env)
-  in->env = pair_make(&in->gc, prim_make(in, "print", prim_print), in->env);
+
-  in->env = pair_make(&in->gc, prim_make(in, "println", prim_println), in->env);
+  PRIM("progn", prim_progn);
+  PRIM("def", prim_def);
+  PRIM("defn", prim_defn);
+  PRIM("cons", prim_cons);
+  PRIM("head", prim_head);
+  PRIM("tail", prim_tail);
+  PRIM("list", prim_list);
+  PRIM("quote", prim_quote);
+  PRIM("print", prim_print);
+  PRIM("println", prim_println);
+  PRIM("if", prim_if);
+  PRIM("+", prim_add);
+  PRIM("-", prim_sub);
+  PRIM("*", prim_mul);
+  PRIM("/", prim_div);
+  PRIM("<", prim_lt);
+  PRIM(">", prim_gt);
+
+  PRIM("=", prim_equal);
+  PRIM("fn", prim_fn);
+  PRIM("gc", prim_gc);
+#undef PRIM
 }
 
 V interp_finalize(In *in) {
@@ -23,26 +44,25 @@ V interp_finalize(In *in) {
   gc_finalize(&in->gc);
 }
 
-static O bind(Gc *gc, O params, O args, O env) {
+static O bind(In *in, O params, O args, O env) {
-  I mark = gc_rootmark(gc);
+  I mark = gc_rootmark(&in->gc);
-  gc_addroot(gc, &params);
+  gc_addroot(&in->gc, &params);
-  gc_addroot(gc, &args);
+  gc_addroot(&in->gc, &args);
-  gc_addroot(gc, &env);
+  gc_addroot(&in->gc, &env);
 
   O res = env;
-  gc_addroot(gc, &res);
+  gc_addroot(&in->gc, &res);
 
   while (params != NIL) {
     if (type(params) == TYPE_SYM) {
-      O pair = pair_make(gc, params, args);
+      O pair = pair_make(in, params, args);
-      gc_addroot(gc, &pair);
+      gc_addroot(&in->gc, &pair);
-      res = pair_make(gc, pair, res);
+      res = pair_make(in, pair, res);
       break;
     }
 
     if (type(params) != TYPE_PAIR) {
-      fprintf(stderr, "error: expected proper list or symbol for parameters\n");
+      error_throw(in, "expected proper list or symbol for parameters");
-      abort();
     }
 
     Pa *p = pair_unwrap(params);
@@ -51,22 +71,21 @@ static O bind(Gc *gc, O params, O args, O env) {
     O val = NIL;
     if (args != NIL) {
       if (type(args) != TYPE_PAIR) {
-        fprintf(stderr, "error: too many parameters for arguments\n");
+        error_throw(in, "too many parameters for arguments");
-        abort();
       }
       Pa *a = pair_unwrap(args);
       val = a->head;
       args = a->tail;
     }
 
-    O pair = pair_make(gc, sym, val);
+    O pair = pair_make(in, sym, val);
-    gc_addroot(gc, &pair);
+    gc_addroot(&in->gc, &pair);
-    res = pair_make(gc, pair, res);
+    res = pair_make(in, pair, res);
 
     params = p->tail;
   }
 
-  gc_rootreset(gc, mark);
+  gc_rootreset(&in->gc, mark);
   return res;
 }
 
@@ -86,7 +105,7 @@ static O eval_list(In *in, O list, O env) {
   while (curr != NIL) {
     Pa *p = pair_unwrap(curr);
     O obj = eval(in, p->head, env);
-    head = pair_make(&in->gc, obj, head);
+    head = pair_make(in, obj, head);
     curr = p->tail;
   }
 
@@ -96,22 +115,32 @@ static O eval_list(In *in, O list, O env) {
 }
 
 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);
-    return pr->fn(in, args, env);
+    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);
-    args = eval_list(in, args, env);
+    O nenv = bind(in, cl->args, args, cl->env);
-    O nenv = bind(&in->gc, cl->args, args, cl->env);
+    cl = (Cl *)(UNBOX(fn) +
+                1); // `bind' may have moved the closure if a GC was triggered
+    gc_rootreset(&in->gc, mark);
     return eval(in, cl->body, nenv);
   }
   default:
-    fprintf(stderr, "tried to call non-function value\n");
+    error_throw(in, "tried to call non-function value");
-    abort();
+    return NIL;
   }
 }
 
@@ -120,10 +149,12 @@ static O eval(In *in, O obj, O env) {
 
   if (ty == TYPE_SYM) {
     O pair = list_assoc(obj, env);
+    if (pair == NIL) {
+      pair = list_assoc(obj, in->env);
+    }
     if (pair == NIL) {
       Sy *s = (Sy *)UNTAG(obj);
-      fprintf(stderr, "error: undefined symbol '%.*s'\n", (int)s->len, s->data);
+      error_throw(in, "undefined symbol '%.*s'", (int)s->len, s->data);
-      abort();
     }
     return pair_unwrap(pair)->tail;
   } else if (ty != TYPE_PAIR) {
@@ -152,5 +183,5 @@ O interp_eval_list(In *in, O list, O env) {
 O interp_eval(In *in, O obj, O env) {
   if (env == NIL)
     env = in->env;
-  return eval(in, obj, in->env);
+  return eval(in, obj, env);
 }

src/lex.c

@@ -0,0 +1,117 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+#include <wolflisp.h>
+
+// helpers
+static int iswhite(int ch) { return ch == ' ' || ch == '\t' || ch == '\n'; }
+
+static int isdelim(int ch) {
+  return ch == '(' || ch == ')' || ch == '\'' || ch == ';';
+}
+
+static inline void appendchar(Lx *lex, char ch) {
+  if (lex->cursor > LEXER_CAP) {
+    fprintf(stderr, "lexer buffer overflow");
+    abort();
+  }
+  lex->buffer[lex->cursor++] = ch;
+}
+
+static int getcws(Lx *lex) {
+  if (feof(lex->input))
+    return EOF;
+  for (;;) {
+    int ch = getc(lex->input);
+    if (iswhite(ch))
+      continue;
+    return ch;
+  }
+}
+
+static int scanword(Lx *lex) {
+  int ch = getc(lex->input);
+  for (;;) {
+    if (ch == EOF) {
+      if (lex->cursor == 0)
+        lex->kind = TOK_EOF;
+      appendchar(lex, 0);
+      return lex->kind;
+    } else if (iswhite(ch) || isdelim(ch)) {
+      ungetc(ch, lex->input);
+      appendchar(lex, 0);
+      return lex->kind;
+    } else {
+      appendchar(lex, ch);
+      ch = getc(lex->input);
+    }
+  }
+}
+
+static int scanstring(Lx *lex) {
+  int ch;
+  for (;;) {
+    ch = getc(lex->input);
+    switch (ch) {
+    case EOF:
+      goto eof;
+    case '\\':
+      ch = getc(lex->input);
+      if (ch == EOF)
+        goto eof;
+      switch (ch) {
+      case 'n':
+        appendchar(lex, '\n');
+        break;
+      case 't':
+        appendchar(lex, '\t');
+        break;
+      case '"':
+        appendchar(lex, '"');
+        break;
+      }
+      break;
+    case '"':
+      appendchar(lex, 0);
+      return (lex->kind = TOK_STRING);
+    default:
+      appendchar(lex, ch);
+    }
+  }
+
+eof:
+  fprintf(stderr, "unterminated string literal");
+  abort();
+}
+
+int nexttoken(Lx *lex) {
+  int ch;
+  lex->cursor = 0;
+
+  if (feof(lex->input)) {
+    lex->kind = TOK_EOF;
+    *lex->buffer = 0;
+    return 0;
+  }
+
+  ch = getcws(lex);
+  switch (ch) {
+  case ';':
+    for (; ch != '\n' && ch != EOF; ch = getc(lex->input))
+      ;
+    return nexttoken(lex);
+  case '(':
+  case ')':
+  case '.':
+  case '\'':
+    return (lex->kind = ch);
+  case '"':
+    return scanstring(lex);
+  default:
+    ungetc(ch, lex->input);
+    lex->kind = TOK_WORD;
+    return scanword(lex);
+  }
+
+  return 0;
+}

src/main.c

@@ -1,19 +1,31 @@
+#include <setjmp.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) {
   In interp;
   interp_init(&interp);
 
-  // Build code
+  Lx lex = {0, 0, stdin, {0}};
-  O s_println = symbol_make(&interp, "println");
+  nexttoken(&lex);
-  O s_quote = symbol_make(&interp, "quote");
 
-  O data = pair_make(
+  while (lex.kind != TOK_EOF) {
-      &interp.gc, s_quote,
+    O expr = NIL;
-      pair_make(&interp.gc, pair_make(&interp.gc, NUM(1), NUM(2)), NIL));
+    I mark = gc_rootmark(&interp.gc);
-
+    gc_addroot(&interp.gc, &expr);
-  O code = pair_make(&interp.gc, s_println, pair_make(&interp.gc, data, NIL));
+    if (read_expr(&interp, &lex, &expr) == -1)
-  (void)interp_eval(&interp, code, NIL);
+      break;
+    if (setjmp(interp.err.handler) == 0) {
+      interp.err.active = 1;
+      (void)interp_eval(&interp, expr, NIL);
+    } else {
+      error_print(&interp);
+    }
+    gc_rootreset(&interp.gc, mark);
+    nexttoken(&lex);
+  }
 
   interp_finalize(&interp);
 }

src/pair.c

@@ -2,20 +2,20 @@
 #include <stdio.h>
 #include <wolflisp.h>
 
-O pair_make(Gc *gc, O head, O tail) {
+O pair_make(In *in, O head, O tail) {
-  I mark = gc_rootmark(gc);
+  I mark = gc_rootmark(&in->gc);
-  gc_addroot(gc, &head);
+  gc_addroot(&in->gc, &head);
-  gc_addroot(gc, &tail);
+  gc_addroot(&in->gc, &tail);
 
   Z size = sizeof(Gh) + sizeof(Pa);
-  Gh *hdr = gc_alloc(gc, size);
+  Gh *hdr = gc_alloc(&in->gc, size);
   hdr->type = TYPE_PAIR;
 
   Pa *pair = (Pa *)(hdr + 1);
   pair->head = head;
   pair->tail = tail;
 
-  gc_rootreset(gc, mark);
+  gc_rootreset(&in->gc, mark);
   return BOX(hdr);
 }
 

src/prim.c

@@ -2,43 +2,58 @@
 #include <stdlib.h>
 #include <wolflisp.h>
 
+static O nextarg(O *list) {
+  if (*list == NIL)
+    return NIL;
+  O arg = pair_unwrap(*list)->head;
+  *list = pair_unwrap(*list)->tail;
+  return arg;
+}
+
+static O bool(In *in, I i) {
+  if (i)
+    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;
   O sym = BOX(TAG(intern(&in->symtab, name, 0), TAG_SYM));
   O prim = BOX(TAG(pr, TAG_PRIM));
-  return pair_make(&in->gc, sym, prim);
+  return pair_make(in, sym, prim);
 }
 
 O prim_cons(In *in, O args, O env) {
   args = interp_eval_list(in, args, env);
-  O head = pair_unwrap(args)->head;
+  O head = nextarg(&args);
-  args = pair_unwrap(args)->tail;
+  O tail = nextarg(&args);
-  O tail = pair_unwrap(args)->head;
+  return pair_make(in, head, tail);
-  return pair_make(&in->gc, 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(pair_unwrap(args)->head)->head;
+  return pair_unwrap(nextarg(&args))->head;
 }
 
 O prim_tail(In *in, O args, O env) {
   args = interp_eval_list(in, args, env);
-  return pair_unwrap(pair_unwrap(args)->head)->tail;
+  return pair_unwrap(nextarg(&args))->tail;
 }
 
 O prim_print(In *in, O args, O env) {
   args = interp_eval_list(in, args, env);
-  O arg = pair_unwrap(args)->head;
+  print(nextarg(&args));
-  print(arg);
   return NIL;
 }
 
 O prim_println(In *in, O args, O env) {
   args = interp_eval_list(in, args, env);
-  O arg = pair_unwrap(args)->head;
+  O arg = nextarg(&args);
   println(arg);
   return NIL;
 }
@@ -46,8 +61,234 @@ O prim_println(In *in, O args, O env) {
 O prim_quote(In *in, O args, O env) {
   (void)in;
   (void)env;
-
+  return nextarg(&args);
-  if (args == NIL)
+}
-    return NIL;
+
-  return pair_unwrap(args)->head;
+O prim_if(In *in, O args, O env) {
+  O cond_expr = nextarg(&args);
+  O then_expr = nextarg(&args);
+  O else_expr = nextarg(&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(&args); expr != NIL; expr = nextarg(&args))
+    result = interp_eval(in, expr, env);
+  return result;
+}
+
+O prim_add(In *in, O args, O env) {
+  args = interp_eval_list(in, args, env);
+  I result = nextarg(&args);
+  if (result == NIL) {
+    return NUM(0);
+  } else {
+    result = ORD(result);
+  }
+  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
+    if (!IMM(arg)) {
+      error_throw(in, "+: non numeric argument");
+    }
+    result += ORD(arg);
+  }
+  return NUM(result);
+}
+
+O prim_sub(In *in, O args, O env) {
+  args = interp_eval_list(in, args, env);
+  I result = nextarg(&args);
+  if (result == NIL) {
+    return NUM(0);
+  } else {
+    result = ORD(result);
+  }
+  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&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) {
+  args = interp_eval_list(in, args, env);
+  I result = nextarg(&args);
+  if (result == NIL) {
+    return NUM(1);
+  } else {
+    result = ORD(result);
+  }
+  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
+    if (!IMM(arg)) {
+      error_throw(in, "*: non numeric argument");
+    }
+    result *= ORD(arg);
+  }
+  return NUM(result);
+}
+
+O prim_div(In *in, O args, O env) {
+  args = interp_eval_list(in, args, env);
+  I result = nextarg(&args);
+  if (result == NIL) {
+    return NUM(1);
+  } else {
+    result = ORD(result);
+  }
+  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&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(&args);
+  for (O next = nextarg(&args); next != NIL; next = nextarg(&args)) {
+    if (fst == next) {
+      result = in->t;
+    } else {
+      return NIL;
+    }
+    fst = next;
+  }
+  return result;
+}
+
+O prim_lt(In *in, O args, O env) {
+  args = interp_eval_list(in, args, env);
+  O fst = nextarg(&args);
+  O snd = nextarg(&args);
+  if (IMM(fst) && IMM(snd)) {
+    return bool(in, ORD(fst) < ORD(snd));
+  } else {
+    error_throw(in, "<: expected numeric arguments");
+    return NIL;
+  };
+}
+
+O prim_gt(In *in, O args, O env) {
+  args = interp_eval_list(in, args, env);
+  O fst = nextarg(&args);
+  O snd = nextarg(&args);
+  if (IMM(fst) && IMM(snd)) {
+    return bool(in, ORD(fst) > ORD(snd));
+  } else {
+    error_throw(in, ">: expected numeric arguments");
+    return NIL;
+  };
+}
+
+O prim_fn(In *in, O args, O env) {
+  O params = nextarg(&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_gc(In *in, O args, O env) {
+  (void)in;
+  (void)args;
+  (void)env;
+  gc_collect(&in->gc);
+  return NIL;
+}
+
+O prim_def(In *in, O args, O env) {
+  O sym = nextarg(&args);
+  O val_expr = nextarg(&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(&args);
+  O params = nextarg(&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,8 +1,22 @@
 #include <wolflisp.h>
 
+O prim_progn(In *in, O args, O env);
 O prim_cons(In *in, O args, O env);
 O prim_head(In *in, O args, O env);
 O prim_tail(In *in, O args, O env);
+O prim_list(In *in, O args, O env);
 O prim_quote(In *in, O args, O env);
 O prim_print(In *in, O args, O env);
 O prim_println(In *in, O args, O env);
+O prim_if(In *in, O args, O env);
+O prim_add(In *in, O args, O env);
+O prim_sub(In *in, O args, O env);
+O prim_mul(In *in, O args, O env);
+O prim_div(In *in, O args, O env);
+O prim_equal(In *in, O args, O env);
+O prim_lt(In *in, O args, O env);
+O prim_gt(In *in, O args, O env);
+O prim_fn(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

@@ -34,7 +34,7 @@ void print_pair(O obj) {
 
 void print(O obj) {
   if (obj == NIL) {
-    printf("()");
+    printf("NIL");
   } else if (IMM(obj)) {
     printf("%" PRIdPTR, ORD(obj));
   } else {
@@ -55,6 +55,13 @@ void print(O obj) {
       case TYPE_PAIR:
         print_pair(obj);
         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);
         break;

src/read.c

@@ -0,0 +1,80 @@
+#include <ctype.h>
+#include <stdlib.h>
+#include <wolflisp.h>
+
+static int is_number(const char *str) {
+  if (*str == '-' || *str == '+')
+    str++;
+  if (!*str)
+    return 0;
+  while (*str) {
+    if (!isdigit(*str))
+      return 0;
+    str++;
+  }
+  return 1;
+}
+
+int read_expr(In *in, Lx *lex, O *result) {
+  I mark = gc_rootmark(&in->gc);
+  gc_addroot(&in->gc, result);
+
+  switch (lex->kind) {
+  case TOK_EOF:
+    return -1;
+
+  case TOK_LPAREN: {
+    nexttoken(lex);
+    O list = NIL, tail = NIL;
+    gc_addroot(&in->gc, &list);
+    gc_addroot(&in->gc, &tail);
+
+    while (lex->kind != TOK_RPAREN && lex->kind != TOK_EOF) {
+      O elem;
+      read_expr(in, lex, &elem);
+      nexttoken(lex);
+
+      O cell = pair_make(in, elem, NIL);
+
+      if (list == NIL) {
+        list = tail = cell;
+      } else {
+        pair_unwrap(tail)->tail = cell;
+        tail = cell;
+      }
+    }
+
+    if (lex->kind != TOK_RPAREN)
+      error_throw(in, "expected closing parenthesis\n");
+    *result = list;
+    break;
+  }
+
+  case TOK_QUOTE: {
+    nexttoken(lex);
+    O quoted;
+    read_expr(in, lex, &quoted);
+    O quote_sym = symbol_make(in, "quote");
+    *result = pair_make(in, quote_sym, pair_make(in, quoted, NIL));
+    break;
+  }
+
+  case TOK_STRING:
+    *result = symbol_make(in, lex->buffer);
+    break;
+
+  case TOK_WORD:
+    if (is_number(lex->buffer)) {
+      *result = NUM(atoi(lex->buffer));
+    } else {
+      *result = symbol_make(in, lex->buffer);
+    }
+    break;
+
+  default:
+    error_throw(in, "unexpected token: %c", lex->kind);
+  }
+
+  gc_rootreset(&in->gc, mark);
+  return 0;
+}

src/symbol.c

@@ -6,7 +6,7 @@
 
 #define ALIGN(n) (((n) + 7) & ~7)
 
-static Sy *find(St *tab, U32 hash, Z len) {
+static Sy *find(St *tab, const char *str, U32 hash, Z len) {
   if (tab->capacity == 0)
     return NULL;
 
@@ -17,6 +17,8 @@ static Sy *find(St *tab, U32 hash, Z len) {
       return NULL;
     if (s->hash == hash && s->len == len)
       return s;
+    if (memcmp(s->data, str, len) == 0)
+      return s;
     ix = (ix + 1) % tab->capacity;
   }
   return NULL;
@@ -55,7 +57,7 @@ Sy *intern(St *tab, const char *str, Z len) {
   if (len == 0)
     len = strlen(str);
   U32 hash = hashstr(str, len);
-  Sy *sym = find(tab, hash, len);
+  Sy *sym = find(tab, str, hash, len);
   if (sym)
     return sym;
 

src/type.c

@@ -11,6 +11,7 @@ static const char *typenames[] = {
   [TYPE_PRIM] = "primitive",
   [TYPE_PAIR] = "pair",
   [TYPE_CLOS] = "closure",
+  [TYPE_CODE] = "code",
 };
 // clang-format on
 

test.lisp

@@ -0,0 +1,3 @@
+(defn fib (n)
+  (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(println (fib 10))