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

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