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