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.
21 lambda_size(void *addr)
24 return sizeof (struct ao_lisp_lambda);
28 lambda_mark(void *addr)
30 struct ao_lisp_lambda *lambda = addr;
32 ao_lisp_poly_mark(lambda->code, 0);
33 ao_lisp_poly_mark(lambda->frame, 0);
37 lambda_move(void *addr)
39 struct ao_lisp_lambda *lambda = addr;
41 ao_lisp_poly_move(&lambda->code, 0);
42 ao_lisp_poly_move(&lambda->frame, 0);
45 const struct ao_lisp_type ao_lisp_lambda_type = {
53 ao_lisp_lambda_print(ao_poly poly)
55 struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly);
56 struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code);
59 printf("%s", ao_lisp_args_name(lambda->args));
62 ao_lisp_poly_print(cons->car);
63 cons = ao_lisp_poly_cons(cons->cdr);
69 ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args)
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;
81 return ao_lisp_error(AO_LISP_INVALID, "missing parameters to lambda");
83 if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1))
86 arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
88 if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM)
89 return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f);
90 arg = ao_lisp_poly_cons(arg->cdr);
94 lambda->type = AO_LISP_LAMBDA;
96 lambda->code = ao_lisp_cons_poly(code);
97 lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current);
98 DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n");
100 return ao_lisp_lambda_poly(lambda);
104 ao_lisp_lambda(struct ao_lisp_cons *cons)
106 return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA);
110 ao_lisp_lexpr(struct ao_lisp_cons *cons)
112 return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR);
116 ao_lisp_nlambda(struct ao_lisp_cons *cons)
118 return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA);
122 ao_lisp_macro(struct ao_lisp_cons *cons)
124 return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO);
128 ao_lisp_lambda_eval(void)
130 struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v);
131 struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
132 struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code);
133 struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
134 struct ao_lisp_frame *next_frame;
138 struct ao_lisp_cons *vals;
140 DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n");
142 args_wanted = ao_lisp_cons_length(args);
144 /* Create a frame to hold the variables
146 args_provided = ao_lisp_cons_length(cons) - 1;
147 if (lambda->args == AO_LISP_FUNC_LAMBDA) {
148 if (args_wanted != args_provided)
149 return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided);
151 if (args_provided < args_wanted - 1)
152 return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided);
155 next_frame = ao_lisp_frame_new(args_wanted);
157 /* Re-fetch all of the values in case something moved */
158 lambda = ao_lisp_poly_lambda(ao_lisp_v);
159 cons = ao_lisp_poly_cons(ao_lisp_stack->values);
160 code = ao_lisp_poly_cons(lambda->code);
161 args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
162 vals = ao_lisp_poly_cons(cons->cdr);
164 next_frame->prev = lambda->frame;
165 ao_lisp_frame_current = next_frame;
166 ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
168 switch (lambda->args) {
169 case AO_LISP_FUNC_LAMBDA:
170 for (f = 0; f < args_wanted; f++) {
171 DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
172 next_frame->vals[f].atom = args->car;
173 next_frame->vals[f].val = vals->car;
174 args = ao_lisp_poly_cons(args->cdr);
175 vals = ao_lisp_poly_cons(vals->cdr);
177 if (!ao_lisp_stack_marked(ao_lisp_stack))
178 ao_lisp_cons_free(cons);
181 case AO_LISP_FUNC_LEXPR:
182 case AO_LISP_FUNC_NLAMBDA:
183 case AO_LISP_FUNC_MACRO:
184 for (f = 0; f < args_wanted - 1; f++) {
185 DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
186 next_frame->vals[f].atom = args->car;
187 next_frame->vals[f].val = vals->car;
188 args = ao_lisp_poly_cons(args->cdr);
189 vals = ao_lisp_poly_cons(vals->cdr);
191 DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n");
192 next_frame->vals[f].atom = args->car;
193 next_frame->vals[f].val = ao_lisp_cons_poly(vals);
198 DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n");
200 DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n");