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