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

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