X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=src%2Feval.c;h=253c8ec45f1833f9d3e39edf909f09819d5f6349;hb=refs%2Fheads%2Fmaster;hp=e563fdfd3acd91eab0048e537b7d7a1aba039b7f;hpb=6c1eef40f411ff4eec7a3f7599a81be7fae07e2a;p=muddle-interpreter.git

diff --git a/src/eval.c b/src/eval.c
index e563fdf..253c8ec 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -16,14 +16,17 @@ License along with this file. If not, see
 <http://www.gnu.org/licenses/>.
 */
 
+#include "alloc.h"
 #include "eval.h"
+#include "oblist.h"
 
-#include "alloc.h"
+#include <string.h>
 
 // globals for now
 extern object ret;
 extern frame *cf;
 extern object *cst;
+extern vector_object globals;
 
 void
 push_frame (void (*fn) (), tuple_object args, void (*cont) ())
@@ -34,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);
@@ -55,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);
@@ -80,6 +91,10 @@ generic calls must perform wrapping
 // * FSUBR: call impl
 // * complex FUNCTION: call impl
 
+static object *gval (atom_object * var);
+
+static void subr_NTH ();
+
 // Upon initial entry, `cf->args.body[0]` is the FORM, and
 // `ret` is the result of evaluating the FORM's first position.
 // Typically, the first position will be an ATOM, which is
@@ -92,13 +107,51 @@ call ()
 {
   switch (ret.type)
     {
-      /*
-         case EVALTYPE_ATOM:
-         break;
-         case EVALTYPE_FIX32:
-         case EVALTYPE_FIX64:
-         break;
-       */
+    case EVALTYPE_ATOM:
+      {
+	object *val = gval (&ret.atom);
+	if (!val)
+	  {
+	    // 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)
+	  CALL_THEN_RET (val->subr.val.fn, new_tuple (args, argct));
+	if (val->type == EVALTYPE_FIX32 || val->type == EVALTYPE_FIX64)
+	  {
+	    pool_ptr p = as_list (&cf->args.body[0])->val.head;
+	    object * args = cst;
+	    *cst++ = *val;
+	    cst++->pool = *POOL_OBJECT (POOL_OBJECT (p)->rest);
+	    assert (!POOL_OBJECT (POOL_OBJECT (p)->rest)->rest);
+	    CALL_THEN_RET (subr_NTH, new_tuple (args, 2));
+	  }
+	assert (0 && "I don't know how to call that");
+	break;
+      }
+    case EVALTYPE_FIX32:
+    case EVALTYPE_FIX64:
+      {
+	pool_ptr p = as_list (&cf->args.body[0])->val.head;
+	object * args = cst;
+	*cst++ = ret;
+	assert (POOL_OBJECT (p)->rest);
+	cst++->pool = *POOL_OBJECT (POOL_OBJECT (p)->rest);
+	assert (!POOL_OBJECT (POOL_OBJECT (p)->rest)->rest);
+	CALL_THEN_RET (subr_NTH, new_tuple (args, 2));
+      }
     default:
       assert (0 && "I don't know how to call that");
     }
@@ -111,25 +164,25 @@ eval_rest ()
   // store result of previous call
   pool_object *prev_res = as_pool (&ret);
   list_object *tail = as_list (&cf->locals[1]);
-  *POOL_OBJECT (tail->head) = (pool_object)
+  *POOL_OBJECT (tail->val.head) = (pool_object)
   {
-  .type = prev_res->type,.rest = tail->head + 1,.val = prev_res->val};
+  .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
 
   // advance input and output
   assert (cf->args.len == 1);
   list_object *args = as_list (&cf->args.body[0]);
-  assert (args->head);
-  args->head = POOL_OBJECT (args->head)->rest;
-  if (!args->head)
+  assert (args->val.head);
+  args->val.head = POOL_OBJECT (args->val.head)->rest;
+  if (!args->val.head)
     {
-      POOL_OBJECT (tail->head)->rest = 0;
+      POOL_OBJECT (tail->val.head)->rest = 0;
       RETURN (cf->locals[0]);
     }
-  tail->head++;
+  tail->val.head++;
 
   // eval next element
   END_LOCALS ();
-  CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->head), 1),
+  CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
 	     eval_rest);
 }
 
@@ -141,11 +194,12 @@ eval ()
     {
     case EVALTYPE_FIX32:
     case EVALTYPE_FIX64:
+    case EVALTYPE_ATOM:
       RETURN (cf->args.body[0]);
     case EVALTYPE_LIST:
       // Handle `head` now; then iterate on `.rest`.
 
-      if (!cf->args.body[0].list.head)
+      if (!cf->args.body[0].list.val.head)
 	RETURN (cf->args.body[0]);
       // locals: { list_object list, list_object tail }
       cst += 2;
@@ -157,11 +211,11 @@ eval ()
       END_LOCALS ();
       CALL_THEN (eval,
 		 new_tuple ((object *)
-			    POOL_OBJECT (cf->args.body[0].list.head), 1),
+			    POOL_OBJECT (cf->args.body[0].list.val.head), 1),
 		 eval_rest);
     case EVALTYPE_FORM:
       // `<>` is a special case.
-      if (!cf->args.body[0].list.head)
+      if (!cf->args.body[0].list.val.head)
 	{
 	  cf->args.body[0].type = EVALTYPE_FALSE;
 	  RETURN (cf->args.body[0]);
@@ -170,12 +224,224 @@ eval ()
       END_LOCALS ();
       CALL_THEN (eval,
 		 new_tuple ((object *)
-			    POOL_OBJECT (cf->args.body[0].list.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");
     }
 }
+
+inline static object *
+create_global_binding (uvector_object oblist, const char *pname)
+{
+  object *p = stack_push (&globals);
+  stack_push (&globals)->atom =
+    oblist_find_or_insert (root, pname, strlen (pname));
+  return p;
+}
+
+#include "atom.h"
+#include "print.h"
+#include <stdio.h>
+
+static void
+subr_root ()
+{
+  ret.uvector = 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 ();
+}
+
+static void appl_NTH ()
+{
+  assert (cf->args.len == 2);
+  int ix;
+  switch (cf->args.body[0].type)
+    {
+    case EVALTYPE_FIX32:
+    case EVALTYPE_FIX64:
+      ix = cf->args.body[0].fix64.val.n;
+      assert ((uint64_t)ix == cf->args.body[0].fix64.val.n);
+      break;
+    default:
+      assert (0 && "tried to NTH a strange index type?");
+    }
+  switch (cf->args.body[1].type)
+    {
+    case EVALTYPE_VECTOR:
+      assert (ix < cf->args.body[1].vector.val.len);
+      RETURN (HEAP_OBJECT (cf->args.body[1].vector.val.body)[ix]);
+    case EVALTYPE_UVECTOR:
+      assert (ix < cf->args.body[1].uvector.val.len);
+      RETURN (uv_get (&cf->args.body[1].uvector, ix));
+    case EVALTYPE_LIST:
+      {
+	pool_ptr p = cf->args.body[1].list.val.head;
+	for (int i=0; i<ix; i++) {
+	  assert (p);
+	  p = POOL_OBJECT (p)->rest;
+	}
+	assert (p);
+	RETURN (*(object*)POOL_OBJECT (p));
+      }
+    }
+  assert (0 && "tried to NTH a strange collection type?");
+}
+
+void subr_NTH ()
+{
+  eval_arg ()? : appl_NTH ();
+}
+
+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);
+  create_global_binding (root, "NTH")->subr = new_subr (subr_NTH);
+}
+
+object *
+gval (atom_object * var)
+{
+  object *gvals = HEAP_OBJECT (globals.val.body);
+  for (int i = 0; i < globals.val.len / 2; i++)
+    {
+      // TODO: need proper atom comparison once multiple OBLISTs active
+      if (as_atom (&gvals[i * 2])->val.body == var->val.body)
+	{
+	  return &gvals[i * 2 + 1];
+	}
+    }
+  return 0;
+}