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