*

README

@@ -12,5 +12,5 @@
 
 TODO:
 - [o] "#load" pragma
-- [o  better dip/keep (avoid using the retain stack for them)
+- [o] better dip/keep (avoid using the retain stack for them)
 - [ ] hand-rolled parser

examples/cat.grr

@@ -1,11 +1,4 @@
 #load("std.grr")
 
-def while {
-  swap dup bury >r >r
-  if: call dup
-    [r> dup >r call r> r> swap while]
-    [drop r> drop r> drop];
-}
-
 while: [stdin fgetline]
   [print];

src/chunk.c

@@ -32,8 +32,9 @@ V chunk_release(Bc *chunk) {
 #if CHUNK_DEBUG
     fprintf(stderr, "DEBUG: freeing chunk %s at %p\n", chunk->name, (V *)chunk);
 #endif
-    yar_free(&chunk->lines);
     yar_free(&chunk->constants);
+    yar_free(&chunk->lines);
+    yar_free(&chunk->symbols);
     yar_free(chunk);
     free(chunk);
   }

src/compile.c

@@ -23,12 +23,17 @@ struct {
   {"dup",     {OP_DUP, 0}},
   {"drop",    {OP_DROP, 0}},
   {"swap",    {OP_SWAP, 0}},
+  {"2dup",    {OP_2DUP, 0}},
+  {"2drop",   {OP_2DROP, 0}},
+  {"2swap",   {OP_2SWAP, 0}},
   {"over",    {OP_OVER, 0}},
   {"nip",     {OP_NIP, 0}},
   {"bury",    {OP_BURY, 0}},
   {"dig",     {OP_DIG, 0}},
   {">r",      {OP_TOR, 0}},
   {"r>",      {OP_FROMR, 0}},
+  {"2>r",     {OP_2TOR, 0}},
+  {"2r>",     {OP_2FROMR, 0}},
   {"if",      {OP_CHOOSE, OP_CALL, 0}},
   {"call",    {OP_CALL, 0}},
   {"compose", {OP_COMPOSE, 0}},
@@ -395,6 +400,8 @@ static I compile_ast(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
 }
 
 Bc *compile_program(Cm *cm, mpc_ast_t *ast) {
+  mpc_ast_print_to(ast, stderr);
+
   mpc_ast_trav_t *next = mpc_ast_traverse_start(ast, mpc_ast_trav_order_pre);
   mpc_ast_t *curr = mpc_ast_traverse_next(&next); // Begin traversal
 

src/compile.h

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

src/gc.c

@@ -60,7 +60,7 @@ static V printstats(Gc *gc, const char *label) {
 }
 #endif
 
-V gc_collect(Vm *vm) {
+V gc_collect(Vm *vm, I final) {
   Gc *gc = &vm->gc;
   uint8_t *scan = gc->to.free;
 
@@ -68,6 +68,8 @@ V gc_collect(Vm *vm) {
   printstats(gc, "before GC");
 #endif
 
+  if (!final) {
+    // Final GC ignores roots.
     for (Z i = 0; i < gc->roots.count; i++) {
       O *o = gc->roots.items[i];
       *o = forward(gc, *o);
@@ -93,6 +95,7 @@ V gc_collect(Vm *vm) {
           *dsp++ = node->child[i];
       }
     }
+  }
 
   while (scan < gc->to.free) {
     if (scan >= gc->to.end) {
@@ -170,7 +173,7 @@ Hd *gc_alloc(Vm *vm, Z sz) {
   Gc *gc = &vm->gc;
   sz = ALIGN(sz);
   if (gc->from.free + sz > gc->from.end) {
-    gc_collect(vm);
+    gc_collect(vm, 0);
     if (gc->from.free + sz > gc->from.end) {
       fprintf(stderr, "out of memory (requested %" PRIdPTR "bytes\n", sz);
       abort();

src/gc.h

@@ -32,7 +32,7 @@ V gc_deinit(Gc *);
 
 typedef struct Vm Vm;
 
-V gc_collect(Vm *);
+V gc_collect(Vm *, I);
 Hd *gc_alloc(Vm *, Z);
 
 #endif

src/vm.c

@@ -90,7 +90,7 @@ V vm_deinit(Vm *vm) {
   vm->dictionary = NULL;
 
   // Run final GC pass
-  gc_collect(vm);
+  gc_collect(vm, 1);
   gc_deinit(&vm->gc);
 }
 
@@ -191,12 +191,26 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       (void)vm_pop(vm);
       break;
     }
+    case OP_2DROP: {
+      (void)vm_pop(vm);
+      (void)vm_pop(vm);
+      break;
+    }
     case OP_DUP: {
       O obj = vm_pop(vm);
       vm_push(vm, obj);
       vm_push(vm, obj);
       break;
     }
+    case OP_2DUP: {
+      O obj2 = vm_pop(vm);
+      O obj1 = vm_pop(vm);
+      vm_push(vm, obj1);
+      vm_push(vm, obj1);
+      vm_push(vm, obj2);
+      vm_push(vm, obj2);
+      break;
+    }
     case OP_SWAP: {
       O b = vm_pop(vm);
       O a = vm_pop(vm);
@@ -204,6 +218,17 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       vm_push(vm, a);
       break;
     }
+    case OP_2SWAP: {
+      O d = vm_pop(vm);
+      O c = vm_pop(vm);
+      O b = vm_pop(vm);
+      O a = vm_pop(vm);
+      vm_push(vm, d);
+      vm_push(vm, c);
+      vm_push(vm, b);
+      vm_push(vm, a);
+      break;
+    }
     case OP_NIP: {
       /* a b -> b */
       O b = vm_pop(vm);
@@ -244,10 +269,24 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       vm_tpush(vm, vm_pop(vm));
       break;
     }
+    case OP_2TOR: {
+      O obj2 = vm_pop(vm);
+      O obj1 = vm_pop(vm);
+      vm_tpush(vm, obj1);
+      vm_tpush(vm, obj2);
+      break;
+    }
     case OP_FROMR: {
       vm_push(vm, vm_tpop(vm));
       break;
     }
+    case OP_2FROMR: {
+      O obj2 = vm_tpop(vm);
+      O obj1 = vm_tpop(vm);
+      vm_push(vm, obj1);
+      vm_push(vm, obj2);
+      break;
+    }
     case OP_DOWORD: {
       I idx = decode_sleb128(&vm->ip);
       Dt *word = vm->chunk->symbols.items[idx].resolved;

src/vm.h

@@ -13,21 +13,26 @@
 
 enum {
   OP_NOP = 0,
-  OP_CONST, // Push constant to stack
+  OP_CONST,
-  OP_NIL,   // Push constant to stack
+  OP_NIL,
   OP_DROP,
+  OP_2DROP,
   OP_DUP,
+  OP_2DUP,
   OP_SWAP,
+  OP_2SWAP,
   OP_NIP,
   OP_OVER,
   OP_BURY,
   OP_DIG,
-  OP_TOR,    // Push from stack to retain stack
+  OP_TOR,
-  OP_FROMR,  // Push from retain stack to stack
+  OP_2TOR,
-  OP_DOWORD, // Call word from dictionary by name hash
+  OP_FROMR,
+  OP_2FROMR,
+  OP_DOWORD,
   OP_CALL,
-  OP_TAIL_DOWORD, // Tail call to dictionary word (reuses current frame)
+  OP_TAIL_DOWORD,
-  OP_TAIL_CALL,   // Tail call to quotation (reuses current frame)
+  OP_TAIL_CALL,
   OP_PRIM,
   OP_COMPOSE,
   OP_CURRY,

std.grr

@@ -9,7 +9,12 @@ def when { [] if }
 def unless { swap when }
 
 def dip { swap [] curry compose call }
+def 2dip { swap [dip] dip }
+def 3dip { swap [2dip] dip }
+
 def keep { over [call] dip }
+def 2keep { [2dup] dip 2dip }
+
 def bi { [keep] dip call }
 def tri { [[keep] dip keep] dip call }
 
@@ -18,3 +23,10 @@ def times {
     [drop drop]
     [swap over >r >r call r> 1 - r> times];
 }
+
+def while {
+  swap dup bury >r >r
+  if: call dup
+    [r> dup >r call r> r> swap while]
+    [drop r> drop r> drop];
+}