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

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