]> git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_lambda.c
e818d7b04bd5dcbcfe6a57431d27a165c1b89b99
[fw/altos] / 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(code);
93         lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda));
94         code = ao_scheme_cons_fetch();
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(varargs);
164         next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL));
165         varargs = ao_scheme_poly_fetch();
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 }