From: Kaz Wesley Date: Sat, 3 Feb 2018 01:40:02 +0000 (-0800) Subject: Implement global bindings X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=b216cf50ef563b02b2558654dd8aa55d37834280;p=muddle-interpreter.git Implement global bindings Signed-off-by: Kaz Wesley --- diff --git a/src/eval.c b/src/eval.c index 7d28057..5e17d7e 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) ()) @@ -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 c9876ce..126579f 100644 --- a/src/main.c +++ b/src/main.c @@ -16,6 +16,7 @@ License along with this file. If not, see . */ +#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 f7b5526..af50eda 100644 --- a/src/object.c +++ b/src/object.c @@ -18,6 +18,8 @@ License along with this file. If not, see #include "object.h" +#include + 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 8ebd807..54281f2 100644 --- 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. */