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
  17 #if 1
  18 static int stack_depth;
  19 #define DBG_INDENT()    do { int _s; for(_s = 0; _s < stack_depth; _s++) printf("  "); } while(0)
  20 #define DBG_IN()        (++stack_depth)
  21 #define DBG_OUT()       (--stack_depth)
  22 #define DBG(...)        printf(__VA_ARGS__)
  23 #define DBGI(...)       do { DBG_INDENT(); DBG(__VA_ARGS__); } while (0)
  24 #define DBG_CONS(a)     ao_lisp_cons_print(ao_lisp_cons_poly(a))
  25 #define DBG_POLY(a)     ao_lisp_poly_print(a)
  26 #define OFFSET(a)       ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1)
  27 #else
  28 #define DBG_INDENT()
  29 #define DBG_IN()
  30 #define DBG_OUT()
  31 #define DBG(...)
  32 #define DBGI(...)
  33 #define DBG_CONS(a)
  34 #define DBG_POLY(a)
  35 #endif
  36
  37 enum eval_state {
  38         eval_sexpr,
  39         eval_val,
  40         eval_exec,
  41         eval_exec_direct
  42 };
  43
  44 struct ao_lisp_stack {
  45         ao_poly                 prev;
  46         uint8_t                 state;
  47         ao_poly                 actuals;
  48         ao_poly                 formals;
  49         ao_poly                 formals_tail;
  50         ao_poly                 frame;
  51 };
  52
  53 static struct ao_lisp_stack *
  54 ao_lisp_poly_stack(ao_poly p)
  55 {
  56         return ao_lisp_ref(p);
  57 }
  58
  59 static ao_poly
  60 ao_lisp_stack_poly(struct ao_lisp_stack *stack)
  61 {
  62         return ao_lisp_poly(stack, AO_LISP_OTHER);
  63 }
  64
  65 static int
  66 stack_size(void *addr)
  67 {
  68         (void) addr;
  69         return sizeof (struct ao_lisp_stack);
  70 }
  71
  72 static void
  73 stack_mark(void *addr)
  74 {
  75         struct ao_lisp_stack    *stack = addr;
  76         for (;;) {
  77                 ao_lisp_poly_mark(stack->actuals);
  78                 ao_lisp_poly_mark(stack->formals);
  79                 ao_lisp_poly_mark(stack->frame);
  80                 stack = ao_lisp_poly_stack(stack->prev);
  81                 if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
  82                         break;
  83         }
  84 }
  85
  86 static void
  87 stack_move(void *addr)
  88 {
  89         struct ao_lisp_stack    *stack = addr;
  90
  91         for (;;) {
  92                 struct ao_lisp_stack *prev;
  93                 stack->actuals = ao_lisp_poly_move(stack->actuals);
  94                 stack->formals = ao_lisp_poly_move(stack->formals);
  95                 stack->frame = ao_lisp_poly_move(stack->frame);
  96                 prev = ao_lisp_ref(stack->prev);
  97                 prev = ao_lisp_move_memory(prev, sizeof (struct ao_lisp_stack));
  98                 stack->prev = ao_lisp_stack_poly(prev);
  99                 stack = prev;
 100         }
 101 }
 102
 103 static const struct ao_lisp_type ao_lisp_stack_type = {
 104         .size = stack_size,
 105         .mark = stack_mark,
 106         .move = stack_move
 107 };
 108
 109
 110 static struct ao_lisp_stack     *ao_lisp_stack;
 111 static uint8_t been_here;
 112
 113 ao_poly
 114 ao_lisp_set_cond(struct ao_lisp_cons *c)
 115 {
 116         return AO_LISP_NIL;
 117 }
 118
 119 static void
 120 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
 121 {
 122         stack->state = eval_sexpr;
 123         stack->actuals = AO_LISP_NIL;
 124         stack->formals = AO_LISP_NIL;
 125         stack->formals_tail = AO_LISP_NIL;
 126         stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
 127 }
 128
 129 static struct ao_lisp_stack *
 130 ao_lisp_stack_push(void)
 131 {
 132         struct ao_lisp_stack    *stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
 133         if (!stack)
 134                 return NULL;
 135         stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
 136         ao_lisp_stack_reset(stack);
 137         ao_lisp_stack = stack;
 138         DBGI("stack push\n");
 139         DBG_IN();
 140         return stack;
 141 }
 142
 143 static struct ao_lisp_stack *
 144 ao_lisp_stack_pop(void)
 145 {
 146         if (!ao_lisp_stack)
 147                 return NULL;
 148         DBG_OUT();
 149         DBGI("stack pop\n");
 150         ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev);
 151         if (ao_lisp_stack)
 152                 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
 153         else
 154                 ao_lisp_frame_current = NULL;
 155         return ao_lisp_stack;
 156 }
 157
 158 static void
 159 ao_lisp_stack_clear(void)
 160 {
 161         ao_lisp_stack = NULL;
 162         ao_lisp_frame_current = NULL;
 163 }
 164
 165
 166 static ao_poly
 167 func_type(ao_poly func)
 168 {
 169         struct ao_lisp_cons     *cons;
 170         struct ao_lisp_cons     *args;
 171         int                     f;
 172
 173         DBGI("func type "); DBG_POLY(func); DBG("\n");
 174         if (func == AO_LISP_NIL)
 175                 return ao_lisp_error(AO_LISP_INVALID, "func is nil");
 176         if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) {
 177                 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func);
 178                 return b->args;
 179         } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) {
 180                 cons = ao_lisp_poly_cons(func);
 181                 if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
 182                         return AO_LISP_NIL;
 183                 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
 184                         return AO_LISP_NIL;
 185                 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
 186                         return AO_LISP_NIL;
 187                 args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
 188                 f = 0;
 189                 while (args) {
 190                         if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
 191                                 return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
 192                         }
 193                         args = ao_lisp_poly_cons(args->cdr);
 194                         f++;
 195                 }
 196                 return ao_lisp_arg(cons, 0);
 197         } else
 198                 return ao_lisp_error(AO_LISP_INVALID, "not a func");
 199 }
 200
 201 static int
 202 ao_lisp_cons_length(struct ao_lisp_cons *cons)
 203 {
 204         int     len = 0;
 205         while (cons) {
 206                 len++;
 207                 cons = ao_lisp_poly_cons(cons->cdr);
 208         }
 209         return len;
 210 }
 211
 212 static ao_poly
 213 ao_lisp_lambda(struct ao_lisp_cons *cons)
 214 {
 215         ao_poly                 type;
 216         struct ao_lisp_cons     *lambda;
 217         struct ao_lisp_cons     *args;
 218         struct ao_lisp_frame    *next_frame;
 219         int                     args_wanted;
 220         int                     args_provided;
 221
 222         lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
 223         DBGI("lambda "); DBG_CONS(lambda); DBG("\n");
 224         type = ao_lisp_arg(lambda, 0);
 225         args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
 226
 227         args_wanted = ao_lisp_cons_length(args);
 228
 229         /* Create a frame to hold the variables
 230          */
 231         if (type == _ao_lisp_atom_lambda)
 232                 args_provided = ao_lisp_cons_length(cons) - 1;
 233         else
 234                 args_provided = 1;
 235         if (args_wanted != args_provided)
 236                 return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
 237         next_frame = ao_lisp_frame_new(args_wanted, 0);
 238         DBGI("new frame %d\n", OFFSET(next_frame));
 239         switch (type) {
 240         case _ao_lisp_atom_lambda: {
 241                 int                     f;
 242                 struct ao_lisp_cons     *vals = ao_lisp_poly_cons(cons->cdr);
 243
 244                 for (f = 0; f < args_wanted; f++) {
 245                         next_frame->vals[f].atom = args->car;
 246                         next_frame->vals[f].val = vals->car;
 247                         args = ao_lisp_poly_cons(args->cdr);
 248                         vals = ao_lisp_poly_cons(vals->cdr);
 249                 }
 250                 break;
 251         }
 252         case _ao_lisp_atom_lexpr:
 253         case _ao_lisp_atom_nlambda:
 254                 next_frame->vals[0].atom = args->car;
 255                 next_frame->vals[0].val = cons->cdr;
 256                 break;
 257         case _ao_lisp_atom_macro:
 258                 next_frame->vals[0].atom = args->car;
 259                 next_frame->vals[0].val = ao_lisp_cons_poly(cons);
 260                 break;
 261         }
 262         next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current);
 263         ao_lisp_frame_current = next_frame;
 264         ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame);
 265         return ao_lisp_arg(lambda, 2);
 266 }
 267
 268 ao_poly
 269 ao_lisp_eval(ao_poly v)
 270 {
 271         struct ao_lisp_stack    *stack;
 272         ao_poly                 formal;
 273
 274         if (!been_here) {
 275                 been_here = 1;
 276                 ao_lisp_root_add(&ao_lisp_stack_type, &stack);
 277         }
 278
 279         stack = ao_lisp_stack_push();
 280
 281         for (;;) {
 282                 if (ao_lisp_exception)
 283                         return AO_LISP_NIL;
 284                 switch (stack->state) {
 285                 case eval_sexpr:
 286                         DBGI("sexpr: "); DBG_POLY(v); DBG("\n");
 287                         switch (ao_lisp_poly_type(v)) {
 288                         case AO_LISP_CONS:
 289                                 if (v == AO_LISP_NIL) {
 290                                         stack->state = eval_exec;
 291                                         break;
 292                                 }
 293                                 stack->actuals = v;
 294                                 stack = ao_lisp_stack_push();
 295                                 v = ao_lisp_poly_cons(v)->car;
 296                                 break;
 297                         case AO_LISP_ATOM:
 298                                 v = ao_lisp_atom_get(v);
 299                                 /* fall through */
 300                         case AO_LISP_INT:
 301                         case AO_LISP_STRING:
 302                                 stack->state = eval_val;
 303                                 break;
 304                         }
 305                         break;
 306                 case eval_val:
 307                         DBGI("val: "); DBG_POLY(v); DBG("\n");
 308                         stack = ao_lisp_stack_pop();
 309                         if (!stack)
 310                                 return v;
 311
 312                         stack->state = eval_sexpr;
 313                         /* Check what kind of function we've got */
 314                         if (!stack->formals) {
 315                                 switch (func_type(v)) {
 316                                 case AO_LISP_LAMBDA:
 317                                 case _ao_lisp_atom_lambda:
 318                                 case AO_LISP_LEXPR:
 319                                 case _ao_lisp_atom_lexpr:
 320                                         DBGI(".. lambda or lexpr\n");
 321                                         break;
 322                                 case AO_LISP_NLAMBDA:
 323                                 case _ao_lisp_atom_nlambda:
 324                                 case AO_LISP_MACRO:
 325                                 case _ao_lisp_atom_macro:
 326                                         DBGI(".. nlambda or macro\n");
 327                                         stack->formals = stack->actuals;
 328                                         stack->state = eval_exec_direct;
 329                                         break;
 330                                 }
 331                                 if (stack->state == eval_exec_direct)
 332                                         break;
 333                         }
 334
 335                         formal = ao_lisp_cons_poly(ao_lisp_cons_cons(v, NULL));
 336                         if (!formal) {
 337                                 ao_lisp_stack_clear();
 338                                 return AO_LISP_NIL;
 339                         }
 340
 341                         if (stack->formals_tail)
 342                                 ao_lisp_poly_cons(stack->formals_tail)->cdr = formal;
 343                         else
 344                                 stack->formals = formal;
 345                         stack->formals_tail = formal;
 346
 347                         DBGI("formals now "); DBG_POLY(stack->formals); DBG("\n");
 348
 349                         v = ao_lisp_poly_cons(stack->actuals)->cdr;
 350
 351                         break;
 352                 case eval_exec:
 353                         v = ao_lisp_poly_cons(stack->formals)->car;
 354                 case eval_exec_direct:
 355                         DBGI("exec: "); DBG_POLY(v); DBG(" formals "); DBG_POLY(stack->formals); DBG ("\n");
 356                         if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
 357                                 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
 358
 359                                 v = ao_lisp_func(b) (ao_lisp_poly_cons(ao_lisp_poly_cons(stack->formals)->cdr));
 360                                 DBGI("builtin result:"); DBG_POLY(v); DBG ("\n");
 361                                 if (ao_lisp_exception) {
 362                                         ao_lisp_stack_clear();
 363                                         return AO_LISP_NIL;
 364                                 }
 365                                 stack->state = eval_val;
 366                                 break;
 367                         } else {
 368                                 v = ao_lisp_lambda(ao_lisp_poly_cons(stack->formals));
 369                                 ao_lisp_stack_reset(stack);
 370                         }
 371                         break;
 372                 }
 373         }
 374 }
 375 #if 0
 376
 377
 378         restart:
 379                 if (cond) {
 380                         DBGI("cond is now "); DBG_CONS(cond); DBG("\n");
 381                         if (cond->car == AO_LISP_NIL) {
 382                                 cond = AO_LISP_NIL;
 383                                 v = AO_LISP_NIL;
 384                         } else {
 385                                 if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) {
 386                                         ao_lisp_error(AO_LISP_INVALID, "malformed cond");
 387                                         goto bail;
 388                                 }
 389                                 v = ao_lisp_poly_cons(cond->car)->car;
 390                         }
 391                 }
 392
 393                 /* Build stack frames for each list */
 394                 while (ao_lisp_poly_type(v) == AO_LISP_CONS) {
 395                         if (v == AO_LISP_NIL)
 396                                 break;
 397
 398                         /* Push existing bits on the stack */
 399                         if (cons++)
 400                                 if (!ao_lisp_stack_push())
 401                                         goto bail;
 402
 403                         actuals = ao_lisp_poly_cons(v);
 404                         formals = NULL;
 405                         formals_tail = NULL;
 406                         save_cond = cond;
 407                         cond = NULL;
 408
 409                         v = actuals->car;
 410
 411 //                      DBG("start: stack"); DBG_CONS(stack); DBG("\n");
 412 //                      DBG("start: actuals"); DBG_CONS(actuals); DBG("\n");
 413 //                      DBG("start: formals"); DBG_CONS(formals); DBG("\n");
 414                 }
 415
 416                         if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
 417                                 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
 418                                 switch (b->args) {
 419                                 case AO_LISP_NLAMBDA:
 420                                         formals = actuals;
 421                                         goto eval;
 422
 423                                 case AO_LISP_MACRO:
 424                                         v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
 425                                         DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals));
 426                                         DBG(" -> "); DBG_POLY(v);
 427                                         DBG("\n");
 428                                         if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
 429                                                 ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
 430                                                 goto bail;
 431                                         }
 432                                         /* Reset frame to the new list */
 433                                         actuals = ao_lisp_poly_cons(v);
 434                                         v = actuals->car;
 435                                         goto restart;
 436                                 }
 437                 /* Evaluate primitive types */
 438
 439                 DBG ("actual: "); DBG_POLY(v); DBG("\n");
 440
 441                 switch (ao_lisp_poly_type(v)) {
 442                 case AO_LISP_INT:
 443                 case AO_LISP_STRING:
 444                         break;
 445                 case AO_LISP_ATOM:
 446                         v = ao_lisp_atom_get(v);
 447                         break;
 448                 }
 449
 450                 while (cons) {
 451                         DBG("add formal: "); DBG_POLY(v); DBG("\n");
 452
 453                         /* We've processed the first element of the list, go check
 454                          * what kind of function we've got
 455                          */
 456                         if (formals == NULL) {
 457                                 if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
 458                                         struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
 459                                         switch (b->args) {
 460                                         case AO_LISP_NLAMBDA:
 461                                                 formals = actuals;
 462                                                 goto eval;
 463
 464                                         case AO_LISP_MACRO:
 465                                                 v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
 466                                                 DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals));
 467                                                 DBG(" -> "); DBG_POLY(v);
 468                                                 DBG("\n");
 469                                                 if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
 470                                                         ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
 471                                                         goto bail;
 472                                                 }
 473                                                 /* Reset frame to the new list */
 474                                                 actuals = ao_lisp_poly_cons(v);
 475                                                 v = actuals->car;
 476                                                 goto restart;
 477                                         }
 478                                 } else {
 479                                         switch (func_type(v)) {
 480                                         case _ao_lisp_atom_lambda:
 481                                         case _ao_lisp_atom_lexpr:
 482                                                 break;
 483                                         case _ao_lisp_atom_nlambda:
 484                                                 formals = actuals;
 485                                                 goto eval;
 486                                         case _ao_lisp_atom_macro:
 487                                                 break;
 488                                         default:
 489                                                 ao_lisp_error(AO_LISP_INVALID, "operator is not a function");
 490                                                 goto bail;
 491                                         }
 492                                 }
 493                         }
 494
 495                         formal = ao_lisp_cons_cons(v, NULL);
 496                         if (formals_tail)
 497                                 formals_tail->cdr = ao_lisp_cons_poly(formal);
 498                         else
 499                                 formals = formal;
 500                         formals_tail = formal;
 501                         actuals = ao_lisp_poly_cons(actuals->cdr);
 502
 503                         DBG("formals: ");
 504                         DBG_CONS(formals);
 505                         DBG("\n");
 506                         DBG("actuals: ");
 507                         DBG_CONS(actuals);
 508                         DBG("\n");
 509
 510                         /* Process all of the arguments */
 511                         if (actuals) {
 512                                 v = actuals->car;
 513                                 break;
 514                         }
 515
 516                         v = formals->car;
 517
 518                 eval:
 519
 520                         /* Evaluate the resulting list */
 521                         if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
 522                                 struct ao_lisp_cons *old_cond = cond;
 523                                 struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
 524
 525                                 v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr));
 526
 527                                 DBG ("eval: ");
 528                                 DBG_CONS(formals);
 529                                 DBG(" -> ");
 530                                 DBG_POLY(v);
 531                                 DBG ("\n");
 532                                 if (ao_lisp_exception)
 533                                         goto bail;
 534
 535                                 if (cond != old_cond) {
 536                                         DBG("cond changed from "); DBG_CONS(old_cond); DBG(" to "); DBG_CONS(cond); DBG("\n");
 537                                         actuals = NULL;
 538                                         formals = 0;
 539                                         formals_tail = 0;
 540                                         save_cons = cons;
 541                                         cons = 0;
 542                                         goto restart;
 543                                 }
 544                         } else {
 545                                 v = ao_lisp_lambda(formals);
 546                                 if (ao_lisp_exception)
 547                                         goto bail;
 548                         }
 549
 550                 cond_done:
 551                         --cons;
 552                         if (cons) {
 553                                 ao_lisp_stack_pop();
 554 //                              DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n");
 555 //                              DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n");
 556 //                              DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n");
 557                         } else {
 558                                 actuals = 0;
 559                                 formals = 0;
 560                                 formals_tail = 0;
 561                                 ao_lisp_frame_current = 0;
 562                         }
 563                         if (next_frame) {
 564                                 ao_lisp_frame_current = next_frame;
 565                                 DBG("next frame %d\n", OFFSET(next_frame));
 566                                 next_frame = 0;
 567                                 goto restart;
 568                         }
 569                 }
 570                 if (cond) {
 571                         DBG("next cond cons is %d\n", cons);
 572                         if (v) {
 573                                 v = ao_lisp_poly_cons(cond->car)->cdr;
 574                                 cond = 0;
 575                                 cons = save_cons;
 576                                 if (v != AO_LISP_NIL) {
 577                                         v = ao_lisp_poly_cons(v)->car;
 578                                         DBG("cond complete, sexpr is "); DBG_POLY(v); DBG("\n");
 579                                 }
 580                                 goto cond_done;
 581                         } else {
 582                                 cond = ao_lisp_poly_cons(cond->cdr);
 583                                 DBG("next cond is "); DBG_CONS(cond); DBG("\n");
 584                                 goto restart;
 585                         }
 586                 }
 587                 if (!cons)
 588                         break;
 589         }
 590         DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current));
 591         return v;
 592 bail:
 593         ao_lisp_stack_clear();
 594         return AO_LISP_NIL;
 595 #endif
 596