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