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