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