src/eval.c

   1 /*
   2 Copyright (C) 2017-2018 Keziah Wesley
   3
   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
   7 later version.
   8
   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.
  13
  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/>.
  17 */
  18
  19 #include "alloc.h"
  20 #include "eval.h"
  21 #include "oblist.h"
  22
  23 #include <string.h>
  24
  25 // globals for now
  26 extern object ret;
  27 extern frame *cf;
  28 extern object *cst;
  29 extern vector_object globals;
  30
  31 void
  32 push_frame (void (*fn) (), tuple_object args, void (*cont) ())
  33 {
  34   // update current frame's continuation
  35   cf->cont = new_subr (cont);
  36
  37   // allocate new frame, make current
  38   frame *prev = cf;
  39   cf = (frame *) cst;
  40   cst += sizeof (frame) / sizeof (object);
  41
  42   // set new frame's frametop
  43   cf->cont = new_subr (fn);
  44   cf->args = args;
  45   cf->prevframe =
  46     new_tuple ((object *) prev, sizeof (frame) / sizeof (object));
  47 }
  48
  49 void
  50 pop_frame ()
  51 {
  52   cf = (frame *) cf->prevframe.body;
  53   cst = cf->prevcst;
  54 }
  55
  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)
  62
  63 /*
  64     uint32_t len = 0;
  65     pool_object *x = POOL_OBJECT(o->head);
  66     while (x) {
  67         *--cst = *x;
  68         x = POOL_OBJECT(o->rest);
  69         len++;
  70     }
  71     return mcall(evaluator, len);
  72 */
  73
  74 /*
  75 2 ways to call an applicable:
  76 - generically: `<foo bar>`
  77 - applicably: `<APPLY foo bar>`
  78
  79 generic calls must perform wrapping
  80  */
  81
  82 // * applicable (SUBR / simple FUNCTION): eval whole form, call impl
  83 // * FSUBR: call impl
  84 // * complex FUNCTION: call impl
  85
  86 static object *gval (atom_object * var);
  87
  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:
  93 // * look for a GVAL
  94 // * look for a LVAL
  95 static void
  96 call ()
  97 {
  98   switch (ret.type)
  99     {
 100     case EVALTYPE_ATOM:
 101       {
 102         object *val = gval (&ret.atom);
 103         if (!val)
 104           {
 105             // TODO: lvalue lookup
 106             assert (0 && "attempted to call unbound symbol");
 107           }
 108         if (val->type == EVALTYPE_SUBR)
 109           TAILCALL (val->subr);
 110         assert (0 && "I don't know how to call that");
 111         break;
 112         /*
 113            case EVALTYPE_FIX32:
 114            case EVALTYPE_FIX64:
 115            break;
 116          */
 117       }
 118     default:
 119       assert (0 && "I don't know how to call that");
 120     }
 121 }
 122
 123 // locals: { list_object list, list_object tail }
 124 static void
 125 eval_rest ()
 126 {
 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)
 131   {
 132   .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
 133
 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;
 139   if (!args->val.head)
 140     {
 141       POOL_OBJECT (tail->val.head)->rest = 0;
 142       RETURN (cf->locals[0]);
 143     }
 144   tail->val.head++;
 145
 146   // eval next element
 147   END_LOCALS ();
 148   CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
 149              eval_rest);
 150 }
 151
 152 void
 153 eval ()
 154 {
 155   assert (cf->args.len == 1);
 156   switch (cf->args.body[0].type)
 157     {
 158     case EVALTYPE_FIX32:
 159     case EVALTYPE_FIX64:
 160     case EVALTYPE_ATOM:
 161       RETURN (cf->args.body[0]);
 162     case EVALTYPE_LIST:
 163       // Handle `head` now; then iterate on `.rest`.
 164
 165       if (!cf->args.body[0].list.val.head)
 166         RETURN (cf->args.body[0]);
 167       // locals: { list_object list, list_object tail }
 168       cst += 2;
 169       // Allocate the new list contiguously and keep track of the
 170       // current tail so we can build it in forward order.
 171       cf->locals[0].list =
 172         new_list (pool_alloc (list_length (&cf->args.body[0].list)));
 173       cf->locals[1] = cf->locals[0];
 174       END_LOCALS ();
 175       CALL_THEN (eval,
 176                  new_tuple ((object *)
 177                             POOL_OBJECT (cf->args.body[0].list.val.head), 1),
 178                  eval_rest);
 179     case EVALTYPE_FORM:
 180       // `<>` is a special case.
 181       if (!cf->args.body[0].list.val.head)
 182         {
 183           cf->args.body[0].type = EVALTYPE_FALSE;
 184           RETURN (cf->args.body[0]);
 185         }
 186       // Eval first position, then apply to args
 187       END_LOCALS ();
 188       CALL_THEN (eval,
 189                  new_tuple ((object *)
 190                             POOL_OBJECT (cf->args.body[0].list.val.head), 1),
 191                  call);
 192       /*
 193          case EVALTYPE_VECTOR: TAILCALL(eval_vector);
 194        */
 195     default:
 196       assert (0 && "I don't know how to eval that");
 197     }
 198 }
 199
 200 inline static object *
 201 create_global_binding (uvector_object oblist, const char *pname)
 202 {
 203   object *p = stack_push (&globals);
 204   stack_push (&globals)->atom =
 205     oblist_find_or_insert (root, pname, strlen (pname));
 206   return p;
 207 }
 208
 209 static void
 210 subr_root ()
 211 {
 212   ret.uvector = root;
 213   pop_frame ();
 214 }
 215
 216 void
 217 init_standard_env ()
 218 {
 219   create_global_binding (root, "ROOT")->subr = new_subr (subr_root);
 220 }
 221
 222 object *
 223 gval (atom_object * var)
 224 {
 225   object *gvals = HEAP_OBJECT (globals.val.body);
 226   for (int i = 0; i < globals.val.len / 2; i++)
 227     {
 228       // TODO: need proper atom comparison once multiple OBLISTs active
 229       if (as_atom (&gvals[i * 2])->val.body == var->val.body)
 230         {
 231           return &gvals[i * 2 + 1];
 232         }
 233     }
 234   return 0;
 235 }