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