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