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, either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * General Public License for more details.
15 #include "ao_scheme.h"
17 static void cons_mark(void *addr)
19 struct ao_scheme_cons *cons = addr;
22 ao_poly cdr = cons->cdr;
24 ao_scheme_poly_mark(cons->car, 1);
27 if (!ao_scheme_is_cons(cdr)) {
28 ao_scheme_poly_mark(cdr, 0);
31 cons = ao_scheme_poly_cons(cdr);
32 if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons))
37 static int cons_size(void *addr)
40 return sizeof (struct ao_scheme_cons);
43 static void cons_move(void *addr)
45 struct ao_scheme_cons *cons = addr;
52 struct ao_scheme_cons *c;
55 MDBG_MOVE("cons_move start %d (%d, %d)\n",
56 MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr)));
57 (void) ao_scheme_poly_move(&cons->car, 1);
61 if (!ao_scheme_is_cons(cdr)) {
62 (void) ao_scheme_poly_move(&cons->cdr, 0);
65 c = ao_scheme_poly_cons(cdr);
66 ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c);
67 if (c != ao_scheme_poly_cons(cons->cdr))
68 cons->cdr = ao_scheme_cons_poly(c);
69 MDBG_MOVE("cons_move end %d (%d, %d)\n",
70 MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr)));
77 const struct ao_scheme_type ao_scheme_cons_type = {
84 struct ao_scheme_cons *ao_scheme_cons_free_list;
86 struct ao_scheme_cons *
87 ao_scheme_cons_cons(ao_poly car, ao_poly cdr)
89 struct ao_scheme_cons *cons;
91 if (ao_scheme_cons_free_list) {
92 cons = ao_scheme_cons_free_list;
93 ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr);
95 ao_scheme_poly_stash(car);
96 ao_scheme_poly_stash(cdr);
97 cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons));
98 cdr = ao_scheme_poly_fetch();
99 car = ao_scheme_poly_fetch();
108 struct ao_scheme_cons *
109 ao_scheme_cons_cdr(struct ao_scheme_cons *cons)
111 ao_poly cdr = cons->cdr;
112 if (cdr == AO_SCHEME_NIL)
114 if (!ao_scheme_is_cons(cdr)) {
115 (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr);
118 return ao_scheme_poly_cons(cdr);
122 ao_scheme_cons(ao_poly car, ao_poly cdr)
124 return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr));
127 static struct ao_scheme_cons *
128 ao_scheme_cons_copy(struct ao_scheme_cons *cons)
130 struct ao_scheme_cons *head = NULL;
131 struct ao_scheme_cons *tail = NULL;
134 struct ao_scheme_cons *new;
137 ao_scheme_cons_stash(cons);
138 ao_scheme_cons_stash(head);
139 ao_scheme_cons_stash(tail);
140 new = ao_scheme_alloc(sizeof (struct ao_scheme_cons));
141 tail = ao_scheme_cons_fetch();
142 head = ao_scheme_cons_fetch();
143 cons = ao_scheme_cons_fetch();
145 return AO_SCHEME_NIL;
146 new->car = cons->car;
147 new->cdr = AO_SCHEME_NIL;
151 tail->cdr = ao_scheme_cons_poly(new);
154 if (!ao_scheme_is_cons(cdr)) {
158 cons = ao_scheme_poly_cons(cdr);
164 ao_scheme_cons_free(struct ao_scheme_cons *cons)
167 ao_scheme_cons_check(cons);
170 ao_poly cdr = cons->cdr;
171 cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list);
172 ao_scheme_cons_free_list = cons;
173 cons = ao_scheme_poly_cons(cdr);
178 ao_scheme_cons_write(FILE *out, ao_poly c, bool write)
180 struct ao_scheme_cons *cons = ao_scheme_poly_cons(c);
181 struct ao_scheme_cons *clear = cons;
185 ao_scheme_print_start();
191 /* Note if there's recursion in printing. Not
192 * as good as actual references, but at least
193 * we don't infinite loop...
195 if (ao_scheme_print_mark_addr(cons)) {
200 ao_scheme_poly_write(out, cons->car, write);
202 /* keep track of how many pairs have been printed */
206 if (!ao_scheme_is_cons(cdr)) {
208 ao_scheme_poly_write(out, cdr, write);
211 cons = ao_scheme_poly_cons(cdr);
215 if (ao_scheme_print_stop()) {
217 /* If we're still printing, clear the print marks on
221 ao_scheme_print_clear_addr(clear);
222 clear = ao_scheme_poly_cons(clear->cdr);
228 ao_scheme_cons_length(struct ao_scheme_cons *cons)
233 cons = ao_scheme_cons_cdr(cons);
239 ao_scheme_do_car(struct ao_scheme_cons *cons)
241 struct ao_scheme_cons *pair;
243 if (!ao_scheme_parse_args(_ao_scheme_atom_car, cons,
244 AO_SCHEME_CONS, &pair,
246 return AO_SCHEME_NIL;
251 ao_scheme_do_cdr(struct ao_scheme_cons *cons)
253 struct ao_scheme_cons *pair;
255 if (!ao_scheme_parse_args(_ao_scheme_atom_cdr, cons,
256 AO_SCHEME_CONS, &pair,
258 return AO_SCHEME_NIL;
263 ao_scheme_do_cons(struct ao_scheme_cons *cons)
267 if (!ao_scheme_parse_args(_ao_scheme_atom_cons, cons,
268 AO_SCHEME_POLY, &car,
269 AO_SCHEME_POLY, &cdr,
271 return AO_SCHEME_NIL;
272 return ao_scheme_cons(car, cdr);
276 ao_scheme_do_last(struct ao_scheme_cons *cons)
278 struct ao_scheme_cons *pair;
280 if (!ao_scheme_parse_args(_ao_scheme_atom_last, cons,
281 AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair,
283 return AO_SCHEME_NIL;
287 pair = ao_scheme_cons_cdr(pair);
289 return AO_SCHEME_NIL;
293 ao_scheme_do_length(struct ao_scheme_cons *cons)
295 struct ao_scheme_cons *pair;
296 if (!ao_scheme_parse_args(_ao_scheme_atom_length, cons,
297 AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair,
299 return AO_SCHEME_NIL;
300 return ao_scheme_integer_poly(ao_scheme_cons_length(pair));
304 ao_scheme_do_list_copy(struct ao_scheme_cons *cons)
306 struct ao_scheme_cons *pair;
308 if (!ao_scheme_parse_args(_ao_scheme_atom_list2dcopy, cons,
309 AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK, &pair,
311 return AO_SCHEME_NIL;
312 return ao_scheme_cons_poly(ao_scheme_cons_copy(pair));
316 ao_scheme_do_list_tail(struct ao_scheme_cons *cons)
321 if (!ao_scheme_parse_args(_ao_scheme_atom_list2dtail, cons,
322 AO_SCHEME_CONS | AO_SCHEME_ARG_NIL_OK | AO_SCHEME_ARG_RET_POLY, &list,
325 return AO_SCHEME_NIL;
329 return ao_scheme_error(AO_SCHEME_INVALID, "%v: ran off end", _ao_scheme_atom_list2dtail);
330 if (!ao_scheme_is_cons(list))
331 return ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid list", _ao_scheme_atom_list2dtail);
332 list = ao_scheme_poly_cons(list)->cdr;
339 ao_scheme_do_pairp(struct ao_scheme_cons *cons)
343 if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons,
344 AO_SCHEME_POLY, &val,
346 return AO_SCHEME_NIL;
347 if (ao_scheme_is_pair(val))
348 return _ao_scheme_bool_true;
349 return _ao_scheme_bool_false;
352 /* This one is special -- a list is either nil or
353 * a 'proper' list with only cons cells
356 ao_scheme_do_listp(struct ao_scheme_cons *cons)
360 if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons,
361 AO_SCHEME_POLY, &val,
363 return AO_SCHEME_NIL;
365 if (val == AO_SCHEME_NIL)
366 return _ao_scheme_bool_true;
367 if (!ao_scheme_is_cons(val))
368 return _ao_scheme_bool_false;
369 val = ao_scheme_poly_cons(val)->cdr;
374 ao_scheme_do_set_car(struct ao_scheme_cons *cons)
376 struct ao_scheme_cons *pair;
379 if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons,
380 AO_SCHEME_CONS, &pair,
381 AO_SCHEME_POLY, &val,
383 return AO_SCHEME_NIL;
389 ao_scheme_do_set_cdr(struct ao_scheme_cons *cons)
391 struct ao_scheme_cons *pair;
394 if (!ao_scheme_parse_args(_ao_scheme_atom_set2dcar21, cons,
395 AO_SCHEME_CONS, &pair,
396 AO_SCHEME_POLY, &val,
398 return AO_SCHEME_NIL;