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 static void subr_NTH ();
  97
  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:
 103 // * look for a GVAL
 104 // * look for a LVAL
 105 static void
 106 call ()
 107 {
 108   switch (ret.type)
 109     {
 110     case EVALTYPE_ATOM:
 111       {
 112         object *val = gval (&ret.atom);
 113         if (!val)
 114           {
 115             // TODO: lvalue lookup
 116             assert (0 && "attempted to call unbound symbol");
 117           }
 118         END_LOCALS ();
 119         pool_ptr p = as_list (&cf->args.body[0])->val.head;
 120         assert (p);
 121         p = POOL_OBJECT (p)->rest;
 122         object *args = cst;
 123         uint32_t argct = 0;
 124         while (p)
 125           {
 126             argct++;
 127             (cst++)->pool = *POOL_OBJECT (p);
 128             p = POOL_OBJECT (p)->rest;
 129           }
 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)
 133           {
 134             pool_ptr p = as_list (&cf->args.body[0])->val.head;
 135             object * args = cst;
 136             *cst++ = *val;
 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));
 140           }
 141         assert (0 && "I don't know how to call that");
 142         break;
 143       }
 144     case EVALTYPE_FIX32:
 145     case EVALTYPE_FIX64:
 146       {
 147         pool_ptr p = as_list (&cf->args.body[0])->val.head;
 148         object * args = cst;
 149         *cst++ = ret;
 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));
 154       }
 155     default:
 156       assert (0 && "I don't know how to call that");
 157     }
 158 }
 159
 160 // locals: { list_object list, list_object tail }
 161 static void
 162 eval_rest ()
 163 {
 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)
 168   {
 169   .type = prev_res->type,.rest = tail->val.head + 1,.val = prev_res->val};
 170
 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;
 176   if (!args->val.head)
 177     {
 178       POOL_OBJECT (tail->val.head)->rest = 0;
 179       RETURN (cf->locals[0]);
 180     }
 181   tail->val.head++;
 182
 183   // eval next element
 184   END_LOCALS ();
 185   CALL_THEN (eval, new_tuple ((object *) POOL_OBJECT (args->val.head), 1),
 186              eval_rest);
 187 }
 188
 189 void
 190 eval ()
 191 {
 192   assert (cf->args.len == 1);
 193   switch (cf->args.body[0].type)
 194     {
 195     case EVALTYPE_FIX32:
 196     case EVALTYPE_FIX64:
 197     case EVALTYPE_ATOM:
 198       RETURN (cf->args.body[0]);
 199     case EVALTYPE_LIST:
 200       // Handle `head` now; then iterate on `.rest`.
 201
 202       if (!cf->args.body[0].list.val.head)
 203         RETURN (cf->args.body[0]);
 204       // locals: { list_object list, list_object tail }
 205       cst += 2;
 206       // Allocate the new list contiguously and keep track of the
 207       // current tail so we can build it in forward order.
 208       cf->locals[0].list =
 209         new_list (pool_alloc (list_length (&cf->args.body[0].list)));
 210       cf->locals[1] = cf->locals[0];
 211       END_LOCALS ();
 212       CALL_THEN (eval,
 213                  new_tuple ((object *)
 214                             POOL_OBJECT (cf->args.body[0].list.val.head), 1),
 215                  eval_rest);
 216     case EVALTYPE_FORM:
 217       // `<>` is a special case.
 218       if (!cf->args.body[0].list.val.head)
 219         {
 220           cf->args.body[0].type = EVALTYPE_FALSE;
 221           RETURN (cf->args.body[0]);
 222         }
 223       // Eval first position, then apply to args
 224       END_LOCALS ();
 225       CALL_THEN (eval,
 226                  new_tuple ((object *)
 227                             POOL_OBJECT (cf->args.body[0].list.val.head),
 228                             1), call);
 229       /*
 230         case EVALTYPE_VECTOR: TAILCALL(eval_vector);
 231       */
 232     default:
 233       assert (0 && "I don't know how to eval that");
 234     }
 235 }
 236
 237 inline static object *
 238 create_global_binding (uvector_object oblist, const char *pname)
 239 {
 240   object *p = stack_push (&globals);
 241   stack_push (&globals)->atom =
 242     oblist_find_or_insert (root, pname, strlen (pname));
 243   return p;
 244 }
 245
 246 #include "atom.h"
 247 #include "print.h"
 248 #include <stdio.h>
 249
 250 static void
 251 subr_root ()
 252 {
 253   ret.uvector = root;
 254   pop_frame ();
 255 }
 256
 257 static void
 258 do_gval ()
 259 {
 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);
 266   if (!pv)
 267     assert (0 && "error: GVAL of unbound");
 268   ret = *pv;
 269   pop_frame ();
 270 }
 271
 272 static void
 273 subr_gval ()
 274 {
 275   assert (cf->args.len == 1);
 276   END_LOCALS ();
 277   object *args = cst;
 278   *(cst++) = cf->args.body[0];
 279   CALL_THEN (eval, new_tuple (args, 1), do_gval);
 280 }
 281
 282 static void
 283 do_setg ()
 284 {
 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;
 288   pop_frame ();
 289 }
 290
 291 static void
 292 do_setg1 ()
 293 {
 294   assert (cf->args.len == 2);
 295   // save result of previous
 296   cf->args.body[0] = ret;
 297   END_LOCALS ();
 298   object *args = cst;
 299   *(cst++) = cf->args.body[1];
 300   CALL_THEN (eval, new_tuple (args, 1), do_setg);
 301 }
 302
 303 static void
 304 subr_setg ()
 305 {
 306   assert (cf->args.len == 2);
 307   END_LOCALS ();
 308   object *args = cst;
 309   *(cst++) = cf->args.body[0];
 310   CALL_THEN (eval, new_tuple (args, 1), do_setg1);
 311 }
 312
 313 static void
 314 subr_quote ()
 315 {
 316   assert (cf->args.len == 1);
 317   ret = cf->args.body[0];
 318   pop_frame ();
 319 }
 320
 321 static void
 322 appl_list ()
 323 {
 324   // TODO: deal with non-poolable objects in arguments
 325   ret.list =
 326     new_list (pool_copy_array ((pool_object *) cf->args.body, cf->args.len));
 327   pop_frame ();
 328 }
 329
 330 static bool
 331 eval_arg ()
 332 {
 333   uint32_t next_to_eval = NO_LOCALS ()? (cst++)->fix32 = new_fix32 (0), 0
 334     : ++as_fix32 (&cf->locals[0])->val.n;
 335   END_LOCALS ();
 336   if (next_to_eval > 1)
 337     cf->args.body[next_to_eval - 1] = ret;
 338   if (next_to_eval < cf->args.len)
 339     {
 340       object *args = cst;
 341       *(cst++) = cf->args.body[next_to_eval];
 342       push_frame (eval, new_tuple (args, 1), cf->cont.val.fn);
 343       return true;
 344     }
 345   return false;
 346 }
 347
 348 static void
 349 subr_list ()
 350 {
 351   eval_arg ()? : appl_list ();
 352 }
 353
 354 static void
 355 appl_add ()
 356 {
 357   fix64_object result = new_fix64 (0);
 358   for (int i = 0; i < cf->args.len; i++)
 359     {
 360       switch (cf->args.body[i].type)
 361         {
 362         case EVALTYPE_FIX32:
 363           // fallthough: a fix32 is stored the same way as its fix64
 364         case EVALTYPE_FIX64:
 365           result.val.n += cf->args.body[i].fix64.val.n;
 366           break;
 367         default:
 368           assert (0 && "don't know how to add that");
 369         }
 370     }
 371   ret.fix64 = result;
 372   pop_frame ();
 373 }
 374
 375 static void
 376 subr_add ()
 377 {
 378   eval_arg ()? : appl_add ();
 379 }
 380
 381 static void appl_NTH ()
 382 {
 383   assert (cf->args.len == 2);
 384   int ix;
 385   switch (cf->args.body[0].type)
 386     {
 387     case EVALTYPE_FIX32:
 388     case EVALTYPE_FIX64:
 389       ix = cf->args.body[0].fix64.val.n;
 390       assert ((uint64_t)ix == cf->args.body[0].fix64.val.n);
 391       break;
 392     default:
 393       assert (0 && "tried to NTH a strange index type?");
 394     }
 395   switch (cf->args.body[1].type)
 396     {
 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));
 403     case EVALTYPE_LIST:
 404       {
 405         pool_ptr p = cf->args.body[1].list.val.head;
 406         for (int i=0; i<ix; i++) {
 407           assert (p);
 408           p = POOL_OBJECT (p)->rest;
 409         }
 410         assert (p);
 411         RETURN (*(object*)POOL_OBJECT (p));
 412       }
 413     }
 414   assert (0 && "tried to NTH a strange collection type?");
 415 }
 416
 417 void subr_NTH ()
 418 {
 419   eval_arg ()? : appl_NTH ();
 420 }
 421
 422 void
 423 init_standard_env ()
 424 {
 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);
 432 }
 433
 434 object *
 435 gval (atom_object * var)
 436 {
 437   object *gvals = HEAP_OBJECT (globals.val.body);
 438   for (int i = 0; i < globals.val.len / 2; i++)
 439     {
 440       // TODO: need proper atom comparison once multiple OBLISTs active
 441       if (as_atom (&gvals[i * 2])->val.body == var->val.body)
 442         {
 443           return &gvals[i * 2 + 1];
 444         }
 445     }
 446   return 0;
 447 }