ocean-lang.org Git - ocean/blob - csrc/oceani.mdc

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