2 * Copyright © 2016 Keith Packard <keithp@keithp.com>
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.
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.
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.
18 #include "ao_scheme.h"
21 lambda_size(void *addr)
24 return sizeof (struct ao_scheme_lambda);
28 lambda_mark(void *addr)
30 struct ao_scheme_lambda *lambda = addr;
32 ao_scheme_poly_mark(lambda->code, 0);
33 ao_scheme_poly_mark(lambda->frame, 0);
37 lambda_move(void *addr)
39 struct ao_scheme_lambda *lambda = addr;
41 ao_scheme_poly_move(&lambda->code, 0);
42 ao_scheme_poly_move(&lambda->frame, 0);
45 const struct ao_scheme_type ao_scheme_lambda_type = {
53 ao_scheme_lambda_write(ao_poly poly, bool write)
55 struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly);
56 struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code);
59 printf("%s", ao_scheme_args_name(lambda->args));
62 ao_scheme_poly_write(cons->car, write);
63 cons = ao_scheme_poly_cons(cons->cdr);
69 ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args)
71 struct ao_scheme_lambda *lambda;
73 struct ao_scheme_cons *cons;
75 formal = ao_scheme_arg(code, 0);
76 while (formal != AO_SCHEME_NIL) {
77 switch (ao_scheme_poly_type(formal)) {
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);
85 formal = AO_SCHEME_NIL;
88 return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal);
92 ao_scheme_cons_stash(code);
93 lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda));
94 code = ao_scheme_cons_fetch();
98 lambda->type = AO_SCHEME_LAMBDA;
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");
104 return ao_scheme_lambda_poly(lambda);
108 ao_scheme_do_lambda(struct ao_scheme_cons *cons)
110 return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA);
114 ao_scheme_do_nlambda(struct ao_scheme_cons *cons)
116 return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA);
120 ao_scheme_do_macro(struct ao_scheme_cons *cons)
122 return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO);
126 ao_scheme_lambda_eval(void)
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);
132 struct ao_scheme_frame *next_frame;
134 ao_poly varargs = AO_SCHEME_NIL;
137 struct ao_scheme_cons *vals;
139 DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n");
142 for (formals = ao_scheme_arg(code, 0);
143 ao_scheme_is_pair(formals);
144 formals = ao_scheme_poly_cons(formals)->cdr)
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");
152 /* Create a frame to hold the variables
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);
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);
163 ao_scheme_poly_stash(varargs);
164 next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL));
165 varargs = ao_scheme_poly_fetch();
167 return AO_SCHEME_NIL;
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);
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);
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);
185 vals = ao_scheme_poly_cons(vals->cdr);
188 DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n");
190 * Bind the rest of the arguments to the final parameter
192 ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals));
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
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);
204 DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n");
206 DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n");