Implement eval_arg and some builtins.

Implement GVAL, SETG, QUOTE, LIST, + (for currently implemented
numeric types), based on an eval_arg mechanism for applicable
operatives.

Signed-off-by: Kaz Wesley <kaz@lambdaverse.org>

diff --git a/src/Makefile.am b/src/Makefile.am
index 68f749c8bbfa96e3500a91cf90caf8ca5108d031..50723bd9c55703f5a308cd3a07467ed2e32eeea6 100644 (file)
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -2,4 +2,4 @@ bin_PROGRAMS = muddle
 muddle_SOURCES = main.c read.c eval.c print.c alloc.c object.c atom.c oblist.c
 muddle_CFLAGS = -Wall -Wno-unused-function -Werror=implicit-function-declaration -Werror=incompatible-pointer-types
 
-TESTS = test_oblists
+TESTS = test_oblists test_bindings

diff --git a/src/eval.c b/src/eval.c
index 5e17d7e48543cc1e3a2c6833d35b5b83b53140bf..fb116d327e347ca2529ba8b4418987cd36844955 100644 (file)
--- a/src/eval.c
+++ b/src/eval.c
@@ -37,7 +37,7 @@ push_frame (void (*fn) (), tuple_object args, void (*cont) ())
   // allocate new frame, make current
   frame *prev = cf;
   cf = (frame *) cst;
-  cst += sizeof (frame) / sizeof (object);
+  cst = (object *) (cf + 1);
 
   // set new frame's frametop
   cf->cont = new_subr (fn);
@@ -58,8 +58,16 @@ pop_frame ()
 // TODO: replace with PUSH_ARG interface?
 #define END_LOCALS() do { cf->prevcst = cst; } while (0)
 #define CALL_THEN(fn, args, cont) do { push_frame(fn, args, cont); return; } while (0)
+#define CALL_THEN_RET(fn, args) CALL_THEN(fn, args, pop_frame)
+#define CALL_THEN_RECUR(f, args) do { push_frame(f, args, cf->cont.val.fn); return; } while (0)
 #define TAILCALL(fn) do { cf->cont = fn; return; } while (0)
 
+static inline bool
+NO_LOCALS ()
+{
+  return cst == (object *) (cf + 1);
+}
+
 /*
     uint32_t len = 0;
     pool_object *x = POOL_OBJECT(o->head);
@@ -105,8 +113,20 @@ call ()
            // TODO: lvalue lookup
            assert (0 && "attempted to call unbound symbol");
          }
+       END_LOCALS ();
+       pool_ptr p = as_list (&cf->args.body[0])->val.head;
+       assert (p);
+       p = POOL_OBJECT (p)->rest;
+       object *args = cst;
+       uint32_t argct = 0;
+       while (p)
+         {
+           argct++;
+           (cst++)->pool = *POOL_OBJECT (p);
+           p = POOL_OBJECT (p)->rest;
+         }
        if (val->type == EVALTYPE_SUBR)
-         TAILCALL (val->subr);
+         CALL_THEN_RET (val->subr.val.fn, new_tuple (args, argct));
        assert (0 && "I don't know how to call that");
        break;
        /*
@@ -187,11 +207,11 @@ eval ()
       END_LOCALS ();
       CALL_THEN (eval,
                 new_tuple ((object *)
-                           POOL_OBJECT (cf->args.body[0].list.val.head), 1),
-                call);
+                           POOL_OBJECT (cf->args.body[0].list.val.head),
+                           1), call);
       /*
-         case EVALTYPE_VECTOR: TAILCALL(eval_vector);
-       */
+       case EVALTYPE_VECTOR: TAILCALL(eval_vector);
+      */
     default:
       assert (0 && "I don't know how to eval that");
     }
@@ -206,6 +226,10 @@ create_global_binding (uvector_object oblist, const char *pname)
   return p;
 }
 
+#include "atom.h"
+#include "print.h"
+#include <stdio.h>
+
 static void
 subr_root ()
 {
@@ -213,10 +237,139 @@ subr_root ()
   pop_frame ();
 }
 
+static void
+do_gval ()
+{
+  if (cf->args.len != 1)
+    assert (0 && "error: GVAL expects arity 1");
+  if (cf->args.body[0].type != EVALTYPE_ATOM)
+    fprintf (stderr, "error: GVAL of a evaltype=%x\n", cf->args.body[0].type);
+  atom_object *atomos = as_atom (&cf->args.body[0]);
+  object *pv = gval (atomos);
+  if (!pv)
+    assert (0 && "error: GVAL of unbound");
+  ret = *pv;
+  pop_frame ();
+}
+
+static void
+subr_gval ()
+{
+  assert (cf->args.len == 1);
+  END_LOCALS ();
+  object *args = cst;
+  *(cst++) = cf->args.body[0];
+  CALL_THEN (eval, new_tuple (args, 1), do_gval);
+}
+
+static void
+do_setg ()
+{
+  assert (cf->args.len == 2);
+  atom_object *name = as_atom (&cf->args.body[0]);
+  *create_global_binding (root, atom_pname (*name)) = ret;
+  pop_frame ();
+}
+
+static void
+do_setg1 ()
+{
+  assert (cf->args.len == 2);
+  // save result of previous
+  cf->args.body[0] = ret;
+  END_LOCALS ();
+  object *args = cst;
+  *(cst++) = cf->args.body[1];
+  CALL_THEN (eval, new_tuple (args, 1), do_setg);
+}
+
+static void
+subr_setg ()
+{
+  assert (cf->args.len == 2);
+  END_LOCALS ();
+  object *args = cst;
+  *(cst++) = cf->args.body[0];
+  CALL_THEN (eval, new_tuple (args, 1), do_setg1);
+}
+
+static void
+subr_quote ()
+{
+  assert (cf->args.len == 1);
+  ret = cf->args.body[0];
+  pop_frame ();
+}
+
+static void
+appl_list ()
+{
+  // TODO: deal with non-poolable objects in arguments
+  ret.list =
+    new_list (pool_copy_array ((pool_object *) cf->args.body, cf->args.len));
+  pop_frame ();
+}
+
+static bool
+eval_arg ()
+{
+  uint32_t next_to_eval = NO_LOCALS ()? (cst++)->fix32 = new_fix32 (0), 0
+    : ++as_fix32 (&cf->locals[0])->val.n;
+  END_LOCALS ();
+  if (next_to_eval > 1)
+    cf->args.body[next_to_eval - 1] = ret;
+  if (next_to_eval < cf->args.len)
+    {
+      object *args = cst;
+      *(cst++) = cf->args.body[next_to_eval];
+      push_frame (eval, new_tuple (args, 1), cf->cont.val.fn);
+      return true;
+    }
+  return false;
+}
+
+static void
+subr_list ()
+{
+  eval_arg ()? : appl_list ();
+}
+
+static void
+appl_add ()
+{
+  fix64_object result = new_fix64 (0);
+  for (int i = 0; i < cf->args.len; i++)
+    {
+      switch (cf->args.body[i].type)
+       {
+       case EVALTYPE_FIX32:
+         // fallthough: a fix32 is stored the same way as its fix64
+       case EVALTYPE_FIX64:
+         result.val.n += cf->args.body[i].fix64.val.n;
+         break;
+       default:
+         assert (0 && "don't know how to add that");
+       }
+    }
+  ret.fix64 = result;
+  pop_frame ();
+}
+
+static void
+subr_add ()
+{
+  eval_arg ()? : appl_add ();
+}
+
 void
 init_standard_env ()
 {
   create_global_binding (root, "ROOT")->subr = new_subr (subr_root);
+  create_global_binding (root, "GVAL")->subr = new_subr (subr_gval);
+  create_global_binding (root, "SETG")->subr = new_subr (subr_setg);
+  create_global_binding (root, "QUOTE")->subr = new_subr (subr_quote);
+  create_global_binding (root, "LIST")->subr = new_subr (subr_list);
+  create_global_binding (root, "+")->subr = new_subr (subr_add);
 }
 
 object *

diff --git a/src/test_bindings b/src/test_bindings
new file mode 100755 (executable)
index 0000000..256b2dc
--- /dev/null
+++ b/src/test_bindings
@@ -0,0 +1,25 @@
+#!/bin/sh
+
+# Copyright (C) 2018 Keziah Wesley
+
+# You can redistribute and/or modify this file under the terms of the
+# GNU Affero General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any
+# later version.
+
+# This file is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Affero General Public License for more details.
+
+# You should have received a copy of the GNU Affero General Public
+# License along with this file. If not, see
+# <http://www.gnu.org/licenses/>.
+
+assert_eq () {
+    [ "$1" = "$2" ] || ( echo Assertion failed: "\"$1\"" = "\"$2\""; exit 1 )
+}
+
+assert_eq 'ROOT' "$(echo '<SETG BAZ ROOT>' | ./muddle)"
+assert_eq '(ROOT BAZ)' "$(echo '(<SETG BAZ ROOT> BAZ)' | ./muddle)"
+assert_eq '(ROOT ROOT)' "$(echo '(<SETG BAZ ROOT> <GVAL BAZ>)' | ./muddle)"