+ while (t && (t->anon ||
+ text_cmp(t->name, s) != 0))
+ t = t->next;
+ return t;
+ }
+
+ static struct type *_add_type(struct parse_context *c, struct text s,
+ struct type *proto, int anon)
+ {
+ struct type *n;
+
+ n = calloc(1, sizeof(*n));
+ if (proto)
+ *n = *proto;
+ else
+ n->size = -1;
+ n->name = s;
+ n->anon = anon;
+ n->next = c->typelist;
+ c->typelist = n;
+ return n;
+ }
+
+ static struct type *add_type(struct parse_context *c, struct text s,
+ struct type *proto)
+ {
+ return _add_type(c, s, proto, 0);
+ }
+
+ static struct type *add_anon_type(struct parse_context *c,
+ struct type *proto, char *name, ...)
+ {
+ struct text t;
+ va_list ap;
+
+ va_start(ap, name);
+ vasprintf(&t.txt, name, ap);
+ va_end(ap);
+ t.len = strlen(t.txt);
+ return _add_type(c, t, proto, 1);
+ }
+
+ static struct type *find_anon_type(struct parse_context *c,
+ struct type *proto, char *name, ...)
+ {
+ struct type *t = c->typelist;
+ struct text nm;
+ va_list ap;
+
+ va_start(ap, name);
+ vasprintf(&nm.txt, name, ap);
+ va_end(ap);
+ nm.len = strlen(name);
+
+ while (t && (!t->anon ||
+ text_cmp(t->name, nm) != 0))
+ t = t->next;
+ if (t) {
+ free(nm.txt);
+ return t;
+ }
+ return _add_type(c, nm, proto, 1);
+ }
+
+ static void free_type(struct type *t)
+ {
+ /* The type is always a reference to something in the
+ * context, so we don't need to free anything.
+ */
+ }
+
+ static void free_value(struct type *type, struct value *v)
+ {
+ if (type && v) {
+ type->free(type, v);
+ memset(v, 0x5a, type->size);
+ }
+ }
+
+ static void type_print(struct type *type, FILE *f)
+ {
+ if (!type)
+ fputs("*unknown*type*", f); // NOTEST
+ else if (type->name.len && !type->anon)
+ fprintf(f, "%.*s", type->name.len, type->name.txt);
+ else if (type->print_type)
+ type->print_type(type, f);
+ else if (type->name.len && type->anon)
+ fprintf(f, "\"%.*s\"", type->name.len, type->name.txt);
+ else
+ fputs("*invalid*type*", f); // NOTEST
+ }
+
+ static void val_init(struct type *type, struct value *val)
+ {
+ if (type && type->init)
+ type->init(type, val);
+ }
+
+ static void dup_value(struct type *type,
+ struct value *vold, struct value *vnew)
+ {
+ if (type && type->dup)
+ type->dup(type, vold, vnew);
+ }
+
+ static int value_cmp(struct type *tl, struct type *tr,
+ struct value *left, struct value *right)
+ {
+ if (tl && tl->cmp_order)
+ return tl->cmp_order(tl, tr, left, right);
+ if (tl && tl->cmp_eq)
+ return tl->cmp_eq(tl, tr, left, right);
+ return -1; // NOTEST
+ }
+
+ static void print_value(struct type *type, struct value *v, FILE *f)
+ {
+ if (type && type->print)
+ type->print(type, v, f);
+ else
+ fprintf(f, "*Unknown*"); // NOTEST
+ }
+
+ static void prepare_types(struct parse_context *c)
+ {
+ struct type *t;
+ int retry = 1;
+ enum { none, some, cannot } progress = none;
+
+ while (retry) {
+ retry = 0;
+
+ for (t = c->typelist; t; t = t->next) {
+ if (t->size < 0)
+ tok_err(c, "error: type used but not declared",
+ &t->first_use);
+ if (t->size == 0 && t->prepare_type) {
+ if (t->prepare_type(c, t, 1))
+ progress = some;
+ else if (progress == cannot)
+ tok_err(c, "error: type has recursive definition",
+ &t->first_use);
+ else
+ retry = 1;
+ }
+ }
+ switch (progress) {
+ case cannot:
+ retry = 0; break;
+ case none:
+ progress = cannot; break;
+ case some:
+ progress = none; break;
+ }
+ }
+ }
+
+###### forward decls
+
+ static void free_value(struct type *type, struct value *v);
+ static int type_compat(struct type *require, struct type *have, enum val_rules rules);
+ static void type_print(struct type *type, FILE *f);
+ static void val_init(struct type *type, struct value *v);
+ static void dup_value(struct type *type,
+ struct value *vold, struct value *vnew);
+ static int value_cmp(struct type *tl, struct type *tr,
+ struct value *left, struct value *right);
+ static void print_value(struct type *type, struct value *v, FILE *f);
+
+###### free context types
+
+ while (context.typelist) {
+ struct type *t = context.typelist;
+
+ context.typelist = t->next;
+ if (t->free_type)
+ t->free_type(t);
+ if (t->anon)
+ free(t->name.txt);
+ free(t);
+ }
+
+Type can be specified for local variables, for fields in a structure,
+for formal parameters to functions, and possibly elsewhere. Different
+rules may apply in different contexts. As a minimum, a named type may
+always be used. Currently the type of a formal parameter can be
+different from types in other contexts, so we have a separate grammar
+symbol for those.
+
+###### Grammar
+
+ $*type
+ Type -> IDENTIFIER ${
+ $0 = find_type(c, $ID.txt);
+ if (!$0) {
+ $0 = add_type(c, $ID.txt, NULL);
+ $0->first_use = $ID;
+ }
+ }$
+ ## type grammar
+
+ FormalType -> Type ${ $0 = $<1; }$
+ ## formal type grammar
+
+#### Base Types
+
+Values of the base types can be numbers, which we represent as
+multi-precision fractions, strings, Booleans and labels. When
+analysing the program we also need to allow for places where no value
+is meaningful (type `Tnone`) and where we don't know what type to
+expect yet (type is `NULL`).
+
+Values are never shared, they are always copied when used, and freed
+when no longer needed.
+
+When propagating type information around the program, we need to
+determine if two types are compatible, where type `NULL` is compatible
+with anything. There are two special cases with type compatibility,
+both related to the Conditional Statement which will be described
+later. In some cases a Boolean can be accepted as well as some other
+primary type, and in others any type is acceptable except a label (`Vlabel`).
+A separate function encoding these cases will simplify some code later.
+
+###### type functions
+
+ int (*compat)(struct type *this, struct type *other, enum val_rules rules);
+
+###### ast functions
+
+ static int type_compat(struct type *require, struct type *have,
+ enum val_rules rules)
+ {
+ if ((rules & Rboolok) && have == Tbool)
+ return 1; // NOTEST
+ if (!require || !have)
+ return 1;
+
+ if (require->compat)
+ return require->compat(require, have, rules);
+
+ return require == have;
+ }
+
+###### includes
+ #include <gmp.h>
+ #include "parse_string.h"
+ #include "parse_number.h"
+
+###### libs
+ myLDLIBS := libnumber.o libstring.o -lgmp
+ LDLIBS := $(filter-out $(myLDLIBS),$(LDLIBS)) $(myLDLIBS)
+
+###### type union fields
+ enum vtype {Vnone, Vstr, Vnum, Vbool, Vlabel} vtype;
+
+###### value union fields
+ struct text str;
+ mpq_t num;
+ unsigned char bool;
+ int label;
+
+###### ast functions
+ static void _free_value(struct type *type, struct value *v)
+ {
+ if (!v)
+ return; // NOTEST
+ switch (type->vtype) {
+ case Vnone: break;
+ case Vstr: free(v->str.txt); break;
+ case Vnum: mpq_clear(v->num); break;
+ case Vlabel:
+ case Vbool: break;
+ }
+ }
+
+###### value functions
+
+ static void _val_init(struct type *type, struct value *val)
+ {