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