+
+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 ();
+}
+
+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 *
+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;
+}