git.gag.com Git - fw/altos/blob - src/lisp/ao_lisp_lambda.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; version 2 of the License.
   7  *
   8  * This program is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License along
  14  * with this program; if not, write to the Free Software Foundation, Inc.,
  15  * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
  16  */
  17
  18 #define DBG_EVAL 0
  19 #include "ao_lisp.h"
  20
  21 int
  22 lambda_size(void *addr)
  23 {
  24         (void) addr;
  25         return sizeof (struct ao_lisp_lambda);
  26 }
  27
  28 void
  29 lambda_mark(void *addr)
  30 {
  31         struct ao_lisp_lambda   *lambda = addr;
  32
  33         ao_lisp_poly_mark(lambda->code, 0);
  34         ao_lisp_poly_mark(lambda->frame, 0);
  35 }
  36
  37 void
  38 lambda_move(void *addr)
  39 {
  40         struct ao_lisp_lambda   *lambda = addr;
  41
  42         ao_lisp_poly_move(&lambda->code, 0);
  43         ao_lisp_poly_move(&lambda->frame, 0);
  44 }
  45
  46 const struct ao_lisp_type ao_lisp_lambda_type = {
  47         .size = lambda_size,
  48         .mark = lambda_mark,
  49         .move = lambda_move,
  50 };
  51
  52 static int
  53 ao_lisp_cons_length(struct ao_lisp_cons *cons)
  54 {
  55         int     len = 0;
  56         while (cons) {
  57                 len++;
  58                 cons = ao_lisp_poly_cons(cons->cdr);
  59         }
  60         return len;
  61 }
  62
  63 void
  64 ao_lisp_lambda_print(ao_poly poly)
  65 {
  66         struct ao_lisp_lambda   *lambda = ao_lisp_poly_lambda(poly);
  67         struct ao_lisp_cons     *cons = ao_lisp_poly_cons(lambda->code);
  68
  69         printf("(");
  70         printf("%s", ao_lisp_args_name(lambda->args));
  71         while (cons) {
  72                 printf(" ");
  73                 ao_lisp_poly_print(cons->car);
  74                 cons = ao_lisp_poly_cons(cons->cdr);
  75         }
  76         printf(")");
  77 }
  78
  79 ao_poly
  80 ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args)
  81 {
  82         struct ao_lisp_lambda   *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda));
  83         struct ao_lisp_cons     *arg;
  84         int                     f;
  85
  86         if (!lambda)
  87                 return AO_LISP_NIL;
  88
  89         if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, code, 2, 2))
  90                 return AO_LISP_NIL;
  91         if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1))
  92                 return AO_LISP_NIL;
  93         f = 0;
  94         arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
  95         while (arg) {
  96                 if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM)
  97                         return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f);
  98                 arg = ao_lisp_poly_cons(arg->cdr);
  99                 f++;
 100         }
 101
 102         lambda->type = AO_LISP_LAMBDA;
 103         lambda->args = args;
 104         lambda->code = ao_lisp_cons_poly(code);
 105         lambda->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
 106         DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n");
 107         DBG_STACK();
 108         return ao_lisp_lambda_poly(lambda);
 109 }
 110
 111 ao_poly
 112 ao_lisp_lambda(struct ao_lisp_cons *cons)
 113 {
 114         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA);
 115 }
 116
 117 ao_poly
 118 ao_lisp_lexpr(struct ao_lisp_cons *cons)
 119 {
 120         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR);
 121 }
 122
 123 ao_poly
 124 ao_lisp_nlambda(struct ao_lisp_cons *cons)
 125 {
 126         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA);
 127 }
 128
 129 ao_poly
 130 ao_lisp_macro(struct ao_lisp_cons *cons)
 131 {
 132         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO);
 133 }
 134
 135 ao_poly
 136 ao_lisp_lambda_eval(void)
 137 {
 138         struct ao_lisp_lambda   *lambda = ao_lisp_poly_lambda(ao_lisp_v);
 139         struct ao_lisp_cons     *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
 140         struct ao_lisp_cons     *code = ao_lisp_poly_cons(lambda->code);
 141         struct ao_lisp_cons     *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
 142         struct ao_lisp_frame    *next_frame;
 143         int                     args_wanted;
 144         int                     args_provided;
 145
 146         DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n");
 147
 148         args_wanted = ao_lisp_cons_length(args);
 149
 150         /* Create a frame to hold the variables
 151          */
 152         if (lambda->args == AO_LISP_FUNC_LAMBDA)
 153                 args_provided = ao_lisp_cons_length(cons) - 1;
 154         else
 155                 args_provided = 1;
 156         if (args_wanted != args_provided)
 157                 return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
 158
 159         next_frame = ao_lisp_frame_new(args_wanted);
 160
 161         /* Re-fetch all of the values in case something moved */
 162         lambda = ao_lisp_poly_lambda(ao_lisp_v);
 163         cons = ao_lisp_poly_cons(ao_lisp_stack->values);
 164         code = ao_lisp_poly_cons(lambda->code);
 165         args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
 166
 167         switch (lambda->args) {
 168         case AO_LISP_FUNC_LAMBDA: {
 169                 int                     f;
 170                 struct ao_lisp_cons     *vals = ao_lisp_poly_cons(cons->cdr);
 171
 172                 for (f = 0; f < args_wanted; f++) {
 173                         DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
 174                         next_frame->vals[f].atom = args->car;
 175                         next_frame->vals[f].val = vals->car;
 176                         args = ao_lisp_poly_cons(args->cdr);
 177                         vals = ao_lisp_poly_cons(vals->cdr);
 178                 }
 179                 break;
 180         }
 181         case AO_LISP_FUNC_LEXPR:
 182         case AO_LISP_FUNC_NLAMBDA:
 183         case AO_LISP_FUNC_MACRO:
 184                 DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(cons->cdr); DBG("\n");
 185                 next_frame->vals[0].atom = args->car;
 186                 next_frame->vals[0].val = cons->cdr;
 187                 break;
 188         }
 189         next_frame->next = lambda->frame;
 190         DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n");
 191         ao_lisp_frame_current = next_frame;
 192         ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
 193         DBG_STACK();
 194         return ao_lisp_arg(code, 1);
 195 }