Implement global bindings

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

diff --git a/src/eval.c b/src/eval.c
index 7d28057ff9e0ad375acd039a657bc7a859a5ba07..5e17d7e48543cc1e3a2c6833d35b5b83b53140bf 100644 (file)
--- 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) ())
@@ -80,6 +83,8 @@ generic calls must perform wrapping
 // * FSUBR: call impl
 // * complex FUNCTION: call impl
 
+static object *gval (atom_object * var);
+
 // 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 +97,24 @@ 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");
+         }
+       if (val->type == EVALTYPE_SUBR)
+         TAILCALL (val->subr);
+       assert (0 && "I don't know how to call that");
+       break;
+       /*
+          case EVALTYPE_FIX32:
+          case EVALTYPE_FIX64:
+          break;
+        */
+      }
     default:
       assert (0 && "I don't know how to call that");
     }
@@ -180,3 +196,40 @@ eval ()
       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;
+}
+
+static void
+subr_root ()
+{
+  ret.uvector = root;
+  pop_frame ();
+}
+
+void
+init_standard_env ()
+{
+  create_global_binding (root, "ROOT")->subr = new_subr (subr_root);
+}
+
+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;
+}

diff --git a/src/main.c b/src/main.c
index c9876ce2c0a6067ad2f3eb6738eab1cffcecf016..126579f314f24eee260bf6863268df7456d606a3 100644 (file)
--- a/src/main.c
+++ b/src/main.c
@@ -16,6 +16,7 @@ License along with this file. If not, see
 <http://www.gnu.org/licenses/>.
 */
 
+#include "atom.h"
 #include "read.h"
 #include "eval.h"
 #include "print.h"
@@ -31,6 +32,7 @@ pool_object *pool;
 pool_ptr ptop;
 object *vhp_base;
 heap_ptr vhp;
+vector_object globals;
 
 // oblists (move to ASOCs once implemented)
 uvector_object root;
@@ -54,6 +56,8 @@ enum
   READER_OBJCT = 64
 };
 
+void init_standard_env ();
+
 int
 main ()
 {
@@ -91,6 +95,8 @@ main ()
       ptop = 1;
       vhp = 1;
       root = oblist_create (13);
+      globals = vector_create (64);
+      init_standard_env ();
       // terminate input
       assert (buf[n - 1] == '\n');
       buf[n - 1] = '\0';

diff --git a/src/object.c b/src/object.c
index f7b5526d42037f9f66a8feb69e7ef49877946065..af50edaa191905c920704fc29af899f3117bbc08 100644 (file)
--- a/src/object.c
+++ b/src/object.c
@@ -18,6 +18,8 @@ License along with this file. If not, see
 
 #include "object.h"
 
+#include <string.h>
+
 uint32_t
 list_length (const list_object * o)
 {
@@ -65,9 +67,35 @@ static object rest(const object *lst) {
 }
 */
 
+dope_object *
+vec_dope (const vector_object * o)
+{
+  return (dope_object *) & HEAP_OBJECT (o->val.body)[o->val.len];
+}
+
 dope_object *
 uv_dope (const uvector_object * o)
 {
   return (dope_object *) & HEAP_OBJECT (o->val.body)[(o->val.len + 1) / 2 +
                                                     1];
 }
+
+vector_object
+vector_create (uint32_t capacity)
+{
+  heap_ptr body = heap_alloc (capacity);
+  memset (HEAP_OBJECT (body), '\0', capacity * sizeof (object));
+  return new_vector (body + capacity, 0);
+}
+
+object *
+stack_push (vector_object * v)
+{
+  if (vec_dope (v)->len > v->val.len)
+    {
+      // TODO
+      assert (0 && "not implemented: GROW in stack_push");
+    }
+  v->val.len++;
+  return HEAP_OBJECT (--(v->val.body));
+}

diff --git a/src/object.h b/src/object.h
index 8ebd80704a39ebdf8a70ba378bb070d34d9f9164..54281f2396ebf7c629be3f6bdd7d4fad09d5ab73 100644 (file)
--- a/src/object.h
+++ b/src/object.h
@@ -252,6 +252,7 @@ typedef union pool_object
   vector_object vector;
   uvector_object uvector;
   atom_object atom;
+  subr_object subr;
 } pool_object;
 
 union object
@@ -274,6 +275,7 @@ union object
   uvector_object uvector;
   atom_object atom;
   tuple_object tuple;
+  subr_object subr;
 };
 
 /**
@@ -380,6 +382,8 @@ Common object operations.
 
 uint32_t list_length (const list_object * o);
 
+dope_object *vec_dope (const vector_object * o);
+
 dope_object *uv_dope (const uvector_object * o);
 
 static inline evaltype
@@ -396,6 +400,12 @@ chtype (object * o, evaltype type)
   o->type = type;
 }
 
+// Allocate an vector of LOSEs and return a handle with length=0.
+vector_object vector_create (uint32_t capacity);
+
+// Stack-like interface to a VECTOR (with automatic GROW!)
+object *stack_push (vector_object * v);
+
 /**
 Checked downcasts.
 */