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 #include "ao_lisp.h"
  19
  20 int
  21 lambda_size(void *addr)
  22 {
  23         (void) addr;
  24         return sizeof (struct ao_lisp_lambda);
  25 }
  26
  27 void
  28 lambda_mark(void *addr)
  29 {
  30         struct ao_lisp_lambda   *lambda = addr;
  31
  32         ao_lisp_poly_mark(lambda->code, 0);
  33         ao_lisp_poly_mark(lambda->frame, 0);
  34 }
  35
  36 void
  37 lambda_move(void *addr)
  38 {
  39         struct ao_lisp_lambda   *lambda = addr;
  40
  41         ao_lisp_poly_move(&lambda->code, 0);
  42         ao_lisp_poly_move(&lambda->frame, 0);
  43 }
  44
  45 const struct ao_lisp_type ao_lisp_lambda_type = {
  46         .size = lambda_size,
  47         .mark = lambda_mark,
  48         .move = lambda_move,
  49         .name = "lambda",
  50 };
  51
  52 void
  53 ao_lisp_lambda_print(ao_poly poly)
  54 {
  55         struct ao_lisp_lambda   *lambda = ao_lisp_poly_lambda(poly);
  56         struct ao_lisp_cons     *cons = ao_lisp_poly_cons(lambda->code);
  57
  58         printf("(");
  59         printf("%s", ao_lisp_args_name(lambda->args));
  60         while (cons) {
  61                 printf(" ");
  62                 ao_lisp_poly_print(cons->car);
  63                 cons = ao_lisp_poly_cons(cons->cdr);
  64         }
  65         printf(")");
  66 }
  67
  68 ao_poly
  69 ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args)
  70 {
  71         ao_lisp_cons_stash(0, code);
  72         struct ao_lisp_lambda   *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda));
  73         code = ao_lisp_cons_fetch(0);
  74         struct ao_lisp_cons     *arg;
  75         int                     f;
  76
  77         if (!lambda)
  78                 return AO_LISP_NIL;
  79
  80         if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1))
  81                 return AO_LISP_NIL;
  82         f = 0;
  83         arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
  84         while (arg) {
  85                 if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM)
  86                         return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f);
  87                 arg = ao_lisp_poly_cons(arg->cdr);
  88                 f++;
  89         }
  90
  91         lambda->type = AO_LISP_LAMBDA;
  92         lambda->args = args;
  93         lambda->code = ao_lisp_cons_poly(code);
  94         lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current);
  95         DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n");
  96         DBG_STACK();
  97         return ao_lisp_lambda_poly(lambda);
  98 }
  99
 100 ao_poly
 101 ao_lisp_lambda(struct ao_lisp_cons *cons)
 102 {
 103         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA);
 104 }
 105
 106 ao_poly
 107 ao_lisp_lexpr(struct ao_lisp_cons *cons)
 108 {
 109         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR);
 110 }
 111
 112 ao_poly
 113 ao_lisp_nlambda(struct ao_lisp_cons *cons)
 114 {
 115         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA);
 116 }
 117
 118 ao_poly
 119 ao_lisp_macro(struct ao_lisp_cons *cons)
 120 {
 121         return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO);
 122 }
 123
 124 ao_poly
 125 ao_lisp_lambda_eval(void)
 126 {
 127         struct ao_lisp_lambda   *lambda = ao_lisp_poly_lambda(ao_lisp_v);
 128         struct ao_lisp_cons     *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
 129         struct ao_lisp_cons     *code = ao_lisp_poly_cons(lambda->code);
 130         struct ao_lisp_cons     *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
 131         struct ao_lisp_frame    *next_frame;
 132         int                     args_wanted;
 133         int                     args_provided;
 134         int                     f;
 135         struct ao_lisp_cons     *vals;
 136
 137         DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n");
 138
 139         args_wanted = ao_lisp_cons_length(args);
 140
 141         /* Create a frame to hold the variables
 142          */
 143         args_provided = ao_lisp_cons_length(cons) - 1;
 144         if (lambda->args == AO_LISP_FUNC_LAMBDA) {
 145                 if (args_wanted != args_provided)
 146                         return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided);
 147         } else {
 148                 if (args_provided < args_wanted - 1)
 149                         return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided);
 150         }
 151
 152         next_frame = ao_lisp_frame_new(args_wanted);
 153
 154         /* Re-fetch all of the values in case something moved */
 155         lambda = ao_lisp_poly_lambda(ao_lisp_v);
 156         cons = ao_lisp_poly_cons(ao_lisp_stack->values);
 157         code = ao_lisp_poly_cons(lambda->code);
 158         args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
 159         vals = ao_lisp_poly_cons(cons->cdr);
 160
 161         next_frame->prev = lambda->frame;
 162         ao_lisp_frame_current = next_frame;
 163         ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
 164
 165         switch (lambda->args) {
 166         case AO_LISP_FUNC_LAMBDA:
 167                 for (f = 0; f < args_wanted; f++) {
 168                         DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
 169                         ao_lisp_frame_bind(next_frame, f, args->car, vals->car);
 170                         args = ao_lisp_poly_cons(args->cdr);
 171                         vals = ao_lisp_poly_cons(vals->cdr);
 172                 }
 173                 if (!ao_lisp_stack_marked(ao_lisp_stack))
 174                         ao_lisp_cons_free(cons);
 175                 cons = NULL;
 176                 break;
 177         case AO_LISP_FUNC_LEXPR:
 178         case AO_LISP_FUNC_NLAMBDA:
 179         case AO_LISP_FUNC_MACRO:
 180                 for (f = 0; f < args_wanted - 1; f++) {
 181                         DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
 182                         ao_lisp_frame_bind(next_frame, f, args->car, vals->car);
 183                         args = ao_lisp_poly_cons(args->cdr);
 184                         vals = ao_lisp_poly_cons(vals->cdr);
 185                 }
 186                 DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n");
 187                 ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals));
 188                 break;
 189         default:
 190                 break;
 191         }
 192         DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n");
 193         DBG_STACK();
 194         DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n");
 195         return code->cdr;
 196 }