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