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

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