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 = (object *) (cf + 1);
  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 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)
  64
  65 static inline bool
  66 NO_LOCALS ()
  67 {
  68   return cst == (object *) (cf + 1);
  69 }
  70
  71 /*
  72     uint32_t len = 0;
  73     pool_object *x = POOL_OBJECT(o->head);
  74     while (x) {
  75         *--cst = *x;
  76         x = POOL_OBJECT(o->rest);
  77         len++;
  78     }
  79     return mcall(evaluator, len);
  80 */
  81
  82 /*
  83 2 ways to call an applicable:
  84 - generically: `<foo bar>`
  85 - applicably: `<APPLY foo bar>`
  86
  87 generic calls must perform wrapping
  88  */
  89
  90 // * applicable (SUBR / simple FUNCTION): eval whole form, call impl
  91 // * FSUBR: call impl
  92 // * complex FUNCTION: call impl
  93
  94 static object *gval (atom_object * var);
  95
  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:
 101 // * look for a GVAL
 102 // * look for a LVAL
 103 static void
 104 call ()
 105 {
 106   switch (ret.type)
 107     {
 108     case EVALTYPE_ATOM:
 109       {
 110         object *val = gval (&ret.atom);
 111         if (!val)
 112           {
 113             // TODO: lvalue lookup
 114             assert (0 && "attempted to call unbound symbol");
 115           }
 116         END_LOCALS ();
 117         pool_ptr p = as_list (&cf->args.body[0])->val.head;
 118         assert (p);
 119         p = POOL_OBJECT (p)->rest;
 120         object *args = cst;
 121         uint32_t argct = 0;
 122         while (p)
 123           {
 124             argct++;
 125             (cst++)->pool = *POOL_OBJECT (p);
 126             p = POOL_OBJECT (p)->rest;
 127           }
 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");
 131         break;
 132         /*
 133            case EVALTYPE_FIX32:
 134            case EVALTYPE_FIX64:
 135            break;
 136          */
 137       }
 138     default:
 139       assert (0 && "I don't know how to call that");
 140     }
 141 }
 142
 143 // locals: { list_object list, list_object tail }
 144 static void
 145 eval_rest ()
 146 {
 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)
 151   {
 152   .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
 153
 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;
 159   if (!args->val.head)
 160     {
 161       POOL_OBJECT (tail->val.head)->rest = 0;
 162       RETURN (cf->locals[0]);
 163     }
 164   tail->val.head++;
 165
 166   // eval next element
 167   END_LOCALS ();
 168   CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
 169              eval_rest);
 170 }
 171
 172 void
 173 eval ()
 174 {
 175   assert (cf->args.len == 1);
 176   switch (cf->args.body[0].type)
 177     {
 178     case EVALTYPE_FIX32:
 179     case EVALTYPE_FIX64:
 180     case EVALTYPE_ATOM:
 181       RETURN (cf->args.body[0]);
 182     case EVALTYPE_LIST:
 183       // Handle `head` now; then iterate on `.rest`.
 184
 185       if (!cf->args.body[0].list.val.head)
 186         RETURN (cf->args.body[0]);
 187       // locals: { list_object list, list_object tail }
 188       cst += 2;
 189       // Allocate the new list contiguously and keep track of the
 190       // current tail so we can build it in forward order.
 191       cf->locals[0].list =
 192         new_list (pool_alloc (list_length (&cf->args.body[0].list)));
 193       cf->locals[1] = cf->locals[0];
 194       END_LOCALS ();
 195       CALL_THEN (eval,
 196                  new_tuple ((object *)
 197                             POOL_OBJECT (cf->args.body[0].list.val.head), 1),
 198                  eval_rest);
 199     case EVALTYPE_FORM:
 200       // `<>` is a special case.
 201       if (!cf->args.body[0].list.val.head)
 202         {
 203           cf->args.body[0].type = EVALTYPE_FALSE;
 204           RETURN (cf->args.body[0]);
 205         }
 206       // Eval first position, then apply to args
 207       END_LOCALS ();
 208       CALL_THEN (eval,
 209                  new_tuple ((object *)
 210                             POOL_OBJECT (cf->args.body[0].list.val.head),
 211                             1), call);
 212       /*
 213         case EVALTYPE_VECTOR: TAILCALL(eval_vector);
 214       */
 215     default:
 216       assert (0 && "I don't know how to eval that");
 217     }
 218 }
 219
 220 inline static object *
 221 create_global_binding (uvector_object oblist, const char *pname)
 222 {
 223   object *p = stack_push (&globals);
 224   stack_push (&globals)->atom =
 225     oblist_find_or_insert (root, pname, strlen (pname));
 226   return p;
 227 }
 228
 229 #include "atom.h"
 230 #include "print.h"
 231 #include <stdio.h>
 232
 233 static void
 234 subr_root ()
 235 {
 236   ret.uvector = root;
 237   pop_frame ();
 238 }
 239
 240 static void
 241 do_gval ()
 242 {
 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);
 249   if (!pv)
 250     assert (0 && "error: GVAL of unbound");
 251   ret = *pv;
 252   pop_frame ();
 253 }
 254
 255 static void
 256 subr_gval ()
 257 {
 258   assert (cf->args.len == 1);
 259   END_LOCALS ();
 260   object *args = cst;
 261   *(cst++) = cf->args.body[0];
 262   CALL_THEN (eval, new_tuple (args, 1), do_gval);
 263 }
 264
 265 static void
 266 do_setg ()
 267 {
 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;
 271   pop_frame ();
 272 }
 273
 274 static void
 275 do_setg1 ()
 276 {
 277   assert (cf->args.len == 2);
 278   // save result of previous
 279   cf->args.body[0] = ret;
 280   END_LOCALS ();
 281   object *args = cst;
 282   *(cst++) = cf->args.body[1];
 283   CALL_THEN (eval, new_tuple (args, 1), do_setg);
 284 }
 285
 286 static void
 287 subr_setg ()
 288 {
 289   assert (cf->args.len == 2);
 290   END_LOCALS ();
 291   object *args = cst;
 292   *(cst++) = cf->args.body[0];
 293   CALL_THEN (eval, new_tuple (args, 1), do_setg1);
 294 }
 295
 296 static void
 297 subr_quote ()
 298 {
 299   assert (cf->args.len == 1);
 300   ret = cf->args.body[0];
 301   pop_frame ();
 302 }
 303
 304 static void
 305 appl_list ()
 306 {
 307   // TODO: deal with non-poolable objects in arguments
 308   ret.list =
 309     new_list (pool_copy_array ((pool_object *) cf->args.body, cf->args.len));
 310   pop_frame ();
 311 }
 312
 313 static bool
 314 eval_arg ()
 315 {
 316   uint32_t next_to_eval = NO_LOCALS ()? (cst++)->fix32 = new_fix32 (0), 0
 317     : ++as_fix32 (&cf->locals[0])->val.n;
 318   END_LOCALS ();
 319   if (next_to_eval > 1)
 320     cf->args.body[next_to_eval - 1] = ret;
 321   if (next_to_eval < cf->args.len)
 322     {
 323       object *args = cst;
 324       *(cst++) = cf->args.body[next_to_eval];
 325       push_frame (eval, new_tuple (args, 1), cf->cont.val.fn);
 326       return true;
 327     }
 328   return false;
 329 }
 330
 331 static void
 332 subr_list ()
 333 {
 334   eval_arg ()? : appl_list ();
 335 }
 336
 337 static void
 338 appl_add ()
 339 {
 340   fix64_object result = new_fix64 (0);
 341   for (int i = 0; i < cf->args.len; i++)
 342     {
 343       switch (cf->args.body[i].type)
 344         {
 345         case EVALTYPE_FIX32:
 346           // fallthough: a fix32 is stored the same way as its fix64
 347         case EVALTYPE_FIX64:
 348           result.val.n += cf->args.body[i].fix64.val.n;
 349           break;
 350         default:
 351           assert (0 && "don't know how to add that");
 352         }
 353     }
 354   ret.fix64 = result;
 355   pop_frame ();
 356 }
 357
 358 static void
 359 subr_add ()
 360 {
 361   eval_arg ()? : appl_add ();
 362 }
 363
 364 void
 365 init_standard_env ()
 366 {
 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);
 373 }
 374
 375 object *
 376 gval (atom_object * var)
 377 {
 378   object *gvals = HEAP_OBJECT (globals.val.body);
 379   for (int i = 0; i < globals.val.len / 2; i++)
 380     {
 381       // TODO: need proper atom comparison once multiple OBLISTs active
 382       if (as_atom (&gvals[i * 2])->val.body == var->val.body)
 383         {
 384           return &gvals[i * 2 + 1];
 385         }
 386     }
 387   return 0;
 388 }