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 ###### declare terminals
3023
3024         $LEFT if $$ifelse
3025
3026 ###### Grammar
3027
3028         $*exec
3029         Expression -> Expression if Expression else Expression $$ifelse ${ {
3030                         struct binode *b1 = new(binode);
3031                         struct binode *b2 = new(binode);
3032                         b1->op = CondExpr;
3033                         b1->left = $<3;
3034                         b1->right = b2;
3035                         b2->op = CondExpr;
3036                         b2->left = $<1;
3037                         b2->right = $<5;
3038                         $0 = b1;
3039                 } }$
3040                 ## expression grammar
3041
3042 ###### print binode cases
3043
3044         case CondExpr:
3045                 b2 = cast(binode, b->right);
3046                 if (bracket) printf("(");
3047                 print_exec(b2->left, -1, bracket);
3048                 printf(" if ");
3049                 print_exec(b->left, -1, bracket);
3050                 printf(" else ");
3051                 print_exec(b2->right, -1, bracket);
3052                 if (bracket) printf(")");
3053                 break;
3054
3055 ###### propagate binode cases
3056
3057         case CondExpr: {
3058                 /* cond must be Tbool, others must match */
3059                 struct binode *b2 = cast(binode, b->right);
3060                 struct type *t2;
3061
3062                 propagate_types(b->left, c, ok, Tbool, 0);
3063                 t = propagate_types(b2->left, c, ok, type, Rnolabel);
3064                 t2 = propagate_types(b2->right, c, ok, type ?: t, Rnolabel);
3065                 return t ?: t2;
3066         }
3067
3068 ###### interp binode cases
3069
3070         case CondExpr: {
3071                 struct binode *b2 = cast(binode, b->right);
3072                 left = interp_exec(c, b->left, &ltype);
3073                 if (left.bool)
3074                         rv = interp_exec(c, b2->left, &rvtype); // UNTESTED
3075                 else
3076                         rv = interp_exec(c, b2->right, &rvtype);
3077                 }
3078                 break;
3079
3080 ### Expression list
3081
3082 We take a brief detour, now that we have expressions, to describe lists
3083 of expressions.  These will be needed for function parameters and
3084 possibly other situations.  They seem generic enough to introduce here
3085 to be used elsewhere.
3086
3087 And ExpressionList will use the `List` type of `binode`, building up at
3088 the end.  And place where they are used will probably call
3089 `reorder_bilist()` to get a more normal first/next arrangement.
3090
3091 ###### declare terminals
3092         $TERM ,
3093
3094 `List` execs have no implicit semantics, so they are never propagated or
3095 interpreted.  The can be printed as a comma separate list, which is how
3096 they are parsed.  Note they are also used for function formal parameter
3097 lists.  In that case a separate function is used to print them.
3098
3099 ###### print binode cases
3100         case List:
3101                 while (b) {
3102                         printf(" ");
3103                         print_exec(b->left, -1, bracket);
3104                         if (b->right)
3105                                 printf(",");
3106                         b = cast(binode, b->right);
3107                 }
3108                 break;
3109
3110 ###### propagate binode cases
3111         case List: abort(); // NOTEST
3112 ###### interp binode cases
3113         case List: abort(); // NOTEST
3114
3115 ###### Grammar
3116
3117         $*binode
3118         ExpressionList -> ExpressionList , Expression ${
3119                         $0 = new(binode);
3120                         $0->op = List;
3121                         $0->left = $<1;
3122                         $0->right = $<3;
3123                 }$
3124                 | Expression ${
3125                         $0 = new(binode);
3126                         $0->op = List;
3127                         $0->left = NULL;
3128                         $0->right = $<1;
3129                 }$
3130
3131 ### Expressions: Boolean
3132
3133 The next class of expressions to use the `binode` will be Boolean
3134 expressions.  "`and then`" and "`or else`" are similar to `and` and `or`
3135 have same corresponding precendence.  The difference is that they don't
3136 evaluate the second expression if not necessary.
3137
3138 ###### Binode types
3139         And,
3140         AndThen,
3141         Or,
3142         OrElse,
3143         Not,
3144
3145 ###### declare terminals
3146         $LEFT or
3147         $LEFT and
3148         $LEFT not
3149
3150 ###### expression grammar
3151                 | Expression or Expression ${ {
3152                         struct binode *b = new(binode);
3153                         b->op = Or;
3154                         b->left = $<1;
3155                         b->right = $<3;
3156                         $0 = b;
3157                 } }$
3158                 | Expression or else Expression ${ {
3159                         struct binode *b = new(binode);
3160                         b->op = OrElse;
3161                         b->left = $<1;
3162                         b->right = $<4;
3163                         $0 = b;
3164                 } }$
3165
3166                 | Expression and Expression ${ {
3167                         struct binode *b = new(binode);
3168                         b->op = And;
3169                         b->left = $<1;
3170                         b->right = $<3;
3171                         $0 = b;
3172                 } }$
3173                 | Expression and then Expression ${ {
3174                         struct binode *b = new(binode);
3175                         b->op = AndThen;
3176                         b->left = $<1;
3177                         b->right = $<4;
3178                         $0 = b;
3179                 } }$
3180
3181                 | not Expression ${ {
3182                         struct binode *b = new(binode);
3183                         b->op = Not;
3184                         b->right = $<2;
3185                         $0 = b;
3186                 } }$
3187
3188 ###### print binode cases
3189         case And:
3190                 if (bracket) printf("(");
3191                 print_exec(b->left, -1, bracket);
3192                 printf(" and ");
3193                 print_exec(b->right, -1, bracket);
3194                 if (bracket) printf(")");
3195                 break;
3196         case AndThen:
3197                 if (bracket) printf("(");
3198                 print_exec(b->left, -1, bracket);
3199                 printf(" and then ");
3200                 print_exec(b->right, -1, bracket);
3201                 if (bracket) printf(")");
3202                 break;
3203         case Or:
3204                 if (bracket) printf("(");
3205                 print_exec(b->left, -1, bracket);
3206                 printf(" or ");
3207                 print_exec(b->right, -1, bracket);
3208                 if (bracket) printf(")");
3209                 break;
3210         case OrElse:
3211                 if (bracket) printf("(");
3212                 print_exec(b->left, -1, bracket);
3213                 printf(" or else ");
3214                 print_exec(b->right, -1, bracket);
3215                 if (bracket) printf(")");
3216                 break;
3217         case Not:
3218                 if (bracket) printf("(");
3219                 printf("not ");
3220                 print_exec(b->right, -1, bracket);
3221                 if (bracket) printf(")");
3222                 break;
3223
3224 ###### propagate binode cases
3225         case And:
3226         case AndThen:
3227         case Or:
3228         case OrElse:
3229         case Not:
3230                 /* both must be Tbool, result is Tbool */
3231                 propagate_types(b->left, c, ok, Tbool, 0);
3232                 propagate_types(b->right, c, ok, Tbool, 0);
3233                 if (type && type != Tbool)
3234                         type_err(c, "error: %1 operation found where %2 expected", prog,
3235                                    Tbool, 0, type);
3236                 return Tbool;
3237
3238 ###### interp binode cases
3239         case And:
3240                 rv = interp_exec(c, b->left, &rvtype);
3241                 right = interp_exec(c, b->right, &rtype);
3242                 rv.bool = rv.bool && right.bool;
3243                 break;
3244         case AndThen:
3245                 rv = interp_exec(c, b->left, &rvtype);
3246                 if (rv.bool)
3247                         rv = interp_exec(c, b->right, NULL);
3248                 break;
3249         case Or:
3250                 rv = interp_exec(c, b->left, &rvtype);
3251                 right = interp_exec(c, b->right, &rtype);
3252                 rv.bool = rv.bool || right.bool;
3253                 break;
3254         case OrElse:
3255                 rv = interp_exec(c, b->left, &rvtype);
3256                 if (!rv.bool)
3257                         rv = interp_exec(c, b->right, NULL);
3258                 break;
3259         case Not:
3260                 rv = interp_exec(c, b->right, &rvtype);
3261                 rv.bool = !rv.bool;
3262                 break;
3263
3264 ### Expressions: Comparison
3265
3266 Of slightly higher precedence that Boolean expressions are Comparisons.
3267 A comparison takes arguments of any comparable type, but the two types
3268 must be the same.
3269
3270 To simplify the parsing we introduce an `eop` which can record an
3271 expression operator, and the `CMPop` non-terminal will match one of them.
3272
3273 ###### ast
3274         struct eop {
3275                 enum Btype op;
3276         };
3277
3278 ###### ast functions
3279         static void free_eop(struct eop *e)
3280         {
3281                 if (e)
3282                         free(e);
3283         }
3284
3285 ###### Binode types
3286         Less,
3287         Gtr,
3288         LessEq,
3289         GtrEq,
3290         Eql,
3291         NEql,
3292
3293 ###### declare terminals
3294         $LEFT < > <= >= == != CMPop
3295
3296 ###### expression grammar
3297         | Expression CMPop Expression ${ {
3298                 struct binode *b = new(binode);
3299                 b->op = $2.op;
3300                 b->left = $<1;
3301                 b->right = $<3;
3302                 $0 = b;
3303         } }$
3304
3305 ###### Grammar
3306
3307         $eop
3308         CMPop ->   < ${ $0.op = Less; }$
3309                 |  > ${ $0.op = Gtr; }$
3310                 |  <= ${ $0.op = LessEq; }$
3311                 |  >= ${ $0.op = GtrEq; }$
3312                 |  == ${ $0.op = Eql; }$
3313                 |  != ${ $0.op = NEql; }$
3314
3315 ###### print binode cases
3316
3317         case Less:
3318         case LessEq:
3319         case Gtr:
3320         case GtrEq:
3321         case Eql:
3322         case NEql:
3323                 if (bracket) printf("(");
3324                 print_exec(b->left, -1, bracket);
3325                 switch(b->op) {
3326                 case Less:   printf(" < "); break;
3327                 case LessEq: printf(" <= "); break;
3328                 case Gtr:    printf(" > "); break;
3329                 case GtrEq:  printf(" >= "); break;
3330                 case Eql:    printf(" == "); break;
3331                 case NEql:   printf(" != "); break;
3332                 default: abort();               // NOTEST
3333                 }
3334                 print_exec(b->right, -1, bracket);
3335                 if (bracket) printf(")");
3336                 break;
3337
3338 ###### propagate binode cases
3339         case Less:
3340         case LessEq:
3341         case Gtr:
3342         case GtrEq:
3343         case Eql:
3344         case NEql:
3345                 /* Both must match but not be labels, result is Tbool */
3346                 t = propagate_types(b->left, c, ok, NULL, Rnolabel);
3347                 if (t)
3348                         propagate_types(b->right, c, ok, t, 0);
3349                 else {
3350                         t = propagate_types(b->right, c, ok, NULL, Rnolabel);   // UNTESTED
3351                         if (t)  // UNTESTED
3352                                 t = propagate_types(b->left, c, ok, t, 0);      // UNTESTED
3353                 }
3354                 if (!type_compat(type, Tbool, 0))
3355                         type_err(c, "error: Comparison returns %1 but %2 expected", prog,
3356                                     Tbool, rules, type);
3357                 return Tbool;
3358
3359 ###### interp binode cases
3360         case Less:
3361         case LessEq:
3362         case Gtr:
3363         case GtrEq:
3364         case Eql:
3365         case NEql:
3366         {
3367                 int cmp;
3368                 left = interp_exec(c, b->left, &ltype);
3369                 right = interp_exec(c, b->right, &rtype);
3370                 cmp = value_cmp(ltype, rtype, &left, &right);
3371                 rvtype = Tbool;
3372                 switch (b->op) {
3373                 case Less:      rv.bool = cmp <  0; break;
3374                 case LessEq:    rv.bool = cmp <= 0; break;
3375                 case Gtr:       rv.bool = cmp >  0; break;
3376                 case GtrEq:     rv.bool = cmp >= 0; break;
3377                 case Eql:       rv.bool = cmp == 0; break;
3378                 case NEql:      rv.bool = cmp != 0; break;
3379                 default:        rv.bool = 0; break;     // NOTEST
3380                 }
3381                 break;
3382         }
3383
3384 ### Expressions: Arithmetic etc.
3385
3386 The remaining expressions with the highest precedence are arithmetic,
3387 string concatenation, and string conversion.  String concatenation
3388 (`++`) has the same precedence as multiplication and division, but lower
3389 than the uniary.
3390
3391 String conversion is a temporary feature until I get a better type
3392 system.  `$` is a prefix operator which expects a string and returns
3393 a number.
3394
3395 `+` and `-` are both infix and prefix operations (where they are
3396 absolute value and negation).  These have different operator names.
3397
3398 We also have a 'Bracket' operator which records where parentheses were
3399 found.  This makes it easy to reproduce these when printing.  Possibly I
3400 should only insert brackets were needed for precedence.
3401
3402 ###### Binode types
3403         Plus, Minus,
3404         Times, Divide, Rem,
3405         Concat,
3406         Absolute, Negate,
3407         StringConv,
3408         Bracket,
3409
3410 ###### declare terminals
3411         $LEFT + - Eop
3412         $LEFT * / % ++ Top
3413         $LEFT Uop $
3414         $TERM ( )
3415
3416 ###### expression grammar
3417                 | Expression Eop Expression ${ {
3418                         struct binode *b = new(binode);
3419                         b->op = $2.op;
3420                         b->left = $<1;
3421                         b->right = $<3;
3422                         $0 = b;
3423                 } }$
3424
3425                 | Expression Top Expression ${ {
3426                         struct binode *b = new(binode);
3427                         b->op = $2.op;
3428                         b->left = $<1;
3429                         b->right = $<3;
3430                         $0 = b;
3431                 } }$
3432
3433                 | ( Expression ) ${ {
3434                         struct binode *b = new_pos(binode, $1);
3435                         b->op = Bracket;
3436                         b->right = $<2;
3437                         $0 = b;
3438                 } }$
3439                 | Uop Expression ${ {
3440                         struct binode *b = new(binode);
3441                         b->op = $1.op;
3442                         b->right = $<2;
3443                         $0 = b;
3444                 } }$
3445                 | Value ${ $0 = $<1; }$
3446                 | Variable ${ $0 = $<1; }$
3447
3448 ###### Grammar
3449
3450         $eop
3451         Eop ->    + ${ $0.op = Plus; }$
3452                 | - ${ $0.op = Minus; }$
3453
3454         Uop ->    + ${ $0.op = Absolute; }$
3455                 | - ${ $0.op = Negate; }$
3456                 | $ ${ $0.op = StringConv; }$
3457
3458         Top ->    * ${ $0.op = Times; }$
3459                 | / ${ $0.op = Divide; }$
3460                 | % ${ $0.op = Rem; }$
3461                 | ++ ${ $0.op = Concat; }$
3462
3463 ###### print binode cases
3464         case Plus:
3465         case Minus:
3466         case Times:
3467         case Divide:
3468         case Concat:
3469         case Rem:
3470                 if (bracket) printf("(");
3471                 print_exec(b->left, indent, bracket);
3472                 switch(b->op) {
3473                 case Plus:   fputs(" + ", stdout); break;
3474                 case Minus:  fputs(" - ", stdout); break;
3475                 case Times:  fputs(" * ", stdout); break;
3476                 case Divide: fputs(" / ", stdout); break;
3477                 case Rem:    fputs(" % ", stdout); break;
3478                 case Concat: fputs(" ++ ", stdout); break;
3479                 default: abort();       // NOTEST
3480                 }                       // NOTEST
3481                 print_exec(b->right, indent, bracket);
3482                 if (bracket) printf(")");
3483                 break;
3484         case Absolute:
3485         case Negate:
3486         case StringConv:
3487                 if (bracket) printf("(");
3488                 switch (b->op) {
3489                 case Absolute:   fputs("+", stdout); break;
3490                 case Negate:     fputs("-", stdout); break;
3491                 case StringConv: fputs("$", stdout); break;
3492                 default: abort();       // NOTEST
3493                 }                       // NOTEST
3494                 print_exec(b->right, indent, bracket);
3495                 if (bracket) printf(")");
3496                 break;
3497         case Bracket:
3498                 printf("(");
3499                 print_exec(b->right, indent, bracket);
3500                 printf(")");
3501                 break;
3502
3503 ###### propagate binode cases
3504         case Plus:
3505         case Minus:
3506         case Times:
3507         case Rem:
3508         case Divide:
3509                 /* both must be numbers, result is Tnum */
3510         case Absolute:
3511         case Negate:
3512                 /* as propagate_types ignores a NULL,
3513                  * unary ops fit here too */
3514                 propagate_types(b->left, c, ok, Tnum, 0);
3515                 propagate_types(b->right, c, ok, Tnum, 0);
3516                 if (!type_compat(type, Tnum, 0))
3517                         type_err(c, "error: Arithmetic returns %1 but %2 expected", prog,
3518                                    Tnum, rules, type);
3519                 return Tnum;
3520
3521         case Concat:
3522                 /* both must be Tstr, result is Tstr */
3523                 propagate_types(b->left, c, ok, Tstr, 0);
3524                 propagate_types(b->right, c, ok, Tstr, 0);
3525                 if (!type_compat(type, Tstr, 0))
3526                         type_err(c, "error: Concat returns %1 but %2 expected", prog,
3527                                    Tstr, rules, type);
3528                 return Tstr;
3529
3530         case StringConv:
3531                 /* op must be string, result is number */
3532                 propagate_types(b->left, c, ok, Tstr, 0);
3533                 if (!type_compat(type, Tnum, 0))
3534                         type_err(c,     // UNTESTED
3535                           "error: Can only convert string to number, not %1",
3536                                 prog, type, 0, NULL);
3537                 return Tnum;
3538
3539         case Bracket:
3540                 return propagate_types(b->right, c, ok, type, 0);
3541
3542 ###### interp binode cases
3543
3544         case Plus:
3545                 rv = interp_exec(c, b->left, &rvtype);
3546                 right = interp_exec(c, b->right, &rtype);
3547                 mpq_add(rv.num, rv.num, right.num);
3548                 break;
3549         case Minus:
3550                 rv = interp_exec(c, b->left, &rvtype);
3551                 right = interp_exec(c, b->right, &rtype);
3552                 mpq_sub(rv.num, rv.num, right.num);
3553                 break;
3554         case Times:
3555                 rv = interp_exec(c, b->left, &rvtype);
3556                 right = interp_exec(c, b->right, &rtype);
3557                 mpq_mul(rv.num, rv.num, right.num);
3558                 break;
3559         case Divide:
3560                 rv = interp_exec(c, b->left, &rvtype);
3561                 right = interp_exec(c, b->right, &rtype);
3562                 mpq_div(rv.num, rv.num, right.num);
3563                 break;
3564         case Rem: {
3565                 mpz_t l, r, rem;
3566
3567                 left = interp_exec(c, b->left, &ltype);
3568                 right = interp_exec(c, b->right, &rtype);
3569                 mpz_init(l); mpz_init(r); mpz_init(rem);
3570                 mpz_tdiv_q(l, mpq_numref(left.num), mpq_denref(left.num));
3571                 mpz_tdiv_q(r, mpq_numref(right.num), mpq_denref(right.num));
3572                 mpz_tdiv_r(rem, l, r);
3573                 val_init(Tnum, &rv);
3574                 mpq_set_z(rv.num, rem);
3575                 mpz_clear(r); mpz_clear(l); mpz_clear(rem);
3576                 rvtype = ltype;
3577                 break;
3578         }
3579         case Negate:
3580                 rv = interp_exec(c, b->right, &rvtype);
3581                 mpq_neg(rv.num, rv.num);
3582                 break;
3583         case Absolute:
3584                 rv = interp_exec(c, b->right, &rvtype);
3585                 mpq_abs(rv.num, rv.num);
3586                 break;
3587         case Bracket:
3588                 rv = interp_exec(c, b->right, &rvtype);
3589                 break;
3590         case Concat:
3591                 left = interp_exec(c, b->left, &ltype);
3592                 right = interp_exec(c, b->right, &rtype);
3593                 rvtype = Tstr;
3594                 rv.str = text_join(left.str, right.str);
3595                 break;
3596         case StringConv:
3597                 right = interp_exec(c, b->right, &rvtype);
3598                 rtype = Tstr;
3599                 rvtype = Tnum;
3600
3601                 struct text tx = right.str;
3602                 char tail[3];
3603                 int neg = 0;
3604                 if (tx.txt[0] == '-') {
3605                         neg = 1;        // UNTESTED
3606                         tx.txt++;       // UNTESTED
3607                         tx.len--;       // UNTESTED
3608                 }
3609                 if (number_parse(rv.num, tail, tx) == 0)
3610                         mpq_init(rv.num);       // UNTESTED
3611                 else if (neg)
3612                         mpq_neg(rv.num, rv.num);        // UNTESTED
3613                 if (tail[0])
3614                         printf("Unsupported suffix: %.*s\n", tx.len, tx.txt);   // UNTESTED
3615
3616                 break;
3617
3618 ###### value functions
3619
3620         static struct text text_join(struct text a, struct text b)
3621         {
3622                 struct text rv;
3623                 rv.len = a.len + b.len;
3624                 rv.txt = malloc(rv.len);
3625                 memcpy(rv.txt, a.txt, a.len);
3626                 memcpy(rv.txt+a.len, b.txt, b.len);
3627                 return rv;
3628         }
3629
3630 ### Function calls
3631
3632 A function call can appear either as an expression or as a statement.
3633 As functions cannot yet return values, only the statement version will work.
3634 We use a new 'Funcall' binode type to link the function with a list of
3635 arguments, form with the 'List' nodes.
3636
3637 ###### Binode types
3638         Funcall,
3639
3640 ###### expression grammar
3641         | Variable ( ExpressionList ) ${ {
3642                 struct binode *b = new(binode);
3643                 b->op = Funcall;
3644                 b->left = $<V;
3645                 b->right = reorder_bilist($<EL);
3646                 $0 = b;
3647         } }$
3648         | Variable ( ) ${ {
3649                 struct binode *b = new(binode);
3650                 b->op = Funcall;
3651                 b->left = $<V;
3652                 b->right = NULL;
3653                 $0 = b;
3654         } }$
3655
3656 ###### SimpleStatement Grammar
3657
3658         | Variable ( ExpressionList ) ${ {
3659                 struct binode *b = new(binode);
3660                 b->op = Funcall;
3661                 b->left = $<V;
3662                 b->right = reorder_bilist($<EL);
3663                 $0 = b;
3664         } }$
3665
3666 ###### print binode cases
3667
3668         case Funcall:
3669                 do_indent(indent, "");
3670                 print_exec(b->left, -1, bracket);
3671                 printf("(");
3672                 for (b = cast(binode, b->right); b; b = cast(binode, b->right)) {
3673                         if (b->left) {
3674                                 printf(" ");
3675                                 print_exec(b->left, -1, bracket);
3676                                 if (b->right)
3677                                         printf(",");
3678                         }
3679                 }
3680                 printf(")");
3681                 if (indent >= 0)
3682                         printf("\n");
3683                 break;
3684
3685 ###### propagate binode cases
3686
3687         case Funcall: {
3688                 /* Every arg must match formal parameter, and result
3689                  * is return type of function
3690                  */
3691                 struct binode *args = cast(binode, b->right);
3692                 struct var *v = cast(var, b->left);
3693
3694                 if (!v->var->type || v->var->type->check_args == NULL) {
3695                         type_err(c, "error: attempt to call a non-function.",
3696                                  prog, NULL, 0, NULL);
3697                         return NULL;
3698                 }
3699                 v->var->type->check_args(c, ok, v->var->type, args);
3700                 return v->var->type->function.return_type;
3701         }
3702
3703 ###### interp binode cases
3704
3705         case Funcall: {
3706                 struct var *v = cast(var, b->left);
3707                 struct type *t = v->var->type;
3708                 void *oldlocal = c->local;
3709                 int old_size = c->local_size;
3710                 void *local = calloc(1, t->function.local_size);
3711                 struct value *fbody = var_value(c, v->var);
3712                 struct binode *arg = cast(binode, b->right);
3713                 struct binode *param = t->function.params;
3714
3715                 while (param) {
3716                         struct var *pv = cast(var, param->left);
3717                         struct type *vtype = NULL;
3718                         struct value val = interp_exec(c, arg->left, &vtype);
3719                         struct value *lval;
3720                         c->local = local; c->local_size = t->function.local_size;
3721                         lval = var_value(c, pv->var);
3722                         c->local = oldlocal; c->local_size = old_size;
3723                         memcpy(lval, &val, vtype->size);
3724                         param = cast(binode, param->right);
3725                         arg = cast(binode, arg->right);
3726                 }
3727                 c->local = local; c->local_size = t->function.local_size;
3728                 if (t->function.inline_result && dtype) {
3729                         _interp_exec(c, fbody->function, NULL, NULL);
3730                         memcpy(dest, local, dtype->size);
3731                         rvtype = ret.type = NULL;
3732                 } else
3733                         rv = interp_exec(c, fbody->function, &rvtype);
3734                 c->local = oldlocal; c->local_size = old_size;
3735                 free(local);
3736                 break;
3737         }
3738
3739 ### Blocks, Statements, and Statement lists.
3740
3741 Now that we have expressions out of the way we need to turn to
3742 statements.  There are simple statements and more complex statements.
3743 Simple statements do not contain (syntactic) newlines, complex statements do.
3744
3745 Statements often come in sequences and we have corresponding simple
3746 statement lists and complex statement lists.
3747 The former comprise only simple statements separated by semicolons.
3748 The later comprise complex statements and simple statement lists.  They are
3749 separated by newlines.  Thus the semicolon is only used to separate
3750 simple statements on the one line.  This may be overly restrictive,
3751 but I'm not sure I ever want a complex statement to share a line with
3752 anything else.
3753
3754 Note that a simple statement list can still use multiple lines if
3755 subsequent lines are indented, so
3756
3757 ###### Example: wrapped simple statement list
3758
3759         a = b; c = d;
3760            e = f; print g
3761
3762 is a single simple statement list.  This might allow room for
3763 confusion, so I'm not set on it yet.
3764
3765 A simple statement list needs no extra syntax.  A complex statement
3766 list has two syntactic forms.  It can be enclosed in braces (much like
3767 C blocks), or it can be introduced by an indent and continue until an
3768 unindented newline (much like Python blocks).  With this extra syntax
3769 it is referred to as a block.
3770
3771 Note that a block does not have to include any newlines if it only
3772 contains simple statements.  So both of:
3773
3774         if condition: a=b; d=f
3775
3776         if condition { a=b; print f }
3777
3778 are valid.
3779
3780 In either case the list is constructed from a `binode` list with
3781 `Block` as the operator.  When parsing the list it is most convenient
3782 to append to the end, so a list is a list and a statement.  When using
3783 the list it is more convenient to consider a list to be a statement
3784 and a list.  So we need a function to re-order a list.
3785 `reorder_bilist` serves this purpose.
3786
3787 The only stand-alone statement we introduce at this stage is `pass`
3788 which does nothing and is represented as a `NULL` pointer in a `Block`
3789 list.  Other stand-alone statements will follow once the infrastructure
3790 is in-place.
3791
3792 ###### Binode types
3793         Block,
3794
3795 ###### Grammar
3796
3797         $TERM { } ;
3798
3799         $*binode
3800         Block -> { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3801                 | { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3802                 | SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3803                 | SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3804                 | IN OptNL Statementlist OUT ${ $0 = $<Sl; }$
3805
3806         OpenBlock -> OpenScope { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3807                 | OpenScope { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3808                 | OpenScope SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3809                 | OpenScope SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3810                 | IN OpenScope OptNL Statementlist OUT ${ $0 = $<Sl; }$
3811
3812         UseBlock -> { OpenScope IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3813                 | { OpenScope SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3814                 | IN OpenScope OptNL Statementlist OUT ${ $0 = $<Sl; }$
3815
3816         ColonBlock -> { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3817                 | { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3818                 | : SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3819                 | : SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3820                 | : IN OptNL Statementlist OUT ${ $0 = $<Sl; }$
3821
3822         Statementlist -> ComplexStatements ${ $0 = reorder_bilist($<CS); }$
3823
3824         ComplexStatements -> ComplexStatements ComplexStatement ${
3825                         if ($2 == NULL) {
3826                                 $0 = $<1;
3827                         } else {
3828                                 $0 = new(binode);
3829                                 $0->op = Block;
3830                                 $0->left = $<1;
3831                                 $0->right = $<2;
3832                         }
3833                 }$
3834                 | ComplexStatement ${
3835                         if ($1 == NULL) {
3836                                 $0 = NULL;
3837                         } else {
3838                                 $0 = new(binode);
3839                                 $0->op = Block;
3840                                 $0->left = NULL;
3841                                 $0->right = $<1;
3842                         }
3843                 }$
3844
3845         $*exec
3846         ComplexStatement -> SimpleStatements Newlines ${
3847                         $0 = reorder_bilist($<SS);
3848                         }$
3849                 |  SimpleStatements ; Newlines ${
3850                         $0 = reorder_bilist($<SS);
3851                         }$
3852                 ## ComplexStatement Grammar
3853
3854         $*binode
3855         SimpleStatements -> SimpleStatements ; SimpleStatement ${
3856                         $0 = new(binode);
3857                         $0->op = Block;
3858                         $0->left = $<1;
3859                         $0->right = $<3;
3860                         }$
3861                 | SimpleStatement ${
3862                         $0 = new(binode);
3863                         $0->op = Block;
3864                         $0->left = NULL;
3865                         $0->right = $<1;
3866                         }$
3867
3868         $TERM pass
3869         SimpleStatement -> pass ${ $0 = NULL; }$
3870                 | ERROR ${ tok_err(c, "Syntax error in statement", &$1); }$
3871                 ## SimpleStatement Grammar
3872
3873 ###### print binode cases
3874         case Block:
3875                 if (indent < 0) {
3876                         // simple statement
3877                         if (b->left == NULL)    // UNTESTED
3878                                 printf("pass"); // UNTESTED
3879                         else
3880                                 print_exec(b->left, indent, bracket);   // UNTESTED
3881                         if (b->right) { // UNTESTED
3882                                 printf("; ");   // UNTESTED
3883                                 print_exec(b->right, indent, bracket);  // UNTESTED
3884                         }
3885                 } else {
3886                         // block, one per line
3887                         if (b->left == NULL)
3888                                 do_indent(indent, "pass\n");
3889                         else
3890                                 print_exec(b->left, indent, bracket);
3891                         if (b->right)
3892                                 print_exec(b->right, indent, bracket);
3893                 }
3894                 break;
3895
3896 ###### propagate binode cases
3897         case Block:
3898         {
3899                 /* If any statement returns something other than Tnone
3900                  * or Tbool then all such must return same type.
3901                  * As each statement may be Tnone or something else,
3902                  * we must always pass NULL (unknown) down, otherwise an incorrect
3903                  * error might occur.  We never return Tnone unless it is
3904                  * passed in.
3905                  */
3906                 struct binode *e;
3907
3908                 for (e = b; e; e = cast(binode, e->right)) {
3909                         t = propagate_types(e->left, c, ok, NULL, rules);
3910                         if ((rules & Rboolok) && (t == Tbool || t == Tnone))
3911                                 t = NULL;
3912                         if (t == Tnone && e->right)
3913                                 /* Only the final statement *must* return a value
3914                                  * when not Rboolok
3915                                  */
3916                                 t = NULL;
3917                         if (t) {
3918                                 if (!type)
3919                                         type = t;
3920                                 else if (t != type)
3921                                         type_err(c, "error: expected %1%r, found %2",
3922                                                  e->left, type, rules, t);
3923                         }
3924                 }
3925                 return type;
3926         }
3927
3928 ###### interp binode cases
3929         case Block:
3930                 while (rvtype == Tnone &&
3931                        b) {
3932                         if (b->left)
3933                                 rv = interp_exec(c, b->left, &rvtype);
3934                         b = cast(binode, b->right);
3935                 }
3936                 break;
3937
3938 ### The Print statement
3939
3940 `print` is a simple statement that takes a comma-separated list of
3941 expressions and prints the values separated by spaces and terminated
3942 by a newline.  No control of formatting is possible.
3943
3944 `print` uses `ExpressionList` to collect the expressions and stores them
3945 on the left side of a `Print` binode unlessthere is a trailing comma
3946 when the list is stored on the `right` side and no trailing newline is
3947 printed.
3948
3949 ###### Binode types
3950         Print,
3951
3952 ##### declare terminals
3953         $TERM print
3954
3955 ###### SimpleStatement Grammar
3956
3957         | print ExpressionList ${
3958                 $0 = new(binode);
3959                 $0->op = Print;
3960                 $0->right = NULL;
3961                 $0->left = reorder_bilist($<EL);
3962         }$
3963         | print ExpressionList , ${ {
3964                 $0 = new(binode);
3965                 $0->op = Print;
3966                 $0->right = reorder_bilist($<EL);
3967                 $0->left = NULL;
3968         } }$
3969         | print ${
3970                 $0 = new(binode);
3971                 $0->op = Print;
3972                 $0->left = NULL;
3973                 $0->right = NULL;
3974         }$
3975
3976 ###### print binode cases
3977
3978         case Print:
3979                 do_indent(indent, "print");
3980                 if (b->right) {
3981                         print_exec(b->right, -1, bracket);
3982                         printf(",");
3983                 } else
3984                         print_exec(b->left, -1, bracket);
3985                 if (indent >= 0)
3986                         printf("\n");
3987                 break;
3988
3989 ###### propagate binode cases
3990
3991         case Print:
3992                 /* don't care but all must be consistent */
3993                 if (b->left)
3994                         b = cast(binode, b->left);
3995                 else
3996                         b = cast(binode, b->right);
3997                 while (b) {
3998                         propagate_types(b->left, c, ok, NULL, Rnolabel);
3999                         b = cast(binode, b->right);
4000                 }
4001                 break;
4002
4003 ###### interp binode cases
4004
4005         case Print:
4006         {
4007                 struct binode *b2 = cast(binode, b->left);
4008                 if (!b2)
4009                         b2 = cast(binode, b->right);
4010                 for (; b2; b2 = cast(binode, b2->right)) {
4011                         left = interp_exec(c, b2->left, &ltype);
4012                         print_value(ltype, &left, stdout);
4013                         free_value(ltype, &left);
4014                         if (b2->right)
4015                                 putchar(' ');
4016                 }
4017                 if (b->right == NULL)
4018                         printf("\n");
4019                 ltype = Tnone;
4020                 break;
4021         }
4022
4023 ###### Assignment statement
4024
4025 An assignment will assign a value to a variable, providing it hasn't
4026 been declared as a constant.  The analysis phase ensures that the type
4027 will be correct so the interpreter just needs to perform the
4028 calculation.  There is a form of assignment which declares a new
4029 variable as well as assigning a value.  If a name is assigned before
4030 it is declared, and error will be raised as the name is created as
4031 `Tlabel` and it is illegal to assign to such names.
4032
4033 ###### Binode types
4034         Assign,
4035         Declare,
4036
4037 ###### declare terminals
4038         $TERM =
4039
4040 ###### SimpleStatement Grammar
4041         | Variable = Expression ${
4042                         $0 = new(binode);
4043                         $0->op = Assign;
4044                         $0->left = $<1;
4045                         $0->right = $<3;
4046                 }$
4047         | VariableDecl = Expression ${
4048                         $0 = new(binode);
4049                         $0->op = Declare;
4050                         $0->left = $<1;
4051                         $0->right =$<3;
4052                 }$
4053
4054         | VariableDecl ${
4055                         if ($1->var->where_set == NULL) {
4056                                 type_err(c,
4057                                          "Variable declared with no type or value: %v",
4058                                          $1, NULL, 0, NULL);
4059                                 free_var($1);
4060                         } else {
4061                                 $0 = new(binode);
4062                                 $0->op = Declare;
4063                                 $0->left = $<1;
4064                                 $0->right = NULL;
4065                         }
4066                 }$
4067
4068 ###### print binode cases
4069
4070         case Assign:
4071                 do_indent(indent, "");
4072                 print_exec(b->left, indent, bracket);
4073                 printf(" = ");
4074                 print_exec(b->right, indent, bracket);
4075                 if (indent >= 0)
4076                         printf("\n");
4077                 break;
4078
4079         case Declare:
4080                 {
4081                 struct variable *v = cast(var, b->left)->var;
4082                 do_indent(indent, "");
4083                 print_exec(b->left, indent, bracket);
4084                 if (cast(var, b->left)->var->constant) {
4085                         printf("::");
4086                         if (v->explicit_type) {
4087                                 type_print(v->type, stdout);
4088                                 printf(" ");
4089                         }
4090                 } else {
4091                         printf(":");
4092                         if (v->explicit_type) {
4093                                 type_print(v->type, stdout);
4094                                 printf(" ");
4095                         }
4096                 }
4097                 if (b->right) {
4098                         printf("= ");
4099                         print_exec(b->right, indent, bracket);
4100                 }
4101                 if (indent >= 0)
4102                         printf("\n");
4103                 }
4104                 break;
4105
4106 ###### propagate binode cases
4107
4108         case Assign:
4109         case Declare:
4110                 /* Both must match and not be labels,
4111                  * Type must support 'dup',
4112                  * For Assign, left must not be constant.
4113                  * result is Tnone
4114                  */
4115                 t = propagate_types(b->left, c, ok, NULL,
4116                                     Rnolabel | (b->op == Assign ? Rnoconstant : 0));
4117                 if (!b->right)
4118                         return Tnone;
4119
4120                 if (t) {
4121                         if (propagate_types(b->right, c, ok, t, 0) != t)
4122                                 if (b->left->type == Xvar)
4123                                         type_err(c, "info: variable '%v' was set as %1 here.",
4124                                                  cast(var, b->left)->var->where_set, t, rules, NULL);
4125                 } else {
4126                         t = propagate_types(b->right, c, ok, NULL, Rnolabel);
4127                         if (t)
4128                                 propagate_types(b->left, c, ok, t,
4129                                                 (b->op == Assign ? Rnoconstant : 0));
4130                 }
4131                 if (t && t->dup == NULL && t->name.txt[0] != ' ') // HACK
4132                         type_err(c, "error: cannot assign value of type %1", b, t, 0, NULL);
4133                 return Tnone;
4134
4135                 break;
4136
4137 ###### interp binode cases
4138
4139         case Assign:
4140                 lleft = linterp_exec(c, b->left, &ltype);
4141                 if (lleft)
4142                         dinterp_exec(c, b->right, lleft, ltype, 1);
4143                 ltype = Tnone;
4144                 break;
4145
4146         case Declare:
4147         {
4148                 struct variable *v = cast(var, b->left)->var;
4149                 struct value *val;
4150                 v = v->merged;
4151                 val = var_value(c, v);
4152                 if (v->type->prepare_type)
4153                         v->type->prepare_type(c, v->type, 0);
4154                 if (b->right)
4155                         dinterp_exec(c, b->right, val, v->type, 0);
4156                 else
4157                         val_init(v->type, val);
4158                 break;
4159         }
4160
4161 ### The `use` statement
4162
4163 The `use` statement is the last "simple" statement.  It is needed when a
4164 statement block can return a value.  This includes the body of a
4165 function which has a return type, and the "condition" code blocks in
4166 `if`, `while`, and `switch` statements.
4167
4168 ###### Binode types
4169         Use,
4170
4171 ###### declare terminals
4172         $TERM use
4173
4174 ###### SimpleStatement Grammar
4175         | use Expression ${
4176                 $0 = new_pos(binode, $1);
4177                 $0->op = Use;
4178                 $0->right = $<2;
4179                 if ($0->right->type == Xvar) {
4180                         struct var *v = cast(var, $0->right);
4181                         if (v->var->type == Tnone) {
4182                                 /* Convert this to a label */
4183                                 struct value *val;
4184
4185                                 v->var->type = Tlabel;
4186                                 val = global_alloc(c, Tlabel, v->var, NULL);
4187                                 val->label = val;
4188                         }
4189                 }
4190         }$
4191
4192 ###### print binode cases
4193
4194         case Use:
4195                 do_indent(indent, "use ");
4196                 print_exec(b->right, -1, bracket);
4197                 if (indent >= 0)
4198                         printf("\n");
4199                 break;
4200
4201 ###### propagate binode cases
4202
4203         case Use:
4204                 /* result matches value */
4205                 return propagate_types(b->right, c, ok, type, 0);
4206
4207 ###### interp binode cases
4208
4209         case Use:
4210                 rv = interp_exec(c, b->right, &rvtype);
4211                 break;
4212
4213 ### The Conditional Statement
4214
4215 This is the biggy and currently the only complex statement.  This
4216 subsumes `if`, `while`, `do/while`, `switch`, and some parts of `for`.
4217 It is comprised of a number of parts, all of which are optional though
4218 set combinations apply.  Each part is (usually) a key word (`then` is
4219 sometimes optional) followed by either an expression or a code block,
4220 except the `casepart` which is a "key word and an expression" followed
4221 by a code block.  The code-block option is valid for all parts and,
4222 where an expression is also allowed, the code block can use the `use`
4223 statement to report a value.  If the code block does not report a value
4224 the effect is similar to reporting `True`.
4225
4226 The `else` and `case` parts, as well as `then` when combined with
4227 `if`, can contain a `use` statement which will apply to some
4228 containing conditional statement. `for` parts, `do` parts and `then`
4229 parts used with `for` can never contain a `use`, except in some
4230 subordinate conditional statement.
4231
4232 If there is a `forpart`, it is executed first, only once.
4233 If there is a `dopart`, then it is executed repeatedly providing
4234 always that the `condpart` or `cond`, if present, does not return a non-True
4235 value.  `condpart` can fail to return any value if it simply executes
4236 to completion.  This is treated the same as returning `True`.
4237
4238 If there is a `thenpart` it will be executed whenever the `condpart`
4239 or `cond` returns True (or does not return any value), but this will happen
4240 *after* `dopart` (when present).
4241
4242 If `elsepart` is present it will be executed at most once when the
4243 condition returns `False` or some value that isn't `True` and isn't
4244 matched by any `casepart`.  If there are any `casepart`s, they will be
4245 executed when the condition returns a matching value.
4246
4247 The particular sorts of values allowed in case parts has not yet been
4248 determined in the language design, so nothing is prohibited.
4249
4250 The various blocks in this complex statement potentially provide scope
4251 for variables as described earlier.  Each such block must include the
4252 "OpenScope" nonterminal before parsing the block, and must call
4253 `var_block_close()` when closing the block.
4254
4255 The code following "`if`", "`switch`" and "`for`" does not get its own
4256 scope, but is in a scope covering the whole statement, so names
4257 declared there cannot be redeclared elsewhere.  Similarly the
4258 condition following "`while`" is in a scope the covers the body
4259 ("`do`" part) of the loop, and which does not allow conditional scope
4260 extension.  Code following "`then`" (both looping and non-looping),
4261 "`else`" and "`case`" each get their own local scope.
4262
4263 The type requirements on the code block in a `whilepart` are quite
4264 unusal.  It is allowed to return a value of some identifiable type, in
4265 which case the loop aborts and an appropriate `casepart` is run, or it
4266 can return a Boolean, in which case the loop either continues to the
4267 `dopart` (on `True`) or aborts and runs the `elsepart` (on `False`).
4268 This is different both from the `ifpart` code block which is expected to
4269 return a Boolean, or the `switchpart` code block which is expected to
4270 return the same type as the casepart values.  The correct analysis of
4271 the type of the `whilepart` code block is the reason for the
4272 `Rboolok` flag which is passed to `propagate_types()`.
4273
4274 The `cond_statement` cannot fit into a `binode` so a new `exec` is
4275 defined.  As there are two scopes which cover multiple parts - one for
4276 the whole statement and one for "while" and "do" - and as we will use
4277 the 'struct exec' to track scopes, we actually need two new types of
4278 exec.  One is a `binode` for the looping part, the rest is the
4279 `cond_statement`.  The `cond_statement` will use an auxilliary `struct
4280 casepart` to track a list of case parts.
4281
4282 ###### Binode types
4283         Loop
4284
4285 ###### exec type
4286         Xcond_statement,
4287
4288 ###### ast
4289         struct casepart {
4290                 struct exec *value;
4291                 struct exec *action;
4292                 struct casepart *next;
4293         };
4294         struct cond_statement {
4295                 struct exec;
4296                 struct exec *forpart, *condpart, *thenpart, *elsepart;
4297                 struct binode *looppart;
4298                 struct casepart *casepart;
4299         };
4300
4301 ###### ast functions
4302
4303         static void free_casepart(struct casepart *cp)
4304         {
4305                 while (cp) {
4306                         struct casepart *t;
4307                         free_exec(cp->value);
4308                         free_exec(cp->action);
4309                         t = cp->next;
4310                         free(cp);
4311                         cp = t;
4312                 }
4313         }
4314
4315         static void free_cond_statement(struct cond_statement *s)
4316         {
4317                 if (!s)
4318                         return;
4319                 free_exec(s->forpart);
4320                 free_exec(s->condpart);
4321                 free_exec(s->looppart);
4322                 free_exec(s->thenpart);
4323                 free_exec(s->elsepart);
4324                 free_casepart(s->casepart);
4325                 free(s);
4326         }
4327
4328 ###### free exec cases
4329         case Xcond_statement: free_cond_statement(cast(cond_statement, e)); break;
4330
4331 ###### ComplexStatement Grammar
4332         | CondStatement ${ $0 = $<1; }$
4333
4334 ###### declare terminals
4335         $TERM for then while do
4336         $TERM else
4337         $TERM switch case
4338
4339 ###### Grammar
4340
4341         $*cond_statement
4342         // A CondStatement must end with EOL, as does CondSuffix and
4343         // IfSuffix.
4344         // ForPart, ThenPart, SwitchPart, CasePart are non-empty and
4345         // may or may not end with EOL
4346         // WhilePart and IfPart include an appropriate Suffix
4347
4348         // ForPart, SwitchPart, and IfPart open scopes, o we have to close
4349         // them.  WhilePart opens and closes its own scope.
4350         CondStatement -> ForPart OptNL ThenPart OptNL WhilePart CondSuffix ${
4351                         $0 = $<CS;
4352                         $0->forpart = $<FP;
4353                         $0->thenpart = $<TP;
4354                         $0->looppart = $<WP;
4355                         var_block_close(c, CloseSequential, $0);
4356                         }$
4357                 | ForPart OptNL WhilePart CondSuffix ${
4358                         $0 = $<CS;
4359                         $0->forpart = $<FP;
4360                         $0->looppart = $<WP;
4361                         var_block_close(c, CloseSequential, $0);
4362                         }$
4363                 | WhilePart CondSuffix ${
4364                         $0 = $<CS;
4365                         $0->looppart = $<WP;
4366                         }$
4367                 | SwitchPart OptNL CasePart CondSuffix ${
4368                         $0 = $<CS;
4369                         $0->condpart = $<SP;
4370                         $CP->next = $0->casepart;
4371                         $0->casepart = $<CP;
4372                         var_block_close(c, CloseSequential, $0);
4373                         }$
4374                 | SwitchPart : IN OptNL CasePart CondSuffix OUT Newlines ${
4375                         $0 = $<CS;
4376                         $0->condpart = $<SP;
4377                         $CP->next = $0->casepart;
4378                         $0->casepart = $<CP;
4379                         var_block_close(c, CloseSequential, $0);
4380                         }$
4381                 | IfPart IfSuffix ${
4382                         $0 = $<IS;
4383                         $0->condpart = $IP.condpart; $IP.condpart = NULL;
4384                         $0->thenpart = $IP.thenpart; $IP.thenpart = NULL;
4385                         // This is where we close an "if" statement
4386                         var_block_close(c, CloseSequential, $0);
4387                         }$
4388
4389         CondSuffix -> IfSuffix ${
4390                         $0 = $<1;
4391                 }$
4392                 | Newlines CasePart CondSuffix ${
4393                         $0 = $<CS;
4394                         $CP->next = $0->casepart;
4395                         $0->casepart = $<CP;
4396                 }$
4397                 | CasePart CondSuffix ${
4398                         $0 = $<CS;
4399                         $CP->next = $0->casepart;
4400                         $0->casepart = $<CP;
4401                 }$
4402
4403         IfSuffix -> Newlines ${ $0 = new(cond_statement); }$
4404                 | Newlines ElsePart ${ $0 = $<EP; }$
4405                 | ElsePart ${$0 = $<EP; }$
4406
4407         ElsePart -> else OpenBlock Newlines ${
4408                         $0 = new(cond_statement);
4409                         $0->elsepart = $<OB;
4410                         var_block_close(c, CloseElse, $0->elsepart);
4411                 }$
4412                 | else OpenScope CondStatement ${
4413                         $0 = new(cond_statement);
4414                         $0->elsepart = $<CS;
4415                         var_block_close(c, CloseElse, $0->elsepart);
4416                 }$
4417
4418         $*casepart
4419         CasePart -> case Expression OpenScope ColonBlock ${
4420                         $0 = calloc(1,sizeof(struct casepart));
4421                         $0->value = $<Ex;
4422                         $0->action = $<Bl;
4423                         var_block_close(c, CloseParallel, $0->action);
4424                 }$
4425
4426         $*exec
4427         // These scopes are closed in CondStatement
4428         ForPart -> for OpenBlock ${
4429                         $0 = $<Bl;
4430                 }$
4431
4432         ThenPart -> then OpenBlock ${
4433                         $0 = $<OB;
4434                         var_block_close(c, CloseSequential, $0);
4435                 }$
4436
4437         $*binode
4438         // This scope is closed in CondStatement
4439         WhilePart -> while UseBlock OptNL do OpenBlock ${
4440                         $0 = new(binode);
4441                         $0->op = Loop;
4442                         $0->left = $<UB;
4443                         $0->right = $<OB;
4444                         var_block_close(c, CloseSequential, $0->right);
4445                         var_block_close(c, CloseSequential, $0);
4446                 }$
4447                 | while OpenScope Expression OpenScope ColonBlock ${
4448                         $0 = new(binode);
4449                         $0->op = Loop;
4450                         $0->left = $<Exp;
4451                         $0->right = $<CB;
4452                         var_block_close(c, CloseSequential, $0->right);
4453                         var_block_close(c, CloseSequential, $0);
4454                 }$
4455
4456         $cond_statement
4457         IfPart -> if UseBlock OptNL then OpenBlock ${
4458                         $0.condpart = $<UB;
4459                         $0.thenpart = $<OB;
4460                         var_block_close(c, CloseParallel, $0.thenpart);
4461                 }$
4462                 | if OpenScope Expression OpenScope ColonBlock ${
4463                         $0.condpart = $<Ex;
4464                         $0.thenpart = $<CB;
4465                         var_block_close(c, CloseParallel, $0.thenpart);
4466                 }$
4467                 | if OpenScope Expression OpenScope OptNL then Block ${
4468                         $0.condpart = $<Ex;
4469                         $0.thenpart = $<Bl;
4470                         var_block_close(c, CloseParallel, $0.thenpart);
4471                 }$
4472
4473         $*exec
4474         // This scope is closed in CondStatement
4475         SwitchPart -> switch OpenScope Expression ${
4476                         $0 = $<Ex;
4477                 }$
4478                 | switch UseBlock ${
4479                         $0 = $<Bl;
4480                 }$
4481
4482 ###### print binode cases
4483         case Loop:
4484                 if (b->left && b->left->type == Xbinode &&
4485                     cast(binode, b->left)->op == Block) {
4486                         if (bracket)
4487                                 do_indent(indent, "while {\n");
4488                         else
4489                                 do_indent(indent, "while\n");
4490                         print_exec(b->left, indent+1, bracket);
4491                         if (bracket)
4492                                 do_indent(indent, "} do {\n");
4493                         else
4494                                 do_indent(indent, "do\n");
4495                         print_exec(b->right, indent+1, bracket);
4496                         if (bracket)
4497                                 do_indent(indent, "}\n");
4498                 } else {
4499                         do_indent(indent, "while ");
4500                         print_exec(b->left, 0, bracket);
4501                         if (bracket)
4502                                 printf(" {\n");
4503                         else
4504                                 printf(":\n");
4505                         print_exec(b->right, indent+1, bracket);
4506                         if (bracket)
4507                                 do_indent(indent, "}\n");
4508                 }
4509                 break;
4510
4511 ###### print exec cases
4512
4513         case Xcond_statement:
4514         {
4515                 struct cond_statement *cs = cast(cond_statement, e);
4516                 struct casepart *cp;
4517                 if (cs->forpart) {
4518                         do_indent(indent, "for");
4519                         if (bracket) printf(" {\n"); else printf("\n");
4520                         print_exec(cs->forpart, indent+1, bracket);
4521                         if (cs->thenpart) {
4522                                 if (bracket)
4523                                         do_indent(indent, "} then {\n");
4524                                 else
4525                                         do_indent(indent, "then\n");
4526                                 print_exec(cs->thenpart, indent+1, bracket);
4527                         }
4528                         if (bracket) do_indent(indent, "}\n");
4529                 }
4530                 if (cs->looppart) {
4531                         print_exec(cs->looppart, indent, bracket);
4532                 } else {
4533                         // a condition
4534                         if (cs->casepart)
4535                                 do_indent(indent, "switch");
4536                         else
4537                                 do_indent(indent, "if");
4538                         if (cs->condpart && cs->condpart->type == Xbinode &&
4539                             cast(binode, cs->condpart)->op == Block) {
4540                                 if (bracket)
4541                                         printf(" {\n");
4542                                 else
4543                                         printf("\n");
4544                                 print_exec(cs->condpart, indent+1, bracket);
4545                                 if (bracket)
4546                                         do_indent(indent, "}\n");
4547                                 if (cs->thenpart) {
4548                                         do_indent(indent, "then\n");
4549                                         print_exec(cs->thenpart, indent+1, bracket);
4550                                 }
4551                         } else {
4552                                 printf(" ");
4553                                 print_exec(cs->condpart, 0, bracket);
4554                                 if (cs->thenpart) {
4555                                         if (bracket)
4556                                                 printf(" {\n");
4557                                         else
4558                                                 printf(":\n");
4559                                         print_exec(cs->thenpart, indent+1, bracket);
4560                                         if (bracket)
4561                                                 do_indent(indent, "}\n");
4562                                 } else
4563                                         printf("\n");
4564                         }
4565                 }
4566                 for (cp = cs->casepart; cp; cp = cp->next) {
4567                         do_indent(indent, "case ");
4568                         print_exec(cp->value, -1, 0);
4569                         if (bracket)
4570                                 printf(" {\n");
4571                         else
4572                                 printf(":\n");
4573                         print_exec(cp->action, indent+1, bracket);
4574                         if (bracket)
4575                                 do_indent(indent, "}\n");
4576                 }
4577                 if (cs->elsepart) {
4578                         do_indent(indent, "else");
4579                         if (bracket)
4580                                 printf(" {\n");
4581                         else
4582                                 printf("\n");
4583                         print_exec(cs->elsepart, indent+1, bracket);
4584                         if (bracket)
4585                                 do_indent(indent, "}\n");
4586                 }
4587                 break;
4588         }
4589
4590 ###### propagate binode cases
4591         case Loop:
4592                 t = propagate_types(b->right, c, ok, Tnone, 0);
4593                 if (!type_compat(Tnone, t, 0))
4594                         *ok = 0;        // UNTESTED
4595                 return propagate_types(b->left, c, ok, type, rules);
4596
4597 ###### propagate exec cases
4598         case Xcond_statement:
4599         {
4600                 // forpart and looppart->right must return Tnone
4601                 // thenpart must return Tnone if there is a loopart,
4602                 // otherwise it is like elsepart.
4603                 // condpart must:
4604                 //    be bool if there is no casepart
4605                 //    match casepart->values if there is a switchpart
4606                 //    either be bool or match casepart->value if there
4607                 //             is a whilepart
4608                 // elsepart and casepart->action must match the return type
4609                 //   expected of this statement.
4610                 struct cond_statement *cs = cast(cond_statement, prog);
4611                 struct casepart *cp;
4612
4613                 t = propagate_types(cs->forpart, c, ok, Tnone, 0);
4614                 if (!type_compat(Tnone, t, 0))
4615                         *ok = 0;        // UNTESTED
4616
4617                 if (cs->looppart) {
4618                         t = propagate_types(cs->thenpart, c, ok, Tnone, 0);
4619                         if (!type_compat(Tnone, t, 0))
4620                                 *ok = 0;        // UNTESTED
4621                 }
4622                 if (cs->casepart == NULL) {
4623                         propagate_types(cs->condpart, c, ok, Tbool, 0);
4624                         propagate_types(cs->looppart, c, ok, Tbool, 0);
4625                 } else {
4626                         /* Condpart must match case values, with bool permitted */
4627                         t = NULL;
4628                         for (cp = cs->casepart;
4629                              cp && !t; cp = cp->next)
4630                                 t = propagate_types(cp->value, c, ok, NULL, 0);
4631                         if (!t && cs->condpart)
4632                                 t = propagate_types(cs->condpart, c, ok, NULL, Rboolok);        // UNTESTED
4633                         if (!t && cs->looppart)
4634                                 t = propagate_types(cs->looppart, c, ok, NULL, Rboolok);        // UNTESTED
4635                         // Now we have a type (I hope) push it down
4636                         if (t) {
4637                                 for (cp = cs->casepart; cp; cp = cp->next)
4638                                         propagate_types(cp->value, c, ok, t, 0);
4639                                 propagate_types(cs->condpart, c, ok, t, Rboolok);
4640                                 propagate_types(cs->looppart, c, ok, t, Rboolok);
4641                         }
4642                 }
4643                 // (if)then, else, and case parts must return expected type.
4644                 if (!cs->looppart && !type)
4645                         type = propagate_types(cs->thenpart, c, ok, NULL, rules);
4646                 if (!type)
4647                         type = propagate_types(cs->elsepart, c, ok, NULL, rules);
4648                 for (cp = cs->casepart;
4649                      cp && !type;
4650                      cp = cp->next)     // UNTESTED
4651                         type = propagate_types(cp->action, c, ok, NULL, rules); // UNTESTED
4652                 if (type) {
4653                         if (!cs->looppart)
4654                                 propagate_types(cs->thenpart, c, ok, type, rules);
4655                         propagate_types(cs->elsepart, c, ok, type, rules);
4656                         for (cp = cs->casepart; cp ; cp = cp->next)
4657                                 propagate_types(cp->action, c, ok, type, rules);
4658                         return type;
4659                 } else
4660                         return NULL;
4661         }
4662
4663 ###### interp binode cases
4664         case Loop:
4665                 // This just performs one iterration of the loop
4666                 rv = interp_exec(c, b->left, &rvtype);
4667                 if (rvtype == Tnone ||
4668                     (rvtype == Tbool && rv.bool != 0))
4669                         // rvtype is Tnone or Tbool, doesn't need to be freed
4670                         interp_exec(c, b->right, NULL);
4671                 break;
4672
4673 ###### interp exec cases
4674         case Xcond_statement:
4675         {
4676                 struct value v, cnd;
4677                 struct type *vtype, *cndtype;
4678                 struct casepart *cp;
4679                 struct cond_statement *cs = cast(cond_statement, e);
4680
4681                 if (cs->forpart)
4682                         interp_exec(c, cs->forpart, NULL);
4683                 if (cs->looppart) {
4684                         while ((cnd = interp_exec(c, cs->looppart, &cndtype)),
4685                                cndtype == Tnone || (cndtype == Tbool && cnd.bool != 0))
4686                                 interp_exec(c, cs->thenpart, NULL);
4687                 } else {
4688                         cnd = interp_exec(c, cs->condpart, &cndtype);
4689                         if ((cndtype == Tnone ||
4690                             (cndtype == Tbool && cnd.bool != 0))) {
4691                                 // cnd is Tnone or Tbool, doesn't need to be freed
4692                                 rv = interp_exec(c, cs->thenpart, &rvtype);
4693                                 // skip else (and cases)
4694                                 goto Xcond_done;
4695                         }
4696                 }
4697                 for (cp = cs->casepart; cp; cp = cp->next) {
4698                         v = interp_exec(c, cp->value, &vtype);
4699                         if (value_cmp(cndtype, vtype, &v, &cnd) == 0) {
4700                                 free_value(vtype, &v);
4701                                 free_value(cndtype, &cnd);
4702                                 rv = interp_exec(c, cp->action, &rvtype);
4703                                 goto Xcond_done;
4704                         }
4705                         free_value(vtype, &v);
4706                 }
4707                 free_value(cndtype, &cnd);
4708                 if (cs->elsepart)
4709                         rv = interp_exec(c, cs->elsepart, &rvtype);
4710                 else
4711                         rvtype = Tnone;
4712         Xcond_done:
4713                 break;
4714         }
4715
4716 ### Top level structure
4717
4718 All the language elements so far can be used in various places.  Now
4719 it is time to clarify what those places are.
4720
4721 At the top level of a file there will be a number of declarations.
4722 Many of the things that can be declared haven't been described yet,
4723 such as functions, procedures, imports, and probably more.
4724 For now there are two sorts of things that can appear at the top
4725 level.  They are predefined constants, `struct` types, and the `main`
4726 function.  While the syntax will allow the `main` function to appear
4727 multiple times, that will trigger an error if it is actually attempted.
4728
4729 The various declarations do not return anything.  They store the
4730 various declarations in the parse context.
4731
4732 ###### Parser: grammar
4733
4734         $void
4735         Ocean -> OptNL DeclarationList
4736
4737         ## declare terminals
4738
4739         OptNL ->
4740                 | OptNL NEWLINE
4741         Newlines -> NEWLINE
4742                 | Newlines NEWLINE
4743
4744         DeclarationList -> Declaration
4745                 | DeclarationList Declaration
4746
4747         Declaration -> ERROR Newlines ${
4748                         tok_err(c,      // UNTESTED
4749                                 "error: unhandled parse error", &$1);
4750                 }$
4751                 | DeclareConstant
4752                 | DeclareFunction
4753                 | DeclareStruct
4754
4755         ## top level grammar
4756
4757         ## Grammar
4758
4759 ### The `const` section
4760
4761 As well as being defined in with the code that uses them, constants
4762 can be declared at the top level.  These have full-file scope, so they
4763 are always `InScope`.  The value of a top level constant can be given
4764 as an expression, and this is evaluated immediately rather than in the
4765 later interpretation stage.  Once we add functions to the language, we
4766 will need rules concern which, if any, can be used to define a top
4767 level constant.
4768
4769 Constants are defined in a section that starts with the reserved word
4770 `const` and then has a block with a list of assignment statements.
4771 For syntactic consistency, these must use the double-colon syntax to
4772 make it clear that they are constants.  Type can also be given: if
4773 not, the type will be determined during analysis, as with other
4774 constants.
4775
4776 As the types constants are inserted at the head of a list, printing
4777 them in the same order that they were read is not straight forward.
4778 We take a quadratic approach here and count the number of constants
4779 (variables of depth 0), then count down from there, each time
4780 searching through for the Nth constant for decreasing N.
4781
4782 ###### top level grammar
4783
4784         $TERM const
4785
4786         DeclareConstant -> const { IN OptNL ConstList OUT OptNL } Newlines
4787                 | const { SimpleConstList } Newlines
4788                 | const IN OptNL ConstList OUT Newlines
4789                 | const SimpleConstList Newlines
4790
4791         ConstList -> ConstList SimpleConstLine
4792                 | SimpleConstLine
4793         SimpleConstList -> SimpleConstList ; Const
4794                 | Const
4795                 | SimpleConstList ;
4796         SimpleConstLine -> SimpleConstList Newlines
4797                 | ERROR Newlines ${ tok_err(c, "Syntax error in constant", &$1); }$
4798
4799         $*type
4800         CType -> Type   ${ $0 = $<1; }$
4801                 |       ${ $0 = NULL; }$
4802         $void
4803         Const -> IDENTIFIER :: CType = Expression ${ {
4804                 int ok;
4805                 struct variable *v;
4806
4807                 v = var_decl(c, $1.txt);
4808                 if (v) {
4809                         struct var *var = new_pos(var, $1);
4810                         v->where_decl = var;
4811                         v->where_set = var;
4812                         var->var = v;
4813                         v->constant = 1;
4814                         v->global = 1;
4815                 } else {
4816                         struct variable *vorig = var_ref(c, $1.txt);
4817                         tok_err(c, "error: name already declared", &$1);
4818                         type_err(c, "info: this is where '%v' was first declared",
4819                                  vorig->where_decl, NULL, 0, NULL);
4820                 }
4821                 do {
4822                         ok = 1;
4823                         propagate_types($5, c, &ok, $3, 0);
4824                 } while (ok == 2);
4825                 if (!ok)
4826                         c->parse_error = 1;
4827                 else if (v) {
4828                         struct value res = interp_exec(c, $5, &v->type);
4829                         global_alloc(c, v->type, v, &res);
4830                 }
4831         } }$
4832
4833 ###### print const decls
4834         {
4835                 struct variable *v;
4836                 int target = -1;
4837
4838                 while (target != 0) {
4839                         int i = 0;
4840                         for (v = context.in_scope; v; v=v->in_scope)
4841                                 if (v->depth == 0 && v->constant) {
4842                                         i += 1;
4843                                         if (i == target)
4844                                                 break;
4845                                 }
4846
4847                         if (target == -1) {
4848                                 if (i)
4849                                         printf("const\n");
4850                                 target = i;
4851                         } else {
4852                                 struct value *val = var_value(&context, v);
4853                                 printf("    %.*s :: ", v->name->name.len, v->name->name.txt);
4854                                 type_print(v->type, stdout);
4855                                 printf(" = ");
4856                                 if (v->type == Tstr)
4857                                         printf("\"");
4858                                 print_value(v->type, val, stdout);
4859                                 if (v->type == Tstr)
4860                                         printf("\"");
4861                                 printf("\n");
4862                                 target -= 1;
4863                         }
4864                 }
4865         }
4866
4867 ### Function declarations
4868
4869 The code in an Ocean program is all stored in function declarations.
4870 One of the functions must be named `main` and it must accept an array of
4871 strings as a parameter - the command line arguments.
4872
4873 As this is the top level, several things are handled a bit differently.
4874 The function is not interpreted by `interp_exec` as that isn't passed
4875 the argument list which the program requires.  Similarly type analysis
4876 is a bit more interesting at this level.
4877
4878 ###### ast functions
4879
4880         static struct type *handle_results(struct parse_context *c,
4881                                            struct binode *results)
4882         {
4883                 /* Create a 'struct' type from the results list, which
4884                  * is a list for 'struct var'
4885                  */
4886                 struct text result_type_name = { " function_result", 5 };
4887                 struct type *t = add_type(c, result_type_name, &structure_prototype);
4888                 int cnt = 0;
4889                 struct binode *b;
4890
4891                 for (b = results; b; b = cast(binode, b->right))
4892                         cnt += 1;
4893                 t->structure.nfields = cnt;
4894                 t->structure.fields = calloc(cnt, sizeof(struct field));
4895                 cnt = 0;
4896                 for (b = results; b; b = cast(binode, b->right)) {
4897                         struct var *v = cast(var, b->left);
4898                         struct field *f = &t->structure.fields[cnt++];
4899                         int a = v->var->type->align;
4900                         f->name = v->var->name->name;
4901                         f->type = v->var->type;
4902                         f->init = NULL;
4903                         f->offset = t->size;
4904                         v->var->frame_pos = f->offset;
4905                         t->size += ((f->type->size - 1) | (a-1)) + 1;
4906                         if (a > t->align)
4907                                 t->align = a;
4908                         variable_unlink_exec(v->var);
4909                 }
4910                 free_binode(results);
4911                 return t;
4912         }
4913
4914         static struct variable *declare_function(struct parse_context *c,
4915                                                 struct variable *name,
4916                                                 struct binode *args,
4917                                                 struct type *ret,
4918                                                 struct binode *results,
4919                                                 struct exec *code)
4920         {
4921                 struct text funcname = {" func", 5};
4922                 if (name) {
4923                         struct value fn = {.function = code};
4924                         struct type *t;
4925                         var_block_close(c, CloseFunction, code);
4926                         t = add_type(c, funcname, &function_prototype);
4927                         name->type = t;
4928                         t->function.params = reorder_bilist(args);
4929                         if (!ret) {
4930                                 ret = handle_results(c, reorder_bilist(results));
4931                                 t->function.inline_result = 1;
4932                                 t->function.local_size = ret->size;
4933                         }
4934                         t->function.return_type = ret;
4935                         global_alloc(c, t, name, &fn);
4936                         name->type->function.scope = c->out_scope;
4937                 } else {
4938                         free_binode(args);
4939                         free_type(ret);
4940                         free_exec(code);
4941                         var_block_close(c, CloseFunction, NULL);
4942                 }
4943                 c->out_scope = NULL;
4944                 return name;
4945         }
4946
4947 ###### declare terminals
4948         $TERM return
4949
4950 ###### top level grammar
4951
4952         $*variable
4953         DeclareFunction -> func FuncName ( OpenScope ArgsLine ) Block Newlines ${
4954                         $0 = declare_function(c, $<FN, $<Ar, Tnone, NULL, $<Bl);
4955                 }$
4956                 | func FuncName IN OpenScope Args OUT OptNL do Block Newlines ${
4957                         $0 = declare_function(c, $<FN, $<Ar, Tnone, NULL, $<Bl);
4958                 }$
4959                 | func FuncName NEWLINE OpenScope OptNL do Block Newlines ${
4960                         $0 = declare_function(c, $<FN, NULL, Tnone, NULL, $<Bl);
4961                 }$
4962                 | func FuncName ( OpenScope ArgsLine ) : Type Block Newlines ${
4963                         $0 = declare_function(c, $<FN, $<Ar, $<Ty, NULL, $<Bl);
4964                 }$
4965                 | func FuncName ( OpenScope ArgsLine ) : ( ArgsLine ) Block Newlines ${
4966                         $0 = declare_function(c, $<FN, $<AL, NULL, $<AL2, $<Bl);
4967                 }$
4968                 | func FuncName IN OpenScope Args OUT OptNL return Type Newlines do Block Newlines ${
4969                         $0 = declare_function(c, $<FN, $<Ar, $<Ty, NULL, $<Bl);
4970                 }$
4971                 | func FuncName NEWLINE OpenScope return Type Newlines do Block Newlines ${
4972                         $0 = declare_function(c, $<FN, NULL, $<Ty, NULL, $<Bl);
4973                 }$
4974                 | func FuncName IN OpenScope Args OUT OptNL return IN Args OUT OptNL do Block Newlines ${
4975                         $0 = declare_function(c, $<FN, $<Ar, NULL, $<Ar2, $<Bl);
4976                 }$
4977                 | func FuncName NEWLINE OpenScope return IN Args OUT OptNL do Block Newlines ${
4978                         $0 = declare_function(c, $<FN, NULL, NULL, $<Ar, $<Bl);
4979                 }$
4980
4981 ###### print func decls
4982         {
4983                 struct variable *v;
4984                 int target = -1;
4985
4986                 while (target != 0) {
4987                         int i = 0;
4988                         for (v = context.in_scope; v; v=v->in_scope)
4989                                 if (v->depth == 0 && v->type && v->type->check_args) {
4990                                         i += 1;
4991                                         if (i == target)
4992                                                 break;
4993                                 }
4994
4995                         if (target == -1) {
4996                                 target = i;
4997                         } else {
4998                                 struct value *val = var_value(&context, v);
4999                                 printf("func %.*s", v->name->name.len, v->name->name.txt);
5000                                 v->type->print_type_decl(v->type, stdout);
5001                                 if (brackets)
5002                                         print_exec(val->function, 0, brackets);
5003                                 else
5004                                         print_value(v->type, val, stdout);
5005                                 printf("/* frame size %d */\n", v->type->function.local_size);
5006                                 target -= 1;
5007                         }
5008                 }
5009         }
5010
5011 ###### core functions
5012
5013         static int analyse_funcs(struct parse_context *c)
5014         {
5015                 struct variable *v;
5016                 int all_ok = 1;
5017                 for (v = c->in_scope; v; v = v->in_scope) {
5018                         struct value *val;
5019                         struct type *ret;
5020                         int ok = 1;
5021                         if (v->depth != 0 || !v->type || !v->type->check_args)
5022                                 continue;
5023                         ret = v->type->function.inline_result ?
5024                                 Tnone : v->type->function.return_type;
5025                         val = var_value(c, v);
5026                         do {
5027                                 ok = 1;
5028                                 propagate_types(val->function, c, &ok, ret, 0);
5029                         } while (ok == 2);
5030                         if (ok)
5031                                 /* Make sure everything is still consistent */
5032                                 propagate_types(val->function, c, &ok, ret, 0);
5033                         if (!ok)
5034                                 all_ok = 0;
5035                         if (!v->type->function.inline_result &&
5036                             !v->type->function.return_type->dup) {
5037                                 type_err(c, "error: function cannot return value of type %1",
5038                                          v->where_decl, v->type->function.return_type, 0, NULL);
5039                         }
5040
5041                         scope_finalize(c, v->type);
5042                 }
5043                 return all_ok;
5044         }
5045
5046         static int analyse_main(struct type *type, struct parse_context *c)
5047         {
5048                 struct binode *bp = type->function.params;
5049                 struct binode *b;
5050                 int ok = 1;
5051                 int arg = 0;
5052                 struct type *argv_type;
5053                 struct text argv_type_name = { " argv", 5 };
5054
5055                 argv_type = add_type(c, argv_type_name, &array_prototype);
5056                 argv_type->array.member = Tstr;
5057                 argv_type->array.unspec = 1;
5058
5059                 for (b = bp; b; b = cast(binode, b->right)) {
5060                         ok = 1;
5061                         switch (arg++) {
5062                         case 0: /* argv */
5063                                 propagate_types(b->left, c, &ok, argv_type, 0);
5064                                 break;
5065                         default: /* invalid */  // NOTEST
5066                                 propagate_types(b->left, c, &ok, Tnone, 0);     // NOTEST
5067                         }
5068                         if (!ok)
5069                                 c->parse_error = 1;
5070                 }
5071
5072                 return !c->parse_error;
5073         }
5074
5075         static void interp_main(struct parse_context *c, int argc, char **argv)
5076         {
5077                 struct value *progp = NULL;
5078                 struct text main_name = { "main", 4 };
5079                 struct variable *mainv;
5080                 struct binode *al;
5081                 int anum = 0;
5082                 struct value v;
5083                 struct type *vtype;
5084
5085                 mainv = var_ref(c, main_name);
5086                 if (mainv)
5087                         progp = var_value(c, mainv);
5088                 if (!progp || !progp->function) {
5089                         fprintf(stderr, "oceani: no main function found.\n");
5090                         c->parse_error = 1;
5091                         return;
5092                 }
5093                 if (!analyse_main(mainv->type, c)) {
5094                         fprintf(stderr, "oceani: main has wrong type.\n");
5095                         c->parse_error = 1;
5096                         return;
5097                 }
5098                 al = mainv->type->function.params;
5099
5100                 c->local_size = mainv->type->function.local_size;
5101                 c->local = calloc(1, c->local_size);
5102                 while (al) {
5103                         struct var *v = cast(var, al->left);
5104                         struct value *vl = var_value(c, v->var);
5105                         struct value arg;
5106                         struct type *t;
5107                         mpq_t argcq;
5108                         int i;
5109
5110                         switch (anum++) {
5111                         case 0: /* argv */
5112                                 t = v->var->type;
5113                                 mpq_init(argcq);
5114                                 mpq_set_ui(argcq, argc, 1);
5115                                 memcpy(var_value(c, t->array.vsize), &argcq, sizeof(argcq));
5116                                 t->prepare_type(c, t, 0);
5117                                 array_init(v->var->type, vl);
5118                                 for (i = 0; i < argc; i++) {
5119                                         struct value *vl2 = vl->array + i * v->var->type->array.member->size;
5120
5121                                         arg.str.txt = argv[i];
5122                                         arg.str.len = strlen(argv[i]);
5123                                         free_value(Tstr, vl2);
5124                                         dup_value(Tstr, &arg, vl2);
5125                                 }
5126                                 break;
5127                         }
5128                         al = cast(binode, al->right);
5129                 }
5130                 v = interp_exec(c, progp->function, &vtype);
5131                 free_value(vtype, &v);
5132                 free(c->local);
5133                 c->local = NULL;
5134         }
5135
5136 ###### ast functions
5137         void free_variable(struct variable *v)
5138         {
5139         }
5140
5141 ## And now to test it out.
5142
5143 Having a language requires having a "hello world" program.  I'll
5144 provide a little more than that: a program that prints "Hello world"
5145 finds the GCD of two numbers, prints the first few elements of
5146 Fibonacci, performs a binary search for a number, and a few other
5147 things which will likely grow as the languages grows.
5148
5149 ###### File: oceani.mk
5150         demos :: sayhello
5151         sayhello : oceani
5152                 @echo "===== DEMO ====="
5153                 ./oceani --section "demo: hello" oceani.mdc 55 33
5154
5155 ###### demo: hello
5156
5157         const
5158                 pi ::= 3.141_592_6
5159                 four ::= 2 + 2 ; five ::= 10/2
5160         const pie ::= "I like Pie";
5161                 cake ::= "The cake is"
5162                   ++ " a lie"
5163
5164         struct fred
5165                 size:[four]number
5166                 name:string
5167                 alive:Boolean
5168
5169         func main(argv:[argc::]string)
5170                 print "Hello World, what lovely oceans you have!"
5171                 print "Are there", five, "?"
5172                 print pi, pie, "but", cake
5173
5174                 A := $argv[1]; B := $argv[2]
5175
5176                 /* When a variable is defined in both branches of an 'if',
5177                  * and used afterwards, the variables are merged.
5178                  */
5179                 if A > B:
5180                         bigger := "yes"
5181                 else
5182                         bigger := "no"
5183                 print "Is", A, "bigger than", B,"? ", bigger
5184                 /* If a variable is not used after the 'if', no
5185                  * merge happens, so types can be different
5186                  */
5187                 if A > B * 2:
5188                         double:string = "yes"
5189                         print A, "is more than twice", B, "?", double
5190                 else
5191                         double := B*2
5192                         print "double", B, "is", double
5193
5194                 a : number
5195                 a = A;
5196                 b:number = B
5197                 if a > 0 and then b > 0:
5198                         while a != b:
5199                                 if a < b:
5200                                         b = b - a
5201                                 else
5202                                         a = a - b
5203                         print "GCD of", A, "and", B,"is", a
5204                 else if a <= 0:
5205                         print a, "is not positive, cannot calculate GCD"
5206                 else
5207                         print b, "is not positive, cannot calculate GCD"
5208
5209                 for
5210                         togo := 10
5211                         f1 := 1; f2 := 1
5212                         print "Fibonacci:", f1,f2,
5213                 then togo = togo - 1
5214                 while togo > 0:
5215                         f3 := f1 + f2
5216                         print "", f3,
5217                         f1 = f2
5218                         f2 = f3
5219                 print ""
5220
5221                 /* Binary search... */
5222                 for
5223                         lo:= 0; hi := 100
5224                         target := 77
5225                 while
5226                         mid := (lo + hi) / 2
5227                         if mid == target:
5228                                 use Found
5229                         if mid < target:
5230                                 lo = mid
5231                         else
5232                                 hi = mid
5233                         if hi - lo < 1:
5234                                 lo = mid
5235                                 use GiveUp
5236                         use True
5237                 do pass
5238                 case Found:
5239                         print "Yay, I found", target
5240                 case GiveUp:
5241                         print "Closest I found was", lo
5242
5243                 size::= 10
5244                 list:[size]number
5245                 list[0] = 1234
5246                 // "middle square" PRNG.  Not particularly good, but one my
5247                 // Dad taught me - the first one I ever heard of.
5248                 for i:=1; then i = i + 1; while i < size:
5249                         n := list[i-1] * list[i-1]
5250                         list[i] = (n / 100) % 10 000
5251
5252                 print "Before sort:",
5253                 for i:=0; then i = i + 1; while i < size:
5254                         print "", list[i],
5255                 print
5256
5257                 for i := 1; then i=i+1; while i < size:
5258                         for j:=i-1; then j=j-1; while j >= 0:
5259                                 if list[j] > list[j+1]:
5260                                         t:= list[j]
5261                                         list[j] = list[j+1]
5262                                         list[j+1] = t
5263                 print " After sort:",
5264                 for i:=0; then i = i + 1; while i < size:
5265                         print "", list[i],
5266                 print
5267
5268                 if 1 == 2 then print "yes"; else print "no"
5269
5270                 bob:fred
5271                 bob.name = "Hello"
5272                 bob.alive = (bob.name == "Hello")
5273                 print "bob", "is" if  bob.alive else "isn't", "alive"