quotation composition

examples/compose.grr

@@ -0,0 +1 @@
+5 [1 +] [2 *] compose call .

src/compile.c

@@ -33,6 +33,7 @@ struct {
   {"keep",   {OP_OVER, OP_TOR, OP_CALL, OP_FROMR, 0}},
   {"if",     {OP_CHOOSE, OP_CALL, 0}},
   {"call",   {OP_CALL, 0}},
+  {"compose",{OP_COMPOSE, 0}},
   {"?",      {OP_CHOOSE, 0}},
   {"+",      {OP_ADD, 0}},
   {"-",      {OP_SUB, 0}},

src/debug.c

@@ -114,6 +114,8 @@ static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
       printf("PRIM \"%s\"\n", prim.name);
       return offset + bytes_read;
     }
+    SIMPLE(COMPOSE);
+    SIMPLE(CURRY);
     SIMPLE(RETURN);
     SIMPLE(CHOOSE);
     SIMPLE(ADD);

src/object.h

@@ -13,6 +13,8 @@
 enum {
   OBJ_FWD = 2,
   OBJ_QUOT,
+  OBJ_COMPOSE,
+  OBJ_CURRY,
   OBJ_STR,
   OBJ_USERDATA,
 };
@@ -22,6 +24,8 @@ enum {
   TYPE_NUM = 1,
   TYPE_FWD = OBJ_FWD,
   TYPE_QUOT = OBJ_QUOT,
+  TYPE_COMPOSE = OBJ_COMPOSE,
+  TYPE_CURRY = OBJ_CURRY,
   TYPE_STR = OBJ_STR,
   TYPE_USERDATA = OBJ_USERDATA,
 };
@@ -33,6 +37,20 @@ typedef struct Hd {
   U32 size, type;
 } Hd;
 
+/** Composition */
+typedef struct Qo {
+  O first, second;
+} Qo;
+
+/** Curry */
+typedef struct Qc {
+  O value, callable;
+} Qc; //
+
 I type(O);
+static inline I callable(O o) {
+  I t = type(o);
+  return t == TYPE_QUOT || t == TYPE_COMPOSE || t == TYPE_CURRY;
+}
 
 #endif

src/print.c

@@ -20,6 +20,12 @@ V print(O o) {
     case OBJ_QUOT:
       printf("<quotation>");
       break;
+    case OBJ_COMPOSE:
+      printf("<composed>");
+      break;
+    case OBJ_CURRY:
+      printf("<curried>");
+      break;
     case OBJ_STR: {
       // TODO: make this binary safe
       Str *s = string_unwrap(o);

src/vm.c

@@ -5,12 +5,12 @@
 #include "chunk.h"
 #include "compile.h"
 #include "dictionary.h"
+#include "file.h"
 #include "gc.h"
 #include "object.h"
 #include "primitive.h"
-#include "userdata.h"
-#include "file.h"
 #include "string.h"
+#include "userdata.h"
 #include "vm.h"
 
 static I decode_sleb128(U8 **ptr) {
@@ -49,6 +49,10 @@ V vm_init(Vm *vm) {
     gc_addroot(&vm->gc, &vm->tstack[i]);
   }
 
+  vm->trampoline = chunk_new("<trampoline>");
+  chunk_emit_byte(vm->trampoline, OP_FROMR);
+  chunk_emit_byte(vm->trampoline, OP_TAIL_CALL);
+
   vm->stdin = userdata_make(vm, (void *)stdin, &userdata_file);
   vm->stdout = userdata_make(vm, (void *)stdout, &userdata_file);
   vm->stderr = userdata_make(vm, (void *)stderr, &userdata_file);
@@ -59,6 +63,8 @@ V vm_init(Vm *vm) {
 }
 
 V vm_deinit(Vm *vm) {
+  chunk_release(vm->trampoline);
+
   // Free all definitions
   Dt *dstack[256];
   Dt **dsp = dstack;
@@ -249,13 +255,24 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
     }
     case OP_CALL: {
       O quot = vm_pop(vm);
-      if (type(quot) == TYPE_QUOT) {
+      vm_rpush(vm, vm->chunk, vm->ip);
+    do_call:
+      switch (type(quot)) {
+      case TYPE_QUOT: {
         Bc **ptr = (Bc **)(UNBOX(quot) + 1);
         Bc *chunk = *ptr;
-        vm_rpush(vm, vm->chunk, vm->ip);
         vm->chunk = chunk;
         vm->ip = chunk->items;
-      } else {
+        break;
+      }
+      case TYPE_COMPOSE: {
+        Qo *comp = (Qo *)(UNBOX(quot) + 1);
+        vm_rpush(vm, vm->trampoline, vm->trampoline->items);
+        vm_tpush(vm, comp->second);
+        quot = comp->first;
+        goto do_call;
+      }
+      default:
         vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object");
       }
       break;
@@ -271,13 +288,24 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
     }
     case OP_TAIL_CALL: {
       O quot = vm_pop(vm);
-      if (type(quot) == TYPE_QUOT) {
+    do_tail_call:
+      switch (type(quot)) {
+      case TYPE_QUOT: {
         Bc **ptr = (Bc **)(UNBOX(quot) + 1);
         Bc *chunk = *ptr;
         vm->chunk = chunk;
         vm->ip = chunk->items;
-      } else {
-        vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object\n");
+        break;
+      }
+      case TYPE_COMPOSE: {
+        Qo *comp = (Qo *)(UNBOX(quot) + 1);
+        vm_rpush(vm, vm->trampoline, vm->trampoline->items);
+        vm_tpush(vm, comp->second);
+        quot = comp->first;
+        goto do_tail_call;
+      }
+      default:
+        vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object");
       }
       break;
     }
@@ -289,6 +317,26 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
         vm_error(vm, err, "primitive call failed");
       break;
     }
+    case OP_COMPOSE: {
+      I mark = gc_mark(&vm->gc);
+      O q2 = vm_pop(vm);
+      O q1 = vm_pop(vm);
+      gc_addroot(&vm->gc, &q1);
+      gc_addroot(&vm->gc, &q2);
+      if (!callable(q1) || !callable(q2))
+        vm_error(vm, VM_ERR_TYPE, "non-callable arguments to compose");
+      Hd *hd = gc_alloc(vm, sizeof(Hd) + sizeof(Qo));
+      hd->type = OBJ_COMPOSE;
+      Qo *comp = (Qo *)(hd + 1);
+      comp->first = q1;
+      comp->second = q2;
+      vm_push(vm, BOX(hd));
+      gc_reset(&vm->gc, mark);
+      break;
+    }
+    case OP_CURRY: {
+      break;
+    }
     case OP_RETURN:
       if (vm->rsp != vm->rstack) {
         Fr frame = vm_rpop(vm);

src/vm.h

@@ -29,6 +29,8 @@ enum {
   OP_TAIL_DOWORD, // Tail call to dictionary word (reuses current frame)
   OP_TAIL_CALL,   // Tail call to quotation (reuses current frame)
   OP_PRIM,
+  OP_COMPOSE,
+  OP_CURRY,
   OP_RETURN,
   OP_CHOOSE,
   OP_ADD,
@@ -68,6 +70,7 @@ typedef struct Vm {
   Dt *dictionary;
   Ar arena;
   jmp_buf error;
+  Bc *trampoline;
 
   // These objects need to stay as roots!
   O stdin, stdout, stderr;