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"
20 static void string_mark(void *addr)
25 static int string_size(void *addr)
27 struct ao_scheme_string *string = addr;
30 return strlen(string->val) + 2;
33 static void string_move(void *addr)
38 const struct ao_scheme_type ao_scheme_string_type = {
45 static struct ao_scheme_string *
46 ao_scheme_string_alloc(int len)
48 struct ao_scheme_string *s;
50 s = ao_scheme_alloc(len + 2);
53 s->type = AO_SCHEME_STRING;
58 struct ao_scheme_string *
59 ao_scheme_string_new(char *a)
61 struct ao_scheme_string *r;
63 r = ao_scheme_string_alloc(strlen(a));
70 struct ao_scheme_string *
71 ao_scheme_atom_to_string(struct ao_scheme_atom *a)
73 int alen = strlen(a->name);
74 struct ao_scheme_string *r;
76 ao_scheme_atom_stash(a);
77 r = ao_scheme_string_alloc(alen);
78 a = ao_scheme_atom_fetch();
81 strcpy(r->val, a->name);
85 struct ao_scheme_string *
86 ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b)
88 int alen = strlen(a->val);
89 int blen = strlen(b->val);
90 struct ao_scheme_string *r;
92 ao_scheme_string_stash(a);
93 ao_scheme_string_stash(b);
94 r = ao_scheme_string_alloc(alen + blen);
95 b = ao_scheme_string_fetch();
96 a = ao_scheme_string_fetch();
99 strcpy(r->val, a->val);
100 strcpy(r->val+alen, b->val);
105 ao_scheme_string_pack(struct ao_scheme_cons *cons)
107 struct ao_scheme_string *string;
111 len = ao_scheme_cons_length(cons);
112 ao_scheme_cons_stash(cons);
113 string = ao_scheme_string_alloc(len);
114 cons = ao_scheme_cons_fetch();
116 return AO_SCHEME_NIL;
120 ao_poly car = cons->car;
122 if (!ao_scheme_is_integer(car) || (c = ao_scheme_poly_integer(car)) == 0)
123 return ao_scheme_error(AO_SCHEME_INVALID, "%v: Invalid %v", _ao_scheme_atom_list2d3estring, car);
125 cons = ao_scheme_cons_cdr(cons);
127 return ao_scheme_string_poly(string);
131 ao_scheme_string_unpack(struct ao_scheme_string *a)
133 ao_poly cons = AO_SCHEME_NIL;
136 for (i = strlen(a->val); --i >= 0;) {
137 ao_scheme_string_stash(a);
138 cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons);
139 a = ao_scheme_string_fetch();
147 ao_scheme_string_write(FILE *out, ao_poly p, bool write)
149 struct ao_scheme_string *s = ao_scheme_poly_string(p);
155 while ((c = *sval++)) {
186 fprintf(out, "\\%03o", c);
194 while ((c = *sval++))
200 ao_scheme_do_stringp(struct ao_scheme_cons *cons)
202 return ao_scheme_do_typep(_ao_scheme_atom_string3f, AO_SCHEME_STRING, cons);
206 ao_scheme_do_list_to_string(struct ao_scheme_cons *cons)
208 struct ao_scheme_cons *list;
210 if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3estring, cons,
211 AO_SCHEME_CONS, &list,
213 return AO_SCHEME_NIL;
214 return ao_scheme_string_pack(list);
218 ao_scheme_do_string_to_list(struct ao_scheme_cons *cons)
220 struct ao_scheme_string *string;
222 if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3elist, cons,
223 AO_SCHEME_STRING, &string,
225 return AO_SCHEME_NIL;
226 return ao_scheme_string_unpack(string);
230 ao_scheme_string_ref(struct ao_scheme_string *string, int32_t r)
232 char *s = string->val;
241 ao_scheme_do_string_ref(struct ao_scheme_cons *cons)
243 struct ao_scheme_string *string;
247 if (!ao_scheme_parse_args(_ao_scheme_atom_string2dref, cons,
248 AO_SCHEME_STRING, &string,
251 return AO_SCHEME_NIL;
253 s = ao_scheme_string_ref(string, ref);
255 return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
256 _ao_scheme_atom_string2dref,
258 ao_scheme_arg(cons, 1));
259 return ao_scheme_integer_poly(*s);
263 ao_scheme_do_string_length(struct ao_scheme_cons *cons)
265 struct ao_scheme_string *string;
267 if (!ao_scheme_parse_args(_ao_scheme_atom_string2dlength, cons,
268 AO_SCHEME_STRING, &string,
270 return AO_SCHEME_NIL;
271 return ao_scheme_integer_poly(strlen(string->val));
275 ao_scheme_do_string_set(struct ao_scheme_cons *cons)
277 struct ao_scheme_string *string;
282 if (!ao_scheme_parse_args(_ao_scheme_atom_string2dset21, cons,
283 AO_SCHEME_STRING, &string,
287 return AO_SCHEME_NIL;
290 s = ao_scheme_string_ref(string, ref);
294 return ao_scheme_integer_poly(val);
296 return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid",
297 _ao_scheme_atom_string2dset21,
298 ao_scheme_arg(cons, 0),
299 ao_scheme_arg(cons, 1),
300 ao_scheme_arg(cons, 2));
304 ao_scheme_do_make_string(struct ao_scheme_cons *cons)
308 struct ao_scheme_string *string;
310 if (!ao_scheme_parse_args(_ao_scheme_atom_make2dstring, cons,
312 AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(' '), &fill,
314 return AO_SCHEME_NIL;
316 return ao_scheme_error(AO_SCHEME_INVALID, "%v: fill 0 invalid",
317 _ao_scheme_atom_make2dstring);
318 string = ao_scheme_string_alloc(len);
320 return AO_SCHEME_NIL;
321 memset(string->val, fill, len);
322 return ao_scheme_string_poly(string);
326 ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
328 struct ao_scheme_atom *atom;
330 if (!ao_scheme_parse_args(_ao_scheme_atom_symbol2d3estring, cons,
331 AO_SCHEME_ATOM, &atom,
333 return AO_SCHEME_NIL;
334 return ao_scheme_string_poly(ao_scheme_atom_to_string(atom));
338 ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
340 struct ao_scheme_string *string;
342 if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3esymbol, cons,
343 AO_SCHEME_STRING, &string,
345 return AO_SCHEME_NIL;
346 return ao_scheme_atom_poly(ao_scheme_string_to_atom(string));