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