git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_string.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 void string_mark(void *addr)
  21 {
  22         (void) addr;
  23 }
  24
  25 static int string_size(void *addr)
  26 {
  27         struct ao_scheme_string *string = addr;
  28         if (!addr)
  29                 return 0;
  30         return strlen(string->val) + 2;
  31 }
  32
  33 static void string_move(void *addr)
  34 {
  35         (void) addr;
  36 }
  37
  38 const struct ao_scheme_type ao_scheme_string_type = {
  39         .mark = string_mark,
  40         .size = string_size,
  41         .move = string_move,
  42         .name = "string",
  43 };
  44
  45 static struct ao_scheme_string *
  46 ao_scheme_string_alloc(int len)
  47 {
  48         struct ao_scheme_string *s;
  49
  50         if (len < 0)
  51                 return NULL;
  52         s = ao_scheme_alloc(len + 2);
  53         if (!s)
  54                 return NULL;
  55         s->type = AO_SCHEME_STRING;
  56         s->val[len] = '\0';
  57         return s;
  58 }
  59
  60 struct ao_scheme_string *
  61 ao_scheme_string_new(char *a)
  62 {
  63         struct ao_scheme_string *r;
  64
  65         r = ao_scheme_string_alloc(strlen(a));
  66         if (!r)
  67                 return NULL;
  68         strcpy(r->val, a);
  69         return r;
  70 }
  71
  72 struct ao_scheme_string *
  73 ao_scheme_atom_to_string(struct ao_scheme_atom *a)
  74 {
  75         int                     alen = strlen(a->name);
  76         struct ao_scheme_string *r;
  77
  78         ao_scheme_atom_stash(a);
  79         r = ao_scheme_string_alloc(alen);
  80         a = ao_scheme_atom_fetch();
  81         if (!r)
  82                 return NULL;
  83         strcpy(r->val, a->name);
  84         return r;
  85 }
  86
  87 struct ao_scheme_string *
  88 ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b)
  89 {
  90         int                             alen = strlen(a->val);
  91         int                             blen = strlen(b->val);
  92         struct ao_scheme_string         *r;
  93
  94         ao_scheme_string_stash(a);
  95         ao_scheme_string_stash(b);
  96         r = ao_scheme_string_alloc(alen + blen);
  97         b = ao_scheme_string_fetch();
  98         a = ao_scheme_string_fetch();
  99         if (!r)
 100                 return NULL;
 101         strcpy(r->val, a->val);
 102         strcpy(r->val+alen, b->val);
 103         return r;
 104 }
 105
 106 static ao_poly
 107 ao_scheme_string_pack(struct ao_scheme_cons *cons)
 108 {
 109         struct ao_scheme_string *string;
 110         char                    *s;
 111         int                     len;
 112
 113         len = ao_scheme_cons_length(cons);
 114         ao_scheme_cons_stash(cons);
 115         string = ao_scheme_string_alloc(len);
 116         cons = ao_scheme_cons_fetch();
 117         if (!string)
 118                 return AO_SCHEME_NIL;
 119         s = string->val;
 120
 121         while (cons) {
 122                 ao_poly car = cons->car;
 123                 int32_t c;
 124                 if (!ao_scheme_is_integer(car) || (c = ao_scheme_poly_integer(car)) == 0)
 125                         return ao_scheme_error(AO_SCHEME_INVALID, "%v: Invalid %v", _ao_scheme_atom_list2d3estring, car);
 126                 *s++ = c;
 127                 cons = ao_scheme_cons_cdr(cons);
 128         }
 129         return ao_scheme_string_poly(string);
 130 }
 131
 132 static ao_poly
 133 ao_scheme_string_unpack(struct ao_scheme_string *a)
 134 {
 135         ao_poly cons = AO_SCHEME_NIL;
 136         int     i;
 137
 138         for (i = strlen(a->val); --i >= 0;) {
 139                 ao_scheme_string_stash(a);
 140                 cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons);
 141                 a = ao_scheme_string_fetch();
 142                 if (!cons)
 143                         break;
 144         }
 145         return cons;
 146 }
 147
 148 void
 149 ao_scheme_string_write(FILE *out, ao_poly p, bool write)
 150 {
 151         struct ao_scheme_string *s = ao_scheme_poly_string(p);
 152         char                    *sval = s->val;
 153         char                    c;
 154
 155         if (write) {
 156                 putc('"', out);
 157                 while ((c = *sval++)) {
 158                         switch (c) {
 159                         case '\a':
 160                                 fputs("\\a", out);
 161                                 break;
 162                         case '\b':
 163                                 fputs("\\b", out);
 164                                 break;
 165                         case '\t':
 166                                 fputs("\\t", out);
 167                                 break;
 168                         case '\n':
 169                                 fputs("\\n", out);
 170                                 break;
 171                         case '\r':
 172                                 fputs("\\r", out);
 173                                 break;
 174                         case '\f':
 175                                 fputs("\\f", out);
 176                                 break;
 177                         case '\v':
 178                                 fputs("\\v", out);
 179                                 break;
 180                         case '\"':
 181                                 fputs("\\\"", out);
 182                                 break;
 183                         case '\\':
 184                                 fputs("\\\\", out);
 185                                 break;
 186                         default:
 187                                 if ((uint8_t) c < ' ')
 188                                         fprintf(out, "\\%03o", (uint8_t) c);
 189                                 else
 190                                         putc(c, out);
 191                                 break;
 192                         }
 193                 }
 194                 putc('"', out);
 195         } else {
 196                 while ((c = *sval++))
 197                         putc(c, out);
 198         }
 199 }
 200
 201 ao_poly
 202 ao_scheme_do_stringp(struct ao_scheme_cons *cons)
 203 {
 204         return ao_scheme_do_typep(_ao_scheme_atom_string3f, AO_SCHEME_STRING, cons);
 205 }
 206
 207 ao_poly
 208 ao_scheme_do_list_to_string(struct ao_scheme_cons *cons)
 209 {
 210         struct ao_scheme_cons   *list;
 211
 212         if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3estring, cons,
 213                                   AO_SCHEME_CONS, &list,
 214                                   AO_SCHEME_ARG_END))
 215                 return AO_SCHEME_NIL;
 216         return ao_scheme_string_pack(list);
 217 }
 218
 219 ao_poly
 220 ao_scheme_do_string_to_list(struct ao_scheme_cons *cons)
 221 {
 222         struct ao_scheme_string *string;
 223
 224         if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3elist, cons,
 225                                   AO_SCHEME_STRING, &string,
 226                                   AO_SCHEME_ARG_END))
 227                 return AO_SCHEME_NIL;
 228         return ao_scheme_string_unpack(string);
 229 }
 230
 231 static char *
 232 ao_scheme_string_ref(struct ao_scheme_string *string, int32_t r)
 233 {
 234         char *s = string->val;
 235         while (*s && r) {
 236                 ++s;
 237                 --r;
 238         }
 239         return s;
 240 }
 241
 242 ao_poly
 243 ao_scheme_do_string_ref(struct ao_scheme_cons *cons)
 244 {
 245         struct ao_scheme_string *string;
 246         int32_t                 ref;
 247         char                    *s;
 248
 249         if (!ao_scheme_parse_args(_ao_scheme_atom_string2dref, cons,
 250                                   AO_SCHEME_STRING, &string,
 251                                   AO_SCHEME_INT, &ref,
 252                                   AO_SCHEME_ARG_END))
 253                 return AO_SCHEME_NIL;
 254
 255         s = ao_scheme_string_ref(string, ref);
 256         if (!*s)
 257                 return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
 258                                        _ao_scheme_atom_string2dref,
 259                                        cons->car,
 260                                        ao_scheme_arg(cons, 1));
 261         return ao_scheme_integer_poly(*s);
 262 }
 263
 264 ao_poly
 265 ao_scheme_do_string_length(struct ao_scheme_cons *cons)
 266 {
 267         struct ao_scheme_string *string;
 268
 269         if (!ao_scheme_parse_args(_ao_scheme_atom_string2dlength, cons,
 270                                   AO_SCHEME_STRING, &string,
 271                                   AO_SCHEME_ARG_END))
 272                 return AO_SCHEME_NIL;
 273         return ao_scheme_integer_poly(strlen(string->val));
 274 }
 275
 276 ao_poly
 277 ao_scheme_do_string_set(struct ao_scheme_cons *cons)
 278 {
 279         struct ao_scheme_string *string;
 280         int32_t                 ref;
 281         int32_t                 val;
 282         char                    *s;
 283
 284         if (!ao_scheme_parse_args(_ao_scheme_atom_string2dset21, cons,
 285                                   AO_SCHEME_STRING, &string,
 286                                   AO_SCHEME_INT, &ref,
 287                                   AO_SCHEME_INT, &val,
 288                                   AO_SCHEME_ARG_END))
 289                 return AO_SCHEME_NIL;
 290         if (!val)
 291                 goto fail;
 292         s = ao_scheme_string_ref(string, ref);
 293         if (!*s)
 294                 goto fail;
 295         *s = val;
 296         return ao_scheme_integer_poly(val);
 297 fail:
 298         return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid",
 299                                _ao_scheme_atom_string2dset21,
 300                                ao_scheme_arg(cons, 0),
 301                                ao_scheme_arg(cons, 1),
 302                                ao_scheme_arg(cons, 2));
 303 }
 304
 305 ao_poly
 306 ao_scheme_do_make_string(struct ao_scheme_cons *cons)
 307 {
 308         int32_t                 len;
 309         int32_t                 fill;
 310         struct ao_scheme_string *string;
 311
 312         if (!ao_scheme_parse_args(_ao_scheme_atom_make2dstring, cons,
 313                                   AO_SCHEME_INT, &len,
 314                                   AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(' '), &fill,
 315                                   AO_SCHEME_ARG_END))
 316                 return AO_SCHEME_NIL;
 317         if (!fill)
 318                 return ao_scheme_error(AO_SCHEME_INVALID, "%v: fill 0 invalid",
 319                                        _ao_scheme_atom_make2dstring);
 320         string = ao_scheme_string_alloc(len);
 321         if (!string)
 322                 return AO_SCHEME_NIL;
 323         memset(string->val, fill, len);
 324         return ao_scheme_string_poly(string);
 325 }
 326
 327 ao_poly
 328 ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
 329 {
 330         struct ao_scheme_atom   *atom;
 331
 332         if (!ao_scheme_parse_args(_ao_scheme_atom_symbol2d3estring, cons,
 333                                   AO_SCHEME_ATOM, &atom,
 334                                   AO_SCHEME_ARG_END))
 335                 return AO_SCHEME_NIL;
 336         return ao_scheme_string_poly(ao_scheme_atom_to_string(atom));
 337 }
 338
 339 ao_poly
 340 ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
 341 {
 342         struct ao_scheme_string *string;
 343
 344         if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3esymbol, cons,
 345                                   AO_SCHEME_STRING, &string,
 346                                   AO_SCHEME_ARG_END))
 347                 return AO_SCHEME_NIL;
 348         return ao_scheme_atom_poly(ao_scheme_string_to_atom(string));
 349 }