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