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