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