git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_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_scheme.h"
  19
  20 static int
  21 lambda_size(void *addr)
  22 {
  23         (void) addr;
  24         return sizeof (struct ao_scheme_lambda);
  25 }
  26
  27 static void
  28 lambda_mark(void *addr)
  29 {
  30         struct ao_scheme_lambda *lambda = addr;
  31
  32         ao_scheme_poly_mark(lambda->code, 0);
  33         ao_scheme_poly_mark(lambda->frame, 0);
  34 }
  35
  36 static void
  37 lambda_move(void *addr)
  38 {
  39         struct ao_scheme_lambda *lambda = addr;
  40
  41         ao_scheme_poly_move(&lambda->code, 0);
  42         ao_scheme_poly_move(&lambda->frame, 0);
  43 }
  44
  45 const struct ao_scheme_type ao_scheme_lambda_type = {
  46         .size = lambda_size,
  47         .mark = lambda_mark,
  48         .move = lambda_move,
  49         .name = "lambda",
  50 };
  51
  52 void
  53 ao_scheme_lambda_write(ao_poly poly, bool write)
  54 {
  55         struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly);
  56         struct ao_scheme_cons   *cons = ao_scheme_poly_cons(lambda->code);
  57
  58         printf("(");
  59         printf("%s", ao_scheme_args_name(lambda->args));
  60         while (cons) {
  61                 printf(" ");
  62                 ao_scheme_poly_write(cons->car, write);
  63                 cons = ao_scheme_poly_cons(cons->cdr);
  64         }
  65         printf(")");
  66 }
  67
  68 static ao_poly
  69 ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args)
  70 {
  71         struct ao_scheme_lambda *lambda;
  72         ao_poly                 formal;
  73         struct ao_scheme_cons   *cons;
  74
  75         formal = ao_scheme_arg(code, 0);
  76         while (formal != AO_SCHEME_NIL) {
  77                 switch (ao_scheme_poly_type(formal)) {
  78                 case AO_SCHEME_CONS:
  79                         cons = ao_scheme_poly_cons(formal);
  80                         if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM)
  81                                 return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car);
  82                         formal = cons->cdr;
  83                         break;
  84                 case AO_SCHEME_ATOM:
  85                         formal = AO_SCHEME_NIL;
  86                         break;
  87                 default:
  88                         return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal);
  89                 }
  90         }
  91
  92         ao_scheme_cons_stash(0, code);
  93         lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda));
  94         code = ao_scheme_cons_fetch(0);
  95         if (!lambda)
  96                 return AO_SCHEME_NIL;
  97
  98         lambda->type = AO_SCHEME_LAMBDA;
  99         lambda->args = args;
 100         lambda->code = ao_scheme_cons_poly(code);
 101         lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current);
 102         DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n");
 103         DBG_STACK();
 104         return ao_scheme_lambda_poly(lambda);
 105 }
 106
 107 ao_poly
 108 ao_scheme_do_lambda(struct ao_scheme_cons *cons)
 109 {
 110         return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA);
 111 }
 112
 113 ao_poly
 114 ao_scheme_do_nlambda(struct ao_scheme_cons *cons)
 115 {
 116         return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA);
 117 }
 118
 119 ao_poly
 120 ao_scheme_do_macro(struct ao_scheme_cons *cons)
 121 {
 122         return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO);
 123 }
 124
 125 ao_poly
 126 ao_scheme_lambda_eval(void)
 127 {
 128         struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(ao_scheme_v);
 129         struct ao_scheme_cons   *cons = ao_scheme_poly_cons(ao_scheme_stack->values);
 130         struct ao_scheme_cons   *code = ao_scheme_poly_cons(lambda->code);
 131         ao_poly                 formals;
 132         struct ao_scheme_frame  *next_frame;
 133         int                     args_wanted;
 134         ao_poly                 varargs = AO_SCHEME_NIL;
 135         int                     args_provided;
 136         int                     f;
 137         struct ao_scheme_cons   *vals;
 138
 139         DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n");
 140
 141         args_wanted = 0;
 142         for (formals = ao_scheme_arg(code, 0);
 143              ao_scheme_is_pair(formals);
 144              formals = ao_scheme_poly_cons(formals)->cdr)
 145                 ++args_wanted;
 146         if (formals != AO_SCHEME_NIL) {
 147                 if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM)
 148                         return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form");
 149                 varargs = formals;
 150         }
 151
 152         /* Create a frame to hold the variables
 153          */
 154         args_provided = ao_scheme_cons_length(cons) - 1;
 155         if (varargs == AO_SCHEME_NIL) {
 156                 if (args_wanted != args_provided)
 157                         return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided);
 158         } else {
 159                 if (args_provided < args_wanted)
 160                         return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided);
 161         }
 162
 163         ao_scheme_poly_stash(1, varargs);
 164         next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL));
 165         varargs = ao_scheme_poly_fetch(1);
 166         if (!next_frame)
 167                 return AO_SCHEME_NIL;
 168
 169         /* Re-fetch all of the values in case something moved */
 170         lambda = ao_scheme_poly_lambda(ao_scheme_v);
 171         cons = ao_scheme_poly_cons(ao_scheme_stack->values);
 172         code = ao_scheme_poly_cons(lambda->code);
 173         formals = ao_scheme_arg(code, 0);
 174         vals = ao_scheme_poly_cons(cons->cdr);
 175
 176         next_frame->prev = lambda->frame;
 177         ao_scheme_frame_current = next_frame;
 178         ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current);
 179
 180         for (f = 0; f < args_wanted; f++) {
 181                 struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals);
 182                 DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
 183                 ao_scheme_frame_bind(next_frame, f, arg->car, vals->car);
 184                 formals = arg->cdr;
 185                 vals = ao_scheme_poly_cons(vals->cdr);
 186         }
 187         if (varargs) {
 188                 DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n");
 189                 /*
 190                  * Bind the rest of the arguments to the final parameter
 191                  */
 192                 ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals));
 193         } else {
 194                 /*
 195                  * Mark the cons cells from the actuals as freed for immediate re-use, unless
 196                  * the actuals point into the source function (nlambdas and macros), or if the
 197                  * stack containing them was copied as a part of a continuation
 198                  */
 199                 if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) {
 200                         ao_scheme_stack->values = AO_SCHEME_NIL;
 201                         ao_scheme_cons_free(cons);
 202                 }
 203         }
 204         DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n");
 205         DBG_STACK();
 206         DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n");
 207         return code->cdr;
 208 }