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

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