git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_atom.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 name_size(char *name)
  21 {
  22         return sizeof(struct ao_scheme_atom) + strlen(name) + 1;
  23 }
  24
  25 static int atom_size(void *addr)
  26 {
  27         struct ao_scheme_atom   *atom = addr;
  28         if (!atom)
  29                 return 0;
  30         return name_size(atom->name);
  31 }
  32
  33 static void atom_mark(void *addr)
  34 {
  35         MDBG_MOVE("mark atom %s\n", ((struct ao_scheme_atom *) addr)->name);
  36         (void) addr;
  37 }
  38
  39 static void atom_move(void *addr)
  40 {
  41         (void) addr;
  42 }
  43
  44 const struct ao_scheme_type ao_scheme_atom_type = {
  45         .mark = atom_mark,
  46         .size = atom_size,
  47         .move = atom_move,
  48         .name = "atom"
  49 };
  50
  51 struct ao_scheme_atom   *ao_scheme_atoms;
  52
  53 static struct ao_scheme_atom *
  54 ao_scheme_atom_find(const char *name)
  55 {
  56         struct ao_scheme_atom   *atom;
  57
  58 #ifdef ao_builtin_atoms
  59         if (!ao_scheme_atoms)
  60                 ao_scheme_atoms = ao_scheme_poly_atom(ao_builtin_atoms);
  61 #endif
  62         for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) {
  63                 if (!strcmp(atom->name, name))
  64                         return atom;
  65         }
  66         return NULL;
  67 }
  68
  69 #ifdef AO_SCHEME_MAKE_CONST
  70
  71 #define AO_SCHEME_BUILTIN_SYNTAX_ATOMS
  72 #include "ao_scheme_builtin.h"
  73 #undef AO_SCHEME_BUILTIN_SYNTAX_ATOMS
  74
  75 static void
  76 ao_scheme_atom_mark_syntax(void)
  77 {
  78         unsigned        a;
  79         for (a = 0; a < sizeof(syntax_atoms)/sizeof(syntax_atoms[0]); a++) {
  80                 struct ao_scheme_atom *atom = ao_scheme_atom_find(syntax_atoms[a]);
  81                 if (atom)
  82                         ao_scheme_mark_memory(&ao_scheme_atom_type, atom);
  83         }
  84 }
  85
  86 #else
  87 #define ao_scheme_atom_mark_syntax()
  88 #endif
  89
  90 void
  91 ao_scheme_atom_move(void)
  92 {
  93         struct ao_scheme_atom   *atom;
  94         ao_scheme_move_memory(&ao_scheme_atom_type, (void **) (void *) &ao_scheme_atoms);
  95         for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) {
  96                 if (!ao_scheme_is_pool_addr(atom)) {
  97                         MDBG_DO(printf("atom out of pool %s\n", atom->name));
  98                         break;
  99                 }
 100                 MDBG_DO(printf("move atom %s\n", atom->name));
 101                 ao_scheme_poly_move(&atom->next, 0);
 102         }
 103 }
 104
 105 void
 106 ao_scheme_atom_check_references(void)
 107 {
 108         struct ao_scheme_atom   *atom;
 109         ao_poly                 *prev = NULL;
 110
 111         ao_scheme_atom_mark_syntax();
 112         for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) {
 113                 if (!ao_scheme_marked(atom)) {
 114                         MDBG_DO(printf("unreferenced atom %s\n", atom->name));
 115                         if (prev)
 116                                 *prev = atom->next;
 117                         else
 118                                 ao_scheme_atoms = ao_scheme_poly_atom(atom->next);
 119                 } else
 120                         prev = &atom->next;
 121         }
 122 }
 123
 124 static void
 125 ao_scheme_atom_init(struct ao_scheme_atom *atom, char *name)
 126 {
 127         if (atom) {
 128                 atom->type = AO_SCHEME_ATOM;
 129                 strcpy(atom->name, name);
 130                 atom->next = ao_scheme_atom_poly(ao_scheme_atoms);
 131                 ao_scheme_atoms = atom;
 132         }
 133 }
 134
 135 struct ao_scheme_atom *
 136 ao_scheme_string_to_atom(struct ao_scheme_string *string)
 137 {
 138         struct ao_scheme_atom   *atom = ao_scheme_atom_find(string->val);
 139
 140         if (atom)
 141                 return atom;
 142         ao_scheme_string_stash(string);
 143         atom = ao_scheme_alloc(name_size(string->val));
 144         string = ao_scheme_string_fetch();
 145         ao_scheme_atom_init(atom, string->val);
 146         return atom;
 147 }
 148
 149 struct ao_scheme_atom *
 150 ao_scheme_atom_intern(char *name)
 151 {
 152         struct ao_scheme_atom   *atom = ao_scheme_atom_find(name);
 153         if (atom)
 154                 return atom;
 155
 156         atom = ao_scheme_alloc(name_size(name));
 157         ao_scheme_atom_init(atom, name);
 158         return atom;
 159 }
 160
 161 ao_poly *
 162 ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref)
 163 {
 164         ao_poly *ref;
 165         struct ao_scheme_frame *frame;
 166
 167         for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) {
 168                 ref = ao_scheme_frame_ref(frame, atom);
 169                 if (ref) {
 170                         if (frame_ref)
 171                                 *frame_ref = frame;
 172                         return ref;
 173                 }
 174         }
 175         ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom);
 176         if (ref)
 177                 if (frame_ref)
 178                         *frame_ref = ao_scheme_frame_global;
 179         return ref;
 180 }
 181
 182 ao_poly
 183 ao_scheme_atom_get(ao_poly atom)
 184 {
 185         ao_poly *ref = ao_scheme_atom_ref(atom, NULL);
 186
 187 #ifdef ao_builtin_frame
 188         if (!ref)
 189                 ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom);
 190 #endif
 191         if (ref)
 192                 return *ref;
 193         return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name);
 194 }
 195
 196 ao_poly
 197 ao_scheme_atom_def(ao_poly atom, ao_poly val)
 198 {
 199         struct ao_scheme_frame  *frame;
 200         ao_poly *ref = ao_scheme_atom_ref(atom, &frame);
 201
 202         if (ref) {
 203                 if (frame == ao_scheme_frame_current)
 204                         return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name);
 205                 *ref = val;
 206                 return val;
 207         }
 208         return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val);
 209 }
 210
 211 void
 212 ao_scheme_atom_write(FILE *out, ao_poly a, bool write)
 213 {
 214         struct ao_scheme_atom *atom = ao_scheme_poly_atom(a);
 215         (void) write;
 216         fprintf(out, "%s", atom->name);
 217 }
 218
 219 ao_poly
 220 ao_scheme_do_symbolp(struct ao_scheme_cons *cons)
 221 {
 222         return ao_scheme_do_typep(_ao_scheme_atom_symbol3f, AO_SCHEME_ATOM, cons);
 223 }
 224
 225 ao_poly
 226 ao_scheme_do_set(struct ao_scheme_cons *cons)
 227 {
 228         ao_poly atom;
 229         ao_poly val;
 230         ao_poly *ref;
 231
 232         if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons,
 233                                   AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom,
 234                                   AO_SCHEME_POLY, &val,
 235                                   AO_SCHEME_ARG_END))
 236                 return AO_SCHEME_NIL;
 237
 238         ref = ao_scheme_atom_ref(atom, NULL);
 239
 240         if (!ref)
 241                 return ao_scheme_error(AO_SCHEME_UNDEFINED, "%v: undefined atom %v",
 242                                        _ao_scheme_atom_set, atom);
 243         *ref = val;
 244         return val;
 245 }
 246
 247 ao_poly
 248 ao_scheme_do_def(struct ao_scheme_cons *cons)
 249 {
 250         ao_poly atom;
 251         ao_poly val;
 252
 253         if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons,
 254                                   AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom,
 255                                   AO_SCHEME_POLY, &val,
 256                                   AO_SCHEME_ARG_END))
 257                 return AO_SCHEME_NIL;
 258         return ao_scheme_atom_def(atom, val);
 259 }
 260
 261 ao_poly
 262 ao_scheme_do_setq(struct ao_scheme_cons *cons)
 263 {
 264         ao_poly atom;
 265         ao_poly val;
 266         ao_poly p;
 267
 268         if (!ao_scheme_parse_args(_ao_scheme_atom_set21, cons,
 269                                   AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom,
 270                                   AO_SCHEME_POLY, &val,
 271                                   AO_SCHEME_ARG_END))
 272                 return AO_SCHEME_NIL;
 273         if (!ao_scheme_atom_ref(atom, NULL))
 274                 return ao_scheme_error(AO_SCHEME_INVALID, "%v: symbol %v not defined",
 275                                        _ao_scheme_atom_set21, atom);
 276         /*
 277          * Build the macro return -- `(set (quote ,atom) ,val)
 278          */
 279         ao_scheme_poly_stash(cons->cdr);
 280         p = ao_scheme_cons(atom, AO_SCHEME_NIL);
 281         p = ao_scheme_cons(_ao_scheme_atom_quote, p);
 282         p = ao_scheme_cons(p, ao_scheme_poly_fetch());
 283         return ao_scheme_cons(_ao_scheme_atom_set, p);
 284 }
 285
 286 #ifdef AO_SCHEME_FEATURE_UNDEF
 287 ao_poly
 288 ao_scheme_do_undef(struct ao_scheme_cons *cons)
 289 {
 290         ao_poly atom;
 291
 292         if (!ao_scheme_parse_args(_ao_scheme_atom_set, cons,
 293                                   AO_SCHEME_ATOM|AO_SCHEME_ARG_RET_POLY, &atom,
 294                                   AO_SCHEME_ARG_END))
 295                 return AO_SCHEME_NIL;
 296         return ao_scheme_frame_del(ao_scheme_frame_global, atom);
 297 }
 298 #endif