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