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

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