ocean-lang.org Git - ocean/blob - csrc/oceani.mdc

   1 # Ocean Interpreter - Jamison Creek version
   2
   3 Ocean is intended to be a compiled language, so this interpreter is
   4 not targeted at being the final product.  It is, rather, an intermediate
   5 stage and fills that role in two distinct ways.
   6
   7 Firstly, it exists as a platform to experiment with the early language
   8 design.  An interpreter is easy to write and easy to get working, so
   9 the barrier for entry is lower if I aim to start with an interpreter.
  10
  11 Secondly, the plan for the Ocean compiler is to write it in the
  12 [Ocean language](http://ocean-lang.org).  To achieve this we naturally
  13 need some sort of boot-strap process and this interpreter - written in
  14 portable C - will fill that role.  It will be used to bootstrap the
  15 Ocean compiler.
  16
  17 Two features that are not needed to fill either of these roles are
  18 performance and completeness.  The interpreter only needs to be fast
  19 enough to run small test programs and occasionally to run the compiler
  20 on itself.  It only needs to be complete enough to test aspects of the
  21 design which are developed before the compiler is working, and to run
  22 the compiler on itself.  Any features not used by the compiler when
  23 compiling itself are superfluous.  They may be included anyway, but
  24 they may not.
  25
  26 Nonetheless, the interpreter should end up being reasonably complete,
  27 and any performance bottlenecks which appear and are easily fixed, will
  28 be.
  29
  30 ## Current version
  31
  32 This third version of the interpreter exists to test out some initial
  33 ideas relating to types.  Particularly it adds arrays (indexed from
  34 zero) and simple structures.  Basic control flow and variable scoping
  35 are already fairly well established, as are basic numerical and
  36 boolean operators.
  37
  38 Some operators that have only recently been added, and so have not
  39 generated all that much experience yet are "and then" and "or else" as
  40 short-circuit Boolean operators, and the "if ... else" trinary
  41 operator which can select between two expressions based on a third
  42 (which appears syntactically in the middle).
  43
  44 The "func" clause currently only allows a "main" function to be
  45 declared.  That will be extended when proper function support is added.
  46
  47 An element that is present purely to make a usable language, and
  48 without any expectation that they will remain, is the "print" statement
  49 which performs simple output.
  50
  51 The current scalar types are "number", "Boolean", and "string".
  52 Boolean will likely stay in its current form, the other two might, but
  53 could just as easily be changed.
  54
  55 ## Naming
  56
  57 Versions of the interpreter which obviously do not support a complete
  58 language will be named after creeks and streams.  This one is Jamison
  59 Creek.
  60
  61 Once we have something reasonably resembling a complete language, the
  62 names of rivers will be used.
  63 Early versions of the compiler will be named after seas.  Major
  64 releases of the compiler will be named after oceans.  Hopefully I will
  65 be finished once I get to the Pacific Ocean release.
  66
  67 ## Outline
  68
  69 As well as parsing and executing a program, the interpreter can print
  70 out the program from the parsed internal structure.  This is useful
  71 for validating the parsing.
  72 So the main requirements of the interpreter are:
  73
  74 - Parse the program, possibly with tracing,
  75 - Analyse the parsed program to ensure consistency,
  76 - Print the program,
  77 - Execute the "main" function in the program, if no parsing or
  78   consistency errors were found.
  79
  80 This is all performed by a single C program extracted with
  81 `parsergen`.
  82
  83 There will be two formats for printing the program: a default and one
  84 that uses bracketing.  So a `--bracket` command line option is needed
  85 for that.  Normally the first code section found is used, however an
  86 alternate section can be requested so that a file (such as this one)
  87 can contain multiple programs.  This is effected with the `--section`
  88 option.
  89
  90 This code must be compiled with `-fplan9-extensions` so that anonymous
  91 structures can be used.
  92
  93 ###### File: oceani.mk
  94
  95         myCFLAGS := -Wall -g -fplan9-extensions
  96         CFLAGS := $(filter-out $(myCFLAGS),$(CFLAGS)) $(myCFLAGS)
  97         myLDLIBS:= libparser.o libscanner.o libmdcode.o -licuuc
  98         LDLIBS := $(filter-out $(myLDLIBS),$(LDLIBS)) $(myLDLIBS)
  99         ## libs
 100         all :: $(LDLIBS) oceani
 101         oceani.c oceani.h : oceani.mdc parsergen
 102                 ./parsergen -o oceani --LALR --tag Parser oceani.mdc
 103         oceani.mk: oceani.mdc md2c
 104                 ./md2c oceani.mdc
 105
 106         oceani: oceani.o $(LDLIBS)
 107                 $(CC) $(CFLAGS) -o oceani oceani.o $(LDLIBS)
 108
 109 ###### Parser: header
 110         ## macros
 111         struct parse_context;
 112         ## ast
 113         struct parse_context {
 114                 struct token_config config;
 115                 char *file_name;
 116                 int parse_error;
 117                 struct exec *prog;
 118                 ## parse context
 119         };
 120
 121 ###### macros
 122
 123         #define container_of(ptr, type, member) ({                      \
 124                 const typeof( ((type *)0)->member ) *__mptr = (ptr);    \
 125                 (type *)( (char *)__mptr - offsetof(type,member) );})
 126
 127         #define config2context(_conf) container_of(_conf, struct parse_context, \
 128                 config)
 129
 130 ###### Parser: reduce
 131         struct parse_context *c = config2context(config);
 132
 133 ###### Parser: code
 134
 135         #include <unistd.h>
 136         #include <stdlib.h>
 137         #include <fcntl.h>
 138         #include <errno.h>
 139         #include <sys/mman.h>
 140         #include <string.h>
 141         #include <stdio.h>
 142         #include <locale.h>
 143         #include <malloc.h>
 144         #include "mdcode.h"
 145         #include "scanner.h"
 146         #include "parser.h"
 147
 148         ## includes
 149
 150         #include "oceani.h"
 151
 152         ## forward decls
 153         ## value functions
 154         ## ast functions
 155         ## core functions
 156
 157         #include <getopt.h>
 158         static char Usage[] =
 159                 "Usage: oceani --trace --print --noexec --brackets --section=SectionName prog.ocn\n";
 160         static const struct option long_options[] = {
 161                 {"trace",     0, NULL, 't'},
 162                 {"print",     0, NULL, 'p'},
 163                 {"noexec",    0, NULL, 'n'},
 164                 {"brackets",  0, NULL, 'b'},
 165                 {"section",   1, NULL, 's'},
 166                 {NULL,        0, NULL, 0},
 167         };
 168         const char *options = "tpnbs";
 169
 170         static void pr_err(char *msg)                   // NOTEST
 171         {
 172                 fprintf(stderr, "%s\n", msg);           // NOTEST
 173         }                                               // NOTEST
 174
 175         int main(int argc, char *argv[])
 176         {
 177                 int fd;
 178                 int len;
 179                 char *file;
 180                 struct section *s, *ss;
 181                 char *section = NULL;
 182                 struct parse_context context = {
 183                         .config = {
 184                                 .ignored = (1 << TK_mark),
 185                                 .number_chars = ".,_+- ",
 186                                 .word_start = "_",
 187                                 .word_cont = "_",
 188                         },
 189                 };
 190                 int doprint=0, dotrace=0, doexec=1, brackets=0;
 191                 int opt;
 192                 while ((opt = getopt_long(argc, argv, options, long_options, NULL))
 193                        != -1) {
 194                         switch(opt) {
 195                         case 't': dotrace=1; break;
 196                         case 'p': doprint=1; break;
 197                         case 'n': doexec=0; break;
 198                         case 'b': brackets=1; break;
 199                         case 's': section = optarg; break;
 200                         default: fprintf(stderr, Usage);
 201                                 exit(1);
 202                         }
 203                 }
 204                 if (optind >= argc) {
 205                         fprintf(stderr, "oceani: no input file given\n");
 206                         exit(1);
 207                 }
 208                 fd = open(argv[optind], O_RDONLY);
 209                 if (fd < 0) {
 210                         fprintf(stderr, "oceani: cannot open %s\n", argv[optind]);
 211                         exit(1);
 212                 }
 213                 context.file_name = argv[optind];
 214                 len = lseek(fd, 0, 2);
 215                 file = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, 0);
 216                 s = code_extract(file, file+len, pr_err);
 217                 if (!s) {
 218                         fprintf(stderr, "oceani: could not find any code in %s\n",
 219                                 argv[optind]);
 220                         exit(1);
 221                 }
 222
 223                 ## context initialization
 224
 225                 if (section) {
 226                         for (ss = s; ss; ss = ss->next) {
 227                                 struct text sec = ss->section;
 228                                 if (sec.len == strlen(section) &&
 229                                     strncmp(sec.txt, section, sec.len) == 0)
 230                                         break;
 231                         }
 232                         if (!ss) {
 233                                 fprintf(stderr, "oceani: cannot find section %s\n",
 234                                         section);
 235                                 exit(1);
 236                         }
 237                 } else
 238                         ss = s;                         // NOTEST
 239                 parse_oceani(ss->code, &context.config, dotrace ? stderr : NULL);
 240
 241                 if (!context.prog) {
 242                         fprintf(stderr, "oceani: no main function found.\n");
 243                         context.parse_error = 1;
 244                 }
 245                 if (context.prog && !context.parse_error) {
 246                         if (!analyse_prog(context.prog, &context)) {
 247                                 fprintf(stderr, "oceani: type error in program - not running.\n");
 248                                 context.parse_error = 1;
 249                         }
 250                 }
 251                 if (context.prog && doprint) {
 252                         ## print const decls
 253                         ## print type decls
 254                         print_exec(context.prog, 0, brackets);
 255                 }
 256                 if (context.prog && doexec && !context.parse_error)
 257                         interp_prog(&context, context.prog, argc - optind, argv+optind);
 258                 free_exec(context.prog);
 259
 260                 while (s) {
 261                         struct section *t = s->next;
 262                         code_free(s->code);
 263                         free(s);
 264                         s = t;
 265                 }
 266                 ## free global vars
 267                 ## free context types
 268                 ## free context storage
 269                 exit(context.parse_error ? 1 : 0);
 270         }
 271
 272 ### Analysis
 273
 274 The four requirements of parse, analyse, print, interpret apply to
 275 each language element individually so that is how most of the code
 276 will be structured.
 277
 278 Three of the four are fairly self explanatory.  The one that requires
 279 a little explanation is the analysis step.
 280
 281 The current language design does not require the types of variables to
 282 be declared, but they must still have a single type.  Different
 283 operations impose different requirements on the variables, for example
 284 addition requires both arguments to be numeric, and assignment
 285 requires the variable on the left to have the same type as the
 286 expression on the right.
 287
 288 Analysis involves propagating these type requirements around and
 289 consequently setting the type of each variable.  If any requirements
 290 are violated (e.g. a string is compared with a number) or if a
 291 variable needs to have two different types, then an error is raised
 292 and the program will not run.
 293
 294 If the same variable is declared in both branchs of an 'if/else', or
 295 in all cases of a 'switch' then the multiple instances may be merged
 296 into just one variable if the variable is referenced after the
 297 conditional statement.  When this happens, the types must naturally be
 298 consistent across all the branches.  When the variable is not used
 299 outside the if, the variables in the different branches are distinct
 300 and can be of different types.
 301
 302 Undeclared names may only appear in "use" statements and "case" expressions.
 303 These names are given a type of "label" and a unique value.
 304 This allows them to fill the role of a name in an enumerated type, which
 305 is useful for testing the `switch` statement.
 306
 307 As we will see, the condition part of a `while` statement can return
 308 either a Boolean or some other type.  This requires that the expected
 309 type that gets passed around comprises a type and a flag to indicate
 310 that `Tbool` is also permitted.
 311
 312 As there are, as yet, no distinct types that are compatible, there
 313 isn't much subtlety in the analysis.  When we have distinct number
 314 types, this will become more interesting.
 315
 316 #### Error reporting
 317
 318 When analysis discovers an inconsistency it needs to report an error;
 319 just refusing to run the code ensures that the error doesn't cascade,
 320 but by itself it isn't very useful.  A clear understanding of the sort
 321 of error message that are useful will help guide the process of
 322 analysis.
 323
 324 At a simplistic level, the only sort of error that type analysis can
 325 report is that the type of some construct doesn't match a contextual
 326 requirement.  For example, in `4 + "hello"` the addition provides a
 327 contextual requirement for numbers, but `"hello"` is not a number.  In
 328 this particular example no further information is needed as the types
 329 are obvious from local information.  When a variable is involved that
 330 isn't the case.  It may be helpful to explain why the variable has a
 331 particular type, by indicating the location where the type was set,
 332 whether by declaration or usage.
 333
 334 Using a recursive-descent analysis we can easily detect a problem at
 335 multiple locations. In "`hello:= "there"; 4 + hello`" the addition
 336 will detect that one argument is not a number and the usage of `hello`
 337 will detect that a number was wanted, but not provided.  In this
 338 (early) version of the language, we will generate error reports at
 339 multiple locations, so the use of `hello` will report an error and
 340 explain were the value was set, and the addition will report an error
 341 and say why numbers are needed.  To be able to report locations for
 342 errors, each language element will need to record a file location
 343 (line and column) and each variable will need to record the language
 344 element where its type was set.  For now we will assume that each line
 345 of an error message indicates one location in the file, and up to 2
 346 types.  So we provide a `printf`-like function which takes a format, a
 347 location (a `struct exec` which has not yet been introduced), and 2
 348 types. "`%1`" reports the first type, "`%2`" reports the second.  We
 349 will need a function to print the location, once we know how that is
 350 stored. e As will be explained later, there are sometimes extra rules for
 351 type matching and they might affect error messages, we need to pass those
 352 in too.
 353
 354 As well as type errors, we sometimes need to report problems with
 355 tokens, which might be unexpected or might name a type that has not
 356 been defined.  For these we have `tok_err()` which reports an error
 357 with a given token.  Each of the error functions sets the flag in the
 358 context so indicate that parsing failed.
 359
 360 ###### forward decls
 361
 362         static void fput_loc(struct exec *loc, FILE *f);
 363
 364 ###### core functions
 365
 366         static void type_err(struct parse_context *c,
 367                              char *fmt, struct exec *loc,
 368                              struct type *t1, int rules, struct type *t2)
 369         {
 370                 fprintf(stderr, "%s:", c->file_name);
 371                 fput_loc(loc, stderr);
 372                 for (; *fmt ; fmt++) {
 373                         if (*fmt != '%') {
 374                                 fputc(*fmt, stderr);
 375                                 continue;
 376                         }
 377                         fmt++;
 378                         switch (*fmt) {
 379                         case '%': fputc(*fmt, stderr); break;   // NOTEST
 380                         default: fputc('?', stderr); break;     // NOTEST
 381                         case '1':
 382                                 type_print(t1, stderr);
 383                                 break;
 384                         case '2':
 385                                 type_print(t2, stderr);
 386                                 break;
 387                         ## format cases
 388                         }
 389                 }
 390                 fputs("\n", stderr);
 391                 c->parse_error = 1;
 392         }
 393
 394         static void tok_err(struct parse_context *c, char *fmt, struct token *t)
 395         {
 396                 fprintf(stderr, "%s:%d:%d: %s: %.*s\n", c->file_name, t->line, t->col, fmt,
 397                         t->txt.len, t->txt.txt);
 398                 c->parse_error = 1;
 399         }
 400
 401 ## Entities: declared and predeclared.
 402
 403 There are various "things" that the language and/or the interpreter
 404 needs to know about to parse and execute a program.  These include
 405 types, variables, values, and executable code.  These are all lumped
 406 together under the term "entities" (calling them "objects" would be
 407 confusing) and introduced here.  The following section will present the
 408 different specific code elements which comprise or manipulate these
 409 various entities.
 410
 411 ### Types
 412
 413 Values come in a wide range of types, with more likely to be added.
 414 Each type needs to be able to print its own values (for convenience at
 415 least) as well as to compare two values, at least for equality and
 416 possibly for order.  For now, values might need to be duplicated and
 417 freed, though eventually such manipulations will be better integrated
 418 into the language.
 419
 420 Rather than requiring every numeric type to support all numeric
 421 operations (add, multiple, etc), we allow types to be able to present
 422 as one of a few standard types: integer, float, and fraction.  The
 423 existence of these conversion functions eventually enable types to
 424 determine if they are compatible with other types, though such types
 425 have not yet been implemented.
 426
 427 Named type are stored in a simple linked list.  Objects of each type are
 428 "values" which are often passed around by value.
 429
 430 ###### ast
 431
 432         struct value {
 433                 union {
 434                         char ptr[1];
 435                         ## value union fields
 436                 };
 437         };
 438
 439         struct type {
 440                 struct text name;
 441                 struct type *next;
 442                 int size, align;
 443                 void (*init)(struct type *type, struct value *val);
 444                 void (*prepare_type)(struct parse_context *c, struct type *type, int parse_time);
 445                 void (*print)(struct type *type, struct value *val);
 446                 void (*print_type)(struct type *type, FILE *f);
 447                 int (*cmp_order)(struct type *t1, struct type *t2,
 448                                  struct value *v1, struct value *v2);
 449                 int (*cmp_eq)(struct type *t1, struct type *t2,
 450                               struct value *v1, struct value *v2);
 451                 void (*dup)(struct type *type, struct value *vold, struct value *vnew);
 452                 void (*free)(struct type *type, struct value *val);
 453                 void (*free_type)(struct type *t);
 454                 long long (*to_int)(struct value *v);
 455                 double (*to_float)(struct value *v);
 456                 int (*to_mpq)(mpq_t *q, struct value *v);
 457                 ## type functions
 458                 union {
 459                         ## type union fields
 460                 };
 461         };
 462
 463 ###### parse context
 464
 465         struct type *typelist;
 466
 467 ###### ast functions
 468
 469         static struct type *find_type(struct parse_context *c, struct text s)
 470         {
 471                 struct type *l = c->typelist;
 472
 473                 while (l &&
 474                        text_cmp(l->name, s) != 0)
 475                                 l = l->next;
 476                 return l;
 477         }
 478
 479         static struct type *add_type(struct parse_context *c, struct text s,
 480                                      struct type *proto)
 481         {
 482                 struct type *n;
 483
 484                 n = calloc(1, sizeof(*n));
 485                 *n = *proto;
 486                 n->name = s;
 487                 n->next = c->typelist;
 488                 c->typelist = n;
 489                 return n;
 490         }
 491
 492         static void free_type(struct type *t)
 493         {
 494                 /* The type is always a reference to something in the
 495                  * context, so we don't need to free anything.
 496                  */
 497         }
 498
 499         static void free_value(struct type *type, struct value *v)
 500         {
 501                 if (type && v) {
 502                         type->free(type, v);
 503                         memset(v, 0x5a, type->size);
 504                 }
 505         }
 506
 507         static void type_print(struct type *type, FILE *f)
 508         {
 509                 if (!type)
 510                         fputs("*unknown*type*", f);     // NOTEST
 511                 else if (type->name.len)
 512                         fprintf(f, "%.*s", type->name.len, type->name.txt);
 513                 else if (type->print_type)
 514                         type->print_type(type, f);
 515                 else
 516                         fputs("*invalid*type*", f);     // NOTEST
 517         }
 518
 519         static void val_init(struct type *type, struct value *val)
 520         {
 521                 if (type && type->init)
 522                         type->init(type, val);
 523         }
 524
 525         static void dup_value(struct type *type,
 526                               struct value *vold, struct value *vnew)
 527         {
 528                 if (type && type->dup)
 529                         type->dup(type, vold, vnew);
 530         }
 531
 532         static int value_cmp(struct type *tl, struct type *tr,
 533                              struct value *left, struct value *right)
 534         {
 535                 if (tl && tl->cmp_order)
 536                         return tl->cmp_order(tl, tr, left, right);
 537                 if (tl && tl->cmp_eq)                   // NOTEST
 538                         return tl->cmp_eq(tl, tr, left, right); // NOTEST
 539                 return -1;                              // NOTEST
 540         }
 541
 542         static void print_value(struct type *type, struct value *v)
 543         {
 544                 if (type && type->print)
 545                         type->print(type, v);
 546                 else
 547                         printf("*Unknown*");            // NOTEST
 548         }
 549
 550 ###### forward decls
 551
 552         static void free_value(struct type *type, struct value *v);
 553         static int type_compat(struct type *require, struct type *have, int rules);
 554         static void type_print(struct type *type, FILE *f);
 555         static void val_init(struct type *type, struct value *v);
 556         static void dup_value(struct type *type,
 557                               struct value *vold, struct value *vnew);
 558         static int value_cmp(struct type *tl, struct type *tr,
 559                              struct value *left, struct value *right);
 560         static void print_value(struct type *type, struct value *v);
 561
 562 ###### free context types
 563
 564         while (context.typelist) {
 565                 struct type *t = context.typelist;
 566
 567                 context.typelist = t->next;
 568                 if (t->free_type)
 569                         t->free_type(t);
 570                 free(t);
 571         }
 572
 573 Type can be specified for local variables, for fields in a structure,
 574 for formal parameters to functions, and possibly elsewhere.  Different
 575 rules may apply in different contexts.  As a minimum, a named type may
 576 always be used.  Currently the type of a formal parameter can be
 577 different from types in other contexts, so we have a separate grammar
 578 symbol for those.
 579
 580 ###### Grammar
 581
 582         $*type
 583         Type -> IDENTIFIER ${
 584                 $0 = find_type(c, $1.txt);
 585                 if (!$0) {
 586                         tok_err(c,
 587                                 "error: undefined type", &$1);
 588
 589                         $0 = Tnone;
 590                 }
 591         }$
 592         ## type grammar
 593
 594         FormalType -> Type ${ $0 = $<1; }$
 595         ## formal type grammar
 596
 597 #### Base Types
 598
 599 Values of the base types can be numbers, which we represent as
 600 multi-precision fractions, strings, Booleans and labels.  When
 601 analysing the program we also need to allow for places where no value
 602 is meaningful (type `Tnone`) and where we don't know what type to
 603 expect yet (type is `NULL`).
 604
 605 Values are never shared, they are always copied when used, and freed
 606 when no longer needed.
 607
 608 When propagating type information around the program, we need to
 609 determine if two types are compatible, where type `NULL` is compatible
 610 with anything.  There are two special cases with type compatibility,
 611 both related to the Conditional Statement which will be described
 612 later.  In some cases a Boolean can be accepted as well as some other
 613 primary type, and in others any type is acceptable except a label (`Vlabel`).
 614 A separate function encoding these cases will simplify some code later.
 615
 616 ###### type functions
 617
 618         int (*compat)(struct type *this, struct type *other);
 619
 620 ###### ast functions
 621
 622         static int type_compat(struct type *require, struct type *have, int rules)
 623         {
 624                 if ((rules & Rboolok) && have == Tbool)
 625                         return 1;       // NOTEST
 626                 if ((rules & Rnolabel) && have == Tlabel)
 627                         return 0;       // NOTEST
 628                 if (!require || !have)
 629                         return 1;
 630
 631                 if (require->compat)
 632                         return require->compat(require, have);
 633
 634                 return require == have;
 635         }
 636
 637 ###### includes
 638         #include <gmp.h>
 639         #include "parse_string.h"
 640         #include "parse_number.h"
 641
 642 ###### libs
 643         myLDLIBS := libnumber.o libstring.o -lgmp
 644         LDLIBS := $(filter-out $(myLDLIBS),$(LDLIBS)) $(myLDLIBS)
 645
 646 ###### type union fields
 647         enum vtype {Vnone, Vstr, Vnum, Vbool, Vlabel} vtype;
 648
 649 ###### value union fields
 650         struct text str;
 651         mpq_t num;
 652         unsigned char bool;
 653         void *label;
 654
 655 ###### ast functions
 656         static void _free_value(struct type *type, struct value *v)
 657         {
 658                 if (!v)
 659                         return;         // NOTEST
 660                 switch (type->vtype) {
 661                 case Vnone: break;
 662                 case Vstr: free(v->str.txt); break;
 663                 case Vnum: mpq_clear(v->num); break;
 664                 case Vlabel:
 665                 case Vbool: break;
 666                 }
 667         }
 668
 669 ###### value functions
 670
 671         static void _val_init(struct type *type, struct value *val)
 672         {
 673                 switch(type->vtype) {
 674                 case Vnone:             // NOTEST
 675                         break;          // NOTEST
 676                 case Vnum:
 677                         mpq_init(val->num); break;
 678                 case Vstr:
 679                         val->str.txt = malloc(1);
 680                         val->str.len = 0;
 681                         break;
 682                 case Vbool:
 683                         val->bool = 0;
 684                         break;
 685                 case Vlabel:
 686                         val->label = NULL;
 687                         break;
 688                 }
 689         }
 690
 691         static void _dup_value(struct type *type,
 692                                struct value *vold, struct value *vnew)
 693         {
 694                 switch (type->vtype) {
 695                 case Vnone:             // NOTEST
 696                         break;          // NOTEST
 697                 case Vlabel:
 698                         vnew->label = vold->label;
 699                         break;
 700                 case Vbool:
 701                         vnew->bool = vold->bool;
 702                         break;
 703                 case Vnum:
 704                         mpq_init(vnew->num);
 705                         mpq_set(vnew->num, vold->num);
 706                         break;
 707                 case Vstr:
 708                         vnew->str.len = vold->str.len;
 709                         vnew->str.txt = malloc(vnew->str.len);
 710                         memcpy(vnew->str.txt, vold->str.txt, vnew->str.len);
 711                         break;
 712                 }
 713         }
 714
 715         static int _value_cmp(struct type *tl, struct type *tr,
 716                               struct value *left, struct value *right)
 717         {
 718                 int cmp;
 719                 if (tl != tr)
 720                         return tl - tr; // NOTEST
 721                 switch (tl->vtype) {
 722                 case Vlabel: cmp = left->label == right->label ? 0 : 1; break;
 723                 case Vnum: cmp = mpq_cmp(left->num, right->num); break;
 724                 case Vstr: cmp = text_cmp(left->str, right->str); break;
 725                 case Vbool: cmp = left->bool - right->bool; break;
 726                 case Vnone: cmp = 0;                    // NOTEST
 727                 }
 728                 return cmp;
 729         }
 730
 731         static void _print_value(struct type *type, struct value *v)
 732         {
 733                 switch (type->vtype) {
 734                 case Vnone:                             // NOTEST
 735                         printf("*no-value*"); break;    // NOTEST
 736                 case Vlabel:                            // NOTEST
 737                         printf("*label-%p*", v->label); break; // NOTEST
 738                 case Vstr:
 739                         printf("%.*s", v->str.len, v->str.txt); break;
 740                 case Vbool:
 741                         printf("%s", v->bool ? "True":"False"); break;
 742                 case Vnum:
 743                         {
 744                         mpf_t fl;
 745                         mpf_init2(fl, 20);
 746                         mpf_set_q(fl, v->num);
 747                         gmp_printf("%Fg", fl);
 748                         mpf_clear(fl);
 749                         break;
 750                         }
 751                 }
 752         }
 753
 754         static void _free_value(struct type *type, struct value *v);
 755
 756         static struct type base_prototype = {
 757                 .init = _val_init,
 758                 .print = _print_value,
 759                 .cmp_order = _value_cmp,
 760                 .cmp_eq = _value_cmp,
 761                 .dup = _dup_value,
 762                 .free = _free_value,
 763         };
 764
 765         static struct type *Tbool, *Tstr, *Tnum, *Tnone, *Tlabel;
 766
 767 ###### ast functions
 768         static struct type *add_base_type(struct parse_context *c, char *n,
 769                                           enum vtype vt, int size)
 770         {
 771                 struct text txt = { n, strlen(n) };
 772                 struct type *t;
 773
 774                 t = add_type(c, txt, &base_prototype);
 775                 t->vtype = vt;
 776                 t->size = size;
 777                 t->align = size > sizeof(void*) ? sizeof(void*) : size;
 778                 if (t->size & (t->align - 1))
 779                         t->size = (t->size | (t->align - 1)) + 1;       // NOTEST
 780                 return t;
 781         }
 782
 783 ###### context initialization
 784
 785         Tbool  = add_base_type(&context, "Boolean", Vbool, sizeof(char));
 786         Tstr   = add_base_type(&context, "string", Vstr, sizeof(struct text));
 787         Tnum   = add_base_type(&context, "number", Vnum, sizeof(mpq_t));
 788         Tnone  = add_base_type(&context, "none", Vnone, 0);
 789         Tlabel = add_base_type(&context, "label", Vlabel, sizeof(void*));
 790
 791 ### Variables
 792
 793 Variables are scoped named values.  We store the names in a linked list
 794 of "bindings" sorted in lexical order, and use sequential search and
 795 insertion sort.
 796
 797 ###### ast
 798
 799         struct binding {
 800                 struct text name;
 801                 struct binding *next;   // in lexical order
 802                 ## binding fields
 803         };
 804
 805 This linked list is stored in the parse context so that "reduce"
 806 functions can find or add variables, and so the analysis phase can
 807 ensure that every variable gets a type.
 808
 809 ###### parse context
 810
 811         struct binding *varlist;  // In lexical order
 812
 813 ###### ast functions
 814
 815         static struct binding *find_binding(struct parse_context *c, struct text s)
 816         {
 817                 struct binding **l = &c->varlist;
 818                 struct binding *n;
 819                 int cmp = 1;
 820
 821                 while (*l &&
 822                         (cmp = text_cmp((*l)->name, s)) < 0)
 823                                 l = & (*l)->next;
 824                 if (cmp == 0)
 825                         return *l;
 826                 n = calloc(1, sizeof(*n));
 827                 n->name = s;
 828                 n->next = *l;
 829                 *l = n;
 830                 return n;
 831         }
 832
 833 Each name can be linked to multiple variables defined in different
 834 scopes.  Each scope starts where the name is declared and continues
 835 until the end of the containing code block.  Scopes of a given name
 836 cannot nest, so a declaration while a name is in-scope is an error.
 837
 838 ###### binding fields
 839         struct variable *var;
 840
 841 ###### ast
 842         struct variable {
 843                 struct variable *previous;
 844                 struct type *type;
 845                 struct binding *name;
 846                 struct exec *where_decl;// where name was declared
 847                 struct exec *where_set; // where type was set
 848                 ## variable fields
 849         };
 850
 851 When a scope closes, the values of the variables might need to be freed.
 852 This happens in the context of some `struct exec` and each `exec` will
 853 need to know which variables need to be freed when it completes.
 854
 855 ####### exec fields
 856         struct variable *to_free;
 857
 858 ####### variable fields
 859         struct exec *cleanup_exec;
 860         struct variable *next_free;
 861
 862 ####### interp exec cleanup
 863         {
 864                 struct variable *v;
 865                 for (v = e->to_free; v; v = v->next_free) {
 866                         struct value *val = var_value(c, v);
 867                         free_value(v->type, val);
 868                 }
 869         }
 870
 871 ###### ast functions
 872         static void variable_unlink_exec(struct variable *v)
 873         {
 874                 struct variable **vp;
 875                 if (!v->cleanup_exec)
 876                         return;
 877                 for (vp = &v->cleanup_exec->to_free;
 878                     *vp; vp = &(*vp)->next_free) {
 879                         if (*vp != v)
 880                                 continue;
 881                         *vp = v->next_free;
 882                         v->cleanup_exec = NULL;
 883                         break;
 884                 }
 885         }
 886
 887 While the naming seems strange, we include local constants in the
 888 definition of variables.  A name declared `var := value` can
 889 subsequently be changed, but a name declared `var ::= value` cannot -
 890 it is constant
 891
 892 ###### variable fields
 893         int constant;
 894
 895 Scopes in parallel branches can be partially merged.  More
 896 specifically, if a given name is declared in both branches of an
 897 if/else then its scope is a candidate for merging.  Similarly if
 898 every branch of an exhaustive switch (e.g. has an "else" clause)
 899 declares a given name, then the scopes from the branches are
 900 candidates for merging.
 901
 902 Note that names declared inside a loop (which is only parallel to
 903 itself) are never visible after the loop.  Similarly names defined in
 904 scopes which are not parallel, such as those started by `for` and
 905 `switch`, are never visible after the scope.  Only variables defined in
 906 both `then` and `else` (including the implicit then after an `if`, and
 907 excluding `then` used with `for`) and in all `case`s and `else` of a
 908 `switch` or `while` can be visible beyond the `if`/`switch`/`while`.
 909
 910 Labels, which are a bit like variables, follow different rules.
 911 Labels are not explicitly declared, but if an undeclared name appears
 912 in a context where a label is legal, that effectively declares the
 913 name as a label.  The declaration remains in force (or in scope) at
 914 least to the end of the immediately containing block and conditionally
 915 in any larger containing block which does not declare the name in some
 916 other way.  Importantly, the conditional scope extension happens even
 917 if the label is only used in one parallel branch of a conditional --
 918 when used in one branch it is treated as having been declared in all
 919 branches.
 920
 921 Merge candidates are tentatively visible beyond the end of the
 922 branching statement which creates them.  If the name is used, the
 923 merge is affirmed and they become a single variable visible at the
 924 outer layer.  If not - if it is redeclared first - the merge lapses.
 925
 926 To track scopes we have an extra stack, implemented as a linked list,
 927 which roughly parallels the parse stack and which is used exclusively
 928 for scoping.  When a new scope is opened, a new frame is pushed and
 929 the child-count of the parent frame is incremented.  This child-count
 930 is used to distinguish between the first of a set of parallel scopes,
 931 in which declared variables must not be in scope, and subsequent
 932 branches, whether they may already be conditionally scoped.
 933
 934 To push a new frame *before* any code in the frame is parsed, we need a
 935 grammar reduction.  This is most easily achieved with a grammar
 936 element which derives the empty string, and creates the new scope when
 937 it is recognised.  This can be placed, for example, between a keyword
 938 like "if" and the code following it.
 939
 940 ###### ast
 941         struct scope {
 942                 struct scope *parent;
 943                 int child_count;
 944         };
 945
 946 ###### parse context
 947         int scope_depth;
 948         struct scope *scope_stack;
 949
 950 ###### ast functions
 951         static void scope_pop(struct parse_context *c)
 952         {
 953                 struct scope *s = c->scope_stack;
 954
 955                 c->scope_stack = s->parent;
 956                 free(s);
 957                 c->scope_depth -= 1;
 958         }
 959
 960         static void scope_push(struct parse_context *c)
 961         {
 962                 struct scope *s = calloc(1, sizeof(*s));
 963                 if (c->scope_stack)
 964                         c->scope_stack->child_count += 1;
 965                 s->parent = c->scope_stack;
 966                 c->scope_stack = s;
 967                 c->scope_depth += 1;
 968         }
 969
 970 ###### Grammar
 971
 972         $void
 973         OpenScope -> ${ scope_push(c); }$
 974
 975 Each variable records a scope depth and is in one of four states:
 976
 977 - "in scope".  This is the case between the declaration of the
 978   variable and the end of the containing block, and also between
 979   the usage with affirms a merge and the end of that block.
 980
 981   The scope depth is not greater than the current parse context scope
 982   nest depth.  When the block of that depth closes, the state will
 983   change.  To achieve this, all "in scope" variables are linked
 984   together as a stack in nesting order.
 985
 986 - "pending".  The "in scope" block has closed, but other parallel
 987   scopes are still being processed.  So far, every parallel block at
 988   the same level that has closed has declared the name.
 989
 990   The scope depth is the depth of the last parallel block that
 991   enclosed the declaration, and that has closed.
 992
 993 - "conditionally in scope".  The "in scope" block and all parallel
 994   scopes have closed, and no further mention of the name has been seen.
 995   This state includes a secondary nest depth (`min_depth`) which records
 996   the outermost scope seen since the variable became conditionally in
 997   scope.  If a use of the name is found, the variable becomes "in scope"
 998   and that secondary depth becomes the recorded scope depth.  If the
 999   name is declared as a new variable, the old variable becomes "out of
1000   scope" and the recorded scope depth stays unchanged.
1001
1002 - "out of scope".  The variable is neither in scope nor conditionally
1003   in scope.  It is permanently out of scope now and can be removed from
1004   the "in scope" stack.
1005
1006 ###### variable fields
1007         int depth, min_depth;
1008         enum { OutScope, PendingScope, CondScope, InScope } scope;
1009         struct variable *in_scope;
1010
1011 ###### parse context
1012
1013         struct variable *in_scope;
1014
1015 All variables with the same name are linked together using the
1016 'previous' link.  Those variable that have been affirmatively merged all
1017 have a 'merged' pointer that points to one primary variable - the most
1018 recently declared instance.  When merging variables, we need to also
1019 adjust the 'merged' pointer on any other variables that had previously
1020 been merged with the one that will no longer be primary.
1021
1022 A variable that is no longer the most recent instance of a name may
1023 still have "pending" scope, if it might still be merged with most
1024 recent instance.  These variables don't really belong in the
1025 "in_scope" list, but are not immediately removed when a new instance
1026 is found.  Instead, they are detected and ignored when considering the
1027 list of in_scope names.
1028
1029 The storage of the value of a variable will be described later.  For now
1030 we just need to know that when a variable goes out of scope, it might
1031 need to be freed.  For this we need to be able to find it, so assume that
1032 `var_value()` will provide that.
1033
1034 ###### variable fields
1035         struct variable *merged;
1036
1037 ###### ast functions
1038
1039         static void variable_merge(struct variable *primary, struct variable *secondary)
1040         {
1041                 struct variable *v;
1042
1043                 primary = primary->merged;
1044
1045                 for (v = primary->previous; v; v=v->previous)
1046                         if (v == secondary || v == secondary->merged ||
1047                             v->merged == secondary ||
1048                             v->merged == secondary->merged) {
1049                                 v->scope = OutScope;
1050                                 v->merged = primary;
1051                                 variable_unlink_exec(v);
1052                         }
1053         }
1054
1055 ###### forward decls
1056         static struct value *var_value(struct parse_context *c, struct variable *v);
1057
1058 ###### free global vars
1059
1060         while (context.varlist) {
1061                 struct binding *b = context.varlist;
1062                 struct variable *v = b->var;
1063                 context.varlist = b->next;
1064                 free(b);
1065                 while (v) {
1066                         struct variable *t = v;
1067
1068                         v = t->previous;
1069                         if (t->global) {
1070                                 free_value(t->type, var_value(&context, t));
1071                                 if (t->depth == 0)
1072                                         free_exec(t->where_decl);
1073                         }
1074                         free(t);
1075                 }
1076         }
1077
1078 #### Manipulating Bindings
1079
1080 When a name is conditionally visible, a new declaration discards the
1081 old binding - the condition lapses.  Conversely a usage of the name
1082 affirms the visibility and extends it to the end of the containing
1083 block - i.e. the block that contains both the original declaration and
1084 the latest usage.  This is determined from `min_depth`.  When a
1085 conditionally visible variable gets affirmed like this, it is also
1086 merged with other conditionally visible variables with the same name.
1087
1088 When we parse a variable declaration we either report an error if the
1089 name is currently bound, or create a new variable at the current nest
1090 depth if the name is unbound or bound to a conditionally scoped or
1091 pending-scope variable.  If the previous variable was conditionally
1092 scoped, it and its homonyms becomes out-of-scope.
1093
1094 When we parse a variable reference (including non-declarative assignment
1095 "foo = bar") we report an error if the name is not bound or is bound to
1096 a pending-scope variable; update the scope if the name is bound to a
1097 conditionally scoped variable; or just proceed normally if the named
1098 variable is in scope.
1099
1100 When we exit a scope, any variables bound at this level are either
1101 marked out of scope or pending-scoped, depending on whether the scope
1102 was sequential or parallel.  Here a "parallel" scope means the "then"
1103 or "else" part of a conditional, or any "case" or "else" branch of a
1104 switch.  Other scopes are "sequential".
1105
1106 When exiting a parallel scope we check if there are any variables that
1107 were previously pending and are still visible. If there are, then
1108 they weren't redeclared in the most recent scope, so they cannot be
1109 merged and must become out-of-scope.  If it is not the first of
1110 parallel scopes (based on `child_count`), we check that there was a
1111 previous binding that is still pending-scope.  If there isn't, the new
1112 variable must now be out-of-scope.
1113
1114 When exiting a sequential scope that immediately enclosed parallel
1115 scopes, we need to resolve any pending-scope variables.  If there was
1116 no `else` clause, and we cannot determine that the `switch` was exhaustive,
1117 we need to mark all pending-scope variable as out-of-scope.  Otherwise
1118 all pending-scope variables become conditionally scoped.
1119
1120 ###### ast
1121         enum closetype { CloseSequential, CloseParallel, CloseElse };
1122
1123 ###### ast functions
1124
1125         static struct variable *var_decl(struct parse_context *c, struct text s)
1126         {
1127                 struct binding *b = find_binding(c, s);
1128                 struct variable *v = b->var;
1129
1130                 switch (v ? v->scope : OutScope) {
1131                 case InScope:
1132                         /* Caller will report the error */
1133                         return NULL;
1134                 case CondScope:
1135                         for (;
1136                              v && v->scope == CondScope;
1137                              v = v->previous)
1138                                 v->scope = OutScope;
1139                         break;
1140                 default: break;
1141                 }
1142                 v = calloc(1, sizeof(*v));
1143                 v->previous = b->var;
1144                 b->var = v;
1145                 v->name = b;
1146                 v->merged = v;
1147                 v->min_depth = v->depth = c->scope_depth;
1148                 v->scope = InScope;
1149                 v->in_scope = c->in_scope;
1150                 c->in_scope = v;
1151                 return v;
1152         }
1153
1154         static struct variable *var_ref(struct parse_context *c, struct text s)
1155         {
1156                 struct binding *b = find_binding(c, s);
1157                 struct variable *v = b->var;
1158                 struct variable *v2;
1159
1160                 switch (v ? v->scope : OutScope) {
1161                 case OutScope:
1162                 case PendingScope:
1163                         /* Caller will report the error */
1164                         return NULL;
1165                 case CondScope:
1166                         /* All CondScope variables of this name need to be merged
1167                          * and become InScope
1168                          */
1169                         v->depth = v->min_depth;
1170                         v->scope = InScope;
1171                         for (v2 = v->previous;
1172                              v2 && v2->scope == CondScope;
1173                              v2 = v2->previous)
1174                                 variable_merge(v, v2);
1175                         break;
1176                 case InScope:
1177                         break;
1178                 }
1179                 return v;
1180         }
1181
1182         static void var_block_close(struct parse_context *c, enum closetype ct,
1183                                     struct exec *e)
1184         {
1185                 /* Close off all variables that are in_scope.
1186                  * Some variables in c->scope may already be not-in-scope,
1187                  * such as when a PendingScope variable is hidden by a new
1188                  * variable with the same name.
1189                  * So we check for v->name->var != v and drop them.
1190                  * If we choose to make a variable OutScope, we drop it
1191                  * immediately too.
1192                  */
1193                 struct variable *v, **vp, *v2;
1194
1195                 scope_pop(c);
1196                 for (vp = &c->in_scope;
1197                      (v = *vp) && v->min_depth > c->scope_depth;
1198                      (v->scope == OutScope || v->name->var != v)
1199                      ? (*vp =  v->in_scope, 0)
1200                      : ( vp = &v->in_scope, 0)) {
1201                         v->min_depth = c->scope_depth;
1202                         if (v->name->var != v)
1203                                 /* This is still in scope, but we haven't just
1204                                  * closed the scope.
1205                                  */
1206                                 continue;
1207                         v->min_depth = c->scope_depth;
1208                         if (v->scope == InScope) {
1209                                 /* This variable gets cleaned up when 'e' finishes */
1210                                 variable_unlink_exec(v);
1211                                 v->cleanup_exec = e;
1212                                 v->next_free = e->to_free;
1213                                 e->to_free = v;
1214                         }
1215                         switch (ct) {
1216                         case CloseElse:
1217                         case CloseParallel: /* handle PendingScope */
1218                                 switch(v->scope) {
1219                                 case InScope:
1220                                 case CondScope:
1221                                         if (c->scope_stack->child_count == 1)
1222                                                 /* first among parallel branches */
1223                                                 v->scope = PendingScope;
1224                                         else if (v->previous &&
1225                                                  v->previous->scope == PendingScope)
1226                                                 /* all previous branches used name */
1227                                                 v->scope = PendingScope;
1228                                         else if (v->type == Tlabel)
1229                                                 /* Labels remain pending even when not used */
1230                                                 v->scope = PendingScope;        // UNTESTED
1231                                         else
1232                                                 v->scope = OutScope;
1233                                         if (ct == CloseElse) {
1234                                                 /* All Pending variables with this name
1235                                                  * are now Conditional */
1236                                                 for (v2 = v;
1237                                                      v2 && v2->scope == PendingScope;
1238                                                      v2 = v2->previous)
1239                                                         v2->scope = CondScope;
1240                                         }
1241                                         break;
1242                                 case PendingScope:
1243                                         /* Not possible as it would require
1244                                          * parallel scope to be nested immediately
1245                                          * in a parallel scope, and that never
1246                                          * happens.
1247                                          */                     // NOTEST
1248                                 case OutScope:
1249                                         /* Not possible as we already tested for
1250                                          * OutScope
1251                                          */
1252                                         abort();                // NOTEST
1253                                 }
1254                                 break;
1255                         case CloseSequential:
1256                                 if (v->type == Tlabel)
1257                                         v->scope = PendingScope;
1258                                 switch (v->scope) {
1259                                 case InScope:
1260                                         v->scope = OutScope;
1261                                         break;
1262                                 case PendingScope:
1263                                         /* There was no 'else', so we can only become
1264                                          * conditional if we know the cases were exhaustive,
1265                                          * and that doesn't mean anything yet.
1266                                          * So only labels become conditional..
1267                                          */
1268                                         for (v2 = v;
1269                                              v2 && v2->scope == PendingScope;
1270                                              v2 = v2->previous)
1271                                                 if (v2->type == Tlabel)
1272                                                         v2->scope = CondScope;
1273                                                 else
1274                                                         v2->scope = OutScope;
1275                                         break;
1276                                 case CondScope:
1277                                 case OutScope: break;
1278                                 }
1279                                 break;
1280                         }
1281                 }
1282         }
1283
1284 #### Storing Values
1285
1286 The value of a variable is store separately from the variable, on an
1287 analogue of a stack frame.  There are (currently) two frames that can be
1288 active.  A global frame which currently only stores constants, and a
1289 stacked frame which stores local variables.  Each variable knows if it
1290 is global or not, and what its index into the frame is.
1291
1292 Values in the global frame are known immediately they are relevant, so
1293 the frame needs to be reallocated as it grows so it can store those
1294 values.  The local frame doesn't get values until the interpreted phase
1295 is started, so there is no need to allocate until the size is known.
1296
1297 ###### variable fields
1298                 short frame_pos;
1299                 short global;
1300
1301 ###### parse context
1302
1303         short global_size, global_alloc;
1304         short local_size;
1305         void *global, *local;
1306
1307 ###### ast functions
1308
1309         static struct value *var_value(struct parse_context *c, struct variable *v)
1310         {
1311                 if (!v->global) {
1312                         if (!c->local || !v->type)
1313                                 return NULL;                    // NOTEST
1314                         if (v->frame_pos + v->type->size > c->local_size) {
1315                                 printf("INVALID frame_pos\n");  // NOTEST
1316                                 exit(2);                        // NOTEST
1317                         }
1318                         return c->local + v->frame_pos;
1319                 }
1320                 if (c->global_size > c->global_alloc) {
1321                         int old = c->global_alloc;
1322                         c->global_alloc = (c->global_size | 1023) + 1024;
1323                         c->global = realloc(c->global, c->global_alloc);
1324                         memset(c->global + old, 0, c->global_alloc - old);
1325                 }
1326                 return c->global + v->frame_pos;
1327         }
1328
1329         static struct value *global_alloc(struct parse_context *c, struct type *t,
1330                                           struct variable *v, struct value *init)
1331         {
1332                 struct value *ret;
1333                 struct variable scratch;
1334
1335                 if (t->prepare_type)
1336                         t->prepare_type(c, t, 1);       // NOTEST
1337
1338                 if (c->global_size & (t->align - 1))
1339                         c->global_size = (c->global_size + t->align) & ~(t->align-1);   // UNTESTED
1340                 if (!v) {
1341                         v = &scratch;
1342                         v->type = t;
1343                 }
1344                 v->frame_pos = c->global_size;
1345                 v->global = 1;
1346                 c->global_size += v->type->size;
1347                 ret = var_value(c, v);
1348                 if (init)
1349                         memcpy(ret, init, t->size);
1350                 else
1351                         val_init(t, ret);
1352                 return ret;
1353         }
1354
1355 As global values are found -- struct field initializers, labels etc --
1356 `global_alloc()` is called to record the value in the global frame.
1357
1358 When the program is fully parsed, we need to walk the list of variables
1359 to find any that weren't merged away and that aren't global, and to
1360 calculate the frame size and assign a frame position for each variable.
1361 For this we have `scope_finalize()`.
1362
1363 ###### ast functions
1364
1365         static void scope_finalize(struct parse_context *c)
1366         {
1367                 struct binding *b;
1368
1369                 for (b = c->varlist; b; b = b->next) {
1370                         struct variable *v;
1371                         for (v = b->var; v; v = v->previous) {
1372                                 struct type *t = v->type;
1373                                 if (v->merged != v)
1374                                         continue;
1375                                 if (v->global)
1376                                         continue;
1377                                 if (c->local_size & (t->align - 1))
1378                                         c->local_size = (c->local_size + t->align) & ~(t->align-1);
1379                                 v->frame_pos = c->local_size;
1380                                 c->local_size += v->type->size;
1381                         }
1382                 }
1383                 c->local = calloc(1, c->local_size);
1384         }
1385
1386 ###### free context storage
1387         free(context.global);
1388         free(context.local);
1389
1390 ### Executables
1391
1392 Executables can be lots of different things.  In many cases an
1393 executable is just an operation combined with one or two other
1394 executables.  This allows for expressions and lists etc.  Other times an
1395 executable is something quite specific like a constant or variable name.
1396 So we define a `struct exec` to be a general executable with a type, and
1397 a `struct binode` which is a subclass of `exec`, forms a node in a
1398 binary tree, and holds an operation.  There will be other subclasses,
1399 and to access these we need to be able to `cast` the `exec` into the
1400 various other types.  The first field in any `struct exec` is the type
1401 from the `exec_types` enum.
1402
1403 ###### macros
1404         #define cast(structname, pointer) ({            \
1405                 const typeof( ((struct structname *)0)->type) *__mptr = &(pointer)->type; \
1406                 if (__mptr && *__mptr != X##structname) abort();                \
1407                 (struct structname *)( (char *)__mptr);})
1408
1409         #define new(structname) ({                                              \
1410                 struct structname *__ptr = ((struct structname *)calloc(1,sizeof(struct structname))); \
1411                 __ptr->type = X##structname;                                            \
1412                 __ptr->line = -1; __ptr->column = -1;                                   \
1413                 __ptr;})
1414
1415         #define new_pos(structname, token) ({                                           \
1416                 struct structname *__ptr = ((struct structname *)calloc(1,sizeof(struct structname))); \
1417                 __ptr->type = X##structname;                                            \
1418                 __ptr->line = token.line; __ptr->column = token.col;                    \
1419                 __ptr;})
1420
1421 ###### ast
1422         enum exec_types {
1423                 Xbinode,
1424                 ## exec type
1425         };
1426         struct exec {
1427                 enum exec_types type;
1428                 int line, column;
1429                 ## exec fields
1430         };
1431         struct binode {
1432                 struct exec;
1433                 enum Btype {
1434                         ## Binode types
1435                 } op;
1436                 struct exec *left, *right;
1437         };
1438
1439 ###### ast functions
1440
1441         static int __fput_loc(struct exec *loc, FILE *f)
1442         {
1443                 if (!loc)
1444                         return 0;
1445                 if (loc->line >= 0) {
1446                         fprintf(f, "%d:%d: ", loc->line, loc->column);
1447                         return 1;
1448                 }
1449                 if (loc->type == Xbinode)
1450                         return __fput_loc(cast(binode,loc)->left, f) ||
1451                                __fput_loc(cast(binode,loc)->right, f);  // NOTEST
1452                 return 0;                       // NOTEST
1453         }
1454         static void fput_loc(struct exec *loc, FILE *f)
1455         {
1456                 if (!__fput_loc(loc, f))
1457                         fprintf(f, "??:??: ");  // NOTEST
1458         }
1459
1460 Each different type of `exec` node needs a number of functions defined,
1461 a bit like methods.  We must be able to free it, print it, analyse it
1462 and execute it.  Once we have specific `exec` types we will need to
1463 parse them too.  Let's take this a bit more slowly.
1464
1465 #### Freeing
1466
1467 The parser generator requires a `free_foo` function for each struct
1468 that stores attributes and they will often be `exec`s and subtypes
1469 there-of.  So we need `free_exec` which can handle all the subtypes,
1470 and we need `free_binode`.
1471
1472 ###### ast functions
1473
1474         static void free_binode(struct binode *b)
1475         {
1476                 if (!b)
1477                         return;
1478                 free_exec(b->left);
1479                 free_exec(b->right);
1480                 free(b);
1481         }
1482
1483 ###### core functions
1484         static void free_exec(struct exec *e)
1485         {
1486                 if (!e)
1487                         return;
1488                 switch(e->type) {
1489                         ## free exec cases
1490                 }
1491         }
1492
1493 ###### forward decls
1494
1495         static void free_exec(struct exec *e);
1496
1497 ###### free exec cases
1498         case Xbinode: free_binode(cast(binode, e)); break;
1499
1500 #### Printing
1501
1502 Printing an `exec` requires that we know the current indent level for
1503 printing line-oriented components.  As will become clear later, we
1504 also want to know what sort of bracketing to use.
1505
1506 ###### ast functions
1507
1508         static void do_indent(int i, char *str)
1509         {
1510                 while (i--)
1511                         printf("    ");
1512                 printf("%s", str);
1513         }
1514
1515 ###### core functions
1516         static void print_binode(struct binode *b, int indent, int bracket)
1517         {
1518                 struct binode *b2;
1519                 switch(b->op) {
1520                 ## print binode cases
1521                 }
1522         }
1523
1524         static void print_exec(struct exec *e, int indent, int bracket)
1525         {
1526                 if (!e)
1527                         return;
1528                 switch (e->type) {
1529                 case Xbinode:
1530                         print_binode(cast(binode, e), indent, bracket); break;
1531                 ## print exec cases
1532                 }
1533                 if (e->to_free) {
1534                         struct variable *v;
1535                         do_indent(indent, "/* FREE");
1536                         for (v = e->to_free; v; v = v->next_free)
1537                                 printf(" %.*s(%c%d+%d)", v->name->name.len, v->name->name.txt,
1538                                        v->global ? 'G':'L',
1539                                        v->frame_pos, v->type ? v->type->size:0);
1540                         printf(" */\n");
1541                 }
1542         }
1543
1544 ###### forward decls
1545
1546         static void print_exec(struct exec *e, int indent, int bracket);
1547
1548 #### Analysing
1549
1550 As discussed, analysis involves propagating type requirements around the
1551 program and looking for errors.
1552
1553 So `propagate_types` is passed an expected type (being a `struct type`
1554 pointer together with some `val_rules` flags) that the `exec` is
1555 expected to return, and returns the type that it does return, either
1556 of which can be `NULL` signifying "unknown".  An `ok` flag is passed
1557 by reference. It is set to `0` when an error is found, and `2` when
1558 any change is made.  If it remains unchanged at `1`, then no more
1559 propagation is needed.
1560
1561 ###### ast
1562
1563         enum val_rules {Rnolabel = 1<<0, Rboolok = 1<<1, Rnoconstant = 2<<1};
1564
1565 ###### format cases
1566         case 'r':
1567                 if (rules & Rnolabel)
1568                         fputs(" (labels not permitted)", stderr);
1569                 break;
1570
1571 ###### core functions
1572
1573         static struct type *propagate_types(struct exec *prog, struct parse_context *c, int *ok,
1574                                             struct type *type, int rules);
1575         static struct type *__propagate_types(struct exec *prog, struct parse_context *c, int *ok,
1576                                               struct type *type, int rules)
1577         {
1578                 struct type *t;
1579
1580                 if (!prog)
1581                         return Tnone;
1582
1583                 switch (prog->type) {
1584                 case Xbinode:
1585                 {
1586                         struct binode *b = cast(binode, prog);
1587                         switch (b->op) {
1588                         ## propagate binode cases
1589                         }
1590                         break;
1591                 }
1592                 ## propagate exec cases
1593                 }
1594                 return Tnone;
1595         }
1596
1597         static struct type *propagate_types(struct exec *prog, struct parse_context *c, int *ok,
1598                                             struct type *type, int rules)
1599         {
1600                 struct type *ret = __propagate_types(prog, c, ok, type, rules);
1601
1602                 if (c->parse_error)
1603                         *ok = 0;
1604                 return ret;
1605         }
1606
1607 #### Interpreting
1608
1609 Interpreting an `exec` doesn't require anything but the `exec`.  State
1610 is stored in variables and each variable will be directly linked from
1611 within the `exec` tree.  The exception to this is the `main` function
1612 which needs to look at command line arguments.  This function will be
1613 interpreted separately.
1614
1615 Each `exec` can return a value combined with a type in `struct lrval`.
1616 The type may be `Tnone` but must be non-NULL.  Some `exec`s will return
1617 the location of a value, which can be updated, in `lval`.  Others will
1618 set `lval` to NULL indicating that there is a value of appropriate type
1619 in `rval`.
1620
1621 ###### core functions
1622
1623         struct lrval {
1624                 struct type *type;
1625                 struct value rval, *lval;
1626         };
1627
1628         static struct lrval _interp_exec(struct parse_context *c, struct exec *e);
1629
1630         static struct value interp_exec(struct parse_context *c, struct exec *e,
1631                                         struct type **typeret)
1632         {
1633                 struct lrval ret = _interp_exec(c, e);
1634
1635                 if (!ret.type) abort();
1636                 if (typeret)
1637                         *typeret = ret.type;
1638                 if (ret.lval)
1639                         dup_value(ret.type, ret.lval, &ret.rval);
1640                 return ret.rval;
1641         }
1642
1643         static struct value *linterp_exec(struct parse_context *c, struct exec *e,
1644                                           struct type **typeret)
1645         {
1646                 struct lrval ret = _interp_exec(c, e);
1647
1648                 if (ret.lval)
1649                         *typeret = ret.type;
1650                 else
1651                         free_value(ret.type, &ret.rval);
1652                 return ret.lval;
1653         }
1654
1655         static struct lrval _interp_exec(struct parse_context *c, struct exec *e)
1656         {
1657                 struct lrval ret;
1658                 struct value rv = {}, *lrv = NULL;
1659                 struct type *rvtype;
1660
1661                 rvtype = ret.type = Tnone;
1662                 if (!e) {
1663                         ret.lval = lrv;
1664                         ret.rval = rv;
1665                         return ret;
1666                 }
1667
1668                 switch(e->type) {
1669                 case Xbinode:
1670                 {
1671                         struct binode *b = cast(binode, e);
1672                         struct value left, right, *lleft;
1673                         struct type *ltype, *rtype;
1674                         ltype = rtype = Tnone;
1675                         switch (b->op) {
1676                         ## interp binode cases
1677                         }
1678                         free_value(ltype, &left);
1679                         free_value(rtype, &right);
1680                         break;
1681                 }
1682                 ## interp exec cases
1683                 }
1684                 ret.lval = lrv;
1685                 ret.rval = rv;
1686                 ret.type = rvtype;
1687                 ## interp exec cleanup
1688                 return ret;
1689         }
1690
1691 ### Complex types
1692
1693 Now that we have the shape of the interpreter in place we can add some
1694 complex types and connected them in to the data structures and the
1695 different phases of parse, analyse, print, interpret.
1696
1697 Thus far we have arrays and structs.
1698
1699 #### Arrays
1700
1701 Arrays can be declared by giving a size and a type, as `[size]type' so
1702 `freq:[26]number` declares `freq` to be an array of 26 numbers.  The
1703 size can be either a literal number, or a named constant.  Some day an
1704 arbitrary expression will be supported.
1705
1706 As a formal parameter to a function, the array can be declared with a
1707 new variable as the size: `name:[size::number]string`.  The `size`
1708 variable is set to the size of the array and must be a constant.  As
1709 `number` is the only supported type, it can be left out:
1710 `name:[size::]string`.
1711
1712 Arrays cannot be assigned.  When pointers are introduced we will also
1713 introduce array slices which can refer to part or all of an array -
1714 the assignment syntax will create a slice.  For now, an array can only
1715 ever be referenced by the name it is declared with.  It is likely that
1716 a "`copy`" primitive will eventually be define which can be used to
1717 make a copy of an array with controllable recursive depth.
1718
1719 For now we have two sorts of array, those with fixed size either because
1720 it is given as a literal number or because it is a struct member (which
1721 cannot have a runtime-changing size), and those with a size that is
1722 determined at runtime - local variables with a const size.  The former
1723 have their size calculated at parse time, the latter at run time.
1724
1725 For the latter type, the `size` field of the type is the size of a
1726 pointer, and the array is reallocated every time it comes into scope.
1727
1728 We differentiate struct fields with a const size from local variables
1729 with a const size by whether they are prepared at parse time or not.
1730
1731 ###### type union fields
1732
1733         struct {
1734                 int unspec;     // size is unspecified - vsize must be set.
1735                 short size;
1736                 short static_size;
1737                 struct variable *vsize;
1738                 struct type *member;
1739         } array;
1740
1741 ###### value union fields
1742         void *array;  // used if not static_size
1743
1744 ###### value functions
1745
1746         static void array_prepare_type(struct parse_context *c, struct type *type,
1747                                        int parse_time)
1748         {
1749                 struct value *vsize;
1750                 mpz_t q;
1751                 if (!type->array.vsize || type->array.static_size)
1752                         return;
1753
1754                 vsize = var_value(c, type->array.vsize);
1755                 mpz_init(q);
1756                 mpz_tdiv_q(q, mpq_numref(vsize->num), mpq_denref(vsize->num));
1757                 type->array.size = mpz_get_si(q);
1758                 mpz_clear(q);
1759
1760                 if (parse_time) {
1761                         type->array.static_size = 1;
1762                         type->size = type->array.size * type->array.member->size;
1763                         type->align = type->array.member->align;
1764                 }
1765         }
1766
1767         static void array_init(struct type *type, struct value *val)
1768         {
1769                 int i;
1770                 void *ptr = val->ptr;
1771
1772                 if (!val)
1773                         return;                         // NOTEST
1774                 if (!type->array.static_size) {
1775                         val->array = calloc(type->array.size,
1776                                             type->array.member->size);
1777                         ptr = val->array;
1778                 }
1779                 for (i = 0; i < type->array.size; i++) {
1780                         struct value *v;
1781                         v = (void*)ptr + i * type->array.member->size;
1782                         val_init(type->array.member, v);
1783                 }
1784         }
1785
1786         static void array_free(struct type *type, struct value *val)
1787         {
1788                 int i;
1789                 void *ptr = val->ptr;
1790
1791                 if (!type->array.static_size)
1792                         ptr = val->array;
1793                 for (i = 0; i < type->array.size; i++) {
1794                         struct value *v;
1795                         v = (void*)ptr + i * type->array.member->size;
1796                         free_value(type->array.member, v);
1797                 }
1798                 if (!type->array.static_size)
1799                         free(ptr);
1800         }
1801
1802         static int array_compat(struct type *require, struct type *have)
1803         {
1804                 if (have->compat != require->compat)
1805                         return 0;       // UNTESTED
1806                 /* Both are arrays, so we can look at details */
1807                 if (!type_compat(require->array.member, have->array.member, 0))
1808                         return 0;
1809                 if (have->array.unspec && require->array.unspec) {
1810                         if (have->array.vsize && require->array.vsize &&
1811                             have->array.vsize != require->array.vsize)  // UNTESTED
1812                                 /* sizes might not be the same */
1813                                 return 0;       // UNTESTED
1814                         return 1;
1815                 }
1816                 if (have->array.unspec || require->array.unspec)
1817                         return 1;       // UNTESTED
1818                 if (require->array.vsize == NULL && have->array.vsize == NULL)
1819                         return require->array.size == have->array.size;
1820
1821                 return require->array.vsize == have->array.vsize;       // UNTESTED
1822         }
1823
1824         static void array_print_type(struct type *type, FILE *f)
1825         {
1826                 fputs("[", f);
1827                 if (type->array.vsize) {
1828                         struct binding *b = type->array.vsize->name;
1829                         fprintf(f, "%.*s%s]", b->name.len, b->name.txt,
1830                                 type->array.unspec ? "::" : "");
1831                 } else
1832                         fprintf(f, "%d]", type->array.size);
1833                 type_print(type->array.member, f);
1834         }
1835
1836         static struct type array_prototype = {
1837                 .init = array_init,
1838                 .prepare_type = array_prepare_type,
1839                 .print_type = array_print_type,
1840                 .compat = array_compat,
1841                 .free = array_free,
1842                 .size = sizeof(void*),
1843                 .align = sizeof(void*),
1844         };
1845
1846 ###### declare terminals
1847         $TERM [ ]
1848
1849 ###### type grammar
1850
1851         | [ NUMBER ] Type ${ {
1852                 char tail[3];
1853                 mpq_t num;
1854                 struct text noname = { "", 0 };
1855                 struct type *t;
1856
1857                 $0 = t = add_type(c, noname, &array_prototype);
1858                 t->array.member = $<4;
1859                 t->array.vsize = NULL;
1860                 if (number_parse(num, tail, $2.txt) == 0)
1861                         tok_err(c, "error: unrecognised number", &$2);
1862                 else if (tail[0])
1863                         tok_err(c, "error: unsupported number suffix", &$2);
1864                 else {
1865                         t->array.size = mpz_get_ui(mpq_numref(num));
1866                         if (mpz_cmp_ui(mpq_denref(num), 1) != 0) {
1867                                 tok_err(c, "error: array size must be an integer",
1868                                         &$2);
1869                         } else if (mpz_cmp_ui(mpq_numref(num), 1UL << 30) >= 0)
1870                                 tok_err(c, "error: array size is too large",
1871                                         &$2);
1872                         mpq_clear(num);
1873                 }
1874                 t->array.static_size = 1;
1875                 t->size = t->array.size * t->array.member->size;
1876                 t->align = t->array.member->align;
1877         } }$
1878
1879         | [ IDENTIFIER ] Type ${ {
1880                 struct variable *v = var_ref(c, $2.txt);
1881                 struct text noname = { "", 0 };
1882
1883                 if (!v)
1884                         tok_err(c, "error: name undeclared", &$2);
1885                 else if (!v->constant)
1886                         tok_err(c, "error: array size must be a constant", &$2);
1887
1888                 $0 = add_type(c, noname, &array_prototype);
1889                 $0->array.member = $<4;
1890                 $0->array.size = 0;
1891                 $0->array.vsize = v;
1892         } }$
1893
1894 ###### Grammar
1895         $*type
1896         OptType -> Type ${ $0 = $<1; }$
1897                 | ${ $0 = NULL; }$
1898
1899 ###### formal type grammar
1900
1901         | [ IDENTIFIER :: OptType ] Type ${ {
1902                 struct variable *v = var_decl(c, $ID.txt);
1903                 struct text noname = { "", 0 };
1904
1905                 v->type = $<OT;
1906                 v->constant = 1;
1907                 if (!v->type)
1908                         v->type = Tnum;
1909                 $0 = add_type(c, noname, &array_prototype);
1910                 $0->array.member = $<6;
1911                 $0->array.size = 0;
1912                 $0->array.unspec = 1;
1913                 $0->array.vsize = v;
1914         } }$
1915
1916 ###### Binode types
1917         Index,
1918
1919 ###### variable grammar
1920
1921         | Variable [ Expression ] ${ {
1922                 struct binode *b = new(binode);
1923                 b->op = Index;
1924                 b->left = $<1;
1925                 b->right = $<3;
1926                 $0 = b;
1927         } }$
1928
1929 ###### print binode cases
1930         case Index:
1931                 print_exec(b->left, -1, bracket);
1932                 printf("[");
1933                 print_exec(b->right, -1, bracket);
1934                 printf("]");
1935                 break;
1936
1937 ###### propagate binode cases
1938         case Index:
1939                 /* left must be an array, right must be a number,
1940                  * result is the member type of the array
1941                  */
1942                 propagate_types(b->right, c, ok, Tnum, 0);
1943                 t = propagate_types(b->left, c, ok, NULL, rules & Rnoconstant);
1944                 if (!t || t->compat != array_compat) {
1945                         type_err(c, "error: %1 cannot be indexed", prog, t, 0, NULL);
1946                         return NULL;
1947                 } else {
1948                         if (!type_compat(type, t->array.member, rules)) {
1949                                 type_err(c, "error: have %1 but need %2", prog,
1950                                          t->array.member, rules, type);
1951                         }
1952                         return t->array.member;
1953                 }
1954                 break;
1955
1956 ###### interp binode cases
1957         case Index: {
1958                 mpz_t q;
1959                 long i;
1960                 void *ptr;
1961
1962                 lleft = linterp_exec(c, b->left, &ltype);
1963                 right = interp_exec(c, b->right, &rtype);
1964                 mpz_init(q);
1965                 mpz_tdiv_q(q, mpq_numref(right.num), mpq_denref(right.num));
1966                 i = mpz_get_si(q);
1967                 mpz_clear(q);
1968
1969                 if (ltype->array.static_size)
1970                         ptr = lleft;
1971                 else
1972                         ptr = *(void**)lleft;
1973                 rvtype = ltype->array.member;
1974                 if (i >= 0 && i < ltype->array.size)
1975                         lrv = ptr + i * rvtype->size;
1976                 else
1977                         val_init(ltype->array.member, &rv);
1978                 ltype = NULL;
1979                 break;
1980         }
1981
1982 #### Structs
1983
1984 A `struct` is a data-type that contains one or more other data-types.
1985 It differs from an array in that each member can be of a different
1986 type, and they are accessed by name rather than by number.  Thus you
1987 cannot choose an element by calculation, you need to know what you
1988 want up-front.
1989
1990 The language makes no promises about how a given structure will be
1991 stored in memory - it is free to rearrange fields to suit whatever
1992 criteria seems important.
1993
1994 Structs are declared separately from program code - they cannot be
1995 declared in-line in a variable declaration like arrays can.  A struct
1996 is given a name and this name is used to identify the type - the name
1997 is not prefixed by the word `struct` as it would be in C.
1998
1999 Structs are only treated as the same if they have the same name.
2000 Simply having the same fields in the same order is not enough.  This
2001 might change once we can create structure initializers from a list of
2002 values.
2003
2004 Each component datum is identified much like a variable is declared,
2005 with a name, one or two colons, and a type.  The type cannot be omitted
2006 as there is no opportunity to deduce the type from usage.  An initial
2007 value can be given following an equals sign, so
2008
2009 ##### Example: a struct type
2010
2011         struct complex:
2012                 x:number = 0
2013                 y:number = 0
2014
2015 would declare a type called "complex" which has two number fields,
2016 each initialised to zero.
2017
2018 Struct will need to be declared separately from the code that uses
2019 them, so we will need to be able to print out the declaration of a
2020 struct when reprinting the whole program.  So a `print_type_decl` type
2021 function will be needed.
2022
2023 ###### type union fields
2024
2025         struct {
2026                 int nfields;
2027                 struct field {
2028                         struct text name;
2029                         struct type *type;
2030                         struct value *init;
2031                         int offset;
2032                 } *fields;
2033         } structure;
2034
2035 ###### type functions
2036         void (*print_type_decl)(struct type *type, FILE *f);
2037
2038 ###### value functions
2039
2040         static void structure_init(struct type *type, struct value *val)
2041         {
2042                 int i;
2043
2044                 for (i = 0; i < type->structure.nfields; i++) {
2045                         struct value *v;
2046                         v = (void*) val->ptr + type->structure.fields[i].offset;
2047                         if (type->structure.fields[i].init)
2048                                 dup_value(type->structure.fields[i].type,
2049                                           type->structure.fields[i].init,
2050                                           v);
2051                         else
2052                                 val_init(type->structure.fields[i].type, v);
2053                 }
2054         }
2055
2056         static void structure_free(struct type *type, struct value *val)
2057         {
2058                 int i;
2059
2060                 for (i = 0; i < type->structure.nfields; i++) {
2061                         struct value *v;
2062                         v = (void*)val->ptr + type->structure.fields[i].offset;
2063                         free_value(type->structure.fields[i].type, v);
2064                 }
2065         }
2066
2067         static void structure_free_type(struct type *t)
2068         {
2069                 int i;
2070                 for (i = 0; i < t->structure.nfields; i++)
2071                         if (t->structure.fields[i].init) {
2072                                 free_value(t->structure.fields[i].type,
2073                                            t->structure.fields[i].init);
2074                         }
2075                 free(t->structure.fields);
2076         }
2077
2078         static struct type structure_prototype = {
2079                 .init = structure_init,
2080                 .free = structure_free,
2081                 .free_type = structure_free_type,
2082                 .print_type_decl = structure_print_type,
2083         };
2084
2085 ###### exec type
2086         Xfieldref,
2087
2088 ###### ast
2089         struct fieldref {
2090                 struct exec;
2091                 struct exec *left;
2092                 int index;
2093                 struct text name;
2094         };
2095
2096 ###### free exec cases
2097         case Xfieldref:
2098                 free_exec(cast(fieldref, e)->left);
2099                 free(e);
2100                 break;
2101
2102 ###### declare terminals
2103         $TERM struct .
2104
2105 ###### variable grammar
2106
2107         | Variable . IDENTIFIER ${ {
2108                 struct fieldref *fr = new_pos(fieldref, $2);
2109                 fr->left = $<1;
2110                 fr->name = $3.txt;
2111                 fr->index = -2;
2112                 $0 = fr;
2113         } }$
2114
2115 ###### print exec cases
2116
2117         case Xfieldref:
2118         {
2119                 struct fieldref *f = cast(fieldref, e);
2120                 print_exec(f->left, -1, bracket);
2121                 printf(".%.*s", f->name.len, f->name.txt);
2122                 break;
2123         }
2124
2125 ###### ast functions
2126         static int find_struct_index(struct type *type, struct text field)
2127         {
2128                 int i;
2129                 for (i = 0; i < type->structure.nfields; i++)
2130                         if (text_cmp(type->structure.fields[i].name, field) == 0)
2131                                 return i;
2132                 return -1;
2133         }
2134
2135 ###### propagate exec cases
2136
2137         case Xfieldref:
2138         {
2139                 struct fieldref *f = cast(fieldref, prog);
2140                 struct type *st = propagate_types(f->left, c, ok, NULL, 0);
2141
2142                 if (!st)
2143                         type_err(c, "error: unknown type for field access", f->left,    // UNTESTED
2144                                  NULL, 0, NULL);
2145                 else if (st->init != structure_init)
2146                         type_err(c, "error: field reference attempted on %1, not a struct",
2147                                  f->left, st, 0, NULL);
2148                 else if (f->index == -2) {
2149                         f->index = find_struct_index(st, f->name);
2150                         if (f->index < 0)
2151                                 type_err(c, "error: cannot find requested field in %1",
2152                                          f->left, st, 0, NULL);
2153                 }
2154                 if (f->index >= 0) {
2155                         struct type *ft = st->structure.fields[f->index].type;
2156                         if (!type_compat(type, ft, rules))
2157                                 type_err(c, "error: have %1 but need %2", prog,
2158                                          ft, rules, type);
2159                         return ft;
2160                 }
2161                 break;
2162         }
2163
2164 ###### interp exec cases
2165         case Xfieldref:
2166         {
2167                 struct fieldref *f = cast(fieldref, e);
2168                 struct type *ltype;
2169                 struct value *lleft = linterp_exec(c, f->left, &ltype);
2170                 lrv = (void*)lleft->ptr + ltype->structure.fields[f->index].offset;
2171                 rvtype = ltype->structure.fields[f->index].type;
2172                 break;
2173         }
2174
2175 ###### ast
2176         struct fieldlist {
2177                 struct fieldlist *prev;
2178                 struct field f;
2179         };
2180
2181 ###### ast functions
2182         static void free_fieldlist(struct fieldlist *f)
2183         {
2184                 if (!f)
2185                         return;
2186                 free_fieldlist(f->prev);
2187                 if (f->f.init) {
2188                         free_value(f->f.type, f->f.init);       // UNTESTED
2189                         free(f->f.init);        // UNTESTED
2190                 }
2191                 free(f);
2192         }
2193
2194 ###### top level grammar
2195         DeclareStruct -> struct IDENTIFIER FieldBlock Newlines ${ {
2196                         struct type *t =
2197                                 add_type(c, $2.txt, &structure_prototype);
2198                         int cnt = 0;
2199                         struct fieldlist *f;
2200
2201                         for (f = $3; f; f=f->prev)
2202                                 cnt += 1;
2203
2204                         t->structure.nfields = cnt;
2205                         t->structure.fields = calloc(cnt, sizeof(struct field));
2206                         f = $3;
2207                         while (cnt > 0) {
2208                                 int a = f->f.type->align;
2209                                 cnt -= 1;
2210                                 t->structure.fields[cnt] = f->f;
2211                                 if (t->size & (a-1))
2212                                         t->size = (t->size | (a-1)) + 1;
2213                                 t->structure.fields[cnt].offset = t->size;
2214                                 t->size += ((f->f.type->size - 1) | (a-1)) + 1;
2215                                 if (a > t->align)
2216                                         t->align = a;
2217                                 f->f.init = NULL;
2218                                 f = f->prev;
2219                         }
2220                 } }$
2221
2222         $*fieldlist
2223         FieldBlock -> { IN OptNL FieldLines OUT OptNL } ${ $0 = $<FL; }$
2224                 | { SimpleFieldList } ${ $0 = $<SFL; }$
2225                 | IN OptNL FieldLines OUT ${ $0 = $<FL; }$
2226                 | SimpleFieldList EOL ${ $0 = $<SFL; }$
2227
2228         FieldLines -> SimpleFieldList Newlines ${ $0 = $<SFL; }$
2229                 | FieldLines SimpleFieldList Newlines ${
2230                         $SFL->prev = $<FL;
2231                         $0 = $<SFL;
2232                 }$
2233
2234         SimpleFieldList -> Field ${ $0 = $<F; }$
2235                 | SimpleFieldList ; Field ${
2236                         $F->prev = $<SFL;
2237                         $0 = $<F;
2238                 }$
2239                 | SimpleFieldList ; ${
2240                         $0 = $<SFL;
2241                 }$
2242                 | ERROR ${ tok_err(c, "Syntax error in struct field", &$1); }$
2243
2244         Field -> IDENTIFIER : Type = Expression ${ {
2245                         int ok; // UNTESTED
2246
2247                         $0 = calloc(1, sizeof(struct fieldlist));
2248                         $0->f.name = $1.txt;
2249                         $0->f.type = $<3;
2250                         $0->f.init = NULL;
2251                         do {
2252                                 ok = 1;
2253                                 propagate_types($<5, c, &ok, $3, 0);
2254                         } while (ok == 2);
2255                         if (!ok)
2256                                 c->parse_error = 1;     // UNTESTED
2257                         else {
2258                                 struct value vl = interp_exec(c, $5, NULL);
2259                                 $0->f.init = global_alloc(c, $0->f.type, NULL, &vl);
2260                         }
2261                 } }$
2262                 | IDENTIFIER : Type ${
2263                         $0 = calloc(1, sizeof(struct fieldlist));
2264                         $0->f.name = $1.txt;
2265                         $0->f.type = $<3;
2266                         if ($0->f.type->prepare_type)
2267                                 $0->f.type->prepare_type(c, $0->f.type, 1);
2268                 }$
2269
2270 ###### forward decls
2271         static void structure_print_type(struct type *t, FILE *f);
2272
2273 ###### value functions
2274         static void structure_print_type(struct type *t, FILE *f)       // UNTESTED
2275         {       // UNTESTED
2276                 int i;  // UNTESTED
2277
2278                 fprintf(f, "struct %.*s\n", t->name.len, t->name.txt);
2279
2280                 for (i = 0; i < t->structure.nfields; i++) {
2281                         struct field *fl = t->structure.fields + i;
2282                         fprintf(f, "    %.*s : ", fl->name.len, fl->name.txt);
2283                         type_print(fl->type, f);
2284                         if (fl->type->print && fl->init) {
2285                                 fprintf(f, " = ");
2286                                 if (fl->type == Tstr)
2287                                         fprintf(f, "\"");       // UNTESTED
2288                                 print_value(fl->type, fl->init);
2289                                 if (fl->type == Tstr)
2290                                         fprintf(f, "\"");       // UNTESTED
2291                         }
2292                         printf("\n");
2293                 }
2294         }
2295
2296 ###### print type decls
2297         {       // UNTESTED
2298                 struct type *t; // UNTESTED
2299                 int target = -1;
2300
2301                 while (target != 0) {
2302                         int i = 0;
2303                         for (t = context.typelist; t ; t=t->next)
2304                                 if (t->print_type_decl) {
2305                                         i += 1;
2306                                         if (i == target)
2307                                                 break;
2308                                 }
2309
2310                         if (target == -1) {
2311                                 target = i;
2312                         } else {
2313                                 t->print_type_decl(t, stdout);
2314                                 target -= 1;
2315                         }
2316                 }
2317         }
2318
2319 ### Functions
2320
2321 A function is a named chunk of code which can be passed parameters and
2322 can return results.  Each function has an implicit type which includes
2323 the set of parameters and the return value.  As yet these types cannot
2324 be declared separate from the function itself.
2325
2326 In fact, only one function is currently possible - `main`.  `main` is
2327 passed an array of strings together with the size of the array, and
2328 doesn't return anything.  The strings are command line arguments.
2329
2330 The parameters can be specified either in parentheses as a list, such as
2331
2332 ##### Example: function 1
2333
2334         func main(av:[ac::number]string)
2335                 code block
2336
2337 or as an indented list of one parameter per line
2338
2339 ##### Example: function 2
2340
2341         func main
2342                 argv:[argc::number]string
2343         do
2344                 code block
2345
2346 For constructing these lists we use a `List` binode, which will be
2347 further detailed when Expression Lists are introduced.
2348
2349 ###### Binode types
2350         Func, List,
2351
2352 ###### Grammar
2353
2354         $TERM func main
2355
2356         $*binode
2357         MainFunction -> func main ( OpenScope Args ) Block Newlines ${
2358                         $0 = new(binode);
2359                         $0->op = Func;
2360                         $0->left = reorder_bilist($<Ar);
2361                         $0->right = $<Bl;
2362                         var_block_close(c, CloseSequential, $0);
2363                         if (c->scope_stack && !c->parse_error) abort();
2364                 }$
2365                 | func main IN OpenScope OptNL Args OUT OptNL do Block Newlines ${
2366                         $0 = new(binode);
2367                         $0->op = Func;
2368                         $0->left = reorder_bilist($<Ar);
2369                         $0->right = $<Bl;
2370                         var_block_close(c, CloseSequential, $0);
2371                         if (c->scope_stack && !c->parse_error) abort();
2372                 }$
2373                 | func main NEWLINE OpenScope OptNL do Block Newlines ${
2374                         $0 = new(binode);
2375                         $0->op = Func;
2376                         $0->left = NULL;
2377                         $0->right = $<Bl;
2378                         var_block_close(c, CloseSequential, $0);
2379                         if (c->scope_stack && !c->parse_error) abort();
2380                 }$
2381
2382         Args -> ${ $0 = NULL; }$
2383                 | Varlist ${ $0 = $<1; }$
2384                 | Varlist ; ${ $0 = $<1; }$
2385                 | Varlist NEWLINE ${ $0 = $<1; }$
2386
2387         Varlist -> Varlist ; ArgDecl ${ // UNTESTED
2388                         $0 = new(binode);
2389                         $0->op = List;
2390                         $0->left = $<Vl;
2391                         $0->right = $<AD;
2392                 }$
2393                 | ArgDecl ${
2394                         $0 = new(binode);
2395                         $0->op = List;
2396                         $0->left = NULL;
2397                         $0->right = $<AD;
2398                 }$
2399
2400         $*var
2401         ArgDecl -> IDENTIFIER : FormalType ${ {
2402                 struct variable *v = var_decl(c, $1.txt);
2403                 $0 = new(var);
2404                 $0->var = v;
2405                 v->type = $<FT;
2406         } }$
2407
2408 ## Executables: the elements of code
2409
2410 Each code element needs to be parsed, printed, analysed,
2411 interpreted, and freed.  There are several, so let's just start with
2412 the easy ones and work our way up.
2413
2414 ### Values
2415
2416 We have already met values as separate objects.  When manifest
2417 constants appear in the program text, that must result in an executable
2418 which has a constant value.  So the `val` structure embeds a value in
2419 an executable.
2420
2421 ###### exec type
2422         Xval,
2423
2424 ###### ast
2425         struct val {
2426                 struct exec;
2427                 struct type *vtype;
2428                 struct value val;
2429         };
2430
2431 ###### ast functions
2432         struct val *new_val(struct type *T, struct token tk)
2433         {
2434                 struct val *v = new_pos(val, tk);
2435                 v->vtype = T;
2436                 return v;
2437         }
2438
2439 ###### Grammar
2440
2441         $TERM True False
2442
2443         $*val
2444         Value ->  True ${
2445                         $0 = new_val(Tbool, $1);
2446                         $0->val.bool = 1;
2447                         }$
2448                 | False ${
2449                         $0 = new_val(Tbool, $1);
2450                         $0->val.bool = 0;
2451                         }$
2452                 | NUMBER ${
2453                         $0 = new_val(Tnum, $1);
2454                         {
2455                         char tail[3];
2456                         if (number_parse($0->val.num, tail, $1.txt) == 0)
2457                                 mpq_init($0->val.num);  // UNTESTED
2458                                 if (tail[0])
2459                                         tok_err(c, "error: unsupported number suffix",
2460                                                 &$1);
2461                         }
2462                         }$
2463                 | STRING ${
2464                         $0 = new_val(Tstr, $1);
2465                         {
2466                         char tail[3];
2467                         string_parse(&$1, '\\', &$0->val.str, tail);
2468                         if (tail[0])
2469                                 tok_err(c, "error: unsupported string suffix",
2470                                         &$1);
2471                         }
2472                         }$
2473                 | MULTI_STRING ${
2474                         $0 = new_val(Tstr, $1);
2475                         {
2476                         char tail[3];
2477                         string_parse(&$1, '\\', &$0->val.str, tail);
2478                         if (tail[0])
2479                                 tok_err(c, "error: unsupported string suffix",
2480                                         &$1);
2481                         }
2482                         }$
2483
2484 ###### print exec cases
2485         case Xval:
2486         {
2487                 struct val *v = cast(val, e);
2488                 if (v->vtype == Tstr)
2489                         printf("\"");
2490                 print_value(v->vtype, &v->val);
2491                 if (v->vtype == Tstr)
2492                         printf("\"");
2493                 break;
2494         }
2495
2496 ###### propagate exec cases
2497         case Xval:
2498         {
2499                 struct val *val = cast(val, prog);
2500                 if (!type_compat(type, val->vtype, rules))
2501                         type_err(c, "error: expected %1%r found %2",
2502                                    prog, type, rules, val->vtype);
2503                 return val->vtype;
2504         }
2505
2506 ###### interp exec cases
2507         case Xval:
2508                 rvtype = cast(val, e)->vtype;
2509                 dup_value(rvtype, &cast(val, e)->val, &rv);
2510                 break;
2511
2512 ###### ast functions
2513         static void free_val(struct val *v)
2514         {
2515                 if (v)
2516                         free_value(v->vtype, &v->val);
2517                 free(v);
2518         }
2519
2520 ###### free exec cases
2521         case Xval: free_val(cast(val, e)); break;
2522
2523 ###### ast functions
2524         // Move all nodes from 'b' to 'rv', reversing their order.
2525         // In 'b' 'left' is a list, and 'right' is the last node.
2526         // In 'rv', left' is the first node and 'right' is a list.
2527         static struct binode *reorder_bilist(struct binode *b)
2528         {
2529                 struct binode *rv = NULL;
2530
2531                 while (b) {
2532                         struct exec *t = b->right;
2533                         b->right = rv;
2534                         rv = b;
2535                         if (b->left)
2536                                 b = cast(binode, b->left);
2537                         else
2538                                 b = NULL;
2539                         rv->left = t;
2540                 }
2541                 return rv;
2542         }
2543
2544 ### Variables
2545
2546 Just as we used a `val` to wrap a value into an `exec`, we similarly
2547 need a `var` to wrap a `variable` into an exec.  While each `val`
2548 contained a copy of the value, each `var` holds a link to the variable
2549 because it really is the same variable no matter where it appears.
2550 When a variable is used, we need to remember to follow the `->merged`
2551 link to find the primary instance.
2552
2553 ###### exec type
2554         Xvar,
2555
2556 ###### ast
2557         struct var {
2558                 struct exec;
2559                 struct variable *var;
2560         };
2561
2562 ###### Grammar
2563
2564         $TERM : ::
2565
2566         $*var
2567         VariableDecl -> IDENTIFIER : ${ {
2568                 struct variable *v = var_decl(c, $1.txt);
2569                 $0 = new_pos(var, $1);
2570                 $0->var = v;
2571                 if (v)
2572                         v->where_decl = $0;
2573                 else {
2574                         v = var_ref(c, $1.txt);
2575                         $0->var = v;
2576                         type_err(c, "error: variable '%v' redeclared",
2577                                  $0, NULL, 0, NULL);
2578                         type_err(c, "info: this is where '%v' was first declared",
2579                                  v->where_decl, NULL, 0, NULL);
2580                 }
2581         } }$
2582             | IDENTIFIER :: ${ {
2583                 struct variable *v = var_decl(c, $1.txt);
2584                 $0 = new_pos(var, $1);
2585                 $0->var = v;
2586                 if (v) {
2587                         v->where_decl = $0;
2588                         v->constant = 1;
2589                 } else {
2590                         v = var_ref(c, $1.txt);
2591                         $0->var = v;
2592                         type_err(c, "error: variable '%v' redeclared",
2593                                  $0, NULL, 0, NULL);
2594                         type_err(c, "info: this is where '%v' was first declared",
2595                                  v->where_decl, NULL, 0, NULL);
2596                 }
2597         } }$
2598             | IDENTIFIER : Type ${ {
2599                 struct variable *v = var_decl(c, $1.txt);
2600                 $0 = new_pos(var, $1);
2601                 $0->var = v;
2602                 if (v) {
2603                         v->where_decl = $0;
2604                         v->where_set = $0;
2605                         v->type = $<Type;
2606                 } else {
2607                         v = var_ref(c, $1.txt);
2608                         $0->var = v;
2609                         type_err(c, "error: variable '%v' redeclared",
2610                                  $0, NULL, 0, NULL);
2611                         type_err(c, "info: this is where '%v' was first declared",
2612                                  v->where_decl, NULL, 0, NULL);
2613                 }
2614         } }$
2615             | IDENTIFIER :: Type ${ {
2616                 struct variable *v = var_decl(c, $1.txt);
2617                 $0 = new_pos(var, $1);
2618                 $0->var = v;
2619                 if (v) {
2620                         v->where_decl = $0;
2621                         v->where_set = $0;
2622                         v->type = $<Type;
2623                         v->constant = 1;
2624                 } else {
2625                         v = var_ref(c, $1.txt);
2626                         $0->var = v;
2627                         type_err(c, "error: variable '%v' redeclared",
2628                                  $0, NULL, 0, NULL);
2629                         type_err(c, "info: this is where '%v' was first declared",
2630                                  v->where_decl, NULL, 0, NULL);
2631                 }
2632         } }$
2633
2634         $*exec
2635         Variable -> IDENTIFIER ${ {
2636                 struct variable *v = var_ref(c, $1.txt);
2637                 $0 = new_pos(var, $1);
2638                 if (v == NULL) {
2639                         /* This might be a label - allocate a var just in case */
2640                         v = var_decl(c, $1.txt);
2641                         if (v) {
2642                                 v->type = Tnone;
2643                                 v->where_decl = $0;
2644                                 v->where_set = $0;
2645                         }
2646                 }
2647                 cast(var, $0)->var = v;
2648         } }$
2649         ## variable grammar
2650
2651 ###### print exec cases
2652         case Xvar:
2653         {
2654                 struct var *v = cast(var, e);
2655                 if (v->var) {
2656                         struct binding *b = v->var->name;
2657                         printf("%.*s", b->name.len, b->name.txt);
2658                 }
2659                 break;
2660         }
2661
2662 ###### format cases
2663         case 'v':
2664                 if (loc && loc->type == Xvar) {
2665                         struct var *v = cast(var, loc);
2666                         if (v->var) {
2667                                 struct binding *b = v->var->name;
2668                                 fprintf(stderr, "%.*s", b->name.len, b->name.txt);
2669                         } else
2670                                 fputs("???", stderr);   // NOTEST
2671                 } else
2672                         fputs("NOTVAR", stderr);        // NOTEST
2673                 break;
2674
2675 ###### propagate exec cases
2676
2677         case Xvar:
2678         {
2679                 struct var *var = cast(var, prog);
2680                 struct variable *v = var->var;
2681                 if (!v) {
2682                         type_err(c, "%d:BUG: no variable!!", prog, NULL, 0, NULL); // NOTEST
2683                         return Tnone;                                   // NOTEST
2684                 }
2685                 v = v->merged;
2686                 if (v->constant && (rules & Rnoconstant)) {
2687                         type_err(c, "error: Cannot assign to a constant: %v",
2688                                  prog, NULL, 0, NULL);
2689                         type_err(c, "info: name was defined as a constant here",
2690                                  v->where_decl, NULL, 0, NULL);
2691                         return v->type;
2692                 }
2693                 if (v->type == Tnone && v->where_decl == prog)
2694                         type_err(c, "error: variable used but not declared: %v",
2695                                  prog, NULL, 0, NULL);
2696                 if (v->type == NULL) {
2697                         if (type && *ok != 0) {
2698                                 v->type = type;
2699                                 v->where_set = prog;
2700                                 *ok = 2;
2701                         }
2702                         return type;
2703                 }
2704                 if (!type_compat(type, v->type, rules)) {
2705                         type_err(c, "error: expected %1%r but variable '%v' is %2", prog,
2706                                  type, rules, v->type);
2707                         type_err(c, "info: this is where '%v' was set to %1", v->where_set,
2708                                  v->type, rules, NULL);
2709                 }
2710                 if (!type)
2711                         return v->type;
2712                 return type;
2713         }
2714
2715 ###### interp exec cases
2716         case Xvar:
2717         {
2718                 struct var *var = cast(var, e);
2719                 struct variable *v = var->var;
2720
2721                 v = v->merged;
2722                 lrv = var_value(c, v);
2723                 rvtype = v->type;
2724                 break;
2725         }
2726
2727 ###### ast functions
2728
2729         static void free_var(struct var *v)
2730         {
2731                 free(v);
2732         }
2733
2734 ###### free exec cases
2735         case Xvar: free_var(cast(var, e)); break;
2736
2737 ### Expressions: Conditional
2738
2739 Our first user of the `binode` will be conditional expressions, which
2740 is a bit odd as they actually have three components.  That will be
2741 handled by having 2 binodes for each expression.  The conditional
2742 expression is the lowest precedence operator which is why we define it
2743 first - to start the precedence list.
2744
2745 Conditional expressions are of the form "value `if` condition `else`
2746 other_value".  They associate to the right, so everything to the right
2747 of `else` is part of an else value, while only a higher-precedence to
2748 the left of `if` is the if values.  Between `if` and `else` there is no
2749 room for ambiguity, so a full conditional expression is allowed in
2750 there.
2751
2752 ###### Binode types
2753         CondExpr,
2754
2755 ###### Grammar
2756
2757         $LEFT if $$ifelse
2758         ## expr precedence
2759
2760         $*exec
2761         Expression -> Expression if Expression else Expression $$ifelse ${ {
2762                         struct binode *b1 = new(binode);
2763                         struct binode *b2 = new(binode);
2764                         b1->op = CondExpr;
2765                         b1->left = $<3;
2766                         b1->right = b2;
2767                         b2->op = CondExpr;
2768                         b2->left = $<1;
2769                         b2->right = $<5;
2770                         $0 = b1;
2771                 } }$
2772                 ## expression grammar
2773
2774 ###### print binode cases
2775
2776         case CondExpr:
2777                 b2 = cast(binode, b->right);
2778                 if (bracket) printf("(");
2779                 print_exec(b2->left, -1, bracket);
2780                 printf(" if ");
2781                 print_exec(b->left, -1, bracket);
2782                 printf(" else ");
2783                 print_exec(b2->right, -1, bracket);
2784                 if (bracket) printf(")");
2785                 break;
2786
2787 ###### propagate binode cases
2788
2789         case CondExpr: {
2790                 /* cond must be Tbool, others must match */
2791                 struct binode *b2 = cast(binode, b->right);
2792                 struct type *t2;
2793
2794                 propagate_types(b->left, c, ok, Tbool, 0);
2795                 t = propagate_types(b2->left, c, ok, type, Rnolabel);
2796                 t2 = propagate_types(b2->right, c, ok, type ?: t, Rnolabel);
2797                 return t ?: t2;
2798         }
2799
2800 ###### interp binode cases
2801
2802         case CondExpr: {
2803                 struct binode *b2 = cast(binode, b->right);
2804                 left = interp_exec(c, b->left, &ltype);
2805                 if (left.bool)
2806                         rv = interp_exec(c, b2->left, &rvtype); // UNTESTED
2807                 else
2808                         rv = interp_exec(c, b2->right, &rvtype);
2809                 }
2810                 break;
2811
2812 ### Expression list
2813
2814 We take a brief detour, now that we have expressions, to describe lists
2815 of expressions.  These will be needed for function parameters and
2816 possibly other situations.  They seem generic enough to introduce here
2817 to be used elsewhere.
2818
2819 And ExpressionList will use the `List` type of `binode`, building up at
2820 the end.  And place where they are used will probably call
2821 `reorder_bilist()` to get a more normal first/next arrangement.
2822
2823 ###### declare terminals
2824         $TERM ,
2825
2826 `List` execs have no implicit semantics, so they are never propagated or
2827 interpreted.  The can be printed as a comma separate list, which is how
2828 they are parsed.  Note they are also used for function formal parameter
2829 lists.  In that case a separate function is used to print them.
2830
2831 ###### print binode cases
2832         case List:
2833                 while (b) {
2834                         printf(" ");
2835                         print_exec(b->left, -1, bracket);
2836                         if (b->right)
2837                                 printf(",");
2838                         b = cast(binode, b->right);
2839                 }
2840                 break;
2841
2842 ###### propagate binode cases
2843         case List: abort(); // NOTEST
2844 ###### interp binode cases
2845         case List: abort(); // NOTEST
2846
2847 ###### Grammar
2848
2849         $*binode
2850         ExpressionList -> ExpressionList , Expression ${
2851                         $0 = new(binode);
2852                         $0->op = List;
2853                         $0->left = $<1;
2854                         $0->right = $<3;
2855                 }$
2856                 | Expression ${
2857                         $0 = new(binode);
2858                         $0->op = List;
2859                         $0->left = NULL;
2860                         $0->right = $<1;
2861                 }$
2862
2863 ### Expressions: Boolean
2864
2865 The next class of expressions to use the `binode` will be Boolean
2866 expressions.  "`and then`" and "`or else`" are similar to `and` and `or`
2867 have same corresponding precendence.  The difference is that they don't
2868 evaluate the second expression if not necessary.
2869
2870 ###### Binode types
2871         And,
2872         AndThen,
2873         Or,
2874         OrElse,
2875         Not,
2876
2877 ###### expr precedence
2878         $LEFT or
2879         $LEFT and
2880         $LEFT not
2881
2882 ###### expression grammar
2883                 | Expression or Expression ${ {
2884                         struct binode *b = new(binode);
2885                         b->op = Or;
2886                         b->left = $<1;
2887                         b->right = $<3;
2888                         $0 = b;
2889                 } }$
2890                 | Expression or else Expression ${ {
2891                         struct binode *b = new(binode);
2892                         b->op = OrElse;
2893                         b->left = $<1;
2894                         b->right = $<4;
2895                         $0 = b;
2896                 } }$
2897
2898                 | Expression and Expression ${ {
2899                         struct binode *b = new(binode);
2900                         b->op = And;
2901                         b->left = $<1;
2902                         b->right = $<3;
2903                         $0 = b;
2904                 } }$
2905                 | Expression and then Expression ${ {
2906                         struct binode *b = new(binode);
2907                         b->op = AndThen;
2908                         b->left = $<1;
2909                         b->right = $<4;
2910                         $0 = b;
2911                 } }$
2912
2913                 | not Expression ${ {
2914                         struct binode *b = new(binode);
2915                         b->op = Not;
2916                         b->right = $<2;
2917                         $0 = b;
2918                 } }$
2919
2920 ###### print binode cases
2921         case And:
2922                 if (bracket) printf("(");
2923                 print_exec(b->left, -1, bracket);
2924                 printf(" and ");
2925                 print_exec(b->right, -1, bracket);
2926                 if (bracket) printf(")");
2927                 break;
2928         case AndThen:
2929                 if (bracket) printf("(");
2930                 print_exec(b->left, -1, bracket);
2931                 printf(" and then ");
2932                 print_exec(b->right, -1, bracket);
2933                 if (bracket) printf(")");
2934                 break;
2935         case Or:
2936                 if (bracket) printf("(");
2937                 print_exec(b->left, -1, bracket);
2938                 printf(" or ");
2939                 print_exec(b->right, -1, bracket);
2940                 if (bracket) printf(")");
2941                 break;
2942         case OrElse:
2943                 if (bracket) printf("(");
2944                 print_exec(b->left, -1, bracket);
2945                 printf(" or else ");
2946                 print_exec(b->right, -1, bracket);
2947                 if (bracket) printf(")");
2948                 break;
2949         case Not:
2950                 if (bracket) printf("(");
2951                 printf("not ");
2952                 print_exec(b->right, -1, bracket);
2953                 if (bracket) printf(")");
2954                 break;
2955
2956 ###### propagate binode cases
2957         case And:
2958         case AndThen:
2959         case Or:
2960         case OrElse:
2961         case Not:
2962                 /* both must be Tbool, result is Tbool */
2963                 propagate_types(b->left, c, ok, Tbool, 0);
2964                 propagate_types(b->right, c, ok, Tbool, 0);
2965                 if (type && type != Tbool)
2966                         type_err(c, "error: %1 operation found where %2 expected", prog,
2967                                    Tbool, 0, type);
2968                 return Tbool;
2969
2970 ###### interp binode cases
2971         case And:
2972                 rv = interp_exec(c, b->left, &rvtype);
2973                 right = interp_exec(c, b->right, &rtype);
2974                 rv.bool = rv.bool && right.bool;
2975                 break;
2976         case AndThen:
2977                 rv = interp_exec(c, b->left, &rvtype);
2978                 if (rv.bool)
2979                         rv = interp_exec(c, b->right, NULL);
2980                 break;
2981         case Or:
2982                 rv = interp_exec(c, b->left, &rvtype);
2983                 right = interp_exec(c, b->right, &rtype);
2984                 rv.bool = rv.bool || right.bool;
2985                 break;
2986         case OrElse:
2987                 rv = interp_exec(c, b->left, &rvtype);
2988                 if (!rv.bool)
2989                         rv = interp_exec(c, b->right, NULL);
2990                 break;
2991         case Not:
2992                 rv = interp_exec(c, b->right, &rvtype);
2993                 rv.bool = !rv.bool;
2994                 break;
2995
2996 ### Expressions: Comparison
2997
2998 Of slightly higher precedence that Boolean expressions are Comparisons.
2999 A comparison takes arguments of any comparable type, but the two types
3000 must be the same.
3001
3002 To simplify the parsing we introduce an `eop` which can record an
3003 expression operator, and the `CMPop` non-terminal will match one of them.
3004
3005 ###### ast
3006         struct eop {
3007                 enum Btype op;
3008         };
3009
3010 ###### ast functions
3011         static void free_eop(struct eop *e)
3012         {
3013                 if (e)
3014                         free(e);
3015         }
3016
3017 ###### Binode types
3018         Less,
3019         Gtr,
3020         LessEq,
3021         GtrEq,
3022         Eql,
3023         NEql,
3024
3025 ###### expr precedence
3026         $LEFT < > <= >= == != CMPop
3027
3028 ###### expression grammar
3029         | Expression CMPop Expression ${ {
3030                 struct binode *b = new(binode);
3031                 b->op = $2.op;
3032                 b->left = $<1;
3033                 b->right = $<3;
3034                 $0 = b;
3035         } }$
3036
3037 ###### Grammar
3038
3039         $eop
3040         CMPop ->   < ${ $0.op = Less; }$
3041                 |  > ${ $0.op = Gtr; }$
3042                 |  <= ${ $0.op = LessEq; }$
3043                 |  >= ${ $0.op = GtrEq; }$
3044                 |  == ${ $0.op = Eql; }$
3045                 |  != ${ $0.op = NEql; }$
3046
3047 ###### print binode cases
3048
3049         case Less:
3050         case LessEq:
3051         case Gtr:
3052         case GtrEq:
3053         case Eql:
3054         case NEql:
3055                 if (bracket) printf("(");
3056                 print_exec(b->left, -1, bracket);
3057                 switch(b->op) {
3058                 case Less:   printf(" < "); break;
3059                 case LessEq: printf(" <= "); break;
3060                 case Gtr:    printf(" > "); break;
3061                 case GtrEq:  printf(" >= "); break;
3062                 case Eql:    printf(" == "); break;
3063                 case NEql:   printf(" != "); break;
3064                 default: abort();               // NOTEST
3065                 }
3066                 print_exec(b->right, -1, bracket);
3067                 if (bracket) printf(")");
3068                 break;
3069
3070 ###### propagate binode cases
3071         case Less:
3072         case LessEq:
3073         case Gtr:
3074         case GtrEq:
3075         case Eql:
3076         case NEql:
3077                 /* Both must match but not be labels, result is Tbool */
3078                 t = propagate_types(b->left, c, ok, NULL, Rnolabel);
3079                 if (t)
3080                         propagate_types(b->right, c, ok, t, 0);
3081                 else {
3082                         t = propagate_types(b->right, c, ok, NULL, Rnolabel);   // UNTESTED
3083                         if (t)  // UNTESTED
3084                                 t = propagate_types(b->left, c, ok, t, 0);      // UNTESTED
3085                 }
3086                 if (!type_compat(type, Tbool, 0))
3087                         type_err(c, "error: Comparison returns %1 but %2 expected", prog,
3088                                     Tbool, rules, type);
3089                 return Tbool;
3090
3091 ###### interp binode cases
3092         case Less:
3093         case LessEq:
3094         case Gtr:
3095         case GtrEq:
3096         case Eql:
3097         case NEql:
3098         {
3099                 int cmp;
3100                 left = interp_exec(c, b->left, &ltype);
3101                 right = interp_exec(c, b->right, &rtype);
3102                 cmp = value_cmp(ltype, rtype, &left, &right);
3103                 rvtype = Tbool;
3104                 switch (b->op) {
3105                 case Less:      rv.bool = cmp <  0; break;
3106                 case LessEq:    rv.bool = cmp <= 0; break;
3107                 case Gtr:       rv.bool = cmp >  0; break;
3108                 case GtrEq:     rv.bool = cmp >= 0; break;
3109                 case Eql:       rv.bool = cmp == 0; break;
3110                 case NEql:      rv.bool = cmp != 0; break;
3111                 default:        rv.bool = 0; break;     // NOTEST
3112                 }
3113                 break;
3114         }
3115
3116 ### Expressions: The rest
3117
3118 The remaining expressions with the highest precedence are arithmetic,
3119 string concatenation, and string conversion.  String concatenation
3120 (`++`) has the same precedence as multiplication and division, but lower
3121 than the uniary.
3122
3123 String conversion is a temporary feature until I get a better type
3124 system.  `$` is a prefix operator which expects a string and returns
3125 a number.
3126
3127 `+` and `-` are both infix and prefix operations (where they are
3128 absolute value and negation).  These have different operator names.
3129
3130 We also have a 'Bracket' operator which records where parentheses were
3131 found.  This makes it easy to reproduce these when printing.  Possibly I
3132 should only insert brackets were needed for precedence.
3133
3134 ###### Binode types
3135         Plus, Minus,
3136         Times, Divide, Rem,
3137         Concat,
3138         Absolute, Negate,
3139         StringConv,
3140         Bracket,
3141
3142 ###### expr precedence
3143         $LEFT + - Eop
3144         $LEFT * / % ++ Top
3145         $LEFT Uop $
3146         $TERM ( )
3147
3148 ###### expression grammar
3149                 | Expression Eop Expression ${ {
3150                         struct binode *b = new(binode);
3151                         b->op = $2.op;
3152                         b->left = $<1;
3153                         b->right = $<3;
3154                         $0 = b;
3155                 } }$
3156
3157                 | Expression Top Expression ${ {
3158                         struct binode *b = new(binode);
3159                         b->op = $2.op;
3160                         b->left = $<1;
3161                         b->right = $<3;
3162                         $0 = b;
3163                 } }$
3164
3165                 | ( Expression ) ${ {
3166                         struct binode *b = new_pos(binode, $1);
3167                         b->op = Bracket;
3168                         b->right = $<2;
3169                         $0 = b;
3170                 } }$
3171                 | Uop Expression ${ {
3172                         struct binode *b = new(binode);
3173                         b->op = $1.op;
3174                         b->right = $<2;
3175                         $0 = b;
3176                 } }$
3177                 | Value ${ $0 = $<1; }$
3178                 | Variable ${ $0 = $<1; }$
3179
3180         $eop
3181         Eop ->    + ${ $0.op = Plus; }$
3182                 | - ${ $0.op = Minus; }$
3183
3184         Uop ->    + ${ $0.op = Absolute; }$
3185                 | - ${ $0.op = Negate; }$
3186                 | $ ${ $0.op = StringConv; }$
3187
3188         Top ->    * ${ $0.op = Times; }$
3189                 | / ${ $0.op = Divide; }$
3190                 | % ${ $0.op = Rem; }$
3191                 | ++ ${ $0.op = Concat; }$
3192
3193 ###### print binode cases
3194         case Plus:
3195         case Minus:
3196         case Times:
3197         case Divide:
3198         case Concat:
3199         case Rem:
3200                 if (bracket) printf("(");
3201                 print_exec(b->left, indent, bracket);
3202                 switch(b->op) {
3203                 case Plus:   fputs(" + ", stdout); break;
3204                 case Minus:  fputs(" - ", stdout); break;
3205                 case Times:  fputs(" * ", stdout); break;
3206                 case Divide: fputs(" / ", stdout); break;
3207                 case Rem:    fputs(" % ", stdout); break;
3208                 case Concat: fputs(" ++ ", stdout); break;
3209                 default: abort();       // NOTEST
3210                 }                       // NOTEST
3211                 print_exec(b->right, indent, bracket);
3212                 if (bracket) printf(")");
3213                 break;
3214         case Absolute:
3215         case Negate:
3216         case StringConv:
3217                 if (bracket) printf("(");
3218                 switch (b->op) {
3219                 case Absolute:   fputs("+", stdout); break;
3220                 case Negate:     fputs("-", stdout); break;
3221                 case StringConv: fputs("$", stdout); break;
3222                 default: abort();       // NOTEST
3223                 }                       // NOTEST
3224                 print_exec(b->right, indent, bracket);
3225                 if (bracket) printf(")");
3226                 break;
3227         case Bracket:
3228                 printf("(");
3229                 print_exec(b->right, indent, bracket);
3230                 printf(")");
3231                 break;
3232
3233 ###### propagate binode cases
3234         case Plus:
3235         case Minus:
3236         case Times:
3237         case Rem:
3238         case Divide:
3239                 /* both must be numbers, result is Tnum */
3240         case Absolute:
3241         case Negate:
3242                 /* as propagate_types ignores a NULL,
3243                  * unary ops fit here too */
3244                 propagate_types(b->left, c, ok, Tnum, 0);
3245                 propagate_types(b->right, c, ok, Tnum, 0);
3246                 if (!type_compat(type, Tnum, 0))
3247                         type_err(c, "error: Arithmetic returns %1 but %2 expected", prog,
3248                                    Tnum, rules, type);
3249                 return Tnum;
3250
3251         case Concat:
3252                 /* both must be Tstr, result is Tstr */
3253                 propagate_types(b->left, c, ok, Tstr, 0);
3254                 propagate_types(b->right, c, ok, Tstr, 0);
3255                 if (!type_compat(type, Tstr, 0))
3256                         type_err(c, "error: Concat returns %1 but %2 expected", prog,
3257                                    Tstr, rules, type);
3258                 return Tstr;
3259
3260         case StringConv:
3261                 /* op must be string, result is number */
3262                 propagate_types(b->left, c, ok, Tstr, 0);
3263                 if (!type_compat(type, Tnum, 0))
3264                         type_err(c,     // UNTESTED
3265                           "error: Can only convert string to number, not %1",
3266                                 prog, type, 0, NULL);
3267                 return Tnum;
3268
3269         case Bracket:
3270                 return propagate_types(b->right, c, ok, type, 0);
3271
3272 ###### interp binode cases
3273
3274         case Plus:
3275                 rv = interp_exec(c, b->left, &rvtype);
3276                 right = interp_exec(c, b->right, &rtype);
3277                 mpq_add(rv.num, rv.num, right.num);
3278                 break;
3279         case Minus:
3280                 rv = interp_exec(c, b->left, &rvtype);
3281                 right = interp_exec(c, b->right, &rtype);
3282                 mpq_sub(rv.num, rv.num, right.num);
3283                 break;
3284         case Times:
3285                 rv = interp_exec(c, b->left, &rvtype);
3286                 right = interp_exec(c, b->right, &rtype);
3287                 mpq_mul(rv.num, rv.num, right.num);
3288                 break;
3289         case Divide:
3290                 rv = interp_exec(c, b->left, &rvtype);
3291                 right = interp_exec(c, b->right, &rtype);
3292                 mpq_div(rv.num, rv.num, right.num);
3293                 break;
3294         case Rem: {
3295                 mpz_t l, r, rem;
3296
3297                 left = interp_exec(c, b->left, &ltype);
3298                 right = interp_exec(c, b->right, &rtype);
3299                 mpz_init(l); mpz_init(r); mpz_init(rem);
3300                 mpz_tdiv_q(l, mpq_numref(left.num), mpq_denref(left.num));
3301                 mpz_tdiv_q(r, mpq_numref(right.num), mpq_denref(right.num));
3302                 mpz_tdiv_r(rem, l, r);
3303                 val_init(Tnum, &rv);
3304                 mpq_set_z(rv.num, rem);
3305                 mpz_clear(r); mpz_clear(l); mpz_clear(rem);
3306                 rvtype = ltype;
3307                 break;
3308         }
3309         case Negate:
3310                 rv = interp_exec(c, b->right, &rvtype);
3311                 mpq_neg(rv.num, rv.num);
3312                 break;
3313         case Absolute:
3314                 rv = interp_exec(c, b->right, &rvtype);
3315                 mpq_abs(rv.num, rv.num);
3316                 break;
3317         case Bracket:
3318                 rv = interp_exec(c, b->right, &rvtype);
3319                 break;
3320         case Concat:
3321                 left = interp_exec(c, b->left, &ltype);
3322                 right = interp_exec(c, b->right, &rtype);
3323                 rvtype = Tstr;
3324                 rv.str = text_join(left.str, right.str);
3325                 break;
3326         case StringConv:
3327                 right = interp_exec(c, b->right, &rvtype);
3328                 rtype = Tstr;
3329                 rvtype = Tnum;
3330
3331                 struct text tx = right.str;
3332                 char tail[3];
3333                 int neg = 0;
3334                 if (tx.txt[0] == '-') {
3335                         neg = 1;        // UNTESTED
3336                         tx.txt++;       // UNTESTED
3337                         tx.len--;       // UNTESTED
3338                 }
3339                 if (number_parse(rv.num, tail, tx) == 0)
3340                         mpq_init(rv.num);       // UNTESTED
3341                 else if (neg)
3342                         mpq_neg(rv.num, rv.num);        // UNTESTED
3343                 if (tail[0])
3344                         printf("Unsupported suffix: %.*s\n", tx.len, tx.txt);   // UNTESTED
3345
3346                 break;
3347
3348 ###### value functions
3349
3350         static struct text text_join(struct text a, struct text b)
3351         {
3352                 struct text rv;
3353                 rv.len = a.len + b.len;
3354                 rv.txt = malloc(rv.len);
3355                 memcpy(rv.txt, a.txt, a.len);
3356                 memcpy(rv.txt+a.len, b.txt, b.len);
3357                 return rv;
3358         }
3359
3360 ### Blocks, Statements, and Statement lists.
3361
3362 Now that we have expressions out of the way we need to turn to
3363 statements.  There are simple statements and more complex statements.
3364 Simple statements do not contain (syntactic) newlines, complex statements do.
3365
3366 Statements often come in sequences and we have corresponding simple
3367 statement lists and complex statement lists.
3368 The former comprise only simple statements separated by semicolons.
3369 The later comprise complex statements and simple statement lists.  They are
3370 separated by newlines.  Thus the semicolon is only used to separate
3371 simple statements on the one line.  This may be overly restrictive,
3372 but I'm not sure I ever want a complex statement to share a line with
3373 anything else.
3374
3375 Note that a simple statement list can still use multiple lines if
3376 subsequent lines are indented, so
3377
3378 ###### Example: wrapped simple statement list
3379
3380         a = b; c = d;
3381            e = f; print g
3382
3383 is a single simple statement list.  This might allow room for
3384 confusion, so I'm not set on it yet.
3385
3386 A simple statement list needs no extra syntax.  A complex statement
3387 list has two syntactic forms.  It can be enclosed in braces (much like
3388 C blocks), or it can be introduced by an indent and continue until an
3389 unindented newline (much like Python blocks).  With this extra syntax
3390 it is referred to as a block.
3391
3392 Note that a block does not have to include any newlines if it only
3393 contains simple statements.  So both of:
3394
3395         if condition: a=b; d=f
3396
3397         if condition { a=b; print f }
3398
3399 are valid.
3400
3401 In either case the list is constructed from a `binode` list with
3402 `Block` as the operator.  When parsing the list it is most convenient
3403 to append to the end, so a list is a list and a statement.  When using
3404 the list it is more convenient to consider a list to be a statement
3405 and a list.  So we need a function to re-order a list.
3406 `reorder_bilist` serves this purpose.
3407
3408 The only stand-alone statement we introduce at this stage is `pass`
3409 which does nothing and is represented as a `NULL` pointer in a `Block`
3410 list.  Other stand-alone statements will follow once the infrastructure
3411 is in-place.
3412
3413 ###### Binode types
3414         Block,
3415
3416 ###### Grammar
3417
3418         $TERM { } ;
3419
3420         $*binode
3421         Block -> { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3422                 | { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3423                 | SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3424                 | SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3425                 | IN OptNL Statementlist OUT ${ $0 = $<Sl; }$
3426
3427         OpenBlock -> OpenScope { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3428                 | OpenScope { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3429                 | OpenScope SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3430                 | OpenScope SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3431                 | IN OpenScope OptNL Statementlist OUT ${ $0 = $<Sl; }$
3432
3433         UseBlock -> { OpenScope IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3434                 | { OpenScope SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3435                 | IN OpenScope OptNL Statementlist OUT ${ $0 = $<Sl; }$
3436
3437         ColonBlock -> { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3438                 | { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3439                 | : SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3440                 | : SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3441                 | : IN OptNL Statementlist OUT ${ $0 = $<Sl; }$
3442
3443         Statementlist -> ComplexStatements ${ $0 = reorder_bilist($<CS); }$
3444
3445         ComplexStatements -> ComplexStatements ComplexStatement ${
3446                         if ($2 == NULL) {
3447                                 $0 = $<1;
3448                         } else {
3449                                 $0 = new(binode);
3450                                 $0->op = Block;
3451                                 $0->left = $<1;
3452                                 $0->right = $<2;
3453                         }
3454                 }$
3455                 | ComplexStatement ${
3456                         if ($1 == NULL) {
3457                                 $0 = NULL;
3458                         } else {
3459                                 $0 = new(binode);
3460                                 $0->op = Block;
3461                                 $0->left = NULL;
3462                                 $0->right = $<1;
3463                         }
3464                 }$
3465
3466         $*exec
3467         ComplexStatement -> SimpleStatements Newlines ${
3468                         $0 = reorder_bilist($<SS);
3469                         }$
3470                 |  SimpleStatements ; Newlines ${
3471                         $0 = reorder_bilist($<SS);
3472                         }$
3473                 ## ComplexStatement Grammar
3474
3475         $*binode
3476         SimpleStatements -> SimpleStatements ; SimpleStatement ${
3477                         $0 = new(binode);
3478                         $0->op = Block;
3479                         $0->left = $<1;
3480                         $0->right = $<3;
3481                         }$
3482                 | SimpleStatement ${
3483                         $0 = new(binode);
3484                         $0->op = Block;
3485                         $0->left = NULL;
3486                         $0->right = $<1;
3487                         }$
3488
3489         $TERM pass
3490         SimpleStatement -> pass ${ $0 = NULL; }$
3491                 | ERROR ${ tok_err(c, "Syntax error in statement", &$1); }$
3492                 ## SimpleStatement Grammar
3493
3494 ###### print binode cases
3495         case Block:
3496                 if (indent < 0) {
3497                         // simple statement
3498                         if (b->left == NULL)    // UNTESTED
3499                                 printf("pass"); // UNTESTED
3500                         else
3501                                 print_exec(b->left, indent, bracket);   // UNTESTED
3502                         if (b->right) { // UNTESTED
3503                                 printf("; ");   // UNTESTED
3504                                 print_exec(b->right, indent, bracket);  // UNTESTED
3505                         }
3506                 } else {
3507                         // block, one per line
3508                         if (b->left == NULL)
3509                                 do_indent(indent, "pass\n");
3510                         else
3511                                 print_exec(b->left, indent, bracket);
3512                         if (b->right)
3513                                 print_exec(b->right, indent, bracket);
3514                 }
3515                 break;
3516
3517 ###### propagate binode cases
3518         case Block:
3519         {
3520                 /* If any statement returns something other than Tnone
3521                  * or Tbool then all such must return same type.
3522                  * As each statement may be Tnone or something else,
3523                  * we must always pass NULL (unknown) down, otherwise an incorrect
3524                  * error might occur.  We never return Tnone unless it is
3525                  * passed in.
3526                  */
3527                 struct binode *e;
3528
3529                 for (e = b; e; e = cast(binode, e->right)) {
3530                         t = propagate_types(e->left, c, ok, NULL, rules);
3531                         if ((rules & Rboolok) && t == Tbool)
3532                                 t = NULL;
3533                         if (t && t != Tnone && t != Tbool) {
3534                                 if (!type)
3535                                         type = t;
3536                                 else if (t != type)
3537                                         type_err(c, "error: expected %1%r, found %2",
3538                                                  e->left, type, rules, t);
3539                         }
3540                 }
3541                 return type;
3542         }
3543
3544 ###### interp binode cases
3545         case Block:
3546                 while (rvtype == Tnone &&
3547                        b) {
3548                         if (b->left)
3549                                 rv = interp_exec(c, b->left, &rvtype);
3550                         b = cast(binode, b->right);
3551                 }
3552                 break;
3553
3554 ### The Print statement
3555
3556 `print` is a simple statement that takes a comma-separated list of
3557 expressions and prints the values separated by spaces and terminated
3558 by a newline.  No control of formatting is possible.
3559
3560 `print` uses `ExpressionList` to collect the expressions and stores them
3561 on the left side of a `Print` binode unlessthere is a trailing comma
3562 when the list is stored on the `right` side and no trailing newline is
3563 printed.
3564
3565 ###### Binode types
3566         Print,
3567
3568 ##### expr precedence
3569         $TERM print
3570
3571 ###### SimpleStatement Grammar
3572
3573         | print ExpressionList ${
3574                 $0 = new(binode);
3575                 $0->op = Print;
3576                 $0->right = NULL;
3577                 $0->left = reorder_bilist($<EL);
3578         }$
3579         | print ExpressionList , ${ {
3580                 $0 = new(binode);
3581                 $0->op = Print;
3582                 $0->right = reorder_bilist($<EL);
3583                 $0->left = NULL;
3584         } }$
3585         | print ${
3586                 $0 = new(binode);
3587                 $0->op = Print;
3588                 $0->left = NULL;
3589                 $0->right = NULL;
3590         }$
3591
3592 ###### print binode cases
3593
3594         case Print:
3595                 do_indent(indent, "print");
3596                 if (b->right) {
3597                         print_exec(b->right, -1, bracket);
3598                         printf(",");
3599                 } else
3600                         print_exec(b->left, -1, bracket);
3601                 if (indent >= 0)
3602                         printf("\n");
3603                 break;
3604
3605 ###### propagate binode cases
3606
3607         case Print:
3608                 /* don't care but all must be consistent */
3609                 if (b->left)
3610                         b = cast(binode, b->left);
3611                 else
3612                         b = cast(binode, b->right);
3613                 while (b) {
3614                         propagate_types(b->left, c, ok, NULL, Rnolabel);
3615                         b = cast(binode, b->right);
3616                 }
3617                 break;
3618
3619 ###### interp binode cases
3620
3621         case Print:
3622         {
3623                 struct binode *b2 = cast(binode, b->left);
3624                 if (!b2)
3625                         b2 = cast(binode, b->right);
3626                 for (; b2; b2 = cast(binode, b2->right)) {
3627                         left = interp_exec(c, b2->left, &ltype);
3628                         print_value(ltype, &left);
3629                         free_value(ltype, &left);
3630                         if (b2->right)
3631                                 putchar(' ');
3632                 }
3633                 if (b->right == NULL)
3634                         printf("\n");
3635                 ltype = Tnone;
3636                 break;
3637         }
3638
3639 ###### Assignment statement
3640
3641 An assignment will assign a value to a variable, providing it hasn't
3642 been declared as a constant.  The analysis phase ensures that the type
3643 will be correct so the interpreter just needs to perform the
3644 calculation.  There is a form of assignment which declares a new
3645 variable as well as assigning a value.  If a name is assigned before
3646 it is declared, and error will be raised as the name is created as
3647 `Tlabel` and it is illegal to assign to such names.
3648
3649 ###### Binode types
3650         Assign,
3651         Declare,
3652
3653 ###### declare terminals
3654         $TERM =
3655
3656 ###### SimpleStatement Grammar
3657         | Variable = Expression ${
3658                         $0 = new(binode);
3659                         $0->op = Assign;
3660                         $0->left = $<1;
3661                         $0->right = $<3;
3662                 }$
3663         | VariableDecl = Expression ${
3664                         $0 = new(binode);
3665                         $0->op = Declare;
3666                         $0->left = $<1;
3667                         $0->right =$<3;
3668                 }$
3669
3670         | VariableDecl ${
3671                         if ($1->var->where_set == NULL) {
3672                                 type_err(c,
3673                                          "Variable declared with no type or value: %v",
3674                                          $1, NULL, 0, NULL);
3675                         } else {
3676                                 $0 = new(binode);
3677                                 $0->op = Declare;
3678                                 $0->left = $<1;
3679                                 $0->right = NULL;
3680                         }
3681                 }$
3682
3683 ###### print binode cases
3684
3685         case Assign:
3686                 do_indent(indent, "");
3687                 print_exec(b->left, indent, bracket);
3688                 printf(" = ");
3689                 print_exec(b->right, indent, bracket);
3690                 if (indent >= 0)
3691                         printf("\n");
3692                 break;
3693
3694         case Declare:
3695                 {
3696                 struct variable *v = cast(var, b->left)->var;
3697                 do_indent(indent, "");
3698                 print_exec(b->left, indent, bracket);
3699                 if (cast(var, b->left)->var->constant) {
3700                         printf("::");
3701                         if (v->where_decl == v->where_set) {
3702                                 type_print(v->type, stdout);
3703                                 printf(" ");
3704                         }
3705                 } else {
3706                         printf(":");
3707                         if (v->where_decl == v->where_set) {
3708                                 type_print(v->type, stdout);
3709                                 printf(" ");
3710                         }
3711                 }
3712                 if (b->right) {
3713                         printf("= ");
3714                         print_exec(b->right, indent, bracket);
3715                 }
3716                 if (indent >= 0)
3717                         printf("\n");
3718                 }
3719                 break;
3720
3721 ###### propagate binode cases
3722
3723         case Assign:
3724         case Declare:
3725                 /* Both must match and not be labels,
3726                  * Type must support 'dup',
3727                  * For Assign, left must not be constant.
3728                  * result is Tnone
3729                  */
3730                 t = propagate_types(b->left, c, ok, NULL,
3731                                     Rnolabel | (b->op == Assign ? Rnoconstant : 0));
3732                 if (!b->right)
3733                         return Tnone;
3734
3735                 if (t) {
3736                         if (propagate_types(b->right, c, ok, t, 0) != t)
3737                                 if (b->left->type == Xvar)
3738                                         type_err(c, "info: variable '%v' was set as %1 here.",
3739                                                  cast(var, b->left)->var->where_set, t, rules, NULL);
3740                 } else {
3741                         t = propagate_types(b->right, c, ok, NULL, Rnolabel);
3742                         if (t)
3743                                 propagate_types(b->left, c, ok, t,
3744                                                 (b->op == Assign ? Rnoconstant : 0));
3745                 }
3746                 if (t && t->dup == NULL)
3747                         type_err(c, "error: cannot assign value of type %1", b, t, 0, NULL);
3748                 return Tnone;
3749
3750                 break;
3751
3752 ###### interp binode cases
3753
3754         case Assign:
3755                 lleft = linterp_exec(c, b->left, &ltype);
3756                 right = interp_exec(c, b->right, &rtype);
3757                 if (lleft) {
3758                         free_value(ltype, lleft);
3759                         dup_value(ltype, &right, lleft);
3760                         ltype = NULL;
3761                 }
3762                 break;
3763
3764         case Declare:
3765         {
3766                 struct variable *v = cast(var, b->left)->var;
3767                 struct value *val;
3768                 v = v->merged;
3769                 val = var_value(c, v);
3770                 if (v->type->prepare_type)
3771                         v->type->prepare_type(c, v->type, 0);
3772                 if (b->right) {
3773                         right = interp_exec(c, b->right, &rtype);
3774                         memcpy(val, &right, rtype->size);
3775                         rtype = Tnone;
3776                 } else {
3777                         val_init(v->type, val);
3778                 }
3779                 break;
3780         }
3781
3782 ### The `use` statement
3783
3784 The `use` statement is the last "simple" statement.  It is needed when
3785 the condition in a conditional statement is a block.  `use` works much
3786 like `return` in C, but only completes the `condition`, not the whole
3787 function.
3788
3789 ###### Binode types
3790         Use,
3791
3792 ###### expr precedence
3793         $TERM use
3794
3795 ###### SimpleStatement Grammar
3796         | use Expression ${
3797                 $0 = new_pos(binode, $1);
3798                 $0->op = Use;
3799                 $0->right = $<2;
3800                 if ($0->right->type == Xvar) {
3801                         struct var *v = cast(var, $0->right);
3802                         if (v->var->type == Tnone) {
3803                                 /* Convert this to a label */
3804                                 struct value *val;
3805
3806                                 v->var->type = Tlabel;
3807                                 val = global_alloc(c, Tlabel, v->var, NULL);
3808                                 val->label = val;
3809                         }
3810                 }
3811         }$
3812
3813 ###### print binode cases
3814
3815         case Use:
3816                 do_indent(indent, "use ");
3817                 print_exec(b->right, -1, bracket);
3818                 if (indent >= 0)
3819                         printf("\n");
3820                 break;
3821
3822 ###### propagate binode cases
3823
3824         case Use:
3825                 /* result matches value */
3826                 return propagate_types(b->right, c, ok, type, 0);
3827
3828 ###### interp binode cases
3829
3830         case Use:
3831                 rv = interp_exec(c, b->right, &rvtype);
3832                 break;
3833
3834 ### The Conditional Statement
3835
3836 This is the biggy and currently the only complex statement.  This
3837 subsumes `if`, `while`, `do/while`, `switch`, and some parts of `for`.
3838 It is comprised of a number of parts, all of which are optional though
3839 set combinations apply.  Each part is (usually) a key word (`then` is
3840 sometimes optional) followed by either an expression or a code block,
3841 except the `casepart` which is a "key word and an expression" followed
3842 by a code block.  The code-block option is valid for all parts and,
3843 where an expression is also allowed, the code block can use the `use`
3844 statement to report a value.  If the code block does not report a value
3845 the effect is similar to reporting `True`.
3846
3847 The `else` and `case` parts, as well as `then` when combined with
3848 `if`, can contain a `use` statement which will apply to some
3849 containing conditional statement. `for` parts, `do` parts and `then`
3850 parts used with `for` can never contain a `use`, except in some
3851 subordinate conditional statement.
3852
3853 If there is a `forpart`, it is executed first, only once.
3854 If there is a `dopart`, then it is executed repeatedly providing
3855 always that the `condpart` or `cond`, if present, does not return a non-True
3856 value.  `condpart` can fail to return any value if it simply executes
3857 to completion.  This is treated the same as returning `True`.
3858
3859 If there is a `thenpart` it will be executed whenever the `condpart`
3860 or `cond` returns True (or does not return any value), but this will happen
3861 *after* `dopart` (when present).
3862
3863 If `elsepart` is present it will be executed at most once when the
3864 condition returns `False` or some value that isn't `True` and isn't
3865 matched by any `casepart`.  If there are any `casepart`s, they will be
3866 executed when the condition returns a matching value.
3867
3868 The particular sorts of values allowed in case parts has not yet been
3869 determined in the language design, so nothing is prohibited.
3870
3871 The various blocks in this complex statement potentially provide scope
3872 for variables as described earlier.  Each such block must include the
3873 "OpenScope" nonterminal before parsing the block, and must call
3874 `var_block_close()` when closing the block.
3875
3876 The code following "`if`", "`switch`" and "`for`" does not get its own
3877 scope, but is in a scope covering the whole statement, so names
3878 declared there cannot be redeclared elsewhere.  Similarly the
3879 condition following "`while`" is in a scope the covers the body
3880 ("`do`" part) of the loop, and which does not allow conditional scope
3881 extension.  Code following "`then`" (both looping and non-looping),
3882 "`else`" and "`case`" each get their own local scope.
3883
3884 The type requirements on the code block in a `whilepart` are quite
3885 unusal.  It is allowed to return a value of some identifiable type, in
3886 which case the loop aborts and an appropriate `casepart` is run, or it
3887 can return a Boolean, in which case the loop either continues to the
3888 `dopart` (on `True`) or aborts and runs the `elsepart` (on `False`).
3889 This is different both from the `ifpart` code block which is expected to
3890 return a Boolean, or the `switchpart` code block which is expected to
3891 return the same type as the casepart values.  The correct analysis of
3892 the type of the `whilepart` code block is the reason for the
3893 `Rboolok` flag which is passed to `propagate_types()`.
3894
3895 The `cond_statement` cannot fit into a `binode` so a new `exec` is
3896 defined.  As there are two scopes which cover multiple parts - one for
3897 the whole statement and one for "while" and "do" - and as we will use
3898 the 'struct exec' to track scopes, we actually need two new types of
3899 exec.  One is a `binode` for the looping part, the rest is the
3900 `cond_statement`.  The `cond_statement` will use an auxilliary `struct
3901 casepart` to track a list of case parts.
3902
3903 ###### Binode types
3904         Loop
3905
3906 ###### exec type
3907         Xcond_statement,
3908
3909 ###### ast
3910         struct casepart {
3911                 struct exec *value;
3912                 struct exec *action;
3913                 struct casepart *next;
3914         };
3915         struct cond_statement {
3916                 struct exec;
3917                 struct exec *forpart, *condpart, *thenpart, *elsepart;
3918                 struct binode *looppart;
3919                 struct casepart *casepart;
3920         };
3921
3922 ###### ast functions
3923
3924         static void free_casepart(struct casepart *cp)
3925         {
3926                 while (cp) {
3927                         struct casepart *t;
3928                         free_exec(cp->value);
3929                         free_exec(cp->action);
3930                         t = cp->next;
3931                         free(cp);
3932                         cp = t;
3933                 }
3934         }
3935
3936         static void free_cond_statement(struct cond_statement *s)
3937         {
3938                 if (!s)
3939                         return;
3940                 free_exec(s->forpart);
3941                 free_exec(s->condpart);
3942                 free_exec(s->looppart);
3943                 free_exec(s->thenpart);
3944                 free_exec(s->elsepart);
3945                 free_casepart(s->casepart);
3946                 free(s);
3947         }
3948
3949 ###### free exec cases
3950         case Xcond_statement: free_cond_statement(cast(cond_statement, e)); break;
3951
3952 ###### ComplexStatement Grammar
3953         | CondStatement ${ $0 = $<1; }$
3954
3955 ###### expr precedence
3956         $TERM for then while do
3957         $TERM else
3958         $TERM switch case
3959
3960 ###### Grammar
3961
3962         $*cond_statement
3963         // A CondStatement must end with EOL, as does CondSuffix and
3964         // IfSuffix.
3965         // ForPart, ThenPart, SwitchPart, CasePart are non-empty and
3966         // may or may not end with EOL
3967         // WhilePart and IfPart include an appropriate Suffix
3968
3969         // ForPart, SwitchPart, and IfPart open scopes, o we have to close
3970         // them.  WhilePart opens and closes its own scope.
3971         CondStatement -> ForPart OptNL ThenPart OptNL WhilePart CondSuffix ${
3972                         $0 = $<CS;
3973                         $0->forpart = $<FP;
3974                         $0->thenpart = $<TP;
3975                         $0->looppart = $<WP;
3976                         var_block_close(c, CloseSequential, $0);
3977                         }$
3978                 | ForPart OptNL WhilePart CondSuffix ${
3979                         $0 = $<CS;
3980                         $0->forpart = $<FP;
3981                         $0->looppart = $<WP;
3982                         var_block_close(c, CloseSequential, $0);
3983                         }$
3984                 | WhilePart CondSuffix ${
3985                         $0 = $<CS;
3986                         $0->looppart = $<WP;
3987                         }$
3988                 | SwitchPart OptNL CasePart CondSuffix ${
3989                         $0 = $<CS;
3990                         $0->condpart = $<SP;
3991                         $CP->next = $0->casepart;
3992                         $0->casepart = $<CP;
3993                         var_block_close(c, CloseSequential, $0);
3994                         }$
3995                 | SwitchPart : IN OptNL CasePart CondSuffix OUT Newlines ${
3996                         $0 = $<CS;
3997                         $0->condpart = $<SP;
3998                         $CP->next = $0->casepart;
3999                         $0->casepart = $<CP;
4000                         var_block_close(c, CloseSequential, $0);
4001                         }$
4002                 | IfPart IfSuffix ${
4003                         $0 = $<IS;
4004                         $0->condpart = $IP.condpart; $IP.condpart = NULL;
4005                         $0->thenpart = $IP.thenpart; $IP.thenpart = NULL;
4006                         // This is where we close an "if" statement
4007                         var_block_close(c, CloseSequential, $0);
4008                         }$
4009
4010         CondSuffix -> IfSuffix ${
4011                         $0 = $<1;
4012                 }$
4013                 | Newlines CasePart CondSuffix ${
4014                         $0 = $<CS;
4015                         $CP->next = $0->casepart;
4016                         $0->casepart = $<CP;
4017                 }$
4018                 | CasePart CondSuffix ${
4019                         $0 = $<CS;
4020                         $CP->next = $0->casepart;
4021                         $0->casepart = $<CP;
4022                 }$
4023
4024         IfSuffix -> Newlines ${ $0 = new(cond_statement); }$
4025                 | Newlines ElsePart ${ $0 = $<EP; }$
4026                 | ElsePart ${$0 = $<EP; }$
4027
4028         ElsePart -> else OpenBlock Newlines ${
4029                         $0 = new(cond_statement);
4030                         $0->elsepart = $<OB;
4031                         var_block_close(c, CloseElse, $0->elsepart);
4032                 }$
4033                 | else OpenScope CondStatement ${
4034                         $0 = new(cond_statement);
4035                         $0->elsepart = $<CS;
4036                         var_block_close(c, CloseElse, $0->elsepart);
4037                 }$
4038
4039         $*casepart
4040         CasePart -> case Expression OpenScope ColonBlock ${
4041                         $0 = calloc(1,sizeof(struct casepart));
4042                         $0->value = $<Ex;
4043                         $0->action = $<Bl;
4044                         var_block_close(c, CloseParallel, $0->action);
4045                 }$
4046
4047         $*exec
4048         // These scopes are closed in CondStatement
4049         ForPart -> for OpenBlock ${
4050                         $0 = $<Bl;
4051                 }$
4052
4053         ThenPart -> then OpenBlock ${
4054                         $0 = $<OB;
4055                         var_block_close(c, CloseSequential, $0);
4056                 }$
4057
4058         $*binode
4059         // This scope is closed in CondStatement
4060         WhilePart -> while UseBlock OptNL do OpenBlock ${
4061                         $0 = new(binode);
4062                         $0->op = Loop;
4063                         $0->left = $<UB;
4064                         $0->right = $<OB;
4065                         var_block_close(c, CloseSequential, $0->right);
4066                         var_block_close(c, CloseSequential, $0);
4067                 }$
4068                 | while OpenScope Expression OpenScope ColonBlock ${
4069                         $0 = new(binode);
4070                         $0->op = Loop;
4071                         $0->left = $<Exp;
4072                         $0->right = $<CB;
4073                         var_block_close(c, CloseSequential, $0->right);
4074                         var_block_close(c, CloseSequential, $0);
4075                 }$
4076
4077         $cond_statement
4078         IfPart -> if UseBlock OptNL then OpenBlock ${
4079                         $0.condpart = $<UB;
4080                         $0.thenpart = $<OB;
4081                         var_block_close(c, CloseParallel, $0.thenpart);
4082                 }$
4083                 | if OpenScope Expression OpenScope ColonBlock ${
4084                         $0.condpart = $<Ex;
4085                         $0.thenpart = $<CB;
4086                         var_block_close(c, CloseParallel, $0.thenpart);
4087                 }$
4088                 | if OpenScope Expression OpenScope OptNL then Block ${
4089                         $0.condpart = $<Ex;
4090                         $0.thenpart = $<Bl;
4091                         var_block_close(c, CloseParallel, $0.thenpart);
4092                 }$
4093
4094         $*exec
4095         // This scope is closed in CondStatement
4096         SwitchPart -> switch OpenScope Expression ${
4097                         $0 = $<Ex;
4098                 }$
4099                 | switch UseBlock ${
4100                         $0 = $<Bl;
4101                 }$
4102
4103 ###### print binode cases
4104         case Loop:
4105                 if (b->left && b->left->type == Xbinode &&
4106                     cast(binode, b->left)->op == Block) {
4107                         if (bracket)
4108                                 do_indent(indent, "while {\n");
4109                         else
4110                                 do_indent(indent, "while\n");
4111                         print_exec(b->left, indent+1, bracket);
4112                         if (bracket)
4113                                 do_indent(indent, "} do {\n");
4114                         else
4115                                 do_indent(indent, "do\n");
4116                         print_exec(b->right, indent+1, bracket);
4117                         if (bracket)
4118                                 do_indent(indent, "}\n");
4119                 } else {
4120                         do_indent(indent, "while ");
4121                         print_exec(b->left, 0, bracket);
4122                         if (bracket)
4123                                 printf(" {\n");
4124                         else
4125                                 printf(":\n");
4126                         print_exec(b->right, indent+1, bracket);
4127                         if (bracket)
4128                                 do_indent(indent, "}\n");
4129                 }
4130                 break;
4131
4132 ###### print exec cases
4133
4134         case Xcond_statement:
4135         {
4136                 struct cond_statement *cs = cast(cond_statement, e);
4137                 struct casepart *cp;
4138                 if (cs->forpart) {
4139                         do_indent(indent, "for");
4140                         if (bracket) printf(" {\n"); else printf("\n");
4141                         print_exec(cs->forpart, indent+1, bracket);
4142                         if (cs->thenpart) {
4143                                 if (bracket)
4144                                         do_indent(indent, "} then {\n");
4145                                 else
4146                                         do_indent(indent, "then\n");
4147                                 print_exec(cs->thenpart, indent+1, bracket);
4148                         }
4149                         if (bracket) do_indent(indent, "}\n");
4150                 }
4151                 if (cs->looppart) {
4152                         print_exec(cs->looppart, indent, bracket);
4153                 } else {
4154                         // a condition
4155                         if (cs->casepart)
4156                                 do_indent(indent, "switch");
4157                         else
4158                                 do_indent(indent, "if");
4159                         if (cs->condpart && cs->condpart->type == Xbinode &&
4160                             cast(binode, cs->condpart)->op == Block) {
4161                                 if (bracket)
4162                                         printf(" {\n");
4163                                 else
4164                                         printf("\n");
4165                                 print_exec(cs->condpart, indent+1, bracket);
4166                                 if (bracket)
4167                                         do_indent(indent, "}\n");
4168                                 if (cs->thenpart) {
4169                                         do_indent(indent, "then\n");
4170                                         print_exec(cs->thenpart, indent+1, bracket);
4171                                 }
4172                         } else {
4173                                 printf(" ");
4174                                 print_exec(cs->condpart, 0, bracket);
4175                                 if (cs->thenpart) {
4176                                         if (bracket)
4177                                                 printf(" {\n");
4178                                         else
4179                                                 printf(":\n");
4180                                         print_exec(cs->thenpart, indent+1, bracket);
4181                                         if (bracket)
4182                                                 do_indent(indent, "}\n");
4183                                 } else
4184                                         printf("\n");
4185                         }
4186                 }
4187                 for (cp = cs->casepart; cp; cp = cp->next) {
4188                         do_indent(indent, "case ");
4189                         print_exec(cp->value, -1, 0);
4190                         if (bracket)
4191                                 printf(" {\n");
4192                         else
4193                                 printf(":\n");
4194                         print_exec(cp->action, indent+1, bracket);
4195                         if (bracket)
4196                                 do_indent(indent, "}\n");
4197                 }
4198                 if (cs->elsepart) {
4199                         do_indent(indent, "else");
4200                         if (bracket)
4201                                 printf(" {\n");
4202                         else
4203                                 printf("\n");
4204                         print_exec(cs->elsepart, indent+1, bracket);
4205                         if (bracket)
4206                                 do_indent(indent, "}\n");
4207                 }
4208                 break;
4209         }
4210
4211 ###### propagate binode cases
4212         case Loop:
4213                 t = propagate_types(b->right, c, ok, Tnone, 0);
4214                 if (!type_compat(Tnone, t, 0))
4215                         *ok = 0;        // UNTESTED
4216                 return propagate_types(b->left, c, ok, type, rules);
4217
4218 ###### propagate exec cases
4219         case Xcond_statement:
4220         {
4221                 // forpart and looppart->right must return Tnone
4222                 // thenpart must return Tnone if there is a loopart,
4223                 // otherwise it is like elsepart.
4224                 // condpart must:
4225                 //    be bool if there is no casepart
4226                 //    match casepart->values if there is a switchpart
4227                 //    either be bool or match casepart->value if there
4228                 //             is a whilepart
4229                 // elsepart and casepart->action must match the return type
4230                 //   expected of this statement.
4231                 struct cond_statement *cs = cast(cond_statement, prog);
4232                 struct casepart *cp;
4233
4234                 t = propagate_types(cs->forpart, c, ok, Tnone, 0);
4235                 if (!type_compat(Tnone, t, 0))
4236                         *ok = 0;        // UNTESTED
4237
4238                 if (cs->looppart) {
4239                         t = propagate_types(cs->thenpart, c, ok, Tnone, 0);
4240                         if (!type_compat(Tnone, t, 0))
4241                                 *ok = 0;        // UNTESTED
4242                 }
4243                 if (cs->casepart == NULL) {
4244                         propagate_types(cs->condpart, c, ok, Tbool, 0);
4245                         propagate_types(cs->looppart, c, ok, Tbool, 0);
4246                 } else {
4247                         /* Condpart must match case values, with bool permitted */
4248                         t = NULL;
4249                         for (cp = cs->casepart;
4250                              cp && !t; cp = cp->next)
4251                                 t = propagate_types(cp->value, c, ok, NULL, 0);
4252                         if (!t && cs->condpart)
4253                                 t = propagate_types(cs->condpart, c, ok, NULL, Rboolok);        // UNTESTED
4254                         if (!t && cs->looppart)
4255                                 t = propagate_types(cs->looppart, c, ok, NULL, Rboolok);        // UNTESTED
4256                         // Now we have a type (I hope) push it down
4257                         if (t) {
4258                                 for (cp = cs->casepart; cp; cp = cp->next)
4259                                         propagate_types(cp->value, c, ok, t, 0);
4260                                 propagate_types(cs->condpart, c, ok, t, Rboolok);
4261                                 propagate_types(cs->looppart, c, ok, t, Rboolok);
4262                         }
4263                 }
4264                 // (if)then, else, and case parts must return expected type.
4265                 if (!cs->looppart && !type)
4266                         type = propagate_types(cs->thenpart, c, ok, NULL, rules);
4267                 if (!type)
4268                         type = propagate_types(cs->elsepart, c, ok, NULL, rules);
4269                 for (cp = cs->casepart;
4270                      cp && !type;
4271                      cp = cp->next)     // UNTESTED
4272                         type = propagate_types(cp->action, c, ok, NULL, rules); // UNTESTED
4273                 if (type) {
4274                         if (!cs->looppart)
4275                                 propagate_types(cs->thenpart, c, ok, type, rules);
4276                         propagate_types(cs->elsepart, c, ok, type, rules);
4277                         for (cp = cs->casepart; cp ; cp = cp->next)
4278                                 propagate_types(cp->action, c, ok, type, rules);
4279                         return type;
4280                 } else
4281                         return NULL;
4282         }
4283
4284 ###### interp binode cases
4285         case Loop:
4286                 // This just performs one iterration of the loop
4287                 rv = interp_exec(c, b->left, &rvtype);
4288                 if (rvtype == Tnone ||
4289                     (rvtype == Tbool && rv.bool != 0))
4290                         // cnd is Tnone or Tbool, doesn't need to be freed
4291                         interp_exec(c, b->right, NULL);
4292                 break;
4293
4294 ###### interp exec cases
4295         case Xcond_statement:
4296         {
4297                 struct value v, cnd;
4298                 struct type *vtype, *cndtype;
4299                 struct casepart *cp;
4300                 struct cond_statement *cs = cast(cond_statement, e);
4301
4302                 if (cs->forpart)
4303                         interp_exec(c, cs->forpart, NULL);
4304                 if (cs->looppart) {
4305                         while ((cnd = interp_exec(c, cs->looppart, &cndtype)),
4306                                cndtype == Tnone || (cndtype == Tbool && cnd.bool != 0))
4307                                 interp_exec(c, cs->thenpart, NULL);
4308                 } else {
4309                         cnd = interp_exec(c, cs->condpart, &cndtype);
4310                         if ((cndtype == Tnone ||
4311                             (cndtype == Tbool && cnd.bool != 0))) {
4312                                 // cnd is Tnone or Tbool, doesn't need to be freed
4313                                 rv = interp_exec(c, cs->thenpart, &rvtype);
4314                                 // skip else (and cases)
4315                                 goto Xcond_done;
4316                         }
4317                 }
4318                 for (cp = cs->casepart; cp; cp = cp->next) {
4319                         v = interp_exec(c, cp->value, &vtype);
4320                         if (value_cmp(cndtype, vtype, &v, &cnd) == 0) {
4321                                 free_value(vtype, &v);
4322                                 free_value(cndtype, &cnd);
4323                                 rv = interp_exec(c, cp->action, &rvtype);
4324                                 goto Xcond_done;
4325                         }
4326                         free_value(vtype, &v);
4327                 }
4328                 free_value(cndtype, &cnd);
4329                 if (cs->elsepart)
4330                         rv = interp_exec(c, cs->elsepart, &rvtype);
4331                 else
4332                         rvtype = Tnone;
4333         Xcond_done:
4334                 break;
4335         }
4336
4337 ### Top level structure
4338
4339 All the language elements so far can be used in various places.  Now
4340 it is time to clarify what those places are.
4341
4342 At the top level of a file there will be a number of declarations.
4343 Many of the things that can be declared haven't been described yet,
4344 such as functions, procedures, imports, and probably more.
4345 For now there are two sorts of things that can appear at the top
4346 level.  They are predefined constants, `struct` types, and the `main`
4347 function.  While the syntax will allow the `main` function to appear
4348 multiple times, that will trigger an error if it is actually attempted.
4349
4350 The various declarations do not return anything.  They store the
4351 various declarations in the parse context.
4352
4353 ###### Parser: grammar
4354
4355         $void
4356         Ocean -> OptNL DeclarationList
4357
4358         ## declare terminals
4359
4360         OptNL ->
4361                 | OptNL NEWLINE
4362         Newlines -> NEWLINE
4363                 | Newlines NEWLINE
4364
4365         DeclarationList -> Declaration
4366                 | DeclarationList Declaration
4367
4368         Declaration -> ERROR Newlines ${
4369                         tok_err(c,      // UNTESTED
4370                                 "error: unhandled parse error", &$1);
4371                 }$
4372                 | DeclareConstant
4373                 | DeclareFunction
4374                 | DeclareStruct
4375
4376         ## top level grammar
4377
4378         ## Grammar
4379
4380 ### The `const` section
4381
4382 As well as being defined in with the code that uses them, constants
4383 can be declared at the top level.  These have full-file scope, so they
4384 are always `InScope`.  The value of a top level constant can be given
4385 as an expression, and this is evaluated immediately rather than in the
4386 later interpretation stage.  Once we add functions to the language, we
4387 will need rules concern which, if any, can be used to define a top
4388 level constant.
4389
4390 Constants are defined in a section that starts with the reserved word
4391 `const` and then has a block with a list of assignment statements.
4392 For syntactic consistency, these must use the double-colon syntax to
4393 make it clear that they are constants.  Type can also be given: if
4394 not, the type will be determined during analysis, as with other
4395 constants.
4396
4397 As the types constants are inserted at the head of a list, printing
4398 them in the same order that they were read is not straight forward.
4399 We take a quadratic approach here and count the number of constants
4400 (variables of depth 0), then count down from there, each time
4401 searching through for the Nth constant for decreasing N.
4402
4403 ###### top level grammar
4404
4405         $TERM const
4406
4407         DeclareConstant -> const { IN OptNL ConstList OUT OptNL } Newlines
4408                 | const { SimpleConstList } Newlines
4409                 | const IN OptNL ConstList OUT Newlines
4410                 | const SimpleConstList Newlines
4411
4412         ConstList -> ConstList SimpleConstLine
4413                 | SimpleConstLine
4414         SimpleConstList -> SimpleConstList ; Const
4415                 | Const
4416                 | SimpleConstList ;
4417         SimpleConstLine -> SimpleConstList Newlines
4418                 | ERROR Newlines ${ tok_err(c, "Syntax error in constant", &$1); }$
4419
4420         $*type
4421         CType -> Type   ${ $0 = $<1; }$
4422                 |       ${ $0 = NULL; }$
4423         $void
4424         Const -> IDENTIFIER :: CType = Expression ${ {
4425                 int ok;
4426                 struct variable *v;
4427
4428                 v = var_decl(c, $1.txt);
4429                 if (v) {
4430                         struct var *var = new_pos(var, $1);
4431                         v->where_decl = var;
4432                         v->where_set = var;
4433                         var->var = v;
4434                         v->constant = 1;
4435                 } else {
4436                         v = var_ref(c, $1.txt);
4437                         tok_err(c, "error: name already declared", &$1);
4438                         type_err(c, "info: this is where '%v' was first declared",
4439                                  v->where_decl, NULL, 0, NULL);
4440                 }
4441                 do {
4442                         ok = 1;
4443                         propagate_types($5, c, &ok, $3, 0);
4444                 } while (ok == 2);
4445                 if (!ok)
4446                         c->parse_error = 1;
4447                 else if (v) {
4448                         struct value res = interp_exec(c, $5, &v->type);
4449                         global_alloc(c, v->type, v, &res);
4450                 }
4451         } }$
4452
4453 ###### print const decls
4454         {
4455                 struct variable *v;
4456                 int target = -1;
4457
4458                 while (target != 0) {
4459                         int i = 0;
4460                         for (v = context.in_scope; v; v=v->in_scope)
4461                                 if (v->depth == 0) {
4462                                         i += 1;
4463                                         if (i == target)
4464                                                 break;
4465                                 }
4466
4467                         if (target == -1) {
4468                                 if (i)
4469                                         printf("const\n");
4470                                 target = i;
4471                         } else {
4472                                 struct value *val = var_value(&context, v);
4473                                 printf("    %.*s :: ", v->name->name.len, v->name->name.txt);
4474                                 type_print(v->type, stdout);
4475                                 printf(" = ");
4476                                 if (v->type == Tstr)
4477                                         printf("\"");
4478                                 print_value(v->type, val);
4479                                 if (v->type == Tstr)
4480                                         printf("\"");
4481                                 printf("\n");
4482                                 target -= 1;
4483                         }
4484                 }
4485         }
4486
4487 ### Finally the whole `main` function.
4488
4489 An Ocean program can currently have only one function - `main` - and
4490 that must exist.  It expects an array of strings with a provided size.
4491 Following this is a `block` which is the code to execute.
4492
4493 As this is the top level, several things are handled a bit
4494 differently.
4495 The function is not interpreted by `interp_exec` as that isn't
4496 passed the argument list which the program requires.  Similarly type
4497 analysis is a bit more interesting at this level.
4498
4499 ###### top level grammar
4500
4501         DeclareFunction -> MainFunction ${ {
4502                 if (c->prog)
4503                         type_err(c, "\"main\" defined a second time",
4504                                  $1, NULL, 0, NULL);
4505                 else
4506                         c->prog = $<1;
4507         } }$
4508
4509 ###### print binode cases
4510         case Func:
4511                 do_indent(indent, "func main(");
4512                 for (b2 = cast(binode, b->left); b2; b2 = cast(binode, b2->right)) {
4513                         struct variable *v = cast(var, b2->left)->var;
4514                         printf(" ");
4515                         print_exec(b2->left, 0, 0);
4516                         printf(":");
4517                         type_print(v->type, stdout);
4518                 }
4519                 if (bracket)
4520                         printf(") {\n");
4521                 else
4522                         printf(")\n");
4523                 print_exec(b->right, indent+1, bracket);
4524                 if (bracket)
4525                         do_indent(indent, "}\n");
4526                 break;
4527
4528 ###### propagate binode cases
4529         case Func: abort();             // NOTEST
4530
4531 ###### core functions
4532
4533         static int analyse_prog(struct exec *prog, struct parse_context *c)
4534         {
4535                 struct binode *bp = cast(binode, prog);
4536                 struct binode *b;
4537                 int ok = 1;
4538                 int arg = 0;
4539                 struct type *argv_type;
4540                 struct text argv_type_name = { " argv", 5 };
4541
4542                 if (!bp)
4543                         return 0;       // NOTEST
4544
4545                 argv_type = add_type(c, argv_type_name, &array_prototype);
4546                 argv_type->array.member = Tstr;
4547                 argv_type->array.unspec = 1;
4548
4549                 for (b = cast(binode, bp->left); b; b = cast(binode, b->right)) {
4550                         ok = 1;
4551                         switch (arg++) {
4552                         case 0: /* argv */
4553                                 propagate_types(b->left, c, &ok, argv_type, 0);
4554                                 break;
4555                         default: /* invalid */  // NOTEST
4556                                 propagate_types(b->left, c, &ok, Tnone, 0);     // NOTEST
4557                         }
4558                 }
4559
4560                 do {
4561                         ok = 1;
4562                         propagate_types(bp->right, c, &ok, Tnone, 0);
4563                 } while (ok == 2);
4564                 if (!ok)
4565                         return 0;
4566
4567                 /* Make sure everything is still consistent */
4568                 propagate_types(bp->right, c, &ok, Tnone, 0);
4569                 if (!ok)
4570                         return 0;       // UNTESTED
4571                 scope_finalize(c);
4572                 return 1;
4573         }
4574
4575         static void interp_prog(struct parse_context *c, struct exec *prog,
4576                                 int argc, char **argv)
4577         {
4578                 struct binode *p = cast(binode, prog);
4579                 struct binode *al;
4580                 int anum = 0;
4581                 struct value v;
4582                 struct type *vtype;
4583
4584                 if (!prog)
4585                         return;         // NOTEST
4586                 al = cast(binode, p->left);
4587                 while (al) {
4588                         struct var *v = cast(var, al->left);
4589                         struct value *vl = var_value(c, v->var);
4590                         struct value arg;
4591                         struct type *t;
4592                         mpq_t argcq;
4593                         int i;
4594
4595                         switch (anum++) {
4596                         case 0: /* argv */
4597                                 t = v->var->type;
4598                                 mpq_init(argcq);
4599                                 mpq_set_ui(argcq, argc, 1);
4600                                 memcpy(var_value(c, t->array.vsize), &argcq, sizeof(argcq));
4601                                 t->prepare_type(c, t, 0);
4602                                 array_init(v->var->type, vl);
4603                                 for (i = 0; i < argc; i++) {
4604                                         struct value *vl2 = vl->array + i * v->var->type->array.member->size;
4605
4606
4607                                         arg.str.txt = argv[i];
4608                                         arg.str.len = strlen(argv[i]);
4609                                         free_value(Tstr, vl2);
4610                                         dup_value(Tstr, &arg, vl2);
4611                                 }
4612                                 break;
4613                         }
4614                         al = cast(binode, al->right);
4615                 }
4616                 v = interp_exec(c, p, &vtype);
4617                 free_value(vtype, &v);
4618         }
4619
4620 ###### interp binode cases
4621         case Func:
4622                 rv = interp_exec(c, b->right, &rvtype);
4623                 break;
4624
4625 ## And now to test it out.
4626
4627 Having a language requires having a "hello world" program.  I'll
4628 provide a little more than that: a program that prints "Hello world"
4629 finds the GCD of two numbers, prints the first few elements of
4630 Fibonacci, performs a binary search for a number, and a few other
4631 things which will likely grow as the languages grows.
4632
4633 ###### File: oceani.mk
4634         demos :: sayhello
4635         sayhello : oceani
4636                 @echo "===== DEMO ====="
4637                 ./oceani --section "demo: hello" oceani.mdc 55 33
4638
4639 ###### demo: hello
4640
4641         const
4642                 pi ::= 3.141_592_6
4643                 four ::= 2 + 2 ; five ::= 10/2
4644         const pie ::= "I like Pie";
4645                 cake ::= "The cake is"
4646                   ++ " a lie"
4647
4648         struct fred
4649                 size:[four]number
4650                 name:string
4651                 alive:Boolean
4652
4653         func main
4654                 argv:[argc::]string
4655         do
4656                 print "Hello World, what lovely oceans you have!"
4657                 print "Are there", five, "?"
4658                 print pi, pie, "but", cake
4659
4660                 A := $argv[1]; B := $argv[2]
4661
4662                 /* When a variable is defined in both branches of an 'if',
4663                  * and used afterwards, the variables are merged.
4664                  */
4665                 if A > B:
4666                         bigger := "yes"
4667                 else
4668                         bigger := "no"
4669                 print "Is", A, "bigger than", B,"? ", bigger
4670                 /* If a variable is not used after the 'if', no
4671                  * merge happens, so types can be different
4672                  */
4673                 if A > B * 2:
4674                         double:string = "yes"
4675                         print A, "is more than twice", B, "?", double
4676                 else
4677                         double := B*2
4678                         print "double", B, "is", double
4679
4680                 a : number
4681                 a = A;
4682                 b:number = B
4683                 if a > 0 and then b > 0:
4684                         while a != b:
4685                                 if a < b:
4686                                         b = b - a
4687                                 else
4688                                         a = a - b
4689                         print "GCD of", A, "and", B,"is", a
4690                 else if a <= 0:
4691                         print a, "is not positive, cannot calculate GCD"
4692                 else
4693                         print b, "is not positive, cannot calculate GCD"
4694
4695                 for
4696                         togo := 10
4697                         f1 := 1; f2 := 1
4698                         print "Fibonacci:", f1,f2,
4699                 then togo = togo - 1
4700                 while togo > 0:
4701                         f3 := f1 + f2
4702                         print "", f3,
4703                         f1 = f2
4704                         f2 = f3
4705                 print ""
4706
4707                 /* Binary search... */
4708                 for
4709                         lo:= 0; hi := 100
4710                         target := 77
4711                 while
4712                         mid := (lo + hi) / 2
4713                         if mid == target:
4714                                 use Found
4715                         if mid < target:
4716                                 lo = mid
4717                         else
4718                                 hi = mid
4719                         if hi - lo < 1:
4720                                 lo = mid
4721                                 use GiveUp
4722                         use True
4723                 do pass
4724                 case Found:
4725                         print "Yay, I found", target
4726                 case GiveUp:
4727                         print "Closest I found was", lo
4728
4729                 size::= 10
4730                 list:[size]number
4731                 list[0] = 1234
4732                 // "middle square" PRNG.  Not particularly good, but one my
4733                 // Dad taught me - the first one I ever heard of.
4734                 for i:=1; then i = i + 1; while i < size:
4735                         n := list[i-1] * list[i-1]
4736                         list[i] = (n / 100) % 10 000
4737
4738                 print "Before sort:",
4739                 for i:=0; then i = i + 1; while i < size:
4740                         print "", list[i],
4741                 print
4742
4743                 for i := 1; then i=i+1; while i < size:
4744                         for j:=i-1; then j=j-1; while j >= 0:
4745                                 if list[j] > list[j+1]:
4746                                         t:= list[j]
4747                                         list[j] = list[j+1]
4748                                         list[j+1] = t
4749                 print " After sort:",
4750                 for i:=0; then i = i + 1; while i < size:
4751                         print "", list[i],
4752                 print
4753
4754                 if 1 == 2 then print "yes"; else print "no"
4755
4756                 bob:fred
4757                 bob.name = "Hello"
4758                 bob.alive = (bob.name == "Hello")
4759                 print "bob", "is" if  bob.alive else "isn't", "alive"