#include "alloc.h"
#include "object.h"
+extern pool_object *pool;
+extern pool_ptr ptop;
+
+pool_ptr
+pool_alloc (uint32_t len)
+{
+ pool_ptr p = ptop;
+ ptop += len;
+ return p;
+}
+
+pool_object *
+POOL_OBJECT (pool_ptr p)
+{
+ if (!p)
+ return (pool_object *) 0;
+ return &pool[p];
+}
+
pool_ptr
pool_copy_array_rev (const pool_object * objs, uint32_t len)
{
if (!len)
return 0;
- pool_object *xs = pool_alloc (len);
- for (int i = 0; i < (int) len; i++)
+ pool_ptr p = pool_alloc (len);
+ for (int i = 0; i < len; i++)
{
- xs[i].type = objs[len - 1 - (unsigned) i].type;
- xs[i].rest = POOL_PTR (&xs[i + 1]);
- xs[i].val = objs[len - 1 - (unsigned) i].val;
+ pool[p + i] = (pool_object)
+ {
+ .type = objs[len - i - 1].type,.rest = p + i + 1,.val =
+ objs[len - i - 1].val};
}
- xs[len - 1].rest = 0;
- return POOL_PTR (xs);
+ pool[p + len - 1].rest = 0;
+ return p;
}
heap_ptr
#include <stdbool.h>
#include <stdint.h>
-/// 0, or a "pointer" to an object allocated in the pool and fully-initialized
+/// 0, or a "pointer" to an object allocated in the pool
typedef uint32_t pool_ptr;
-/// 0, or a "pointer" to an object allocated in the heap and fully-initialized
+/// 0, or a "pointer" to an object allocated in the heap
typedef int32_t heap_ptr;
typedef union pool_object pool_object;
typedef union object object;
-extern char *pool; // pool_object
extern char *vhp_base; // object
extern char *vhp; // object
-static inline pool_object *
-POOL_OBJECT (pool_ptr p)
-{
- return (pool_object *) (uintptr_t) p;
-}
-
-static inline bool
-IS_VALID_POOL_OBJECT (pool_object * p)
-{
- pool_ptr pp = (pool_ptr) (uintptr_t) p;
- return (uintptr_t) pp == (uintptr_t) p;
-}
-
-static inline pool_ptr
-POOL_PTR (pool_object * p)
-{
- pool_ptr pp = (pool_ptr) (uintptr_t) p;
- assert (IS_VALID_POOL_OBJECT (p));
- return pp;
-}
+pool_object *POOL_OBJECT (pool_ptr p);
// TODO make (heap_ptr)0 nullish
static inline object *
return (object *) (vhp_base + (p << 4));
}
-static inline pool_object *
-pool_alloc (uint32_t len)
-{
- char *pp = pool;
- pool += (len << 4);
- return (pool_object *) pp;
-}
+pool_ptr pool_alloc (uint32_t len);
static inline heap_ptr
HEAP_PTR_OF_OBJECT (object * p)
/*
-Copyright (C) 2017 Keziah Wesley
+Copyright (C) 2017-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
pop_frame ()
{
cf = (frame *) cf->prevframe.body;
- cst = (object *) cf - sizeof (frame) / sizeof (object);
+ cst = cf->prevcst;
}
#define RETURN(x) do { ret = (x); pop_frame(); return; } while (0)
+// invoke before pushing args onto stack for child call
+// 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 TAILCALL(fn) do { cf->cont = fn; return; } while (0)
return mcall(evaluator, len);
*/
+/*
+2 ways to call an applicable:
+- generically: `<foo bar>`
+- applicably: `<APPLY foo bar>`
+
+generic calls must perform wrapping
+ */
+
+// * applicable (SUBR / simple FUNCTION): eval whole form, call impl
+// * FSUBR: call impl
+// * complex FUNCTION: call impl
+
+// 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
+// self-evaluating; its value is to be looked up according to the
+// first-position resolution rules:
+// * look for a GVAL
+// * look for a LVAL
static void
-eval_list ()
+call ()
+{
+ switch (ret.type)
+ {
+ /*
+ case EVALTYPE_ATOM:
+ break;
+ case EVALTYPE_FIX32:
+ case EVALTYPE_FIX64:
+ break;
+ */
+ default:
+ assert (0 && "I don't know how to call that");
+ }
+}
+
+// locals: { list_object list, list_object tail }
+static void
+eval_rest ()
{
// store result of previous call
- cf->locals[1] = ret;
+ pool_object *prev_res = as_pool (&ret);
+ list_object *tail = as_list (&cf->locals[1]);
+ *POOL_OBJECT (tail->head) = (pool_object)
+ {
+ .type = prev_res->type,.rest = tail->head + 1,.val = prev_res->val};
- // get next input, and advance input pointer
- pool_ptr rest_in = as_list(&cf->args.body[0])->head;
- if (!rest_in)
- RETURN(cf->locals[0]);
- POOL_OBJECT(as_list(&cf->locals[1])->head)->rest =
- as_list(&cf->locals[1])->head + (pool_ptr)sizeof(pool_object);
+ // advance input and output
+ assert (cf->args.len == 1);
+ list_object *args = as_list (&cf->args.body[0]);
+ assert (args->head);
+ args->head = POOL_OBJECT (args->head)->rest;
+ if (!args->head)
+ {
+ POOL_OBJECT (tail->head)->rest = 0;
+ RETURN (cf->locals[0]);
+ }
+ tail->head++;
// eval next element
- CALL_THEN (eval, new_tuple ((object*)POOL_OBJECT(rest_in), 1), eval_list);
+ END_LOCALS ();
+ CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->head), 1),
+ eval_rest);
}
void
RETURN (cf->args.body[0]);
case EVALTYPE_LIST:
// Handle `head` now; then iterate on `.rest`.
+
if (!cf->args.body[0].list.head)
RETURN (cf->args.body[0]);
// locals: { list_object list, list_object tail }
// Allocate the new list contiguously and keep track of the
// current tail so we can build it in forward order.
cf->locals[0].list =
- new_list (POOL_PTR (pool_alloc (list_length (&cf->args.body[0].list))));
+ new_list (pool_alloc (list_length (&cf->args.body[0].list)));
cf->locals[1] = cf->locals[0];
- CALL_THEN (eval, new_tuple ((object*)POOL_OBJECT (cf->args.body[0].list.head), 1), eval_list);
+ END_LOCALS ();
+ CALL_THEN (eval,
+ new_tuple ((object *)
+ POOL_OBJECT (cf->args.body[0].list.head), 1),
+ eval_rest);
+ case EVALTYPE_FORM:
+ // `<>` is a special case.
+ if (!cf->args.body[0].list.head)
+ {
+ cf->args.body[0].type = EVALTYPE_FALSE;
+ RETURN (cf->args.body[0]);
+ }
+ // Eval first position, then apply to args
+ END_LOCALS ();
+ CALL_THEN (eval,
+ new_tuple ((object *)
+ POOL_OBJECT (cf->args.body[0].list.head), 1),
+ call);
/*
- case EVALTYPE_FORM: TAILCALL(eval_form);
case EVALTYPE_VECTOR: TAILCALL(eval_vector);
*/
default:
void eval ();
void push_frame (void (*fn) (), tuple_object args, void (*cont) ());
+/* TODO: don't expose this in header */
// stack:
// <0> args...
// <0> frametop
tuple_object args;
tuple_object prevframe;
// <0> framebottom (state saved before child call)
+ object *prevcst;
// <0> temps, <1> args
object locals[];
/*
-Copyright (C) 2017 Keziah Wesley
+Copyright (C) 2017-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
#include <unistd.h>
// TODO: put these in interpreter-wide ctx object
-char *pool;
+pool_object *pool;
+pool_ptr ptop;
char *vhp_base;
char *vhp;
main ()
{
// The REST pool (in low mem).
- char *pool_base =
+ pool =
mmap (0, POOL_OBJCT * sizeof (object), PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANONYMOUS | MAP_32BIT, -1, 0);
- pool = pool_base;
+ ptop = 1; // 0 is null
// The CONTROL STACKs (TODO: per-PROCESS).
object *cst_base =
while ((n = read (STDIN_FILENO, buf, sizeof (buf))) > 0)
{
// mock GC (no object persistence)
- pool = pool_base;
+ ptop = 1;
vhp = vhp_base;
// terminate input
assert (buf[n - 1] == '\n');
}
assert (p);
if (!st.framelen)
- continue;
+ continue;
assert (st.framelen == 1);
- /*
// Eval the thing
+ cf->prevcst = cst;
push_frame (eval, new_tuple (st.pos, 1), 0);
while (cf->cont.fn)
{
}
// Print the thing
print_object (&ret);
- */
- // debugging: print without eval
- print_object (st.pos);
printf ("\n");
// Loop!
}
munmap (cst_base, STACK_OBJCT * sizeof (object));
munmap (vhp_base, VECTOR_OBJCT * sizeof (object));
- munmap (pool_base, POOL_OBJCT * sizeof (object));
+ munmap (pool, POOL_OBJCT * sizeof (object));
return 0;
}
EVALTYPE_LIST = TYPEPRIM_LIST,
EVALTYPE_FORM,
+ EVALTYPE_FALSE,
EVALTYPE_VECTOR = TYPEPRIM_VECTOR,
static inline pool_object *
as_pool (object * p)
{
- if (TYPEPRIM (p->type) & TYPEPRIM_NOPOOL_MASK)
- return 0;
+ assert (!(TYPEPRIM (p->type) & TYPEPRIM_NOPOOL_MASK));
return (pool_object *) p;
}
projects / muddle-interpreter.git / commitdiff