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 static void subr_NTH ();
98 // Upon initial entry, `cf->args.body[0]` is the FORM, and
99 // `ret` is the result of evaluating the FORM's first position.
100 // Typically, the first position will be an ATOM, which is
101 // self-evaluating; its value is to be looked up according to the
102 // first-position resolution rules:
112 object *val = gval (&ret.atom);
115 // TODO: lvalue lookup
116 assert (0 && "attempted to call unbound symbol");
119 pool_ptr p = as_list (&cf->args.body[0])->val.head;
121 p = POOL_OBJECT (p)->rest;
127 (cst++)->pool = *POOL_OBJECT (p);
128 p = POOL_OBJECT (p)->rest;
130 if (val->type == EVALTYPE_SUBR)
131 CALL_THEN_RET (val->subr.val.fn, new_tuple (args, argct));
132 if (val->type == EVALTYPE_FIX32 || val->type == EVALTYPE_FIX64)
134 pool_ptr p = as_list (&cf->args.body[0])->val.head;
137 cst++->pool = *POOL_OBJECT (POOL_OBJECT (p)->rest);
138 assert (!POOL_OBJECT (POOL_OBJECT (p)->rest)->rest);
139 CALL_THEN_RET (subr_NTH, new_tuple (args, 2));
141 assert (0 && "I don't know how to call that");
147 pool_ptr p = as_list (&cf->args.body[0])->val.head;
150 assert (POOL_OBJECT (p)->rest);
151 cst++->pool = *POOL_OBJECT (POOL_OBJECT (p)->rest);
152 assert (!POOL_OBJECT (POOL_OBJECT (p)->rest)->rest);
153 CALL_THEN_RET (subr_NTH, new_tuple (args, 2));
156 assert (0 && "I don't know how to call that");
160 // locals: { list_object list, list_object tail }
164 // store result of previous call
165 pool_object *prev_res = as_pool (&ret);
166 list_object *tail = as_list (&cf->locals[1]);
167 *POOL_OBJECT (tail->val.head) = (pool_object)
169 .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
171 // advance input and output
172 assert (cf->args.len == 1);
173 list_object *args = as_list (&cf->args.body[0]);
174 assert (args->val.head);
175 args->val.head = POOL_OBJECT (args->val.head)->rest;
178 POOL_OBJECT (tail->val.head)->rest = 0;
179 RETURN (cf->locals[0]);
185 CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
192 assert (cf->args.len == 1);
193 switch (cf->args.body[0].type)
198 RETURN (cf->args.body[0]);
200 // Handle `head` now; then iterate on `.rest`.
202 if (!cf->args.body[0].list.val.head)
203 RETURN (cf->args.body[0]);
204 // locals: { list_object list, list_object tail }
206 // Allocate the new list contiguously and keep track of the
207 // current tail so we can build it in forward order.
209 new_list (pool_alloc (list_length (&cf->args.body[0].list)));
210 cf->locals[1] = cf->locals[0];
213 new_tuple ((object *)
214 POOL_OBJECT (cf->args.body[0].list.val.head), 1),
217 // `<>` is a special case.
218 if (!cf->args.body[0].list.val.head)
220 cf->args.body[0].type = EVALTYPE_FALSE;
221 RETURN (cf->args.body[0]);
223 // Eval first position, then apply to args
226 new_tuple ((object *)
227 POOL_OBJECT (cf->args.body[0].list.val.head),
230 case EVALTYPE_VECTOR: TAILCALL(eval_vector);
233 assert (0 && "I don't know how to eval that");
237 inline static object *
238 create_global_binding (uvector_object oblist, const char *pname)
240 object *p = stack_push (&globals);
241 stack_push (&globals)->atom =
242 oblist_find_or_insert (root, pname, strlen (pname));
260 if (cf->args.len != 1)
261 assert (0 && "error: GVAL expects arity 1");
262 if (cf->args.body[0].type != EVALTYPE_ATOM)
263 fprintf (stderr, "error: GVAL of a evaltype=%x\n", cf->args.body[0].type);
264 atom_object *atomos = as_atom (&cf->args.body[0]);
265 object *pv = gval (atomos);
267 assert (0 && "error: GVAL of unbound");
275 assert (cf->args.len == 1);
278 *(cst++) = cf->args.body[0];
279 CALL_THEN (eval, new_tuple (args, 1), do_gval);
285 assert (cf->args.len == 2);
286 atom_object *name = as_atom (&cf->args.body[0]);
287 *create_global_binding (root, atom_pname (*name)) = ret;
294 assert (cf->args.len == 2);
295 // save result of previous
296 cf->args.body[0] = ret;
299 *(cst++) = cf->args.body[1];
300 CALL_THEN (eval, new_tuple (args, 1), do_setg);
306 assert (cf->args.len == 2);
309 *(cst++) = cf->args.body[0];
310 CALL_THEN (eval, new_tuple (args, 1), do_setg1);
316 assert (cf->args.len == 1);
317 ret = cf->args.body[0];
324 // TODO: deal with non-poolable objects in arguments
326 new_list (pool_copy_array ((pool_object *) cf->args.body, cf->args.len));
333 uint32_t next_to_eval = NO_LOCALS ()? (cst++)->fix32 = new_fix32 (0), 0
334 : ++as_fix32 (&cf->locals[0])->val.n;
336 if (next_to_eval > 1)
337 cf->args.body[next_to_eval - 1] = ret;
338 if (next_to_eval < cf->args.len)
341 *(cst++) = cf->args.body[next_to_eval];
342 push_frame (eval, new_tuple (args, 1), cf->cont.val.fn);
351 eval_arg ()? : appl_list ();
357 fix64_object result = new_fix64 (0);
358 for (int i = 0; i < cf->args.len; i++)
360 switch (cf->args.body[i].type)
363 // fallthough: a fix32 is stored the same way as its fix64
365 result.val.n += cf->args.body[i].fix64.val.n;
368 assert (0 && "don't know how to add that");
378 eval_arg ()? : appl_add ();
381 static void appl_NTH ()
383 assert (cf->args.len == 2);
385 switch (cf->args.body[0].type)
389 ix = cf->args.body[0].fix64.val.n;
390 assert ((uint64_t)ix == cf->args.body[0].fix64.val.n);
393 assert (0 && "tried to NTH a strange index type?");
395 switch (cf->args.body[1].type)
397 case EVALTYPE_VECTOR:
398 assert (ix < cf->args.body[1].vector.val.len);
399 RETURN (HEAP_OBJECT (cf->args.body[1].vector.val.body)[ix]);
400 case EVALTYPE_UVECTOR:
401 assert (ix < cf->args.body[1].uvector.val.len);
402 RETURN (uv_get (&cf->args.body[1].uvector, ix));
405 pool_ptr p = cf->args.body[1].list.val.head;
406 for (int i=0; i<ix; i++) {
408 p = POOL_OBJECT (p)->rest;
411 RETURN (*(object*)POOL_OBJECT (p));
414 assert (0 && "tried to NTH a strange collection type?");
419 eval_arg ()? : appl_NTH ();
425 create_global_binding (root, "ROOT")->subr = new_subr (subr_root);
426 create_global_binding (root, "GVAL")->subr = new_subr (subr_gval);
427 create_global_binding (root, "SETG")->subr = new_subr (subr_setg);
428 create_global_binding (root, "QUOTE")->subr = new_subr (subr_quote);
429 create_global_binding (root, "LIST")->subr = new_subr (subr_list);
430 create_global_binding (root, "+")->subr = new_subr (subr_add);
431 create_global_binding (root, "NTH")->subr = new_subr (subr_NTH);
435 gval (atom_object * var)
437 object *gvals = HEAP_OBJECT (globals.val.body);
438 for (int i = 0; i < globals.val.len / 2; i++)
440 // TODO: need proper atom comparison once multiple OBLISTs active
441 if (as_atom (&gvals[i * 2])->val.body == var->val.body)
443 return &gvals[i * 2 + 1];