2 Copyright (C) 2017-2018 Keziah Wesley
4 You can redistribute and/or modify this file under the terms of the
5 GNU Affero General Public License as published by the Free Software
6 Foundation, either version 3 of the License, or (at your option) any
9 This file is distributed in the hope that it will be useful, but
10 WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 Affero General Public License for more details.
14 You should have received a copy of the GNU Affero General Public
15 License along with this file. If not, see
16 <http://www.gnu.org/licenses/>.
29 extern vector_object globals;
32 push_frame (void (*fn) (), tuple_object args, void (*cont) ())
34 // update current frame's continuation
35 cf->cont = new_subr (cont);
37 // allocate new frame, make current
40 cst = (object *) (cf + 1);
42 // set new frame's frametop
43 cf->cont = new_subr (fn);
46 new_tuple ((object *) prev, sizeof (frame) / sizeof (object));
52 cf = (frame *) cf->prevframe.body;
56 #define RETURN(x) do { ret = (x); pop_frame(); return; } while (0)
57 // invoke before pushing args onto stack for child call
58 // TODO: replace with PUSH_ARG interface?
59 #define END_LOCALS() do { cf->prevcst = cst; } while (0)
60 #define CALL_THEN(fn, args, cont) do { push_frame(fn, args, cont); return; } while (0)
61 #define CALL_THEN_RET(fn, args) CALL_THEN(fn, args, pop_frame)
62 #define CALL_THEN_RECUR(f, args) do { push_frame(f, args, cf->cont.val.fn); return; } while (0)
63 #define TAILCALL(fn) do { cf->cont = fn; return; } while (0)
68 return cst == (object *) (cf + 1);
73 pool_object *x = POOL_OBJECT(o->head);
76 x = POOL_OBJECT(o->rest);
79 return mcall(evaluator, len);
83 2 ways to call an applicable:
84 - generically: `<foo bar>`
85 - applicably: `<APPLY foo bar>`
87 generic calls must perform wrapping
90 // * applicable (SUBR / simple FUNCTION): eval whole form, call impl
92 // * complex FUNCTION: call impl
94 static object *gval (atom_object * var);
96 // Upon initial entry, `cf->args.body[0]` is the FORM, and
97 // `ret` is the result of evaluating the FORM's first position.
98 // Typically, the first position will be an ATOM, which is
99 // self-evaluating; its value is to be looked up according to the
100 // first-position resolution rules:
110 object *val = gval (&ret.atom);
113 // TODO: lvalue lookup
114 assert (0 && "attempted to call unbound symbol");
117 pool_ptr p = as_list (&cf->args.body[0])->val.head;
119 p = POOL_OBJECT (p)->rest;
125 (cst++)->pool = *POOL_OBJECT (p);
126 p = POOL_OBJECT (p)->rest;
128 if (val->type == EVALTYPE_SUBR)
129 CALL_THEN_RET (val->subr.val.fn, new_tuple (args, argct));
130 assert (0 && "I don't know how to call that");
139 assert (0 && "I don't know how to call that");
143 // locals: { list_object list, list_object tail }
147 // store result of previous call
148 pool_object *prev_res = as_pool (&ret);
149 list_object *tail = as_list (&cf->locals[1]);
150 *POOL_OBJECT (tail->val.head) = (pool_object)
152 .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
154 // advance input and output
155 assert (cf->args.len == 1);
156 list_object *args = as_list (&cf->args.body[0]);
157 assert (args->val.head);
158 args->val.head = POOL_OBJECT (args->val.head)->rest;
161 POOL_OBJECT (tail->val.head)->rest = 0;
162 RETURN (cf->locals[0]);
168 CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
175 assert (cf->args.len == 1);
176 switch (cf->args.body[0].type)
181 RETURN (cf->args.body[0]);
183 // Handle `head` now; then iterate on `.rest`.
185 if (!cf->args.body[0].list.val.head)
186 RETURN (cf->args.body[0]);
187 // locals: { list_object list, list_object tail }
189 // Allocate the new list contiguously and keep track of the
190 // current tail so we can build it in forward order.
192 new_list (pool_alloc (list_length (&cf->args.body[0].list)));
193 cf->locals[1] = cf->locals[0];
196 new_tuple ((object *)
197 POOL_OBJECT (cf->args.body[0].list.val.head), 1),
200 // `<>` is a special case.
201 if (!cf->args.body[0].list.val.head)
203 cf->args.body[0].type = EVALTYPE_FALSE;
204 RETURN (cf->args.body[0]);
206 // Eval first position, then apply to args
209 new_tuple ((object *)
210 POOL_OBJECT (cf->args.body[0].list.val.head),
213 case EVALTYPE_VECTOR: TAILCALL(eval_vector);
216 assert (0 && "I don't know how to eval that");
220 inline static object *
221 create_global_binding (uvector_object oblist, const char *pname)
223 object *p = stack_push (&globals);
224 stack_push (&globals)->atom =
225 oblist_find_or_insert (root, pname, strlen (pname));
243 if (cf->args.len != 1)
244 assert (0 && "error: GVAL expects arity 1");
245 if (cf->args.body[0].type != EVALTYPE_ATOM)
246 fprintf (stderr, "error: GVAL of a evaltype=%x\n", cf->args.body[0].type);
247 atom_object *atomos = as_atom (&cf->args.body[0]);
248 object *pv = gval (atomos);
250 assert (0 && "error: GVAL of unbound");
258 assert (cf->args.len == 1);
261 *(cst++) = cf->args.body[0];
262 CALL_THEN (eval, new_tuple (args, 1), do_gval);
268 assert (cf->args.len == 2);
269 atom_object *name = as_atom (&cf->args.body[0]);
270 *create_global_binding (root, atom_pname (*name)) = ret;
277 assert (cf->args.len == 2);
278 // save result of previous
279 cf->args.body[0] = ret;
282 *(cst++) = cf->args.body[1];
283 CALL_THEN (eval, new_tuple (args, 1), do_setg);
289 assert (cf->args.len == 2);
292 *(cst++) = cf->args.body[0];
293 CALL_THEN (eval, new_tuple (args, 1), do_setg1);
299 assert (cf->args.len == 1);
300 ret = cf->args.body[0];
307 // TODO: deal with non-poolable objects in arguments
309 new_list (pool_copy_array ((pool_object *) cf->args.body, cf->args.len));
316 uint32_t next_to_eval = NO_LOCALS ()? (cst++)->fix32 = new_fix32 (0), 0
317 : ++as_fix32 (&cf->locals[0])->val.n;
319 if (next_to_eval > 1)
320 cf->args.body[next_to_eval - 1] = ret;
321 if (next_to_eval < cf->args.len)
324 *(cst++) = cf->args.body[next_to_eval];
325 push_frame (eval, new_tuple (args, 1), cf->cont.val.fn);
334 eval_arg ()? : appl_list ();
340 fix64_object result = new_fix64 (0);
341 for (int i = 0; i < cf->args.len; i++)
343 switch (cf->args.body[i].type)
346 // fallthough: a fix32 is stored the same way as its fix64
348 result.val.n += cf->args.body[i].fix64.val.n;
351 assert (0 && "don't know how to add that");
361 eval_arg ()? : appl_add ();
367 create_global_binding (root, "ROOT")->subr = new_subr (subr_root);
368 create_global_binding (root, "GVAL")->subr = new_subr (subr_gval);
369 create_global_binding (root, "SETG")->subr = new_subr (subr_setg);
370 create_global_binding (root, "QUOTE")->subr = new_subr (subr_quote);
371 create_global_binding (root, "LIST")->subr = new_subr (subr_list);
372 create_global_binding (root, "+")->subr = new_subr (subr_add);
376 gval (atom_object * var)
378 object *gvals = HEAP_OBJECT (globals.val.body);
379 for (int i = 0; i < globals.val.len / 2; i++)
381 // TODO: need proper atom comparison once multiple OBLISTs active
382 if (as_atom (&gvals[i * 2])->val.body == var->val.body)
384 return &gvals[i * 2 + 1];