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