git.gag.com Git - fw/altos/blob - src/lisp/ao_lisp_eval.c

   1 /*
   2  * Copyright © 2016 Keith Packard <keithp@keithp.com>
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation, either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program 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  * General Public License for more details.
  13  */
  14
  15 #define DBG_EVAL 0
  16 #include "ao_lisp.h"
  17 #include <assert.h>
  18
  19 static int
  20 stack_size(void *addr)
  21 {
  22         (void) addr;
  23         return sizeof (struct ao_lisp_stack);
  24 }
  25
  26 static void
  27 stack_mark(void *addr)
  28 {
  29         struct ao_lisp_stack    *stack = addr;
  30         for (;;) {
  31                 ao_lisp_poly_mark(stack->sexprs, 0);
  32                 ao_lisp_poly_mark(stack->values, 0);
  33                 /* no need to mark values_tail */
  34                 ao_lisp_poly_mark(stack->frame, 0);
  35                 stack = ao_lisp_poly_stack(stack->prev);
  36                 if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
  37                         break;
  38         }
  39 }
  40
  41 static const struct ao_lisp_type ao_lisp_stack_type;
  42
  43 static void
  44 stack_move(void *addr)
  45 {
  46         struct ao_lisp_stack    *stack = addr;
  47
  48         while (stack) {
  49                 struct ao_lisp_stack    *prev;
  50                 int     ret;
  51                 (void) ao_lisp_poly_move(&stack->sexprs, 0);
  52                 (void) ao_lisp_poly_move(&stack->values, 0);
  53                 (void) ao_lisp_poly_move(&stack->values_tail, 0);
  54                 (void) ao_lisp_poly_move(&stack->frame, 0);
  55                 prev = ao_lisp_poly_stack(stack->prev);
  56                 ret = ao_lisp_move_memory((void **) &prev,
  57                                           sizeof (struct ao_lisp_stack));
  58                 if (prev != ao_lisp_poly_stack(stack->prev))
  59                         stack->prev = ao_lisp_stack_poly(prev);
  60                 if (ret)
  61                         break;
  62                 stack = prev;
  63         }
  64 }
  65
  66 static const struct ao_lisp_type ao_lisp_stack_type = {
  67         .size = stack_size,
  68         .mark = stack_mark,
  69         .move = stack_move
  70 };
  71
  72 struct ao_lisp_stack            *ao_lisp_stack;
  73 ao_poly                         ao_lisp_v;
  74
  75 ao_poly
  76 ao_lisp_set_cond(struct ao_lisp_cons *c)
  77 {
  78         ao_lisp_stack->state = eval_cond;
  79         ao_lisp_stack->sexprs = ao_lisp_cons_poly(c);
  80         return AO_LISP_NIL;
  81 }
  82
  83 static void
  84 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
  85 {
  86         stack->state = eval_sexpr;
  87         stack->sexprs = AO_LISP_NIL;
  88         stack->values = AO_LISP_NIL;
  89         stack->values_tail = AO_LISP_NIL;
  90 }
  91
  92
  93 static int
  94 ao_lisp_stack_push(void)
  95 {
  96         struct ao_lisp_stack    *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
  97         if (!stack)
  98                 return 0;
  99         stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
 100         stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
 101         stack->list = AO_LISP_NIL;
 102         ao_lisp_stack = stack;
 103         ao_lisp_stack_reset(stack);
 104         DBGI("stack push\n");
 105         DBG_FRAMES();
 106         DBG_IN();
 107         return 1;
 108 }
 109
 110 static void
 111 ao_lisp_stack_pop(void)
 112 {
 113         if (!ao_lisp_stack)
 114                 return;
 115         ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev);
 116         if (ao_lisp_stack)
 117                 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
 118         else
 119                 ao_lisp_frame_current = NULL;
 120         DBG_OUT();
 121         DBGI("stack pop\n");
 122         DBG_FRAMES();
 123 }
 124
 125 static void
 126 ao_lisp_stack_clear(void)
 127 {
 128         ao_lisp_stack = NULL;
 129         ao_lisp_frame_current = NULL;
 130         ao_lisp_v = AO_LISP_NIL;
 131 }
 132
 133 static int
 134 func_type(ao_poly func)
 135 {
 136         if (func == AO_LISP_NIL)
 137                 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
 138         switch (ao_lisp_poly_type(func)) {
 139         case AO_LISP_BUILTIN:
 140                 return ao_lisp_poly_builtin(func)->args;
 141         case AO_LISP_LAMBDA:
 142                 return ao_lisp_poly_lambda(func)->args;
 143         default:
 144                 ao_lisp_error(AO_LISP_INVALID, "not a func");
 145                 return -1;
 146         }
 147 }
 148
 149 /*
 150  * Flattened eval to avoid stack issues
 151  */
 152
 153 /*
 154  * Evaluate an s-expression
 155  *
 156  * For a list, evaluate all of the elements and
 157  * then execute the resulting function call.
 158  *
 159  * Each element of the list is evaluated in
 160  * a clean stack context.
 161  *
 162  * The current stack state is set to 'formal' so that
 163  * when the evaluation is complete, the value
 164  * will get appended to the values list.
 165  *
 166  * For other types, compute the value directly.
 167  */
 168
 169 static int
 170 ao_lisp_eval_sexpr(void)
 171 {
 172         DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n");
 173         switch (ao_lisp_poly_type(ao_lisp_v)) {
 174         case AO_LISP_CONS:
 175                 if (ao_lisp_v == AO_LISP_NIL) {
 176                         if (!ao_lisp_stack->values) {
 177                                 /*
 178                                  * empty list evaluates to empty list
 179                                  */
 180                                 ao_lisp_v = AO_LISP_NIL;
 181                                 ao_lisp_stack->state = eval_val;
 182                         } else {
 183                                 /*
 184                                  * done with arguments, go execute it
 185                                  */
 186                                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car;
 187                                 ao_lisp_stack->state = eval_exec;
 188                         }
 189                 } else {
 190                         if (!ao_lisp_stack->values)
 191                                 ao_lisp_stack->list = ao_lisp_v;
 192                         /*
 193                          * Evaluate another argument and then switch
 194                          * to 'formal' to add the value to the values
 195                          * list
 196                          */
 197                         ao_lisp_stack->sexprs = ao_lisp_v;
 198                         ao_lisp_stack->state = eval_formal;
 199                         if (!ao_lisp_stack_push())
 200                                 return 0;
 201                         /*
 202                          * push will reset the state to 'sexpr', which
 203                          * will evaluate the expression
 204                          */
 205                         ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
 206                 }
 207                 break;
 208         case AO_LISP_ATOM:
 209                 DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 210                 ao_lisp_v = ao_lisp_atom_get(ao_lisp_v);
 211                 /* fall through */
 212         case AO_LISP_INT:
 213         case AO_LISP_STRING:
 214         case AO_LISP_BUILTIN:
 215         case AO_LISP_LAMBDA:
 216                 ao_lisp_stack->state = eval_val;
 217                 break;
 218         }
 219         DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n");
 220         return 1;
 221 }
 222
 223 /*
 224  * A value has been computed.
 225  *
 226  * If the value was computed from a macro,
 227  * then we want to reset the current context
 228  * to evaluate the macro result again.
 229  *
 230  * If not a macro, then pop the stack.
 231  * If the stack is empty, we're done.
 232  * Otherwise, the stack will contain
 233  * the next state.
 234  */
 235
 236 static int
 237 ao_lisp_eval_val(void)
 238 {
 239         DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n");
 240         /*
 241          * Value computed, pop the stack
 242          * to figure out what to do with the value
 243          */
 244         ao_lisp_stack_pop();
 245         DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1);
 246         return 1;
 247 }
 248
 249 /*
 250  * A formal has been computed.
 251  *
 252  * If this is the first formal, then check to see if we've got a
 253  * lamda/lexpr or macro/nlambda.
 254  *
 255  * For lambda/lexpr, go compute another formal.  This will terminate
 256  * when the sexpr state sees nil.
 257  *
 258  * For macro/nlambda, we're done, so move the sexprs into the values
 259  * and go execute it.
 260  *
 261  * Macros have an additional step of saving a stack frame holding the
 262  * macro value execution context, which then gets the result of the
 263  * macro to run
 264  */
 265
 266 static int
 267 ao_lisp_eval_formal(void)
 268 {
 269         ao_poly                 formal;
 270         struct ao_lisp_stack    *prev;
 271
 272         DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n");
 273
 274         /* Check what kind of function we've got */
 275         if (!ao_lisp_stack->values) {
 276                 switch (func_type(ao_lisp_v)) {
 277                 case AO_LISP_FUNC_LAMBDA:
 278                 case AO_LISP_FUNC_LEXPR:
 279                         DBGI(".. lambda or lexpr\n");
 280                         break;
 281                 case AO_LISP_FUNC_MACRO:
 282                         /* Evaluate the result once more */
 283                         ao_lisp_stack->state = eval_sexpr;
 284                         if (!ao_lisp_stack_push())
 285                                 return 0;
 286
 287                         /* After the function returns, take that
 288                          * value and re-evaluate it
 289                          */
 290                         prev = ao_lisp_poly_stack(ao_lisp_stack->prev);
 291                         ao_lisp_stack->state = eval_sexpr;
 292                         ao_lisp_stack->sexprs = prev->sexprs;
 293                         prev->sexprs = AO_LISP_NIL;
 294
 295                         DBGI(".. start macro\n");
 296                         DBGI(".. sexprs       "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
 297                         DBGI(".. values       "); DBG_POLY(ao_lisp_stack->values); DBG("\n");
 298                         DBG_FRAMES();
 299
 300                         /* fall through ... */
 301                 case AO_LISP_FUNC_NLAMBDA:
 302                         DBGI(".. nlambda or macro\n");
 303
 304                         /* use the raw sexprs as values */
 305                         ao_lisp_stack->values = ao_lisp_stack->sexprs;
 306                         ao_lisp_stack->values_tail = AO_LISP_NIL;
 307                         ao_lisp_stack->state = eval_exec;
 308
 309                         /* ready to execute now */
 310                         return 1;
 311                 case -1:
 312                         return 0;
 313                 }
 314         }
 315
 316         /* Append formal to list of values */
 317         formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL));
 318         if (!formal)
 319                 return 0;
 320
 321         if (ao_lisp_stack->values_tail)
 322                 ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal;
 323         else
 324                 ao_lisp_stack->values = formal;
 325         ao_lisp_stack->values_tail = formal;
 326
 327         DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n");
 328
 329         /*
 330          * Step to the next argument, if this is last, then
 331          * 'sexpr' will end up switching to 'exec'
 332          */
 333         ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
 334
 335         ao_lisp_stack->state = eval_sexpr;
 336
 337         DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n");
 338         return 1;
 339 }
 340
 341 /*
 342  * Start executing a function call
 343  *
 344  * Most builtins are easy, just call the function.
 345  * 'cond' is magic; it sticks the list of clauses
 346  * in 'sexprs' and switches to 'cond' state. That
 347  * bit of magic is done in ao_lisp_set_cond.
 348  *
 349  * Lambdas build a new frame to hold the locals and
 350  * then re-use the current stack context to evaluate
 351  * the s-expression from the lambda.
 352  */
 353
 354 static int
 355 ao_lisp_eval_exec(void)
 356 {
 357         ao_poly v;
 358         DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n");
 359         ao_lisp_stack->sexprs = AO_LISP_NIL;
 360         switch (ao_lisp_poly_type(ao_lisp_v)) {
 361         case AO_LISP_BUILTIN:
 362                 ao_lisp_stack->state = eval_val;
 363                 v = ao_lisp_func(ao_lisp_poly_builtin(ao_lisp_v)) (
 364                         ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr));
 365                 DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) {
 366                                 struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
 367                                 ao_poly atom = ao_lisp_arg(cons, 1);
 368                                 ao_poly val = ao_lisp_arg(cons, 2);
 369                                 DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n");
 370                         });
 371                 ao_lisp_v = v;
 372                 DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n");
 373                 DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 374                 break;
 375         case AO_LISP_LAMBDA:
 376                 ao_lisp_stack->state = eval_sexpr;
 377                 DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 378                 ao_lisp_v = ao_lisp_lambda_eval();
 379                 DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n");
 380                 DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 381                 break;
 382         }
 383         ao_lisp_stack->values = AO_LISP_NIL;
 384         ao_lisp_stack->values_tail = AO_LISP_NIL;
 385         return 1;
 386 }
 387
 388 /*
 389  * Start evaluating the next cond clause
 390  *
 391  * If the list of clauses is empty, then
 392  * the result of the cond is nil.
 393  *
 394  * Otherwise, set the current stack state to 'cond_test' and create a
 395  * new stack context to evaluate the test s-expression. Once that's
 396  * complete, we'll land in 'cond_test' to finish the clause.
 397  */
 398 static int
 399 ao_lisp_eval_cond(void)
 400 {
 401         DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
 402         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 403         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
 404         if (!ao_lisp_stack->sexprs) {
 405                 ao_lisp_v = AO_LISP_NIL;
 406                 ao_lisp_stack->state = eval_val;
 407         } else {
 408                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car;
 409                 if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) {
 410                         ao_lisp_error(AO_LISP_INVALID, "invalid cond clause");
 411                         return 0;
 412                 }
 413                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
 414                 ao_lisp_stack->state = eval_cond_test;
 415                 if (!ao_lisp_stack_push())
 416                         return 0;
 417                 ao_lisp_stack->state = eval_sexpr;
 418         }
 419         return 1;
 420 }
 421
 422 /*
 423  * Finish a cond clause.
 424  *
 425  * Check the value from the test expression, if
 426  * non-nil, then set up to evaluate the value expression.
 427  *
 428  * Otherwise, step to the next clause and go back to the 'cond'
 429  * state
 430  */
 431 static int
 432 ao_lisp_eval_cond_test(void)
 433 {
 434         DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
 435         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 436         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
 437         if (ao_lisp_v) {
 438                 struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car);
 439                 struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr);
 440
 441                 if (c) {
 442                         ao_lisp_stack->state = eval_sexpr;
 443                         ao_lisp_v = c->car;
 444                 } else
 445                         ao_lisp_stack->state = eval_val;
 446         } else {
 447                 ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
 448                 DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
 449                 ao_lisp_stack->state = eval_cond;
 450         }
 451         return 1;
 452 }
 453
 454 /*
 455  * Evaluate a list of sexprs, returning the value from the last one.
 456  *
 457  * ao_lisp_progn records the list in stack->sexprs, so we just need to
 458  * walk that list. Set ao_lisp_v to the car of the list and jump to
 459  * eval_sexpr. When that's done, it will land in eval_val. For all but
 460  * the last, leave a stack frame with eval_progn set so that we come
 461  * back here. For the last, don't add a stack frame so that we can
 462  * just continue on.
 463  */
 464 static int
 465 ao_lisp_eval_progn(void)
 466 {
 467         DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
 468         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 469         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
 470
 471         if (!ao_lisp_stack->sexprs) {
 472                 ao_lisp_v = AO_LISP_NIL;
 473                 ao_lisp_stack->state = eval_val;
 474         } else {
 475                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car;
 476                 ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
 477                 if (ao_lisp_stack->sexprs) {
 478                         ao_lisp_stack->state = eval_progn;
 479                         if (!ao_lisp_stack_push())
 480                                 return 0;
 481                 }
 482                 ao_lisp_stack->state = eval_sexpr;
 483         }
 484         return 1;
 485 }
 486
 487 /*
 488  * Conditionally execute a list of sexprs while the first is true
 489  */
 490 static int
 491 ao_lisp_eval_while(void)
 492 {
 493         DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
 494         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 495         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
 496
 497         if (!ao_lisp_stack->sexprs) {
 498                 ao_lisp_v = AO_LISP_NIL;
 499                 ao_lisp_stack->state = eval_val;
 500         } else {
 501                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car;
 502                 ao_lisp_stack->state = eval_while_test;
 503                 if (!ao_lisp_stack_push())
 504                         return 0;
 505                 ao_lisp_stack->state = eval_sexpr;
 506         }
 507         return 1;
 508 }
 509
 510 /*
 511  * Check the while condition, terminate the loop if nil. Otherwise keep going
 512  */
 513 static int
 514 ao_lisp_eval_while_test(void)
 515 {
 516         DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
 517         DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
 518         DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n");
 519
 520         if (ao_lisp_v) {
 521                 ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr;
 522                 if (ao_lisp_v)
 523                         ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car;
 524                 ao_lisp_stack->state = eval_while;
 525                 if (!ao_lisp_stack_push())
 526                         return 0;
 527         }
 528         else
 529                 ao_lisp_stack->state = eval_val;
 530         return 1;
 531 }
 532
 533 static int (*const evals[])(void) = {
 534         [eval_sexpr] = ao_lisp_eval_sexpr,
 535         [eval_val] = ao_lisp_eval_val,
 536         [eval_formal] = ao_lisp_eval_formal,
 537         [eval_exec] = ao_lisp_eval_exec,
 538         [eval_cond] = ao_lisp_eval_cond,
 539         [eval_cond_test] = ao_lisp_eval_cond_test,
 540         [eval_progn] = ao_lisp_eval_progn,
 541         [eval_while] = ao_lisp_eval_while,
 542         [eval_while_test] = ao_lisp_eval_while_test,
 543 };
 544
 545 ao_poly
 546 ao_lisp_eval(ao_poly _v)
 547 {
 548         static uint8_t been_here;
 549
 550         ao_lisp_v = _v;
 551         if (!been_here) {
 552                 been_here = 1;
 553                 ao_lisp_root_add(&ao_lisp_stack_type, &ao_lisp_stack);
 554                 ao_lisp_root_poly_add(&ao_lisp_v);
 555         }
 556
 557         if (!ao_lisp_stack_push())
 558                 return AO_LISP_NIL;
 559
 560         while (ao_lisp_stack) {
 561                 if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) {
 562                         ao_lisp_stack_clear();
 563                         return AO_LISP_NIL;
 564                 }
 565         }
 566         DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");});
 567         ao_lisp_frame_current = NULL;
 568         return ao_lisp_v;
 569 }