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