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