From 4b917a1f5fe2af0245454fe6be14710b2c24a475 Mon Sep 17 00:00:00 2001 From: Kaz Wesley Date: Fri, 9 Feb 2018 18:19:35 -0800 Subject: [PATCH] Implement eval_arg and some builtins. Implement GVAL, SETG, QUOTE, LIST, + (for currently implemented numeric types), based on an eval_arg mechanism for applicable operatives. Signed-off-by: Kaz Wesley --- src/Makefile.am | 2 +- src/eval.c | 165 ++++++++++++++++++++++++++++++++++++++++++++-- src/test_bindings | 25 +++++++ 3 files changed, 185 insertions(+), 7 deletions(-) create mode 100755 src/test_bindings diff --git a/src/Makefile.am b/src/Makefile.am index 68f749c..50723bd 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -2,4 +2,4 @@ bin_PROGRAMS = muddle muddle_SOURCES = main.c read.c eval.c print.c alloc.c object.c atom.c oblist.c muddle_CFLAGS = -Wall -Wno-unused-function -Werror=implicit-function-declaration -Werror=incompatible-pointer-types -TESTS = test_oblists +TESTS = test_oblists test_bindings diff --git a/src/eval.c b/src/eval.c index 5e17d7e..fb116d3 100644 --- a/src/eval.c +++ b/src/eval.c @@ -37,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); @@ -58,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); @@ -105,8 +113,20 @@ call () // 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) - TAILCALL (val->subr); + CALL_THEN_RET (val->subr.val.fn, new_tuple (args, argct)); assert (0 && "I don't know how to call that"); break; /* @@ -187,11 +207,11 @@ 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"); } @@ -206,6 +226,10 @@ create_global_binding (uvector_object oblist, const char *pname) return p; } +#include "atom.h" +#include "print.h" +#include + static void subr_root () { @@ -213,10 +237,139 @@ subr_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 * diff --git a/src/test_bindings b/src/test_bindings new file mode 100755 index 0000000..256b2dc --- /dev/null +++ b/src/test_bindings @@ -0,0 +1,25 @@ +#!/bin/sh + +# Copyright (C) 2018 Keziah Wesley + +# You can redistribute and/or modify this file under the terms of the +# GNU Affero General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any +# later version. + +# This file is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Affero General Public License for more details. + +# You should have received a copy of the GNU Affero General Public +# License along with this file. If not, see +# . + +assert_eq () { + [ "$1" = "$2" ] || ( echo Assertion failed: "\"$1\"" = "\"$2\""; exit 1 ) +} + +assert_eq 'ROOT' "$(echo '' | ./muddle)" +assert_eq '(ROOT BAZ)' "$(echo '( BAZ)' | ./muddle)" +assert_eq '(ROOT ROOT)' "$(echo '( )' | ./muddle)" -- 2.31.1