*

README

@@ -9,3 +9,7 @@
           (      ) | |
   ________|   _/_  | |
 <__________\______)\__)
+
+TODO:
+- [ ] "#load" pragma
+- [ ] hand-rolled parser

meson.build

@@ -3,7 +3,7 @@ project(
   'c',
   meson_version : '>= 1.3.0',
   version : '0.1',
-  default_options : ['buildtype=debugoptimized', 'c_std=c11', 'warning_level=3'],
+  default_options : ['buildtype=debugoptimized', 'c_std=gnu11', 'warning_level=3'],
 )
 
 sources = [
@@ -16,6 +16,7 @@ sources = [
   'src/gc.c',
   'src/parser.c',
   'src/print.c',
+  'src/string.c',
   'src/vm.c',
   'src/vendor/mpc.c',
   'src/vendor/yar.c',

src/compile.c

@@ -8,6 +8,7 @@
 #include "gc.h"
 #include "object.h"
 #include "vm.h"
+#include "string.h"
 
 #include "vendor/mpc.h"
 
@@ -26,10 +27,10 @@ struct {
   {"dig",  {OP_DIG, 0}},
   {">r",   {OP_TOR, 0}},
   {"r>",   {OP_FROMR, 0}},
-  {"dip",  {OP_SWAP, OP_TOR, OP_APPLY, OP_FROMR, 0}},
-  {"keep", {OP_OVER, OP_TOR, OP_APPLY, OP_FROMR, 0}},
-  {"if",   {OP_CHOOSE, OP_APPLY, 0}},
-  {"call", {OP_APPLY, 0}},
+  {"dip",  {OP_SWAP, OP_TOR, OP_CALL, OP_FROMR, 0}},
+  {"keep", {OP_OVER, OP_TOR, OP_CALL, OP_FROMR, 0}},
+  {"if",   {OP_CHOOSE, OP_CALL, 0}},
+  {"call", {OP_CALL, 0}},
   {"?",    {OP_CHOOSE, 0}},
   {"+",    {OP_ADD, 0}},
   {"-",    {OP_SUB, 0}},
@@ -42,7 +43,10 @@ struct {
   {">",    {OP_GT, 0}},
   {"<=",   {OP_LTE, 0}},
   {">=",   {OP_GTE, 0}},
+  {"type", {OP_TYPE, 0}},
+  {"^",    {OP_CONCAT, 0}},
   {".",    {OP_PPRINT, 0}},
+  {".s",   {OP_PRINTSTACK, 0}},
   {NULL,   {0}},
 };
 // clang-format on
@@ -82,28 +86,20 @@ static V optim_tailcall(Bc *chunk) {
   Z i = 0;
   while (i < chunk->count) {
     U8 opcode = chunk->items[i];
-    if (opcode == OP_CALL) {
-      I ofs = peek_sleb128(&chunk->items[i + 1], NULL);
-      Z next = i + 1 + ofs;
-      if (next < chunk->count && chunk->items[next] == OP_RETURN) {
-        chunk->items[i] = OP_TAIL_CALL;
-      }
-      i++;
-    } else if (opcode == OP_DOWORD) {
+    if (opcode == OP_DOWORD) {
       I ofs = peek_sleb128(&chunk->items[i + 1], NULL);
       Z next = i + 1 + ofs;
       if (next < chunk->count && chunk->items[next] == OP_RETURN) {
         chunk->items[i] = OP_TAIL_DOWORD;
       }
       i++;
-    } else if (opcode == OP_APPLY) {
+    } else if (opcode == OP_CALL) {
       Z ofs = i + 1;
       if (ofs < chunk->count && chunk->items[ofs] == OP_RETURN) {
-        chunk->items[i] = OP_TAIL_APPLY;
+        chunk->items[i] = OP_TAIL_CALL;
       }
       i++;
-    } else if (opcode == OP_CONST || opcode == OP_JUMP ||
-               opcode == OP_JUMP_IF_NIL) {
+    } else if (opcode == OP_CONST) {
       I ofs = peek_sleb128(&chunk->items[i + 1], NULL);
       i += 1 + ofs;
     } else {
@@ -240,6 +236,14 @@ static I compile_expr(Cm *cm, mpc_ast_t *curr, mpc_ast_trav_t **next) {
   if (strstr(curr->tag, "expr|number") != NULL) {
     I num = strtol(curr->contents, NULL, 0);
     return compile_constant(cm, NUM(num), line, col);
+  } else if (strstr(curr->tag, "expr|string") != NULL) {
+    curr->contents[strlen(curr->contents) - 1] = '\0';
+    char *unescaped = malloc(strlen(curr->contents + 1) + 1);
+    strcpy(unescaped, curr->contents + 1);
+    unescaped = mpcf_unescape(unescaped);
+    O obj = string_make(cm->vm, unescaped, -1);
+    free(unescaped);
+    return compile_constant(cm, obj, line, col);
   } else if (strstr(curr->tag, "expr|word") != NULL) {
     return compile_call(cm, curr->contents, line, col);
   } else if (strstr(curr->tag, "expr|quotation") != NULL) {

src/debug.c

@@ -91,24 +91,6 @@ static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
     SIMPLE(DIG);
     SIMPLE(TOR);
     SIMPLE(FROMR);
-    CASE(JUMP) {
-      Z bytes_read;
-      I ofs = decode_sleb128(&chunk->items[offset], &bytes_read);
-      printf("JUMP %ld -> %zu\n", ofs, offset + bytes_read + ofs);
-      return offset + bytes_read;
-    }
-    CASE(JUMP_IF_NIL) {
-      Z bytes_read;
-      I ofs = decode_sleb128(&chunk->items[offset], &bytes_read);
-      printf("JUMP_IF_NIL %ld -> %zu\n", ofs, offset + bytes_read + ofs);
-      return offset + bytes_read;
-    }
-    CASE(CALL) {
-      Z bytes_read;
-      I ofs = decode_sleb128(&chunk->items[offset], &bytes_read);
-      printf("CALL %ld\n", ofs);
-      return offset + bytes_read;
-    }
     CASE(DOWORD) {
       Z bytes_read;
       I hash = decode_sleb128(&chunk->items[offset], &bytes_read);
@@ -127,13 +109,7 @@ static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
       printf("\n");
       return offset + bytes_read;
     }
-    SIMPLE(APPLY);
-    CASE(TAIL_CALL) {
-      Z bytes_read;
-      I ofs = decode_sleb128(&chunk->items[offset], &bytes_read);
-      printf("TAIL_CALL %ld\n", ofs);
-      return offset + bytes_read;
-    }
+    SIMPLE(CALL);
     CASE(TAIL_DOWORD) {
       Z bytes_read;
       I hash = decode_sleb128(&chunk->items[offset], &bytes_read);
@@ -152,7 +128,7 @@ static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
       printf("\n");
       return offset + bytes_read;
     }
-    SIMPLE(TAIL_APPLY);
+    SIMPLE(TAIL_CALL);
     SIMPLE(RETURN);
     SIMPLE(CHOOSE);
     SIMPLE(ADD);
@@ -166,7 +142,10 @@ static Z dis_instr(Bc *chunk, Z offset, Dt **dictionary, I indent) {
     SIMPLE(GT);
     SIMPLE(LTE);
     SIMPLE(GTE);
+    SIMPLE(TYPE);
+    SIMPLE(CONCAT);
     SIMPLE(PPRINT);
+    SIMPLE(PRINTSTACK);
   default:
     printf("??? (%d)\n", opcode);
     return offset;

src/gc.c

@@ -6,8 +6,8 @@
 #include "chunk.h"
 #include "gc.h"
 #include "object.h"
-#include "vm.h"
 #include "vendor/yar.h"
+#include "vm.h"
 
 #define ALIGN(n) (((n) + 7) & ~7)
 static inline int infrom(Gc *gc, V *ptr) {
@@ -67,7 +67,6 @@ V gc_collect(Vm *vm) {
   printstats(gc, "before GC");
 #endif
 
-  // Forward roots
   for (Z i = 0; i < gc->roots.count; i++) {
     O *o = gc->roots.items[i];
     *o = forward(gc, *o);

src/object.h

@@ -13,6 +13,7 @@
 enum {
   OBJ_FWD = 2,
   OBJ_QUOT,
+  OBJ_STR,
 };
 
 enum {
@@ -20,6 +21,7 @@ enum {
   TYPE_NUM = 1,
   TYPE_FWD = OBJ_FWD,
   TYPE_QUOT = OBJ_QUOT,
+  TYPE_STR = OBJ_STR,
 };
 
 typedef uintptr_t O;
@@ -29,12 +31,6 @@ typedef struct Hd {
   U32 size, type;
 } Hd;
 
-/** String */
-typedef struct Str {
-  Z len;
-  char data[];
-} Str;
-
 I type(O);
 
 #endif

src/print.c

@@ -2,6 +2,7 @@
 #include <stdio.h>
 
 #include "object.h"
+#include "string.h"
 #include "print.h"
 
 V print(O o) {
@@ -10,10 +11,16 @@ V print(O o) {
   } else if (IMM(o)) {
     printf("%" PRIdPTR, ORD(o));
   } else {
-    switch (type(o)) {
-    case TYPE_QUOT:
+    Hd *hdr = UNBOX(o);
+    switch (hdr->type) {
+    case OBJ_QUOT:
       printf("<quotation>");
       break;
+    case OBJ_STR: {
+      Str *s = string_unwrap(o);
+      printf("\"%.*s\"", (int)s->len, s->data);
+      break;
+    }
     default:
       printf("<obj type=%ld ptr=%p>", type(o), (void *)o);
     }

src/string.c

@@ -0,0 +1,36 @@
+#include <string.h>
+
+#include "string.h"
+
+O string_make(Vm *vm, const char *str, I len) {
+  if (len < 0)
+    len = strlen(str);
+  Z size = sizeof(Hd) + sizeof(Str) + len + 1;
+  Hd *hdr = gc_alloc(vm, size);
+  hdr->type = OBJ_STR;
+  Str *s = (Str *)(hdr + 1);
+  s->len = len;
+  memcpy(s->data, str, len);
+  s->data[len] = 0;
+  return BOX(hdr);
+}
+
+Str *string_unwrap(O o) {
+  if (o == NIL || IMM(o))
+    return NULL;
+  Hd *hdr = UNBOX(o);
+  if (hdr->type != OBJ_STR)
+    return NULL;
+  return (Str *)(hdr + 1);
+}
+
+O string_concat(Vm *vm, Str *a, Str *b) {
+  O new_obj = string_make(vm, "", a->len + b->len);
+  Str *new = (Str *)(UNBOX(new_obj) + 1);
+
+  memcpy(new->data, a->data, a->len);
+  memcpy(new->data + a->len, b->data, b->len);
+  new->data[a->len + b->len] = 0;
+
+  return new_obj;
+}

src/string.h

@@ -0,0 +1,13 @@
+#include "common.h"
+#include "object.h"
+#include "vm.h"
+
+/** String */
+typedef struct Str {
+  Z len;
+  char data[];
+} Str;
+
+O string_make(Vm *, const char *, I);
+Str *string_unwrap(O);
+O string_concat(Vm *, Str *, Str *);

src/vendor/linenoise.h

@@ -0,0 +1,114 @@
+/* linenoise.h -- VERSION 1.0
+ *
+ * Guerrilla line editing library against the idea that a line editing lib
+ * needs to be 20,000 lines of C code.
+ *
+ * See linenoise.c for more information.
+ *
+ * ------------------------------------------------------------------------
+ *
+ * Copyright (c) 2010-2023, Salvatore Sanfilippo <antirez at gmail dot com>
+ * Copyright (c) 2010-2013, Pieter Noordhuis <pcnoordhuis at gmail dot com>
+ *
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ *  *  Redistributions of source code must retain the above copyright
+ *     notice, this list of conditions and the following disclaimer.
+ *
+ *  *  Redistributions in binary form must reproduce the above copyright
+ *     notice, this list of conditions and the following disclaimer in the
+ *     documentation and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+ * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+ * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+ * HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+ * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+#ifndef __LINENOISE_H
+#define __LINENOISE_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <stddef.h> /* For size_t. */
+
+extern char *linenoiseEditMore;
+
+/* The linenoiseState structure represents the state during line editing.
+ * We pass this state to functions implementing specific editing
+ * functionalities. */
+struct linenoiseState {
+    int in_completion;  /* The user pressed TAB and we are now in completion
+                         * mode, so input is handled by completeLine(). */
+    size_t completion_idx; /* Index of next completion to propose. */
+    int ifd;            /* Terminal stdin file descriptor. */
+    int ofd;            /* Terminal stdout file descriptor. */
+    char *buf;          /* Edited line buffer. */
+    size_t buflen;      /* Edited line buffer size. */
+    const char *prompt; /* Prompt to display. */
+    size_t plen;        /* Prompt length. */
+    size_t pos;         /* Current cursor position. */
+    size_t oldpos;      /* Previous refresh cursor position. */
+    size_t len;         /* Current edited line length. */
+    size_t cols;        /* Number of columns in terminal. */
+    size_t oldrows;     /* Rows used by last refrehsed line (multiline mode) */
+    int oldrpos;        /* Cursor row from last refresh (for multiline clearing). */
+    int history_index;  /* The history index we are currently editing. */
+};
+
+typedef struct linenoiseCompletions {
+  size_t len;
+  char **cvec;
+} linenoiseCompletions;
+
+/* Non blocking API. */
+int linenoiseEditStart(struct linenoiseState *l, int stdin_fd, int stdout_fd, char *buf, size_t buflen, const char *prompt);
+char *linenoiseEditFeed(struct linenoiseState *l);
+void linenoiseEditStop(struct linenoiseState *l);
+void linenoiseHide(struct linenoiseState *l);
+void linenoiseShow(struct linenoiseState *l);
+
+/* Blocking API. */
+char *linenoise(const char *prompt);
+void linenoiseFree(void *ptr);
+
+/* Completion API. */
+typedef void(linenoiseCompletionCallback)(const char *, linenoiseCompletions *);
+typedef char*(linenoiseHintsCallback)(const char *, int *color, int *bold);
+typedef void(linenoiseFreeHintsCallback)(void *);
+void linenoiseSetCompletionCallback(linenoiseCompletionCallback *);
+void linenoiseSetHintsCallback(linenoiseHintsCallback *);
+void linenoiseSetFreeHintsCallback(linenoiseFreeHintsCallback *);
+void linenoiseAddCompletion(linenoiseCompletions *, const char *);
+
+/* History API. */
+int linenoiseHistoryAdd(const char *line);
+int linenoiseHistorySetMaxLen(int len);
+int linenoiseHistorySave(const char *filename);
+int linenoiseHistoryLoad(const char *filename);
+
+/* Other utilities. */
+void linenoiseClearScreen(void);
+void linenoiseSetMultiLine(int ml);
+void linenoisePrintKeyCodes(void);
+void linenoiseMaskModeEnable(void);
+void linenoiseMaskModeDisable(void);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* __LINENOISE_H */

src/vm.c

@@ -8,6 +8,7 @@
 #include "gc.h"
 #include "object.h"
 #include "print.h"
+#include "string.h"
 #include "vm.h"
 
 static I decode_sleb128(U8 **ptr) {
@@ -206,23 +207,6 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
     case OP_FROMR: {
       vm_push(vm, vm_tpop(vm));
       break;
-    }
-    case OP_JUMP: {
-      I ofs = decode_sleb128(&vm->ip);
-      vm->ip += ofs;
-      break;
-    }
-    case OP_JUMP_IF_NIL: {
-      I ofs = decode_sleb128(&vm->ip);
-      if (vm_pop(vm) == NIL)
-        vm->ip += ofs;
-      break;
-    }
-    case OP_CALL: {
-      I ofs = decode_sleb128(&vm->ip);
-      vm_rpush(vm, vm->chunk, vm->ip);
-      vm->ip = chunk->items + ofs;
-      break;
     }
     case OP_DOWORD: {
       I hash = decode_sleb128(&vm->ip);
@@ -234,7 +218,7 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       vm->ip = word->chunk->items;
       break;
     }
-    case OP_APPLY: {
+    case OP_CALL: {
       O quot = vm_pop(vm);
       if (type(quot) == TYPE_QUOT) {
         Bc **ptr = (Bc **)(UNBOX(quot) + 1);
@@ -243,15 +227,10 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
         vm->chunk = chunk;
         vm->ip = chunk->items;
       } else {
-        vm_error(vm, VM_ERR_TYPE, "attempt to apply non-quotation object");
+        vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object");
       }
       break;
     }
-    case OP_TAIL_CALL: {
-      I ofs = decode_sleb128(&vm->ip);
-      vm->ip = chunk->items + ofs;
-      break;
-    }
     case OP_TAIL_DOWORD: {
       I hash = decode_sleb128(&vm->ip);
       Dt *word = lookup_hash(&vm->dictionary, hash);
@@ -261,7 +240,7 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       vm->ip = word->chunk->items;
       break;
     }
-    case OP_TAIL_APPLY: {
+    case OP_TAIL_CALL: {
       O quot = vm_pop(vm);
       if (type(quot) == TYPE_QUOT) {
         Bc **ptr = (Bc **)(UNBOX(quot) + 1);
@@ -269,7 +248,7 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
         vm->chunk = chunk;
         vm->ip = chunk->items;
       } else {
-        vm_error(vm, VM_ERR_TYPE, "attempt to apply non-quotation object\n");
+        vm_error(vm, VM_ERR_TYPE, "attempt to call non-quotation object\n");
       }
       break;
     }
@@ -315,11 +294,37 @@ I vm_run(Vm *vm, Bc *chunk, I offset) {
       CMPOP(<=);
     case OP_GTE:
       CMPOP(>=);
+    case OP_CONCAT: {
+      Str *b = string_unwrap(vm_pop(vm));
+      if (b == NULL)
+        vm_error(vm, VM_ERR_TYPE, "expected string");
+      Str *a = string_unwrap(vm_pop(vm));
+      if (a == NULL)
+        vm_error(vm, VM_ERR_TYPE, "expected string");
+      vm_push(vm, string_concat(vm, a, b));
+      break;
+    }
+    case OP_TYPE: {
+      Str *s = string_unwrap(vm_pop(vm));
+      if (s == NULL)
+        vm_error(vm, VM_ERR_TYPE, "expected string");
+      printf("%.*s", (int)s->len, s->data);
+      break;
+    }
     case OP_PPRINT: {
       O obj = vm_pop(vm);
       println(obj);
       break;
     }
+    case OP_PRINTSTACK: {
+      printf("Stk:");
+      for (O *p = vm->stack; p < vm->sp; p++) {
+        putchar(' ');
+        print(*p);
+      }
+      putchar('\n');
+      break;
+    }
     default:
       vm_error(vm, VM_ERR_RUNTIME, "unknown opcode");
     }

src/vm.h

@@ -1,6 +1,8 @@
 #ifndef VM_H
 #define VM_H
 
+#include <setjmp.h>
+
 #include "common.h"
 
 #include "arena.h"
@@ -8,7 +10,6 @@
 #include "dictionary.h"
 #include "gc.h"
 #include "object.h"
-#include <setjmp.h>
 
 enum {
   OP_NOP = 0,
@@ -23,14 +24,10 @@ enum {
   OP_DIG,
   OP_TOR,         // Push from stack to retain stack
   OP_FROMR,       // Push from retain stack to stack
-  OP_JUMP,        // Relative jump
-  OP_JUMP_IF_NIL, // Relative jump if top-of-stack is nil
-  OP_CALL,
   OP_DOWORD, // Call word from dictionary by name hash
-  OP_APPLY,
-  OP_TAIL_CALL,   // Tail call within chunk (reuses current frame)
+  OP_CALL,
   OP_TAIL_DOWORD, // Tail call to dictionary word (reuses current frame)
-  OP_TAIL_APPLY,  // Tail call to quotation (reuses current frame)
+  OP_TAIL_CALL,  // Tail call to quotation (reuses current frame)
   OP_RETURN,
   OP_CHOOSE,
   OP_ADD,
@@ -44,7 +41,10 @@ enum {
   OP_GT,
   OP_LTE,
   OP_GTE,
+  OP_TYPE,
+  OP_CONCAT,
   OP_PPRINT,
+  OP_PRINTSTACK,
 };
 
 #define STACK_SIZE 256

test.grr

@@ -1,9 +1,25 @@
 def fib/aux {
   if: dig dup 0 =
     [drop drop]
-    [bury [swap 1 - swap] dip dup [+] dip swap fib/aux]
-  ;
+    [bury [swap 1 - swap] dip dup [+] dip swap fib/aux];
 }
 def fib { 0 1 fib/aux }
 
-[ 50 fib ] call .
+"50 fib => " type
+50 fib .
+
+def times {
+  if: over 0 =
+    [drop drop]
+    [swap over >r >r call r> 1 - r> times];
+}
+
+\ We can also calculate the Fibonnaci numbers using the `times' combinator
+\ we just implemented:
+
+def fib-iter {
+  0 1 dig times: [dup [+] dip swap]; drop
+}
+
+"50 fib-iter => " type
+50 fib-iter .