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 "eval.h"
  20
  21 #include "alloc.h"
  22
  23 // globals for now
  24 extern object ret;
  25 extern frame *cf;
  26 extern object *cst;
  27
  28 void
  29 push_frame (void (*fn) (), tuple_object args, void (*cont) ())
  30 {
  31   // update current frame's continuation
  32   cf->cont = new_subr (cont);
  33
  34   // allocate new frame, make current
  35   frame *prev = cf;
  36   cf = (frame *) cst;
  37   cst += sizeof (frame) / sizeof (object);
  38
  39   // set new frame's frametop
  40   cf->cont = new_subr (fn);
  41   cf->args = args;
  42   cf->prevframe =
  43     new_tuple ((object *) prev, sizeof (frame) / sizeof (object));
  44 }
  45
  46 void
  47 pop_frame ()
  48 {
  49   cf = (frame *) cf->prevframe.body;
  50   cst = cf->prevcst;
  51 }
  52
  53 #define RETURN(x) do { ret = (x); pop_frame(); return; } while (0)
  54 // invoke before pushing args onto stack for child call
  55 // TODO: replace with PUSH_ARG interface?
  56 #define END_LOCALS() do { cf->prevcst = cst; } while (0)
  57 #define CALL_THEN(fn, args, cont) do { push_frame(fn, args, cont); return; } while (0)
  58 #define TAILCALL(fn) do { cf->cont = fn; return; } while (0)
  59
  60 /*
  61     uint32_t len = 0;
  62     pool_object *x = POOL_OBJECT(o->head);
  63     while (x) {
  64         *--cst = *x;
  65         x = POOL_OBJECT(o->rest);
  66         len++;
  67     }
  68     return mcall(evaluator, len);
  69 */
  70
  71 /*
  72 2 ways to call an applicable:
  73 - generically: `<foo bar>`
  74 - applicably: `<APPLY foo bar>`
  75
  76 generic calls must perform wrapping
  77  */
  78
  79 // * applicable (SUBR / simple FUNCTION): eval whole form, call impl
  80 // * FSUBR: call impl
  81 // * complex FUNCTION: call impl
  82
  83 // Upon initial entry, `cf->args.body[0]` is the FORM, and
  84 // `ret` is the result of evaluating the FORM's first position.
  85 // Typically, the first position will be an ATOM, which is
  86 // self-evaluating; its value is to be looked up according to the
  87 // first-position resolution rules:
  88 // * look for a GVAL
  89 // * look for a LVAL
  90 static void
  91 call ()
  92 {
  93   switch (ret.type)
  94     {
  95       /*
  96          case EVALTYPE_ATOM:
  97          break;
  98          case EVALTYPE_FIX32:
  99          case EVALTYPE_FIX64:
 100          break;
 101        */
 102     default:
 103       assert (0 && "I don't know how to call that");
 104     }
 105 }
 106
 107 // locals: { list_object list, list_object tail }
 108 static void
 109 eval_rest ()
 110 {
 111   // store result of previous call
 112   pool_object *prev_res = as_pool (&ret);
 113   list_object *tail = as_list (&cf->locals[1]);
 114   *POOL_OBJECT (tail->head) = (pool_object)
 115   {
 116   .type = prev_res->type,.rest = tail->head + 1,.val = prev_res->val};
 117
 118   // advance input and output
 119   assert (cf->args.len == 1);
 120   list_object *args = as_list (&cf->args.body[0]);
 121   assert (args->head);
 122   args->head = POOL_OBJECT (args->head)->rest;
 123   if (!args->head)
 124     {
 125       POOL_OBJECT (tail->head)->rest = 0;
 126       RETURN (cf->locals[0]);
 127     }
 128   tail->head++;
 129
 130   // eval next element
 131   END_LOCALS ();
 132   CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->head), 1),
 133              eval_rest);
 134 }
 135
 136 void
 137 eval ()
 138 {
 139   assert (cf->args.len == 1);
 140   switch (cf->args.body[0].type)
 141     {
 142     case EVALTYPE_FIX32:
 143     case EVALTYPE_FIX64:
 144       RETURN (cf->args.body[0]);
 145     case EVALTYPE_LIST:
 146       // Handle `head` now; then iterate on `.rest`.
 147
 148       if (!cf->args.body[0].list.head)
 149         RETURN (cf->args.body[0]);
 150       // locals: { list_object list, list_object tail }
 151       cst += 2;
 152       // Allocate the new list contiguously and keep track of the
 153       // current tail so we can build it in forward order.
 154       cf->locals[0].list =
 155         new_list (pool_alloc (list_length (&cf->args.body[0].list)));
 156       cf->locals[1] = cf->locals[0];
 157       END_LOCALS ();
 158       CALL_THEN (eval,
 159                  new_tuple ((object *)
 160                             POOL_OBJECT (cf->args.body[0].list.head), 1),
 161                  eval_rest);
 162     case EVALTYPE_FORM:
 163       // `<>` is a special case.
 164       if (!cf->args.body[0].list.head)
 165         {
 166           cf->args.body[0].type = EVALTYPE_FALSE;
 167           RETURN (cf->args.body[0]);
 168         }
 169       // Eval first position, then apply to args
 170       END_LOCALS ();
 171       CALL_THEN (eval,
 172                  new_tuple ((object *)
 173                             POOL_OBJECT (cf->args.body[0].list.head), 1),
 174                  call);
 175       /*
 176          case EVALTYPE_VECTOR: TAILCALL(eval_vector);
 177        */
 178     default:
 179       assert (0 && "I don't know how to eval that");
 180     }
 181 }