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