X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=src%2Feval.c;h=253c8ec45f1833f9d3e39edf909f09819d5f6349;hb=e3dcc1d3966fb95a5a232daa193c6b5d89a06b7e;hp=7d28057ff9e0ad375acd039a657bc7a859a5ba07;hpb=081a7c4eedd6e6aa9da616ed88c82ab85efdb98f;p=muddle-interpreter.git
diff --git a/src/eval.c b/src/eval.c
index 7d28057..253c8ec 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -16,14 +16,17 @@ License along with this file. If not, see
.
*/
+#include "alloc.h"
#include "eval.h"
+#include "oblist.h"
-#include "alloc.h"
+#include
// 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");
}
@@ -171,12 +224,224 @@ 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");
}
}
+
+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
+
+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; irest;
+ }
+ 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;
+}