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 += sizeof (frame) / sizeof (object);
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 TAILCALL(fn) do { cf->cont = fn; return; } while (0)
65 pool_object *x = POOL_OBJECT(o->head);
68 x = POOL_OBJECT(o->rest);
71 return mcall(evaluator, len);
75 2 ways to call an applicable:
76 - generically: `<foo bar>`
77 - applicably: `<APPLY foo bar>`
79 generic calls must perform wrapping
82 // * applicable (SUBR / simple FUNCTION): eval whole form, call impl
84 // * complex FUNCTION: call impl
86 static object *gval (atom_object * var);
88 // Upon initial entry, `cf->args.body[0]` is the FORM, and
89 // `ret` is the result of evaluating the FORM's first position.
90 // Typically, the first position will be an ATOM, which is
91 // self-evaluating; its value is to be looked up according to the
92 // first-position resolution rules:
102 object *val = gval (&ret.atom);
105 // TODO: lvalue lookup
106 assert (0 && "attempted to call unbound symbol");
108 if (val->type == EVALTYPE_SUBR)
109 TAILCALL (val->subr);
110 assert (0 && "I don't know how to call that");
119 assert (0 && "I don't know how to call that");
123 // locals: { list_object list, list_object tail }
127 // store result of previous call
128 pool_object *prev_res = as_pool (&ret);
129 list_object *tail = as_list (&cf->locals[1]);
130 *POOL_OBJECT (tail->val.head) = (pool_object)
132 .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
134 // advance input and output
135 assert (cf->args.len == 1);
136 list_object *args = as_list (&cf->args.body[0]);
137 assert (args->val.head);
138 args->val.head = POOL_OBJECT (args->val.head)->rest;
141 POOL_OBJECT (tail->val.head)->rest = 0;
142 RETURN (cf->locals[0]);
148 CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
155 assert (cf->args.len == 1);
156 switch (cf->args.body[0].type)
161 RETURN (cf->args.body[0]);
163 // Handle `head` now; then iterate on `.rest`.
165 if (!cf->args.body[0].list.val.head)
166 RETURN (cf->args.body[0]);
167 // locals: { list_object list, list_object tail }
169 // Allocate the new list contiguously and keep track of the
170 // current tail so we can build it in forward order.
172 new_list (pool_alloc (list_length (&cf->args.body[0].list)));
173 cf->locals[1] = cf->locals[0];
176 new_tuple ((object *)
177 POOL_OBJECT (cf->args.body[0].list.val.head), 1),
180 // `<>` is a special case.
181 if (!cf->args.body[0].list.val.head)
183 cf->args.body[0].type = EVALTYPE_FALSE;
184 RETURN (cf->args.body[0]);
186 // Eval first position, then apply to args
189 new_tuple ((object *)
190 POOL_OBJECT (cf->args.body[0].list.val.head), 1),
193 case EVALTYPE_VECTOR: TAILCALL(eval_vector);
196 assert (0 && "I don't know how to eval that");
200 inline static object *
201 create_global_binding (uvector_object oblist, const char *pname)
203 object *p = stack_push (&globals);
204 stack_push (&globals)->atom =
205 oblist_find_or_insert (root, pname, strlen (pname));
219 create_global_binding (root, "ROOT")->subr = new_subr (subr_root);
223 gval (atom_object * var)
225 object *gvals = HEAP_OBJECT (globals.val.body);
226 for (int i = 0; i < globals.val.len / 2; i++)
228 // TODO: need proper atom comparison once multiple OBLISTs active
229 if (as_atom (&gvals[i * 2])->val.body == var->val.body)
231 return &gvals[i * 2 + 1];