*

README

@@ -11,5 +11,5 @@
 <__________\______)\__)
 
 TODO:
-- [ ] "#load" pragma
+- [o] "#load" pragma
 - [ ] hand-rolled parser

examples/fibonacci.grr

@@ -0,0 +1,7 @@
+#load("std.grr")
+
+def fib {
+  0 1 dig [dup [+] dip swap] times drop
+}
+
+50 fib .

examples/fizzbuzz.grr

@@ -0,0 +1,19 @@
+#load("std.grr")
+
+def fizzbuzz? { [3 % 0 =] [5 % 0 =] bi or }
+def fizz { when: 3 % 0 = ["Fizz" type]; }
+def buzz { when: 5 % 0 = ["Buzz" type]; }
+
+def fizzbuzz1 {
+  if: fizzbuzz?
+    [ [fizz] keep buzz "\n" type ]
+    [ . ];
+}
+
+def fizzbuzz {
+  0 swap times:
+    [ 1 + dup [fizzbuzz1] keep ];
+  drop
+}
+
+30 fizzbuzz

shell.nix

@@ -12,6 +12,7 @@ pkgs.mkShell {
     ninja
     rlwrap
     hyperfine
+    valgrind
     muon
     samurai
   ];

src/chunk.h

@@ -1,7 +1,7 @@
 #ifndef CHUNK_H
 #define CHUNK_H
 
-#define CHUNK_DEBUG 0
+#define CHUNK_DEBUG DEBUG
 
 #include "common.h"
 #include "object.h"

src/common.h

@@ -1,4 +1,4 @@
-#ifndef COMMON_H
+  #ifndef COMMON_H
 #define COMMON_H
 
 #include <stdint.h>
@@ -13,4 +13,6 @@ typedef uint8_t   U8;
 typedef uint32_t  U32;
 typedef uint64_t  U64;
 
+#define DEBUG 0
+
 #endif

src/compile.c

@@ -7,8 +7,8 @@
 #include "debug.h"
 #include "gc.h"
 #include "object.h"
-#include "vm.h"
 #include "string.h"
+#include "vm.h"
 
 #include "vendor/mpc.h"
 
@@ -37,12 +37,18 @@ struct {
   {"*",      {OP_MUL, 0}},
   {"/",      {OP_DIV, 0}},
   {"%",      {OP_MOD, 0}},
+  {"logand", {OP_LOGAND, 0}},
+  {"logor",  {OP_LOGOR, 0}},
+  {"logxor", {OP_LOGXOR, 0}},
+  {"lognot", {OP_LOGNOT, 0}},
   {"=",      {OP_EQ, 0}},
   {"<>",     {OP_NEQ, 0}},
   {"<",      {OP_LT, 0}},
   {">",      {OP_GT, 0}},
   {"<=",     {OP_LTE, 0}},
   {">=",     {OP_GTE, 0}},
+  {"and",    {OP_AND, 0}},
+  {"or",     {OP_OR, 0}},
   {"type",   {OP_TYPE, 0}},
   {"^",      {OP_CONCAT, 0}},
   {".",      {OP_PPRINT, 0}},
@@ -198,6 +204,7 @@ static I compile_definition(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
 static O compile_quotation_obj(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
   Cm inner = {0};
   inner.arena = cm->arena;
+
   inner.chunk = chunk_new("<quotation>");
   inner.vm = cm->vm;
   inner.dictionary = cm->dictionary;
@@ -214,7 +221,8 @@ static O compile_quotation_obj(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
     }
     curr = mpc_ast_traverse_next(next);
   }
-  chunk_emit_byte(inner.chunk, OP_RETURN);
+  chunk_emit_byte_with_line(inner.chunk, OP_RETURN, curr->state.row,
+                            curr->state.col);
   optim_tailcall(inner.chunk);
 
   Hd *hd = gc_alloc(cm->vm, sizeof(Hd) + sizeof(Bc *));
@@ -230,6 +238,94 @@ static I compile_quotation(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next,
   return compile_constant(cm, compile_quotation_obj(cm, curr, next), line, col);
 }
 
+static I compile_pragma(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
+  (void)mpc_ast_traverse_next(next);
+  curr = mpc_ast_traverse_next(next);
+  const char *name = curr->contents;
+  I line = curr->state.row;
+  I col = curr->state.col;
+  curr = mpc_ast_traverse_next(next);
+  I has_args = 0;
+
+  if (curr != NULL && strcmp(curr->tag, "char") == 0 &&
+      strcmp(curr->contents, "(") == 0) {
+    has_args = 1;
+    curr = mpc_ast_traverse_next(next); // Skip '('
+  }
+
+  if (strcmp(name, "load") == 0) {
+    if (!has_args) {
+      fprintf(stderr,
+              "compiler error at %ld:%ld: #load requires a filename argument\n",
+              line + 1, col + 1);
+      return 0;
+    }
+    if (!strstr(curr->tag, "expr|string")) {
+      fprintf(stderr,
+              "compiler error at %ld:%ld: #load requires a string argument\n",
+              line + 1, col + 1);
+      return 0;
+    }
+
+    char *fname_raw = curr->contents;
+    Z len = strlen(fname_raw);
+    char *fname = malloc(len + 1);
+    memcpy(fname, fname_raw + 1, len - 2);
+    fname[len - 2] = '\0';
+    fname = mpcf_unescape(fname);
+
+    mpc_result_t res;
+    extern mpc_parser_t *Program;
+
+    if (!mpc_parse_contents(fname, Program, &res)) {
+      fprintf(stderr, "compiler error at %ld:%ld: failed to parse file '%s':\n",
+              line + 1, col + 1, fname);
+      mpc_err_print_to(res.error, stderr);
+      mpc_err_delete(res.error);
+      free(fname);
+      return 0;
+    }
+
+    mpc_ast_trav_t *inner_next =
+        mpc_ast_traverse_start(res.output, mpc_ast_trav_order_pre);
+    mpc_ast_t *inner_curr = mpc_ast_traverse_next(&inner_next);
+
+    I success = compile_ast(cm, inner_curr, &inner_next);
+
+    mpc_ast_delete(res.output);
+
+    if (!success) {
+      fprintf(stderr,
+              "compiler error at %ld:%ld: failed to compile file '%s'\n",
+              line + 1, col + 1, fname);
+      free(fname);
+      return 0;
+    }
+
+    free(fname);
+
+    curr = mpc_ast_traverse_next(next);
+    while (curr != NULL) {
+      if (strcmp(curr->tag, "char") == 0 && strcmp(curr->contents, ")") == 0)
+        break;
+      curr = mpc_ast_traverse_next(next);
+    }
+  } else {
+    fprintf(stderr, "compiler warning at %ld:%ld: unknown pragma \"%s\"\n",
+            line + 1, col + 1, name);
+  }
+
+  if (has_args) {
+    if (curr == NULL || strcmp(curr->contents, ")") != 0) {
+      fprintf(stderr, "error at %ld:%ld: expected ')' after pragma arguments\n",
+              line + 1, col + 1);
+      return 0;
+    }
+  }
+
+  return 1;
+}
+
 static I compile_expr(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
   I line = curr->state.row;
   I col = curr->state.col;
@@ -252,6 +348,8 @@ static I compile_expr(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
     return compile_definition(cm, curr, next);
   } else if (strstr(curr->tag, "expr|command") != NULL) {
     return compile_command(cm, curr, next);
+  } else if (strstr(curr->tag, "expr|pragma") != NULL) {
+    return compile_pragma(cm, curr, next);
   } else if (strstr(curr->tag, "expr|comment") != NULL) {
     return 1;
   } else {
@@ -259,8 +357,6 @@ static I compile_expr(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
             col + 1, curr->tag);
     return 0;
   }
-
-  return 1;
 }
 
 static I compile_ast(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {

src/compile.h

@@ -7,7 +7,7 @@
 
 #include "vendor/mpc.h"
 
-#define COMPILER_DEBUG 0
+#define COMPILER_DEBUG DEBUG
 
 /** Compiler context */
 typedef struct Cm {

src/debug.c

@@ -36,9 +36,8 @@ V disassemble(Bc *chunk, const char *name, Dt **dictionary) {
 }
 
 static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
-  for (I i = 0; i < indent * 2; i++)
+  for (I i = 0; i < indent; i++)
-    putchar(' ');
+    printf("  ");
-  fflush(stdout);
   printf("%04zu ", offset);
 
   I col = -1;
@@ -136,12 +135,18 @@ static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
     SIMPLE(MUL);
     SIMPLE(DIV);
     SIMPLE(MOD);
+    SIMPLE(LOGAND);
+    SIMPLE(LOGOR);
+    SIMPLE(LOGXOR);
+    SIMPLE(LOGNOT);
     SIMPLE(EQ);
     SIMPLE(NEQ);
     SIMPLE(LT);
     SIMPLE(GT);
     SIMPLE(LTE);
     SIMPLE(GTE);
+    SIMPLE(AND);
+    SIMPLE(OR);
     SIMPLE(TYPE);
     SIMPLE(CONCAT);
     SIMPLE(PPRINT);

src/gc.c

@@ -101,6 +101,8 @@ V gc_collect(Vm *vm) {
     Hd *hdr = (Hd *)scan;
     switch (hdr->type) {
       // TODO: the rest of the owl
+    case OBJ_STR:
+      break;
     case OBJ_QUOT: {
       Bc **chunk_ptr = (Bc **)(hdr + 1);
       Bc *chunk = *chunk_ptr;

src/gc.h

@@ -4,8 +4,12 @@
 #include "common.h"
 #include "object.h"
 
-#define GC_DEBUG 0
+#define GC_DEBUG 1
+#if GC_DEBUG
+#define HEAP_BYTES (8 * 1024)
+#else
 #define HEAP_BYTES (4 * 1024 * 1024)
+#endif
 
 typedef struct Gs {
   U8 *start, *end;

src/print.c

@@ -1,9 +1,12 @@
 #include <inttypes.h>
 #include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
 
 #include "object.h"
-#include "string.h"
 #include "print.h"
+#include "string.h"
+#include "vendor/mpc.h"
 
 V print(O o) {
   if (o == NIL) {
@@ -18,7 +21,12 @@ V print(O o) {
       break;
     case OBJ_STR: {
       Str *s = string_unwrap(o);
-      printf("\"%.*s\"", (int)s->len, s->data);
+      char *escaped = malloc(s->len + 1);
+      memcpy(escaped, s->data, s->len);
+      escaped[s->len] = 0;
+      escaped = mpcf_escape(escaped);
+      printf("\"%s\"", escaped);
+      free(escaped);
       break;
     }
     default:

src/string.c

@@ -1,6 +1,7 @@
 #include <string.h>
 
 #include "string.h"
+#include "src/gc.h"
 
 O string_make(Vm *vm, const char *str, I len) {
   if (len < 0)
@@ -24,13 +25,27 @@ Str *string_unwrap(O o) {
   return (Str *)(hdr + 1);
 }
 
-O string_concat(Vm *vm, Str *a, Str *b) {
+O string_concat(Vm *vm, O a_obj, O b_obj) {
-  O new_obj = string_make(vm, "", a->len + b->len);
+  I mark = gc_mark(&vm->gc);
-  Str *new = (Str *)(UNBOX(new_obj) + 1);
+  gc_addroot(&vm->gc, &a_obj);
+  gc_addroot(&vm->gc, &b_obj);
 
-  memcpy(new->data, a->data, a->len);
+  Str *as = string_unwrap(a_obj);
-  memcpy(new->data + a->len, b->data, b->len);
+  Str *bs = string_unwrap(b_obj);
-  new->data[a->len + b->len] = 0;
+  I a_len = as->len;
+  I b_len = bs->len;
 
-  return new_obj;
+  O new = string_make(vm, "", a_len + b_len);
+
+  as = string_unwrap(a_obj);
+  bs = string_unwrap(b_obj);
+  Str *news = (Str *)(UNBOX(new) + 1);
+
+  memcpy(news->data, as->data, a_len);
+  memcpy(news->data + a_len, bs->data, b_len);
+  news->data[a_len + b_len] = 0;
+
+  gc_reset(&vm->gc, mark);
+
+  return new;
 }

src/string.h

@@ -10,4 +10,4 @@ typedef struct Str {
 
 O string_make(Vm *, const char *, I);
 Str *string_unwrap(O);
-O string_concat(Vm *, Str *, Str *);
+O string_concat(Vm *, O, O);

src/vm.c

@@ -49,10 +49,29 @@ V vm_init(Vm *vm) {
 }
 
 V vm_deinit(Vm *vm) {
-  gc_collect(vm);
+  // Free all definitions
-  gc_deinit(&vm->gc);
+  Dt *dstack[256];
+  Dt **dsp = dstack;
+  *dsp++ = vm->dictionary;
+
+  while (dsp > dstack) {
+    Dt *node = *--dsp;
+    if (!node)
+      continue;
+    if (node->chunk != NULL)
+      chunk_release(node->chunk);
+    for (I i = 0; i < 4; i++) {
+      if (node->child[i] != NULL)
+        *dsp++ = node->child[i];
+    }
+  }
+
   arena_free(&vm->arena);
   vm->dictionary = NULL;
+
+  // Run final GC pass
+  gc_collect(vm);
+  gc_deinit(&vm->gc);
 }
 
 static V vm_error(Vm *vm, I error, const char *message) {
@@ -116,7 +135,7 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
     O b = vm_pop(vm);                                                          \
     O a = vm_pop(vm);                                                          \
     if (!IMM(a) || !IMM(b))                                                    \
-      vm_error(vm, VM_ERR_TYPE, "arithmetic on non-numeric objects");          \
+      vm_error(vm, VM_ERR_TYPE, "numop on non-numeric objects");               \
     vm_push(vm, NUM(ORD(a) op ORD(b)));                                        \
     break;                                                                     \
   }
@@ -282,6 +301,19 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       BINOP(/);
     case OP_MOD:
       BINOP(%);
+    case OP_LOGAND:
+      BINOP(&);
+    case OP_LOGOR:
+      BINOP(|);
+    case OP_LOGXOR:
+      BINOP(^);
+    case OP_LOGNOT: {
+      O o = vm_pop(vm);
+      if (!IMM(o))
+        vm_error(vm, VM_ERR_TYPE, "numop on non-number");
+      vm_push(vm, NUM(~ORD(o)));
+      break;
+    }
     case OP_EQ:
       CMPOP(==);
     case OP_NEQ:
@@ -294,12 +326,32 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       CMPOP(<=);
     case OP_GTE:
       CMPOP(>=);
+    case OP_AND: {
+      O b = vm_pop(vm);
+      O a = vm_pop(vm);
+      if (a == NIL) {
+        vm_push(vm, NIL);
+      } else {
+        vm_push(vm, b);
+      }
+      break;
+    }
+    case OP_OR: {
+      O b = vm_pop(vm);
+      O a = vm_pop(vm);
+      if (a == NIL) {
+        vm_push(vm, b);
+      } else {
+        vm_push(vm, a);
+      }
+      break;
+    }
     case OP_CONCAT: {
-      Str *b = string_unwrap(vm_pop(vm));
+      O b = vm_pop(vm);
-      if (b == NULL)
+      if (type(b) != TYPE_STR)
         vm_error(vm, VM_ERR_TYPE, "expected string");
-      Str *a = string_unwrap(vm_pop(vm));
+      O a = vm_pop(vm);
-      if (a == NULL)
+      if (type(a) != TYPE_STR)
         vm_error(vm, VM_ERR_TYPE, "expected string");
       vm_push(vm, string_concat(vm, a, b));
       break;

src/vm.h

@@ -37,10 +37,16 @@ enum {
   OP_MOD,
   OP_EQ,
   OP_NEQ,
+  OP_LOGAND,
+  OP_LOGOR,
+  OP_LOGXOR,
+  OP_LOGNOT,
   OP_LT,
   OP_GT,
   OP_LTE,
   OP_GTE,
+  OP_AND,
+  OP_OR,
   OP_TYPE,
   OP_CONCAT,
   OP_PPRINT,

std.grr

@@ -0,0 +1,11 @@
+def when { [] if }
+def unless { swap when }
+
+def bi { [keep] dip call }
+def tri { [[keep] dip keep] dip call }
+
+def times {
+  if: over 0 =
+    [drop drop]
+    [swap over >r >r call r> 1 - r> times];
+}

test.grr

@@ -1,12 +0,0 @@
-def times {
-  if: over 0 =
-    [drop drop]
-    [swap over >r >r call r> 1 - r> times];
-}
-
-def fib {
-  0 1 dig [dup [+] dip swap] times drop
-}
-
-"50 fib => " type
-50 fib .