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