From cfc45d763abdc4486c9301a21c00573e0b4480d0 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Fri, 23 Jan 2026 14:19:47 -0300 Subject: [PATCH] quotation composition --- examples/compose.grr | 1 + src/compile.c | 1 + src/debug.c | 2 ++ src/object.h | 18 +++++++++++++ src/print.c | 6 +++++ src/vm.c | 64 ++++++++++++++++++++++++++++++++++++++------ src/vm.h | 3 +++ 7 files changed, 87 insertions(+), 8 deletions(-) create mode 100644 examples/compose.grr diff --git a/examples/compose.grr b/examples/compose.grr new file mode 100644 index 0000000..daabece --- /dev/null +++ b/examples/compose.grr @@ -0,0 +1 @@ +5 [1 +] [2 *] compose call . diff --git a/src/compile.c b/src/compile.c index e71430d..76c50c1 100644 --- a/src/compile.c +++ b/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}}, diff --git a/src/debug.c b/src/debug.c index e414e56..eda0ee6 100644 --- a/src/debug.c +++ b/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); diff --git a/src/object.h b/src/object.h index 34ce4b0..f987b5f 100644 --- a/src/object.h +++ b/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 diff --git a/src/print.c b/src/print.c index 1407963..8549e5d 100644 --- a/src/print.c +++ b/src/print.c @@ -20,6 +20,12 @@ V print(O o) { case OBJ_QUOT: printf(""); break; + case OBJ_COMPOSE: + printf(""); + break; + case OBJ_CURRY: + printf(""); + break; case OBJ_STR: { // TODO: make this binary safe Str *s = string_unwrap(o); diff --git a/src/vm.c b/src/vm.c index ae56946..288985f 100644 --- a/src/vm.c +++ b/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(""); + 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); diff --git a/src/vm.h b/src/vm.h index 8fb4b55..3eac49e 100644 --- a/src/vm.h +++ b/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;