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