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 (though results are not yet implemented).  Each function
2339 has a type which includes the set of parameters and the return value.
2340 As yet these types cannot be declared separately from the function
2341 itself.
2342
2343 The parameters can be specified either in parentheses as a ';' separated
2344 list, such as
2345
2346 ##### Example: function 1
2347
2348         func main(av:[ac::number]string; env:[envc::number]string)
2349                 code block
2350
2351 or as an indented list of one parameter per line (though each line can
2352 be a ';' separated list)
2353
2354 ##### Example: function 2
2355
2356         func main
2357                 argv:[argc::number]string
2358                 env:[envc::number]string
2359         do
2360                 code block
2361
2362 For constructing these lists we use a `List` binode, which will be
2363 further detailed when Expression Lists are introduced.
2364
2365 ###### type union fields
2366
2367         struct {
2368                 struct binode *params;
2369                 int local_size;
2370         } function;
2371
2372 ###### value union fields
2373         struct exec *function;
2374
2375 ###### type functions
2376         void (*check_args)(struct parse_context *c, int *ok,
2377                            struct type *require, struct exec *args);
2378
2379 ###### value functions
2380
2381         static void function_free(struct type *type, struct value *val)
2382         {
2383                 free_exec(val->function);
2384                 val->function = NULL;
2385         }
2386
2387         static int function_compat(struct type *require, struct type *have)
2388         {
2389                 // FIXME can I do anything here yet?
2390                 return 0;
2391         }
2392
2393         static void function_check_args(struct parse_context *c, int *ok,
2394                                         struct type *require, struct exec *args)
2395         {
2396                 /* This should be 'compat', but we don't have a 'tuple' type to
2397                  * hold the type of 'args'
2398                  */
2399                 struct binode *arg = cast(binode, args);
2400                 struct binode *param = require->function.params;
2401
2402                 while (param) {
2403                         struct var *pv = cast(var, param->left);
2404                         if (!arg) {
2405                                 type_err(c, "error: insufficient arguments to function.",
2406                                          args, NULL, 0, NULL);
2407                                 break;
2408                         }
2409                         *ok = 1;
2410                         propagate_types(arg->left, c, ok, pv->var->type, 0);
2411                         param = cast(binode, param->right);
2412                         arg = cast(binode, arg->right);
2413                 }
2414                 if (arg)
2415                         type_err(c, "error: too many arguments to function.",
2416                                  args, NULL, 0, NULL);
2417         }
2418
2419         static void function_print(struct type *type, struct value *val)
2420         {
2421                 print_exec(val->function, 1, 0);
2422         }
2423
2424         static void function_print_type_decl(struct type *type, FILE *f)
2425         {
2426                 struct binode *b;
2427                 fprintf(f, "(");
2428                 for (b = type->function.params; b; b = cast(binode, b->right)) {
2429                         struct variable *v = cast(var, b->left)->var;
2430                         fprintf(f, "%.*s%s", v->name->name.len, v->name->name.txt,
2431                                 v->constant ? "::" : ":");
2432                         type_print(v->type, f);
2433                         if (b->right)
2434                                 fprintf(f, "; ");
2435                 }
2436                 fprintf(f, ")\n");
2437         }
2438
2439         static void function_free_type(struct type *t)
2440         {
2441                 free_exec(t->function.params);
2442         }
2443
2444         static struct type function_prototype = {
2445                 .size = sizeof(void*),
2446                 .align = sizeof(void*),
2447                 .free = function_free,
2448                 .compat = function_compat,
2449                 .check_args = function_check_args,
2450                 .print = function_print,
2451                 .print_type_decl = function_print_type_decl,
2452                 .free_type = function_free_type,
2453         };
2454
2455 ###### declare terminals
2456
2457         $TERM func
2458
2459 ###### Binode types
2460         List,
2461
2462 ###### Grammar
2463
2464         $*variable
2465         FuncName -> IDENTIFIER ${ {
2466                         struct variable *v = var_decl(c, $1.txt);
2467                         struct var *e = new_pos(var, $1);
2468                         e->var = v;
2469                         if (v) {
2470                                 v->where_decl = e;
2471                                 $0 = v;
2472                         } else {
2473                                 v = var_ref(c, $1.txt);
2474                                 e->var = v;
2475                                 type_err(c, "error: function '%v' redeclared",
2476                                         e, NULL, 0, NULL);
2477                                 type_err(c, "info: this is where '%v' was first declared",
2478                                         v->where_decl, NULL, 0, NULL);
2479                                 free_exec(e);
2480                         }
2481                 } }$
2482
2483         $*binode
2484         Args -> ArgsLine NEWLINE ${ $0 = $<AL; }$
2485                 | Args ArgsLine NEWLINE ${ {
2486                         struct binode *b = $<AL;
2487                         struct binode **bp = &b;
2488                         while (*bp)
2489                                 bp = (struct binode **)&(*bp)->left;
2490                         *bp = $<A;
2491                         $0 = b;
2492                 } }$
2493
2494         ArgsLine -> ${ $0 = NULL; }$
2495                 | Varlist ${ $0 = $<1; }$
2496                 | Varlist ; ${ $0 = $<1; }$
2497
2498         Varlist -> Varlist ; ArgDecl ${
2499                         $0 = new(binode);
2500                         $0->op = List;
2501                         $0->left = $<Vl;
2502                         $0->right = $<AD;
2503                 }$
2504                 | ArgDecl ${
2505                         $0 = new(binode);
2506                         $0->op = List;
2507                         $0->left = NULL;
2508                         $0->right = $<AD;
2509                 }$
2510
2511         $*var
2512         ArgDecl -> IDENTIFIER : FormalType ${ {
2513                 struct variable *v = var_decl(c, $1.txt);
2514                 $0 = new(var);
2515                 $0->var = v;
2516                 v->type = $<FT;
2517         } }$
2518
2519 ## Executables: the elements of code
2520
2521 Each code element needs to be parsed, printed, analysed,
2522 interpreted, and freed.  There are several, so let's just start with
2523 the easy ones and work our way up.
2524
2525 ### Values
2526
2527 We have already met values as separate objects.  When manifest
2528 constants appear in the program text, that must result in an executable
2529 which has a constant value.  So the `val` structure embeds a value in
2530 an executable.
2531
2532 ###### exec type
2533         Xval,
2534
2535 ###### ast
2536         struct val {
2537                 struct exec;
2538                 struct type *vtype;
2539                 struct value val;
2540         };
2541
2542 ###### ast functions
2543         struct val *new_val(struct type *T, struct token tk)
2544         {
2545                 struct val *v = new_pos(val, tk);
2546                 v->vtype = T;
2547                 return v;
2548         }
2549
2550 ###### Grammar
2551
2552         $TERM True False
2553
2554         $*val
2555         Value ->  True ${
2556                         $0 = new_val(Tbool, $1);
2557                         $0->val.bool = 1;
2558                         }$
2559                 | False ${
2560                         $0 = new_val(Tbool, $1);
2561                         $0->val.bool = 0;
2562                         }$
2563                 | NUMBER ${
2564                         $0 = new_val(Tnum, $1);
2565                         {
2566                         char tail[3];
2567                         if (number_parse($0->val.num, tail, $1.txt) == 0)
2568                                 mpq_init($0->val.num);  // UNTESTED
2569                                 if (tail[0])
2570                                         tok_err(c, "error: unsupported number suffix",
2571                                                 &$1);
2572                         }
2573                         }$
2574                 | STRING ${
2575                         $0 = new_val(Tstr, $1);
2576                         {
2577                         char tail[3];
2578                         string_parse(&$1, '\\', &$0->val.str, tail);
2579                         if (tail[0])
2580                                 tok_err(c, "error: unsupported string suffix",
2581                                         &$1);
2582                         }
2583                         }$
2584                 | MULTI_STRING ${
2585                         $0 = new_val(Tstr, $1);
2586                         {
2587                         char tail[3];
2588                         string_parse(&$1, '\\', &$0->val.str, tail);
2589                         if (tail[0])
2590                                 tok_err(c, "error: unsupported string suffix",
2591                                         &$1);
2592                         }
2593                         }$
2594
2595 ###### print exec cases
2596         case Xval:
2597         {
2598                 struct val *v = cast(val, e);
2599                 if (v->vtype == Tstr)
2600                         printf("\"");
2601                 print_value(v->vtype, &v->val);
2602                 if (v->vtype == Tstr)
2603                         printf("\"");
2604                 break;
2605         }
2606
2607 ###### propagate exec cases
2608         case Xval:
2609         {
2610                 struct val *val = cast(val, prog);
2611                 if (!type_compat(type, val->vtype, rules))
2612                         type_err(c, "error: expected %1%r found %2",
2613                                    prog, type, rules, val->vtype);
2614                 return val->vtype;
2615         }
2616
2617 ###### interp exec cases
2618         case Xval:
2619                 rvtype = cast(val, e)->vtype;
2620                 dup_value(rvtype, &cast(val, e)->val, &rv);
2621                 break;
2622
2623 ###### ast functions
2624         static void free_val(struct val *v)
2625         {
2626                 if (v)
2627                         free_value(v->vtype, &v->val);
2628                 free(v);
2629         }
2630
2631 ###### free exec cases
2632         case Xval: free_val(cast(val, e)); break;
2633
2634 ###### ast functions
2635         // Move all nodes from 'b' to 'rv', reversing their order.
2636         // In 'b' 'left' is a list, and 'right' is the last node.
2637         // In 'rv', left' is the first node and 'right' is a list.
2638         static struct binode *reorder_bilist(struct binode *b)
2639         {
2640                 struct binode *rv = NULL;
2641
2642                 while (b) {
2643                         struct exec *t = b->right;
2644                         b->right = rv;
2645                         rv = b;
2646                         if (b->left)
2647                                 b = cast(binode, b->left);
2648                         else
2649                                 b = NULL;
2650                         rv->left = t;
2651                 }
2652                 return rv;
2653         }
2654
2655 ### Variables
2656
2657 Just as we used a `val` to wrap a value into an `exec`, we similarly
2658 need a `var` to wrap a `variable` into an exec.  While each `val`
2659 contained a copy of the value, each `var` holds a link to the variable
2660 because it really is the same variable no matter where it appears.
2661 When a variable is used, we need to remember to follow the `->merged`
2662 link to find the primary instance.
2663
2664 ###### exec type
2665         Xvar,
2666
2667 ###### ast
2668         struct var {
2669                 struct exec;
2670                 struct variable *var;
2671         };
2672
2673 ###### Grammar
2674
2675         $TERM : ::
2676
2677         $*var
2678         VariableDecl -> IDENTIFIER : ${ {
2679                 struct variable *v = var_decl(c, $1.txt);
2680                 $0 = new_pos(var, $1);
2681                 $0->var = v;
2682                 if (v)
2683                         v->where_decl = $0;
2684                 else {
2685                         v = var_ref(c, $1.txt);
2686                         $0->var = v;
2687                         type_err(c, "error: variable '%v' redeclared",
2688                                  $0, NULL, 0, NULL);
2689                         type_err(c, "info: this is where '%v' was first declared",
2690                                  v->where_decl, NULL, 0, NULL);
2691                 }
2692         } }$
2693             | IDENTIFIER :: ${ {
2694                 struct variable *v = var_decl(c, $1.txt);
2695                 $0 = new_pos(var, $1);
2696                 $0->var = v;
2697                 if (v) {
2698                         v->where_decl = $0;
2699                         v->constant = 1;
2700                 } else {
2701                         v = var_ref(c, $1.txt);
2702                         $0->var = v;
2703                         type_err(c, "error: variable '%v' redeclared",
2704                                  $0, NULL, 0, NULL);
2705                         type_err(c, "info: this is where '%v' was first declared",
2706                                  v->where_decl, NULL, 0, NULL);
2707                 }
2708         } }$
2709             | IDENTIFIER : Type ${ {
2710                 struct variable *v = var_decl(c, $1.txt);
2711                 $0 = new_pos(var, $1);
2712                 $0->var = v;
2713                 if (v) {
2714                         v->where_decl = $0;
2715                         v->where_set = $0;
2716                         v->type = $<Type;
2717                 } else {
2718                         v = var_ref(c, $1.txt);
2719                         $0->var = v;
2720                         type_err(c, "error: variable '%v' redeclared",
2721                                  $0, NULL, 0, NULL);
2722                         type_err(c, "info: this is where '%v' was first declared",
2723                                  v->where_decl, NULL, 0, NULL);
2724                 }
2725         } }$
2726             | IDENTIFIER :: Type ${ {
2727                 struct variable *v = var_decl(c, $1.txt);
2728                 $0 = new_pos(var, $1);
2729                 $0->var = v;
2730                 if (v) {
2731                         v->where_decl = $0;
2732                         v->where_set = $0;
2733                         v->type = $<Type;
2734                         v->constant = 1;
2735                 } else {
2736                         v = var_ref(c, $1.txt);
2737                         $0->var = v;
2738                         type_err(c, "error: variable '%v' redeclared",
2739                                  $0, NULL, 0, NULL);
2740                         type_err(c, "info: this is where '%v' was first declared",
2741                                  v->where_decl, NULL, 0, NULL);
2742                 }
2743         } }$
2744
2745         $*exec
2746         Variable -> IDENTIFIER ${ {
2747                 struct variable *v = var_ref(c, $1.txt);
2748                 $0 = new_pos(var, $1);
2749                 if (v == NULL) {
2750                         /* This might be a label - allocate a var just in case */
2751                         v = var_decl(c, $1.txt);
2752                         if (v) {
2753                                 v->type = Tnone;
2754                                 v->where_decl = $0;
2755                                 v->where_set = $0;
2756                         }
2757                 }
2758                 cast(var, $0)->var = v;
2759         } }$
2760         ## variable grammar
2761
2762 ###### print exec cases
2763         case Xvar:
2764         {
2765                 struct var *v = cast(var, e);
2766                 if (v->var) {
2767                         struct binding *b = v->var->name;
2768                         printf("%.*s", b->name.len, b->name.txt);
2769                 }
2770                 break;
2771         }
2772
2773 ###### format cases
2774         case 'v':
2775                 if (loc && loc->type == Xvar) {
2776                         struct var *v = cast(var, loc);
2777                         if (v->var) {
2778                                 struct binding *b = v->var->name;
2779                                 fprintf(stderr, "%.*s", b->name.len, b->name.txt);
2780                         } else
2781                                 fputs("???", stderr);   // NOTEST
2782                 } else
2783                         fputs("NOTVAR", stderr);
2784                 break;
2785
2786 ###### propagate exec cases
2787
2788         case Xvar:
2789         {
2790                 struct var *var = cast(var, prog);
2791                 struct variable *v = var->var;
2792                 if (!v) {
2793                         type_err(c, "%d:BUG: no variable!!", prog, NULL, 0, NULL); // NOTEST
2794                         return Tnone;                                   // NOTEST
2795                 }
2796                 v = v->merged;
2797                 if (v->constant && (rules & Rnoconstant)) {
2798                         type_err(c, "error: Cannot assign to a constant: %v",
2799                                  prog, NULL, 0, NULL);
2800                         type_err(c, "info: name was defined as a constant here",
2801                                  v->where_decl, NULL, 0, NULL);
2802                         return v->type;
2803                 }
2804                 if (v->type == Tnone && v->where_decl == prog)
2805                         type_err(c, "error: variable used but not declared: %v",
2806                                  prog, NULL, 0, NULL);
2807                 if (v->type == NULL) {
2808                         if (type && *ok != 0) {
2809                                 v->type = type;
2810                                 v->where_set = prog;
2811                                 *ok = 2;
2812                         }
2813                         return type;
2814                 }
2815                 if (!type_compat(type, v->type, rules)) {
2816                         type_err(c, "error: expected %1%r but variable '%v' is %2", prog,
2817                                  type, rules, v->type);
2818                         type_err(c, "info: this is where '%v' was set to %1", v->where_set,
2819                                  v->type, rules, NULL);
2820                 }
2821                 if (!type)
2822                         return v->type;
2823                 return type;
2824         }
2825
2826 ###### interp exec cases
2827         case Xvar:
2828         {
2829                 struct var *var = cast(var, e);
2830                 struct variable *v = var->var;
2831
2832                 v = v->merged;
2833                 lrv = var_value(c, v);
2834                 rvtype = v->type;
2835                 break;
2836         }
2837
2838 ###### ast functions
2839
2840         static void free_var(struct var *v)
2841         {
2842                 free(v);
2843         }
2844
2845 ###### free exec cases
2846         case Xvar: free_var(cast(var, e)); break;
2847
2848 ### Expressions: Conditional
2849
2850 Our first user of the `binode` will be conditional expressions, which
2851 is a bit odd as they actually have three components.  That will be
2852 handled by having 2 binodes for each expression.  The conditional
2853 expression is the lowest precedence operator which is why we define it
2854 first - to start the precedence list.
2855
2856 Conditional expressions are of the form "value `if` condition `else`
2857 other_value".  They associate to the right, so everything to the right
2858 of `else` is part of an else value, while only a higher-precedence to
2859 the left of `if` is the if values.  Between `if` and `else` there is no
2860 room for ambiguity, so a full conditional expression is allowed in
2861 there.
2862
2863 ###### Binode types
2864         CondExpr,
2865
2866 ###### Grammar
2867
2868         $LEFT if $$ifelse
2869         ## expr precedence
2870
2871         $*exec
2872         Expression -> Expression if Expression else Expression $$ifelse ${ {
2873                         struct binode *b1 = new(binode);
2874                         struct binode *b2 = new(binode);
2875                         b1->op = CondExpr;
2876                         b1->left = $<3;
2877                         b1->right = b2;
2878                         b2->op = CondExpr;
2879                         b2->left = $<1;
2880                         b2->right = $<5;
2881                         $0 = b1;
2882                 } }$
2883                 ## expression grammar
2884
2885 ###### print binode cases
2886
2887         case CondExpr:
2888                 b2 = cast(binode, b->right);
2889                 if (bracket) printf("(");
2890                 print_exec(b2->left, -1, bracket);
2891                 printf(" if ");
2892                 print_exec(b->left, -1, bracket);
2893                 printf(" else ");
2894                 print_exec(b2->right, -1, bracket);
2895                 if (bracket) printf(")");
2896                 break;
2897
2898 ###### propagate binode cases
2899
2900         case CondExpr: {
2901                 /* cond must be Tbool, others must match */
2902                 struct binode *b2 = cast(binode, b->right);
2903                 struct type *t2;
2904
2905                 propagate_types(b->left, c, ok, Tbool, 0);
2906                 t = propagate_types(b2->left, c, ok, type, Rnolabel);
2907                 t2 = propagate_types(b2->right, c, ok, type ?: t, Rnolabel);
2908                 return t ?: t2;
2909         }
2910
2911 ###### interp binode cases
2912
2913         case CondExpr: {
2914                 struct binode *b2 = cast(binode, b->right);
2915                 left = interp_exec(c, b->left, &ltype);
2916                 if (left.bool)
2917                         rv = interp_exec(c, b2->left, &rvtype); // UNTESTED
2918                 else
2919                         rv = interp_exec(c, b2->right, &rvtype);
2920                 }
2921                 break;
2922
2923 ### Expression list
2924
2925 We take a brief detour, now that we have expressions, to describe lists
2926 of expressions.  These will be needed for function parameters and
2927 possibly other situations.  They seem generic enough to introduce here
2928 to be used elsewhere.
2929
2930 And ExpressionList will use the `List` type of `binode`, building up at
2931 the end.  And place where they are used will probably call
2932 `reorder_bilist()` to get a more normal first/next arrangement.
2933
2934 ###### declare terminals
2935         $TERM ,
2936
2937 `List` execs have no implicit semantics, so they are never propagated or
2938 interpreted.  The can be printed as a comma separate list, which is how
2939 they are parsed.  Note they are also used for function formal parameter
2940 lists.  In that case a separate function is used to print them.
2941
2942 ###### print binode cases
2943         case List:
2944                 while (b) {
2945                         printf(" ");
2946                         print_exec(b->left, -1, bracket);
2947                         if (b->right)
2948                                 printf(",");
2949                         b = cast(binode, b->right);
2950                 }
2951                 break;
2952
2953 ###### propagate binode cases
2954         case List: abort(); // NOTEST
2955 ###### interp binode cases
2956         case List: abort(); // NOTEST
2957
2958 ###### Grammar
2959
2960         $*binode
2961         ExpressionList -> ExpressionList , Expression ${
2962                         $0 = new(binode);
2963                         $0->op = List;
2964                         $0->left = $<1;
2965                         $0->right = $<3;
2966                 }$
2967                 | Expression ${
2968                         $0 = new(binode);
2969                         $0->op = List;
2970                         $0->left = NULL;
2971                         $0->right = $<1;
2972                 }$
2973
2974 ### Expressions: Boolean
2975
2976 The next class of expressions to use the `binode` will be Boolean
2977 expressions.  "`and then`" and "`or else`" are similar to `and` and `or`
2978 have same corresponding precendence.  The difference is that they don't
2979 evaluate the second expression if not necessary.
2980
2981 ###### Binode types
2982         And,
2983         AndThen,
2984         Or,
2985         OrElse,
2986         Not,
2987
2988 ###### expr precedence
2989         $LEFT or
2990         $LEFT and
2991         $LEFT not
2992
2993 ###### expression grammar
2994                 | Expression or Expression ${ {
2995                         struct binode *b = new(binode);
2996                         b->op = Or;
2997                         b->left = $<1;
2998                         b->right = $<3;
2999                         $0 = b;
3000                 } }$
3001                 | Expression or else Expression ${ {
3002                         struct binode *b = new(binode);
3003                         b->op = OrElse;
3004                         b->left = $<1;
3005                         b->right = $<4;
3006                         $0 = b;
3007                 } }$
3008
3009                 | Expression and Expression ${ {
3010                         struct binode *b = new(binode);
3011                         b->op = And;
3012                         b->left = $<1;
3013                         b->right = $<3;
3014                         $0 = b;
3015                 } }$
3016                 | Expression and then Expression ${ {
3017                         struct binode *b = new(binode);
3018                         b->op = AndThen;
3019                         b->left = $<1;
3020                         b->right = $<4;
3021                         $0 = b;
3022                 } }$
3023
3024                 | not Expression ${ {
3025                         struct binode *b = new(binode);
3026                         b->op = Not;
3027                         b->right = $<2;
3028                         $0 = b;
3029                 } }$
3030
3031 ###### print binode cases
3032         case And:
3033                 if (bracket) printf("(");
3034                 print_exec(b->left, -1, bracket);
3035                 printf(" and ");
3036                 print_exec(b->right, -1, bracket);
3037                 if (bracket) printf(")");
3038                 break;
3039         case AndThen:
3040                 if (bracket) printf("(");
3041                 print_exec(b->left, -1, bracket);
3042                 printf(" and then ");
3043                 print_exec(b->right, -1, bracket);
3044                 if (bracket) printf(")");
3045                 break;
3046         case Or:
3047                 if (bracket) printf("(");
3048                 print_exec(b->left, -1, bracket);
3049                 printf(" or ");
3050                 print_exec(b->right, -1, bracket);
3051                 if (bracket) printf(")");
3052                 break;
3053         case OrElse:
3054                 if (bracket) printf("(");
3055                 print_exec(b->left, -1, bracket);
3056                 printf(" or else ");
3057                 print_exec(b->right, -1, bracket);
3058                 if (bracket) printf(")");
3059                 break;
3060         case Not:
3061                 if (bracket) printf("(");
3062                 printf("not ");
3063                 print_exec(b->right, -1, bracket);
3064                 if (bracket) printf(")");
3065                 break;
3066
3067 ###### propagate binode cases
3068         case And:
3069         case AndThen:
3070         case Or:
3071         case OrElse:
3072         case Not:
3073                 /* both must be Tbool, result is Tbool */
3074                 propagate_types(b->left, c, ok, Tbool, 0);
3075                 propagate_types(b->right, c, ok, Tbool, 0);
3076                 if (type && type != Tbool)
3077                         type_err(c, "error: %1 operation found where %2 expected", prog,
3078                                    Tbool, 0, type);
3079                 return Tbool;
3080
3081 ###### interp binode cases
3082         case And:
3083                 rv = interp_exec(c, b->left, &rvtype);
3084                 right = interp_exec(c, b->right, &rtype);
3085                 rv.bool = rv.bool && right.bool;
3086                 break;
3087         case AndThen:
3088                 rv = interp_exec(c, b->left, &rvtype);
3089                 if (rv.bool)
3090                         rv = interp_exec(c, b->right, NULL);
3091                 break;
3092         case Or:
3093                 rv = interp_exec(c, b->left, &rvtype);
3094                 right = interp_exec(c, b->right, &rtype);
3095                 rv.bool = rv.bool || right.bool;
3096                 break;
3097         case OrElse:
3098                 rv = interp_exec(c, b->left, &rvtype);
3099                 if (!rv.bool)
3100                         rv = interp_exec(c, b->right, NULL);
3101                 break;
3102         case Not:
3103                 rv = interp_exec(c, b->right, &rvtype);
3104                 rv.bool = !rv.bool;
3105                 break;
3106
3107 ### Expressions: Comparison
3108
3109 Of slightly higher precedence that Boolean expressions are Comparisons.
3110 A comparison takes arguments of any comparable type, but the two types
3111 must be the same.
3112
3113 To simplify the parsing we introduce an `eop` which can record an
3114 expression operator, and the `CMPop` non-terminal will match one of them.
3115
3116 ###### ast
3117         struct eop {
3118                 enum Btype op;
3119         };
3120
3121 ###### ast functions
3122         static void free_eop(struct eop *e)
3123         {
3124                 if (e)
3125                         free(e);
3126         }
3127
3128 ###### Binode types
3129         Less,
3130         Gtr,
3131         LessEq,
3132         GtrEq,
3133         Eql,
3134         NEql,
3135
3136 ###### expr precedence
3137         $LEFT < > <= >= == != CMPop
3138
3139 ###### expression grammar
3140         | Expression CMPop Expression ${ {
3141                 struct binode *b = new(binode);
3142                 b->op = $2.op;
3143                 b->left = $<1;
3144                 b->right = $<3;
3145                 $0 = b;
3146         } }$
3147
3148 ###### Grammar
3149
3150         $eop
3151         CMPop ->   < ${ $0.op = Less; }$
3152                 |  > ${ $0.op = Gtr; }$
3153                 |  <= ${ $0.op = LessEq; }$
3154                 |  >= ${ $0.op = GtrEq; }$
3155                 |  == ${ $0.op = Eql; }$
3156                 |  != ${ $0.op = NEql; }$
3157
3158 ###### print binode cases
3159
3160         case Less:
3161         case LessEq:
3162         case Gtr:
3163         case GtrEq:
3164         case Eql:
3165         case NEql:
3166                 if (bracket) printf("(");
3167                 print_exec(b->left, -1, bracket);
3168                 switch(b->op) {
3169                 case Less:   printf(" < "); break;
3170                 case LessEq: printf(" <= "); break;
3171                 case Gtr:    printf(" > "); break;
3172                 case GtrEq:  printf(" >= "); break;
3173                 case Eql:    printf(" == "); break;
3174                 case NEql:   printf(" != "); break;
3175                 default: abort();               // NOTEST
3176                 }
3177                 print_exec(b->right, -1, bracket);
3178                 if (bracket) printf(")");
3179                 break;
3180
3181 ###### propagate binode cases
3182         case Less:
3183         case LessEq:
3184         case Gtr:
3185         case GtrEq:
3186         case Eql:
3187         case NEql:
3188                 /* Both must match but not be labels, result is Tbool */
3189                 t = propagate_types(b->left, c, ok, NULL, Rnolabel);
3190                 if (t)
3191                         propagate_types(b->right, c, ok, t, 0);
3192                 else {
3193                         t = propagate_types(b->right, c, ok, NULL, Rnolabel);   // UNTESTED
3194                         if (t)  // UNTESTED
3195                                 t = propagate_types(b->left, c, ok, t, 0);      // UNTESTED
3196                 }
3197                 if (!type_compat(type, Tbool, 0))
3198                         type_err(c, "error: Comparison returns %1 but %2 expected", prog,
3199                                     Tbool, rules, type);
3200                 return Tbool;
3201
3202 ###### interp binode cases
3203         case Less:
3204         case LessEq:
3205         case Gtr:
3206         case GtrEq:
3207         case Eql:
3208         case NEql:
3209         {
3210                 int cmp;
3211                 left = interp_exec(c, b->left, &ltype);
3212                 right = interp_exec(c, b->right, &rtype);
3213                 cmp = value_cmp(ltype, rtype, &left, &right);
3214                 rvtype = Tbool;
3215                 switch (b->op) {
3216                 case Less:      rv.bool = cmp <  0; break;
3217                 case LessEq:    rv.bool = cmp <= 0; break;
3218                 case Gtr:       rv.bool = cmp >  0; break;
3219                 case GtrEq:     rv.bool = cmp >= 0; break;
3220                 case Eql:       rv.bool = cmp == 0; break;
3221                 case NEql:      rv.bool = cmp != 0; break;
3222                 default:        rv.bool = 0; break;     // NOTEST
3223                 }
3224                 break;
3225         }
3226
3227 ### Expressions: Arithmetic etc.
3228
3229 The remaining expressions with the highest precedence are arithmetic,
3230 string concatenation, and string conversion.  String concatenation
3231 (`++`) has the same precedence as multiplication and division, but lower
3232 than the uniary.
3233
3234 String conversion is a temporary feature until I get a better type
3235 system.  `$` is a prefix operator which expects a string and returns
3236 a number.
3237
3238 `+` and `-` are both infix and prefix operations (where they are
3239 absolute value and negation).  These have different operator names.
3240
3241 We also have a 'Bracket' operator which records where parentheses were
3242 found.  This makes it easy to reproduce these when printing.  Possibly I
3243 should only insert brackets were needed for precedence.
3244
3245 ###### Binode types
3246         Plus, Minus,
3247         Times, Divide, Rem,
3248         Concat,
3249         Absolute, Negate,
3250         StringConv,
3251         Bracket,
3252
3253 ###### expr precedence
3254         $LEFT + - Eop
3255         $LEFT * / % ++ Top
3256         $LEFT Uop $
3257         $TERM ( )
3258
3259 ###### expression grammar
3260                 | Expression Eop Expression ${ {
3261                         struct binode *b = new(binode);
3262                         b->op = $2.op;
3263                         b->left = $<1;
3264                         b->right = $<3;
3265                         $0 = b;
3266                 } }$
3267
3268                 | Expression Top Expression ${ {
3269                         struct binode *b = new(binode);
3270                         b->op = $2.op;
3271                         b->left = $<1;
3272                         b->right = $<3;
3273                         $0 = b;
3274                 } }$
3275
3276                 | ( Expression ) ${ {
3277                         struct binode *b = new_pos(binode, $1);
3278                         b->op = Bracket;
3279                         b->right = $<2;
3280                         $0 = b;
3281                 } }$
3282                 | Uop Expression ${ {
3283                         struct binode *b = new(binode);
3284                         b->op = $1.op;
3285                         b->right = $<2;
3286                         $0 = b;
3287                 } }$
3288                 | Value ${ $0 = $<1; }$
3289                 | Variable ${ $0 = $<1; }$
3290
3291 ###### Grammar
3292
3293         $eop
3294         Eop ->    + ${ $0.op = Plus; }$
3295                 | - ${ $0.op = Minus; }$
3296
3297         Uop ->    + ${ $0.op = Absolute; }$
3298                 | - ${ $0.op = Negate; }$
3299                 | $ ${ $0.op = StringConv; }$
3300
3301         Top ->    * ${ $0.op = Times; }$
3302                 | / ${ $0.op = Divide; }$
3303                 | % ${ $0.op = Rem; }$
3304                 | ++ ${ $0.op = Concat; }$
3305
3306 ###### print binode cases
3307         case Plus:
3308         case Minus:
3309         case Times:
3310         case Divide:
3311         case Concat:
3312         case Rem:
3313                 if (bracket) printf("(");
3314                 print_exec(b->left, indent, bracket);
3315                 switch(b->op) {
3316                 case Plus:   fputs(" + ", stdout); break;
3317                 case Minus:  fputs(" - ", stdout); break;
3318                 case Times:  fputs(" * ", stdout); break;
3319                 case Divide: fputs(" / ", stdout); break;
3320                 case Rem:    fputs(" % ", stdout); break;
3321                 case Concat: fputs(" ++ ", stdout); break;
3322                 default: abort();       // NOTEST
3323                 }                       // NOTEST
3324                 print_exec(b->right, indent, bracket);
3325                 if (bracket) printf(")");
3326                 break;
3327         case Absolute:
3328         case Negate:
3329         case StringConv:
3330                 if (bracket) printf("(");
3331                 switch (b->op) {
3332                 case Absolute:   fputs("+", stdout); break;
3333                 case Negate:     fputs("-", stdout); break;
3334                 case StringConv: fputs("$", stdout); break;
3335                 default: abort();       // NOTEST
3336                 }                       // NOTEST
3337                 print_exec(b->right, indent, bracket);
3338                 if (bracket) printf(")");
3339                 break;
3340         case Bracket:
3341                 printf("(");
3342                 print_exec(b->right, indent, bracket);
3343                 printf(")");
3344                 break;
3345
3346 ###### propagate binode cases
3347         case Plus:
3348         case Minus:
3349         case Times:
3350         case Rem:
3351         case Divide:
3352                 /* both must be numbers, result is Tnum */
3353         case Absolute:
3354         case Negate:
3355                 /* as propagate_types ignores a NULL,
3356                  * unary ops fit here too */
3357                 propagate_types(b->left, c, ok, Tnum, 0);
3358                 propagate_types(b->right, c, ok, Tnum, 0);
3359                 if (!type_compat(type, Tnum, 0))
3360                         type_err(c, "error: Arithmetic returns %1 but %2 expected", prog,
3361                                    Tnum, rules, type);
3362                 return Tnum;
3363
3364         case Concat:
3365                 /* both must be Tstr, result is Tstr */
3366                 propagate_types(b->left, c, ok, Tstr, 0);
3367                 propagate_types(b->right, c, ok, Tstr, 0);
3368                 if (!type_compat(type, Tstr, 0))
3369                         type_err(c, "error: Concat returns %1 but %2 expected", prog,
3370                                    Tstr, rules, type);
3371                 return Tstr;
3372
3373         case StringConv:
3374                 /* op must be string, result is number */
3375                 propagate_types(b->left, c, ok, Tstr, 0);
3376                 if (!type_compat(type, Tnum, 0))
3377                         type_err(c,     // UNTESTED
3378                           "error: Can only convert string to number, not %1",
3379                                 prog, type, 0, NULL);
3380                 return Tnum;
3381
3382         case Bracket:
3383                 return propagate_types(b->right, c, ok, type, 0);
3384
3385 ###### interp binode cases
3386
3387         case Plus:
3388                 rv = interp_exec(c, b->left, &rvtype);
3389                 right = interp_exec(c, b->right, &rtype);
3390                 mpq_add(rv.num, rv.num, right.num);
3391                 break;
3392         case Minus:
3393                 rv = interp_exec(c, b->left, &rvtype);
3394                 right = interp_exec(c, b->right, &rtype);
3395                 mpq_sub(rv.num, rv.num, right.num);
3396                 break;
3397         case Times:
3398                 rv = interp_exec(c, b->left, &rvtype);
3399                 right = interp_exec(c, b->right, &rtype);
3400                 mpq_mul(rv.num, rv.num, right.num);
3401                 break;
3402         case Divide:
3403                 rv = interp_exec(c, b->left, &rvtype);
3404                 right = interp_exec(c, b->right, &rtype);
3405                 mpq_div(rv.num, rv.num, right.num);
3406                 break;
3407         case Rem: {
3408                 mpz_t l, r, rem;
3409
3410                 left = interp_exec(c, b->left, &ltype);
3411                 right = interp_exec(c, b->right, &rtype);
3412                 mpz_init(l); mpz_init(r); mpz_init(rem);
3413                 mpz_tdiv_q(l, mpq_numref(left.num), mpq_denref(left.num));
3414                 mpz_tdiv_q(r, mpq_numref(right.num), mpq_denref(right.num));
3415                 mpz_tdiv_r(rem, l, r);
3416                 val_init(Tnum, &rv);
3417                 mpq_set_z(rv.num, rem);
3418                 mpz_clear(r); mpz_clear(l); mpz_clear(rem);
3419                 rvtype = ltype;
3420                 break;
3421         }
3422         case Negate:
3423                 rv = interp_exec(c, b->right, &rvtype);
3424                 mpq_neg(rv.num, rv.num);
3425                 break;
3426         case Absolute:
3427                 rv = interp_exec(c, b->right, &rvtype);
3428                 mpq_abs(rv.num, rv.num);
3429                 break;
3430         case Bracket:
3431                 rv = interp_exec(c, b->right, &rvtype);
3432                 break;
3433         case Concat:
3434                 left = interp_exec(c, b->left, &ltype);
3435                 right = interp_exec(c, b->right, &rtype);
3436                 rvtype = Tstr;
3437                 rv.str = text_join(left.str, right.str);
3438                 break;
3439         case StringConv:
3440                 right = interp_exec(c, b->right, &rvtype);
3441                 rtype = Tstr;
3442                 rvtype = Tnum;
3443
3444                 struct text tx = right.str;
3445                 char tail[3];
3446                 int neg = 0;
3447                 if (tx.txt[0] == '-') {
3448                         neg = 1;        // UNTESTED
3449                         tx.txt++;       // UNTESTED
3450                         tx.len--;       // UNTESTED
3451                 }
3452                 if (number_parse(rv.num, tail, tx) == 0)
3453                         mpq_init(rv.num);       // UNTESTED
3454                 else if (neg)
3455                         mpq_neg(rv.num, rv.num);        // UNTESTED
3456                 if (tail[0])
3457                         printf("Unsupported suffix: %.*s\n", tx.len, tx.txt);   // UNTESTED
3458
3459                 break;
3460
3461 ###### value functions
3462
3463         static struct text text_join(struct text a, struct text b)
3464         {
3465                 struct text rv;
3466                 rv.len = a.len + b.len;
3467                 rv.txt = malloc(rv.len);
3468                 memcpy(rv.txt, a.txt, a.len);
3469                 memcpy(rv.txt+a.len, b.txt, b.len);
3470                 return rv;
3471         }
3472
3473 ### Function calls
3474
3475 A function call can appear either as an expression or as a statement.
3476 As functions cannot yet return values, only the statement version will work.
3477 We use a new 'Funcall' binode type to link the function with a list of
3478 arguments, form with the 'List' nodes.
3479
3480 ###### Binode types
3481         Funcall,
3482
3483 ###### expression grammar
3484         | Variable ( ExpressionList ) ${ {
3485                 struct binode *b = new(binode);
3486                 b->op = Funcall;
3487                 b->left = $<V;
3488                 b->right = reorder_bilist($<EL);
3489                 $0 = b;
3490         } }$
3491         | Variable ( ) ${ {
3492                 struct binode *b = new(binode);
3493                 b->op = Funcall;
3494                 b->left = $<V;
3495                 b->right = NULL;
3496                 $0 = b;
3497         } }$
3498
3499 ###### SimpleStatement Grammar
3500
3501         | Variable ( ExpressionList ) ${ {
3502                 struct binode *b = new(binode);
3503                 b->op = Funcall;
3504                 b->left = $<V;
3505                 b->right = reorder_bilist($<EL);
3506                 $0 = b;
3507         } }$
3508
3509 ###### print binode cases
3510
3511         case Funcall:
3512                 do_indent(indent, "");
3513                 print_exec(b->left, -1, bracket);
3514                 printf("(");
3515                 for (b = cast(binode, b->right); b; b = cast(binode, b->right)) {
3516                         if (b->left) {
3517                                 printf(" ");
3518                                 print_exec(b->left, -1, bracket);
3519                                 if (b->right)
3520                                         printf(",");
3521                         }
3522                 }
3523                 printf(")");
3524                 if (indent >= 0)
3525                         printf("\n");
3526                 break;
3527
3528 ###### propagate binode cases
3529
3530         case Funcall: {
3531                 /* Every arg must match formal parameter, and result
3532                  * is return type of function (currently Tnone).
3533                  */
3534                 struct binode *args = cast(binode, b->right);
3535                 struct var *v = cast(var, b->left);
3536
3537                 if (!v->var->type || v->var->type->check_args == NULL) {
3538                         type_err(c, "error: attempt to call a non-function.",
3539                                  prog, NULL, 0, NULL);
3540                         return NULL;
3541                 }
3542                 v->var->type->check_args(c, ok, v->var->type, args);
3543                 return Tnone;
3544         }
3545
3546 ###### interp binode cases
3547
3548         case Funcall: {
3549                 struct var *v = cast(var, b->left);
3550                 struct type *t = v->var->type;
3551                 void *oldlocal = c->local;
3552                 int old_size = c->local_size;
3553                 void *local = calloc(1, t->function.local_size);
3554                 struct value *fbody = var_value(c, v->var);
3555                 struct binode *arg = cast(binode, b->right);
3556                 struct binode *param = t->function.params;
3557
3558                 while (param) {
3559                         struct var *pv = cast(var, param->left);
3560                         struct type *vtype = NULL;
3561                         struct value val = interp_exec(c, arg->left, &vtype);
3562                         struct value *lval;
3563                         c->local = local; c->local_size = t->function.local_size;
3564                         lval = var_value(c, pv->var);
3565                         c->local = oldlocal; c->local_size = old_size;
3566                         memcpy(lval, &val, vtype->size);
3567                         param = cast(binode, param->right);
3568                         arg = cast(binode, arg->right);
3569                 }
3570                 c->local = local; c->local_size = t->function.local_size;
3571                 right = interp_exec(c, fbody->function, &rtype);
3572                 c->local = oldlocal; c->local_size = old_size;
3573                 free(local);
3574                 break;
3575         }
3576
3577 ### Blocks, Statements, and Statement lists.
3578
3579 Now that we have expressions out of the way we need to turn to
3580 statements.  There are simple statements and more complex statements.
3581 Simple statements do not contain (syntactic) newlines, complex statements do.
3582
3583 Statements often come in sequences and we have corresponding simple
3584 statement lists and complex statement lists.
3585 The former comprise only simple statements separated by semicolons.
3586 The later comprise complex statements and simple statement lists.  They are
3587 separated by newlines.  Thus the semicolon is only used to separate
3588 simple statements on the one line.  This may be overly restrictive,
3589 but I'm not sure I ever want a complex statement to share a line with
3590 anything else.
3591
3592 Note that a simple statement list can still use multiple lines if
3593 subsequent lines are indented, so
3594
3595 ###### Example: wrapped simple statement list
3596
3597         a = b; c = d;
3598            e = f; print g
3599
3600 is a single simple statement list.  This might allow room for
3601 confusion, so I'm not set on it yet.
3602
3603 A simple statement list needs no extra syntax.  A complex statement
3604 list has two syntactic forms.  It can be enclosed in braces (much like
3605 C blocks), or it can be introduced by an indent and continue until an
3606 unindented newline (much like Python blocks).  With this extra syntax
3607 it is referred to as a block.
3608
3609 Note that a block does not have to include any newlines if it only
3610 contains simple statements.  So both of:
3611
3612         if condition: a=b; d=f
3613
3614         if condition { a=b; print f }
3615
3616 are valid.
3617
3618 In either case the list is constructed from a `binode` list with
3619 `Block` as the operator.  When parsing the list it is most convenient
3620 to append to the end, so a list is a list and a statement.  When using
3621 the list it is more convenient to consider a list to be a statement
3622 and a list.  So we need a function to re-order a list.
3623 `reorder_bilist` serves this purpose.
3624
3625 The only stand-alone statement we introduce at this stage is `pass`
3626 which does nothing and is represented as a `NULL` pointer in a `Block`
3627 list.  Other stand-alone statements will follow once the infrastructure
3628 is in-place.
3629
3630 ###### Binode types
3631         Block,
3632
3633 ###### Grammar
3634
3635         $TERM { } ;
3636
3637         $*binode
3638         Block -> { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3639                 | { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3640                 | SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3641                 | SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3642                 | IN OptNL Statementlist OUT ${ $0 = $<Sl; }$
3643
3644         OpenBlock -> OpenScope { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3645                 | OpenScope { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3646                 | OpenScope SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3647                 | OpenScope SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3648                 | IN OpenScope OptNL Statementlist OUT ${ $0 = $<Sl; }$
3649
3650         UseBlock -> { OpenScope IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3651                 | { OpenScope SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3652                 | IN OpenScope OptNL Statementlist OUT ${ $0 = $<Sl; }$
3653
3654         ColonBlock -> { IN OptNL Statementlist OUT OptNL } ${ $0 = $<Sl; }$
3655                 | { SimpleStatements } ${ $0 = reorder_bilist($<SS); }$
3656                 | : SimpleStatements ; ${ $0 = reorder_bilist($<SS); }$
3657                 | : SimpleStatements EOL ${ $0 = reorder_bilist($<SS); }$
3658                 | : IN OptNL Statementlist OUT ${ $0 = $<Sl; }$
3659
3660         Statementlist -> ComplexStatements ${ $0 = reorder_bilist($<CS); }$
3661
3662         ComplexStatements -> ComplexStatements ComplexStatement ${
3663                         if ($2 == NULL) {
3664                                 $0 = $<1;
3665                         } else {
3666                                 $0 = new(binode);
3667                                 $0->op = Block;
3668                                 $0->left = $<1;
3669                                 $0->right = $<2;
3670                         }
3671                 }$
3672                 | ComplexStatement ${
3673                         if ($1 == NULL) {
3674                                 $0 = NULL;
3675                         } else {
3676                                 $0 = new(binode);
3677                                 $0->op = Block;
3678                                 $0->left = NULL;
3679                                 $0->right = $<1;
3680                         }
3681                 }$
3682
3683         $*exec
3684         ComplexStatement -> SimpleStatements Newlines ${
3685                         $0 = reorder_bilist($<SS);
3686                         }$
3687                 |  SimpleStatements ; Newlines ${
3688                         $0 = reorder_bilist($<SS);
3689                         }$
3690                 ## ComplexStatement Grammar
3691
3692         $*binode
3693         SimpleStatements -> SimpleStatements ; SimpleStatement ${
3694                         $0 = new(binode);
3695                         $0->op = Block;
3696                         $0->left = $<1;
3697                         $0->right = $<3;
3698                         }$
3699                 | SimpleStatement ${
3700                         $0 = new(binode);
3701                         $0->op = Block;
3702                         $0->left = NULL;
3703                         $0->right = $<1;
3704                         }$
3705
3706         $TERM pass
3707         SimpleStatement -> pass ${ $0 = NULL; }$
3708                 | ERROR ${ tok_err(c, "Syntax error in statement", &$1); }$
3709                 ## SimpleStatement Grammar
3710
3711 ###### print binode cases
3712         case Block:
3713                 if (indent < 0) {
3714                         // simple statement
3715                         if (b->left == NULL)    // UNTESTED
3716                                 printf("pass"); // UNTESTED
3717                         else
3718                                 print_exec(b->left, indent, bracket);   // UNTESTED
3719                         if (b->right) { // UNTESTED
3720                                 printf("; ");   // UNTESTED
3721                                 print_exec(b->right, indent, bracket);  // UNTESTED
3722                         }
3723                 } else {
3724                         // block, one per line
3725                         if (b->left == NULL)
3726                                 do_indent(indent, "pass\n");
3727                         else
3728                                 print_exec(b->left, indent, bracket);
3729                         if (b->right)
3730                                 print_exec(b->right, indent, bracket);
3731                 }
3732                 break;
3733
3734 ###### propagate binode cases
3735         case Block:
3736         {
3737                 /* If any statement returns something other than Tnone
3738                  * or Tbool then all such must return same type.
3739                  * As each statement may be Tnone or something else,
3740                  * we must always pass NULL (unknown) down, otherwise an incorrect
3741                  * error might occur.  We never return Tnone unless it is
3742                  * passed in.
3743                  */
3744                 struct binode *e;
3745
3746                 for (e = b; e; e = cast(binode, e->right)) {
3747                         t = propagate_types(e->left, c, ok, NULL, rules);
3748                         if ((rules & Rboolok) && (t == Tbool || t == Tnone))
3749                                 t = NULL;
3750                         if (t == Tnone && e->right)
3751                                 /* Only the final statement *must* return a value
3752                                  * when not Rboolok
3753                                  */
3754                                 t = NULL;
3755                         if (t) {
3756                                 if (!type)
3757                                         type = t;
3758                                 else if (t != type)
3759                                         type_err(c, "error: expected %1%r, found %2",
3760                                                  e->left, type, rules, t);
3761                         }
3762                 }
3763                 return type;
3764         }
3765
3766 ###### interp binode cases
3767         case Block:
3768                 while (rvtype == Tnone &&
3769                        b) {
3770                         if (b->left)
3771                                 rv = interp_exec(c, b->left, &rvtype);
3772                         b = cast(binode, b->right);
3773                 }
3774                 break;
3775
3776 ### The Print statement
3777
3778 `print` is a simple statement that takes a comma-separated list of
3779 expressions and prints the values separated by spaces and terminated
3780 by a newline.  No control of formatting is possible.
3781
3782 `print` uses `ExpressionList` to collect the expressions and stores them
3783 on the left side of a `Print` binode unlessthere is a trailing comma
3784 when the list is stored on the `right` side and no trailing newline is
3785 printed.
3786
3787 ###### Binode types
3788         Print,
3789
3790 ##### expr precedence
3791         $TERM print
3792
3793 ###### SimpleStatement Grammar
3794
3795         | print ExpressionList ${
3796                 $0 = new(binode);
3797                 $0->op = Print;
3798                 $0->right = NULL;
3799                 $0->left = reorder_bilist($<EL);
3800         }$
3801         | print ExpressionList , ${ {
3802                 $0 = new(binode);
3803                 $0->op = Print;
3804                 $0->right = reorder_bilist($<EL);
3805                 $0->left = NULL;
3806         } }$
3807         | print ${
3808                 $0 = new(binode);
3809                 $0->op = Print;
3810                 $0->left = NULL;
3811                 $0->right = NULL;
3812         }$
3813
3814 ###### print binode cases
3815
3816         case Print:
3817                 do_indent(indent, "print");
3818                 if (b->right) {
3819                         print_exec(b->right, -1, bracket);
3820                         printf(",");
3821                 } else
3822                         print_exec(b->left, -1, bracket);
3823                 if (indent >= 0)
3824                         printf("\n");
3825                 break;
3826
3827 ###### propagate binode cases
3828
3829         case Print:
3830                 /* don't care but all must be consistent */
3831                 if (b->left)
3832                         b = cast(binode, b->left);
3833                 else
3834                         b = cast(binode, b->right);
3835                 while (b) {
3836                         propagate_types(b->left, c, ok, NULL, Rnolabel);
3837                         b = cast(binode, b->right);
3838                 }
3839                 break;
3840
3841 ###### interp binode cases
3842
3843         case Print:
3844         {
3845                 struct binode *b2 = cast(binode, b->left);
3846                 if (!b2)
3847                         b2 = cast(binode, b->right);
3848                 for (; b2; b2 = cast(binode, b2->right)) {
3849                         left = interp_exec(c, b2->left, &ltype);
3850                         print_value(ltype, &left);
3851                         free_value(ltype, &left);
3852                         if (b2->right)
3853                                 putchar(' ');
3854                 }
3855                 if (b->right == NULL)
3856                         printf("\n");
3857                 ltype = Tnone;
3858                 break;
3859         }
3860
3861 ###### Assignment statement
3862
3863 An assignment will assign a value to a variable, providing it hasn't
3864 been declared as a constant.  The analysis phase ensures that the type
3865 will be correct so the interpreter just needs to perform the
3866 calculation.  There is a form of assignment which declares a new
3867 variable as well as assigning a value.  If a name is assigned before
3868 it is declared, and error will be raised as the name is created as
3869 `Tlabel` and it is illegal to assign to such names.
3870
3871 ###### Binode types
3872         Assign,
3873         Declare,
3874
3875 ###### declare terminals
3876         $TERM =
3877
3878 ###### SimpleStatement Grammar
3879         | Variable = Expression ${
3880                         $0 = new(binode);
3881                         $0->op = Assign;
3882                         $0->left = $<1;
3883                         $0->right = $<3;
3884                 }$
3885         | VariableDecl = Expression ${
3886                         $0 = new(binode);
3887                         $0->op = Declare;
3888                         $0->left = $<1;
3889                         $0->right =$<3;
3890                 }$
3891
3892         | VariableDecl ${
3893                         if ($1->var->where_set == NULL) {
3894                                 type_err(c,
3895                                          "Variable declared with no type or value: %v",
3896                                          $1, NULL, 0, NULL);
3897                         } else {
3898                                 $0 = new(binode);
3899                                 $0->op = Declare;
3900                                 $0->left = $<1;
3901                                 $0->right = NULL;
3902                         }
3903                 }$
3904
3905 ###### print binode cases
3906
3907         case Assign:
3908                 do_indent(indent, "");
3909                 print_exec(b->left, indent, bracket);
3910                 printf(" = ");
3911                 print_exec(b->right, indent, bracket);
3912                 if (indent >= 0)
3913                         printf("\n");
3914                 break;
3915
3916         case Declare:
3917                 {
3918                 struct variable *v = cast(var, b->left)->var;
3919                 do_indent(indent, "");
3920                 print_exec(b->left, indent, bracket);
3921                 if (cast(var, b->left)->var->constant) {
3922                         printf("::");
3923                         if (v->where_decl == v->where_set) {
3924                                 type_print(v->type, stdout);
3925                                 printf(" ");
3926                         }
3927                 } else {
3928                         printf(":");
3929                         if (v->where_decl == v->where_set) {
3930                                 type_print(v->type, stdout);
3931                                 printf(" ");
3932                         }
3933                 }
3934                 if (b->right) {
3935                         printf("= ");
3936                         print_exec(b->right, indent, bracket);
3937                 }
3938                 if (indent >= 0)
3939                         printf("\n");
3940                 }
3941                 break;
3942
3943 ###### propagate binode cases
3944
3945         case Assign:
3946         case Declare:
3947                 /* Both must match and not be labels,
3948                  * Type must support 'dup',
3949                  * For Assign, left must not be constant.
3950                  * result is Tnone
3951                  */
3952                 t = propagate_types(b->left, c, ok, NULL,
3953                                     Rnolabel | (b->op == Assign ? Rnoconstant : 0));
3954                 if (!b->right)
3955                         return Tnone;
3956
3957                 if (t) {
3958                         if (propagate_types(b->right, c, ok, t, 0) != t)
3959                                 if (b->left->type == Xvar)
3960                                         type_err(c, "info: variable '%v' was set as %1 here.",
3961                                                  cast(var, b->left)->var->where_set, t, rules, NULL);
3962                 } else {
3963                         t = propagate_types(b->right, c, ok, NULL, Rnolabel);
3964                         if (t)
3965                                 propagate_types(b->left, c, ok, t,
3966                                                 (b->op == Assign ? Rnoconstant : 0));
3967                 }
3968                 if (t && t->dup == NULL)
3969                         type_err(c, "error: cannot assign value of type %1", b, t, 0, NULL);
3970                 return Tnone;
3971
3972                 break;
3973
3974 ###### interp binode cases
3975
3976         case Assign:
3977                 lleft = linterp_exec(c, b->left, &ltype);
3978                 right = interp_exec(c, b->right, &rtype);
3979                 if (lleft) {
3980                         free_value(ltype, lleft);
3981                         dup_value(ltype, &right, lleft);
3982                         ltype = NULL;
3983                 }
3984                 break;
3985
3986         case Declare:
3987         {
3988                 struct variable *v = cast(var, b->left)->var;
3989                 struct value *val;
3990                 v = v->merged;
3991                 val = var_value(c, v);
3992                 if (v->type->prepare_type)
3993                         v->type->prepare_type(c, v->type, 0);
3994                 if (b->right) {
3995                         right = interp_exec(c, b->right, &rtype);
3996                         memcpy(val, &right, rtype->size);
3997                         rtype = Tnone;
3998                 } else {
3999                         val_init(v->type, val);
4000                 }
4001                 break;
4002         }
4003
4004 ### The `use` statement
4005
4006 The `use` statement is the last "simple" statement.  It is needed when
4007 the condition in a conditional statement is a block.  `use` works much
4008 like `return` in C, but only completes the `condition`, not the whole
4009 function.
4010
4011 ###### Binode types
4012         Use,
4013
4014 ###### expr precedence
4015         $TERM use
4016
4017 ###### SimpleStatement Grammar
4018         | use Expression ${
4019                 $0 = new_pos(binode, $1);
4020                 $0->op = Use;
4021                 $0->right = $<2;
4022                 if ($0->right->type == Xvar) {
4023                         struct var *v = cast(var, $0->right);
4024                         if (v->var->type == Tnone) {
4025                                 /* Convert this to a label */
4026                                 struct value *val;
4027
4028                                 v->var->type = Tlabel;
4029                                 val = global_alloc(c, Tlabel, v->var, NULL);
4030                                 val->label = val;
4031                         }
4032                 }
4033         }$
4034
4035 ###### print binode cases
4036
4037         case Use:
4038                 do_indent(indent, "use ");
4039                 print_exec(b->right, -1, bracket);
4040                 if (indent >= 0)
4041                         printf("\n");
4042                 break;
4043
4044 ###### propagate binode cases
4045
4046         case Use:
4047                 /* result matches value */
4048                 return propagate_types(b->right, c, ok, type, 0);
4049
4050 ###### interp binode cases
4051
4052         case Use:
4053                 rv = interp_exec(c, b->right, &rvtype);
4054                 break;
4055
4056 ### The Conditional Statement
4057
4058 This is the biggy and currently the only complex statement.  This
4059 subsumes `if`, `while`, `do/while`, `switch`, and some parts of `for`.
4060 It is comprised of a number of parts, all of which are optional though
4061 set combinations apply.  Each part is (usually) a key word (`then` is
4062 sometimes optional) followed by either an expression or a code block,
4063 except the `casepart` which is a "key word and an expression" followed
4064 by a code block.  The code-block option is valid for all parts and,
4065 where an expression is also allowed, the code block can use the `use`
4066 statement to report a value.  If the code block does not report a value
4067 the effect is similar to reporting `True`.
4068
4069 The `else` and `case` parts, as well as `then` when combined with
4070 `if`, can contain a `use` statement which will apply to some
4071 containing conditional statement. `for` parts, `do` parts and `then`
4072 parts used with `for` can never contain a `use`, except in some
4073 subordinate conditional statement.
4074
4075 If there is a `forpart`, it is executed first, only once.
4076 If there is a `dopart`, then it is executed repeatedly providing
4077 always that the `condpart` or `cond`, if present, does not return a non-True
4078 value.  `condpart` can fail to return any value if it simply executes
4079 to completion.  This is treated the same as returning `True`.
4080
4081 If there is a `thenpart` it will be executed whenever the `condpart`
4082 or `cond` returns True (or does not return any value), but this will happen
4083 *after* `dopart` (when present).
4084
4085 If `elsepart` is present it will be executed at most once when the
4086 condition returns `False` or some value that isn't `True` and isn't
4087 matched by any `casepart`.  If there are any `casepart`s, they will be
4088 executed when the condition returns a matching value.
4089
4090 The particular sorts of values allowed in case parts has not yet been
4091 determined in the language design, so nothing is prohibited.
4092
4093 The various blocks in this complex statement potentially provide scope
4094 for variables as described earlier.  Each such block must include the
4095 "OpenScope" nonterminal before parsing the block, and must call
4096 `var_block_close()` when closing the block.
4097
4098 The code following "`if`", "`switch`" and "`for`" does not get its own
4099 scope, but is in a scope covering the whole statement, so names
4100 declared there cannot be redeclared elsewhere.  Similarly the
4101 condition following "`while`" is in a scope the covers the body
4102 ("`do`" part) of the loop, and which does not allow conditional scope
4103 extension.  Code following "`then`" (both looping and non-looping),
4104 "`else`" and "`case`" each get their own local scope.
4105
4106 The type requirements on the code block in a `whilepart` are quite
4107 unusal.  It is allowed to return a value of some identifiable type, in
4108 which case the loop aborts and an appropriate `casepart` is run, or it
4109 can return a Boolean, in which case the loop either continues to the
4110 `dopart` (on `True`) or aborts and runs the `elsepart` (on `False`).
4111 This is different both from the `ifpart` code block which is expected to
4112 return a Boolean, or the `switchpart` code block which is expected to
4113 return the same type as the casepart values.  The correct analysis of
4114 the type of the `whilepart` code block is the reason for the
4115 `Rboolok` flag which is passed to `propagate_types()`.
4116
4117 The `cond_statement` cannot fit into a `binode` so a new `exec` is
4118 defined.  As there are two scopes which cover multiple parts - one for
4119 the whole statement and one for "while" and "do" - and as we will use
4120 the 'struct exec' to track scopes, we actually need two new types of
4121 exec.  One is a `binode` for the looping part, the rest is the
4122 `cond_statement`.  The `cond_statement` will use an auxilliary `struct
4123 casepart` to track a list of case parts.
4124
4125 ###### Binode types
4126         Loop
4127
4128 ###### exec type
4129         Xcond_statement,
4130
4131 ###### ast
4132         struct casepart {
4133                 struct exec *value;
4134                 struct exec *action;
4135                 struct casepart *next;
4136         };
4137         struct cond_statement {
4138                 struct exec;
4139                 struct exec *forpart, *condpart, *thenpart, *elsepart;
4140                 struct binode *looppart;
4141                 struct casepart *casepart;
4142         };
4143
4144 ###### ast functions
4145
4146         static void free_casepart(struct casepart *cp)
4147         {
4148                 while (cp) {
4149                         struct casepart *t;
4150                         free_exec(cp->value);
4151                         free_exec(cp->action);
4152                         t = cp->next;
4153                         free(cp);
4154                         cp = t;
4155                 }
4156         }
4157
4158         static void free_cond_statement(struct cond_statement *s)
4159         {
4160                 if (!s)
4161                         return;
4162                 free_exec(s->forpart);
4163                 free_exec(s->condpart);
4164                 free_exec(s->looppart);
4165                 free_exec(s->thenpart);
4166                 free_exec(s->elsepart);
4167                 free_casepart(s->casepart);
4168                 free(s);
4169         }
4170
4171 ###### free exec cases
4172         case Xcond_statement: free_cond_statement(cast(cond_statement, e)); break;
4173
4174 ###### ComplexStatement Grammar
4175         | CondStatement ${ $0 = $<1; }$
4176
4177 ###### expr precedence
4178         $TERM for then while do
4179         $TERM else
4180         $TERM switch case
4181
4182 ###### Grammar
4183
4184         $*cond_statement
4185         // A CondStatement must end with EOL, as does CondSuffix and
4186         // IfSuffix.
4187         // ForPart, ThenPart, SwitchPart, CasePart are non-empty and
4188         // may or may not end with EOL
4189         // WhilePart and IfPart include an appropriate Suffix
4190
4191         // ForPart, SwitchPart, and IfPart open scopes, o we have to close
4192         // them.  WhilePart opens and closes its own scope.
4193         CondStatement -> ForPart OptNL ThenPart OptNL WhilePart CondSuffix ${
4194                         $0 = $<CS;
4195                         $0->forpart = $<FP;
4196                         $0->thenpart = $<TP;
4197                         $0->looppart = $<WP;
4198                         var_block_close(c, CloseSequential, $0);
4199                         }$
4200                 | ForPart OptNL WhilePart CondSuffix ${
4201                         $0 = $<CS;
4202                         $0->forpart = $<FP;
4203                         $0->looppart = $<WP;
4204                         var_block_close(c, CloseSequential, $0);
4205                         }$
4206                 | WhilePart CondSuffix ${
4207                         $0 = $<CS;
4208                         $0->looppart = $<WP;
4209                         }$
4210                 | SwitchPart OptNL CasePart CondSuffix ${
4211                         $0 = $<CS;
4212                         $0->condpart = $<SP;
4213                         $CP->next = $0->casepart;
4214                         $0->casepart = $<CP;
4215                         var_block_close(c, CloseSequential, $0);
4216                         }$
4217                 | SwitchPart : IN OptNL CasePart CondSuffix OUT Newlines ${
4218                         $0 = $<CS;
4219                         $0->condpart = $<SP;
4220                         $CP->next = $0->casepart;
4221                         $0->casepart = $<CP;
4222                         var_block_close(c, CloseSequential, $0);
4223                         }$
4224                 | IfPart IfSuffix ${
4225                         $0 = $<IS;
4226                         $0->condpart = $IP.condpart; $IP.condpart = NULL;
4227                         $0->thenpart = $IP.thenpart; $IP.thenpart = NULL;
4228                         // This is where we close an "if" statement
4229                         var_block_close(c, CloseSequential, $0);
4230                         }$
4231
4232         CondSuffix -> IfSuffix ${
4233                         $0 = $<1;
4234                 }$
4235                 | Newlines CasePart CondSuffix ${
4236                         $0 = $<CS;
4237                         $CP->next = $0->casepart;
4238                         $0->casepart = $<CP;
4239                 }$
4240                 | CasePart CondSuffix ${
4241                         $0 = $<CS;
4242                         $CP->next = $0->casepart;
4243                         $0->casepart = $<CP;
4244                 }$
4245
4246         IfSuffix -> Newlines ${ $0 = new(cond_statement); }$
4247                 | Newlines ElsePart ${ $0 = $<EP; }$
4248                 | ElsePart ${$0 = $<EP; }$
4249
4250         ElsePart -> else OpenBlock Newlines ${
4251                         $0 = new(cond_statement);
4252                         $0->elsepart = $<OB;
4253                         var_block_close(c, CloseElse, $0->elsepart);
4254                 }$
4255                 | else OpenScope CondStatement ${
4256                         $0 = new(cond_statement);
4257                         $0->elsepart = $<CS;
4258                         var_block_close(c, CloseElse, $0->elsepart);
4259                 }$
4260
4261         $*casepart
4262         CasePart -> case Expression OpenScope ColonBlock ${
4263                         $0 = calloc(1,sizeof(struct casepart));
4264                         $0->value = $<Ex;
4265                         $0->action = $<Bl;
4266                         var_block_close(c, CloseParallel, $0->action);
4267                 }$
4268
4269         $*exec
4270         // These scopes are closed in CondStatement
4271         ForPart -> for OpenBlock ${
4272                         $0 = $<Bl;
4273                 }$
4274
4275         ThenPart -> then OpenBlock ${
4276                         $0 = $<OB;
4277                         var_block_close(c, CloseSequential, $0);
4278                 }$
4279
4280         $*binode
4281         // This scope is closed in CondStatement
4282         WhilePart -> while UseBlock OptNL do OpenBlock ${
4283                         $0 = new(binode);
4284                         $0->op = Loop;
4285                         $0->left = $<UB;
4286                         $0->right = $<OB;
4287                         var_block_close(c, CloseSequential, $0->right);
4288                         var_block_close(c, CloseSequential, $0);
4289                 }$
4290                 | while OpenScope Expression OpenScope ColonBlock ${
4291                         $0 = new(binode);
4292                         $0->op = Loop;
4293                         $0->left = $<Exp;
4294                         $0->right = $<CB;
4295                         var_block_close(c, CloseSequential, $0->right);
4296                         var_block_close(c, CloseSequential, $0);
4297                 }$
4298
4299         $cond_statement
4300         IfPart -> if UseBlock OptNL then OpenBlock ${
4301                         $0.condpart = $<UB;
4302                         $0.thenpart = $<OB;
4303                         var_block_close(c, CloseParallel, $0.thenpart);
4304                 }$
4305                 | if OpenScope Expression OpenScope ColonBlock ${
4306                         $0.condpart = $<Ex;
4307                         $0.thenpart = $<CB;
4308                         var_block_close(c, CloseParallel, $0.thenpart);
4309                 }$
4310                 | if OpenScope Expression OpenScope OptNL then Block ${
4311                         $0.condpart = $<Ex;
4312                         $0.thenpart = $<Bl;
4313                         var_block_close(c, CloseParallel, $0.thenpart);
4314                 }$
4315
4316         $*exec
4317         // This scope is closed in CondStatement
4318         SwitchPart -> switch OpenScope Expression ${
4319                         $0 = $<Ex;
4320                 }$
4321                 | switch UseBlock ${
4322                         $0 = $<Bl;
4323                 }$
4324
4325 ###### print binode cases
4326         case Loop:
4327                 if (b->left && b->left->type == Xbinode &&
4328                     cast(binode, b->left)->op == Block) {
4329                         if (bracket)
4330                                 do_indent(indent, "while {\n");
4331                         else
4332                                 do_indent(indent, "while\n");
4333                         print_exec(b->left, indent+1, bracket);
4334                         if (bracket)
4335                                 do_indent(indent, "} do {\n");
4336                         else
4337                                 do_indent(indent, "do\n");
4338                         print_exec(b->right, indent+1, bracket);
4339                         if (bracket)
4340                                 do_indent(indent, "}\n");
4341                 } else {
4342                         do_indent(indent, "while ");
4343                         print_exec(b->left, 0, bracket);
4344                         if (bracket)
4345                                 printf(" {\n");
4346                         else
4347                                 printf(":\n");
4348                         print_exec(b->right, indent+1, bracket);
4349                         if (bracket)
4350                                 do_indent(indent, "}\n");
4351                 }
4352                 break;
4353
4354 ###### print exec cases
4355
4356         case Xcond_statement:
4357         {
4358                 struct cond_statement *cs = cast(cond_statement, e);
4359                 struct casepart *cp;
4360                 if (cs->forpart) {
4361                         do_indent(indent, "for");
4362                         if (bracket) printf(" {\n"); else printf("\n");
4363                         print_exec(cs->forpart, indent+1, bracket);
4364                         if (cs->thenpart) {
4365                                 if (bracket)
4366                                         do_indent(indent, "} then {\n");
4367                                 else
4368                                         do_indent(indent, "then\n");
4369                                 print_exec(cs->thenpart, indent+1, bracket);
4370                         }
4371                         if (bracket) do_indent(indent, "}\n");
4372                 }
4373                 if (cs->looppart) {
4374                         print_exec(cs->looppart, indent, bracket);
4375                 } else {
4376                         // a condition
4377                         if (cs->casepart)
4378                                 do_indent(indent, "switch");
4379                         else
4380                                 do_indent(indent, "if");
4381                         if (cs->condpart && cs->condpart->type == Xbinode &&
4382                             cast(binode, cs->condpart)->op == Block) {
4383                                 if (bracket)
4384                                         printf(" {\n");
4385                                 else
4386                                         printf("\n");
4387                                 print_exec(cs->condpart, indent+1, bracket);
4388                                 if (bracket)
4389                                         do_indent(indent, "}\n");
4390                                 if (cs->thenpart) {
4391                                         do_indent(indent, "then\n");
4392                                         print_exec(cs->thenpart, indent+1, bracket);
4393                                 }
4394                         } else {
4395                                 printf(" ");
4396                                 print_exec(cs->condpart, 0, bracket);
4397                                 if (cs->thenpart) {
4398                                         if (bracket)
4399                                                 printf(" {\n");
4400                                         else
4401                                                 printf(":\n");
4402                                         print_exec(cs->thenpart, indent+1, bracket);
4403                                         if (bracket)
4404                                                 do_indent(indent, "}\n");
4405                                 } else
4406                                         printf("\n");
4407                         }
4408                 }
4409                 for (cp = cs->casepart; cp; cp = cp->next) {
4410                         do_indent(indent, "case ");
4411                         print_exec(cp->value, -1, 0);
4412                         if (bracket)
4413                                 printf(" {\n");
4414                         else
4415                                 printf(":\n");
4416                         print_exec(cp->action, indent+1, bracket);
4417                         if (bracket)
4418                                 do_indent(indent, "}\n");
4419                 }
4420                 if (cs->elsepart) {
4421                         do_indent(indent, "else");
4422                         if (bracket)
4423                                 printf(" {\n");
4424                         else
4425                                 printf("\n");
4426                         print_exec(cs->elsepart, indent+1, bracket);
4427                         if (bracket)
4428                                 do_indent(indent, "}\n");
4429                 }
4430                 break;
4431         }
4432
4433 ###### propagate binode cases
4434         case Loop:
4435                 t = propagate_types(b->right, c, ok, Tnone, 0);
4436                 if (!type_compat(Tnone, t, 0))
4437                         *ok = 0;        // UNTESTED
4438                 return propagate_types(b->left, c, ok, type, rules);
4439
4440 ###### propagate exec cases
4441         case Xcond_statement:
4442         {
4443                 // forpart and looppart->right must return Tnone
4444                 // thenpart must return Tnone if there is a loopart,
4445                 // otherwise it is like elsepart.
4446                 // condpart must:
4447                 //    be bool if there is no casepart
4448                 //    match casepart->values if there is a switchpart
4449                 //    either be bool or match casepart->value if there
4450                 //             is a whilepart
4451                 // elsepart and casepart->action must match the return type
4452                 //   expected of this statement.
4453                 struct cond_statement *cs = cast(cond_statement, prog);
4454                 struct casepart *cp;
4455
4456                 t = propagate_types(cs->forpart, c, ok, Tnone, 0);
4457                 if (!type_compat(Tnone, t, 0))
4458                         *ok = 0;        // UNTESTED
4459
4460                 if (cs->looppart) {
4461                         t = propagate_types(cs->thenpart, c, ok, Tnone, 0);
4462                         if (!type_compat(Tnone, t, 0))
4463                                 *ok = 0;        // UNTESTED
4464                 }
4465                 if (cs->casepart == NULL) {
4466                         propagate_types(cs->condpart, c, ok, Tbool, 0);
4467                         propagate_types(cs->looppart, c, ok, Tbool, 0);
4468                 } else {
4469                         /* Condpart must match case values, with bool permitted */
4470                         t = NULL;
4471                         for (cp = cs->casepart;
4472                              cp && !t; cp = cp->next)
4473                                 t = propagate_types(cp->value, c, ok, NULL, 0);
4474                         if (!t && cs->condpart)
4475                                 t = propagate_types(cs->condpart, c, ok, NULL, Rboolok);        // UNTESTED
4476                         if (!t && cs->looppart)
4477                                 t = propagate_types(cs->looppart, c, ok, NULL, Rboolok);        // UNTESTED
4478                         // Now we have a type (I hope) push it down
4479                         if (t) {
4480                                 for (cp = cs->casepart; cp; cp = cp->next)
4481                                         propagate_types(cp->value, c, ok, t, 0);
4482                                 propagate_types(cs->condpart, c, ok, t, Rboolok);
4483                                 propagate_types(cs->looppart, c, ok, t, Rboolok);
4484                         }
4485                 }
4486                 // (if)then, else, and case parts must return expected type.
4487                 if (!cs->looppart && !type)
4488                         type = propagate_types(cs->thenpart, c, ok, NULL, rules);
4489                 if (!type)
4490                         type = propagate_types(cs->elsepart, c, ok, NULL, rules);
4491                 for (cp = cs->casepart;
4492                      cp && !type;
4493                      cp = cp->next)     // UNTESTED
4494                         type = propagate_types(cp->action, c, ok, NULL, rules); // UNTESTED
4495                 if (type) {
4496                         if (!cs->looppart)
4497                                 propagate_types(cs->thenpart, c, ok, type, rules);
4498                         propagate_types(cs->elsepart, c, ok, type, rules);
4499                         for (cp = cs->casepart; cp ; cp = cp->next)
4500                                 propagate_types(cp->action, c, ok, type, rules);
4501                         return type;
4502                 } else
4503                         return NULL;
4504         }
4505
4506 ###### interp binode cases
4507         case Loop:
4508                 // This just performs one iterration of the loop
4509                 rv = interp_exec(c, b->left, &rvtype);
4510                 if (rvtype == Tnone ||
4511                     (rvtype == Tbool && rv.bool != 0))
4512                         // cnd is Tnone or Tbool, doesn't need to be freed
4513                         interp_exec(c, b->right, NULL);
4514                 break;
4515
4516 ###### interp exec cases
4517         case Xcond_statement:
4518         {
4519                 struct value v, cnd;
4520                 struct type *vtype, *cndtype;
4521                 struct casepart *cp;
4522                 struct cond_statement *cs = cast(cond_statement, e);
4523
4524                 if (cs->forpart)
4525                         interp_exec(c, cs->forpart, NULL);
4526                 if (cs->looppart) {
4527                         while ((cnd = interp_exec(c, cs->looppart, &cndtype)),
4528                                cndtype == Tnone || (cndtype == Tbool && cnd.bool != 0))
4529                                 interp_exec(c, cs->thenpart, NULL);
4530                 } else {
4531                         cnd = interp_exec(c, cs->condpart, &cndtype);
4532                         if ((cndtype == Tnone ||
4533                             (cndtype == Tbool && cnd.bool != 0))) {
4534                                 // cnd is Tnone or Tbool, doesn't need to be freed
4535                                 rv = interp_exec(c, cs->thenpart, &rvtype);
4536                                 // skip else (and cases)
4537                                 goto Xcond_done;
4538                         }
4539                 }
4540                 for (cp = cs->casepart; cp; cp = cp->next) {
4541                         v = interp_exec(c, cp->value, &vtype);
4542                         if (value_cmp(cndtype, vtype, &v, &cnd) == 0) {
4543                                 free_value(vtype, &v);
4544                                 free_value(cndtype, &cnd);
4545                                 rv = interp_exec(c, cp->action, &rvtype);
4546                                 goto Xcond_done;
4547                         }
4548                         free_value(vtype, &v);
4549                 }
4550                 free_value(cndtype, &cnd);
4551                 if (cs->elsepart)
4552                         rv = interp_exec(c, cs->elsepart, &rvtype);
4553                 else
4554                         rvtype = Tnone;
4555         Xcond_done:
4556                 break;
4557         }
4558
4559 ### Top level structure
4560
4561 All the language elements so far can be used in various places.  Now
4562 it is time to clarify what those places are.
4563
4564 At the top level of a file there will be a number of declarations.
4565 Many of the things that can be declared haven't been described yet,
4566 such as functions, procedures, imports, and probably more.
4567 For now there are two sorts of things that can appear at the top
4568 level.  They are predefined constants, `struct` types, and the `main`
4569 function.  While the syntax will allow the `main` function to appear
4570 multiple times, that will trigger an error if it is actually attempted.
4571
4572 The various declarations do not return anything.  They store the
4573 various declarations in the parse context.
4574
4575 ###### Parser: grammar
4576
4577         $void
4578         Ocean -> OptNL DeclarationList
4579
4580         ## declare terminals
4581
4582         OptNL ->
4583                 | OptNL NEWLINE
4584         Newlines -> NEWLINE
4585                 | Newlines NEWLINE
4586
4587         DeclarationList -> Declaration
4588                 | DeclarationList Declaration
4589
4590         Declaration -> ERROR Newlines ${
4591                         tok_err(c,      // UNTESTED
4592                                 "error: unhandled parse error", &$1);
4593                 }$
4594                 | DeclareConstant
4595                 | DeclareFunction
4596                 | DeclareStruct
4597
4598         ## top level grammar
4599
4600         ## Grammar
4601
4602 ### The `const` section
4603
4604 As well as being defined in with the code that uses them, constants
4605 can be declared at the top level.  These have full-file scope, so they
4606 are always `InScope`.  The value of a top level constant can be given
4607 as an expression, and this is evaluated immediately rather than in the
4608 later interpretation stage.  Once we add functions to the language, we
4609 will need rules concern which, if any, can be used to define a top
4610 level constant.
4611
4612 Constants are defined in a section that starts with the reserved word
4613 `const` and then has a block with a list of assignment statements.
4614 For syntactic consistency, these must use the double-colon syntax to
4615 make it clear that they are constants.  Type can also be given: if
4616 not, the type will be determined during analysis, as with other
4617 constants.
4618
4619 As the types constants are inserted at the head of a list, printing
4620 them in the same order that they were read is not straight forward.
4621 We take a quadratic approach here and count the number of constants
4622 (variables of depth 0), then count down from there, each time
4623 searching through for the Nth constant for decreasing N.
4624
4625 ###### top level grammar
4626
4627         $TERM const
4628
4629         DeclareConstant -> const { IN OptNL ConstList OUT OptNL } Newlines
4630                 | const { SimpleConstList } Newlines
4631                 | const IN OptNL ConstList OUT Newlines
4632                 | const SimpleConstList Newlines
4633
4634         ConstList -> ConstList SimpleConstLine
4635                 | SimpleConstLine
4636         SimpleConstList -> SimpleConstList ; Const
4637                 | Const
4638                 | SimpleConstList ;
4639         SimpleConstLine -> SimpleConstList Newlines
4640                 | ERROR Newlines ${ tok_err(c, "Syntax error in constant", &$1); }$
4641
4642         $*type
4643         CType -> Type   ${ $0 = $<1; }$
4644                 |       ${ $0 = NULL; }$
4645         $void
4646         Const -> IDENTIFIER :: CType = Expression ${ {
4647                 int ok;
4648                 struct variable *v;
4649
4650                 v = var_decl(c, $1.txt);
4651                 if (v) {
4652                         struct var *var = new_pos(var, $1);
4653                         v->where_decl = var;
4654                         v->where_set = var;
4655                         var->var = v;
4656                         v->constant = 1;
4657                 } else {
4658                         v = var_ref(c, $1.txt);
4659                         tok_err(c, "error: name already declared", &$1);
4660                         type_err(c, "info: this is where '%v' was first declared",
4661                                  v->where_decl, NULL, 0, NULL);
4662                 }
4663                 do {
4664                         ok = 1;
4665                         propagate_types($5, c, &ok, $3, 0);
4666                 } while (ok == 2);
4667                 if (!ok)
4668                         c->parse_error = 1;
4669                 else if (v) {
4670                         struct value res = interp_exec(c, $5, &v->type);
4671                         global_alloc(c, v->type, v, &res);
4672                 }
4673         } }$
4674
4675 ###### print const decls
4676         {
4677                 struct variable *v;
4678                 int target = -1;
4679
4680                 while (target != 0) {
4681                         int i = 0;
4682                         for (v = context.in_scope; v; v=v->in_scope)
4683                                 if (v->depth == 0 && v->constant) {
4684                                         i += 1;
4685                                         if (i == target)
4686                                                 break;
4687                                 }
4688
4689                         if (target == -1) {
4690                                 if (i)
4691                                         printf("const\n");
4692                                 target = i;
4693                         } else {
4694                                 struct value *val = var_value(&context, v);
4695                                 printf("    %.*s :: ", v->name->name.len, v->name->name.txt);
4696                                 type_print(v->type, stdout);
4697                                 printf(" = ");
4698                                 if (v->type == Tstr)
4699                                         printf("\"");
4700                                 print_value(v->type, val);
4701                                 if (v->type == Tstr)
4702                                         printf("\"");
4703                                 printf("\n");
4704                                 target -= 1;
4705                         }
4706                 }
4707         }
4708
4709 ### Function declarations
4710
4711 The code in an Ocean program is all stored in function declarations.
4712 One of the functions must be named `main` and it must accept an array of
4713 strings as a parameter - the command line arguments.
4714
4715 As this is the top level, several things are handled a bit
4716 differently.
4717 The function is not interpreted by `interp_exec` as that isn't
4718 passed the argument list which the program requires.  Similarly type
4719 analysis is a bit more interesting at this level.
4720
4721 ###### ast functions
4722
4723         static struct variable *declare_function(struct parse_context *c,
4724                                                 struct variable *name,
4725                                                 struct binode *args,
4726                                                 struct exec *code)
4727         {
4728                 struct text funcname = {" func", 5};
4729                 if (name) {
4730                         struct value fn = {.function = code};
4731                         name->type = add_type(c, funcname, &function_prototype);
4732                         name->type->function.params = reorder_bilist(args);
4733                         global_alloc(c, name->type, name, &fn);
4734                         var_block_close(c, CloseSequential, code);
4735                 } else
4736                         var_block_close(c, CloseSequential, NULL);
4737                 return name;
4738         }
4739
4740 ###### top level grammar
4741
4742         $*variable
4743         DeclareFunction -> func FuncName ( OpenScope ArgsLine ) Block Newlines ${
4744                         $0 = declare_function(c, $<FN, $<Ar, $<Bl);
4745                 }$
4746                 | func FuncName IN OpenScope Args OUT OptNL do Block Newlines ${
4747                         $0 = declare_function(c, $<FN, $<Ar, $<Bl);
4748                 }$
4749                 | func FuncName NEWLINE OpenScope OptNL do Block Newlines ${
4750                         $0 = declare_function(c, $<FN, NULL, $<Bl);
4751                 }$
4752
4753 ###### print func decls
4754         {
4755                 struct variable *v;
4756                 int target = -1;
4757
4758                 while (target != 0) {
4759                         int i = 0;
4760                         for (v = context.in_scope; v; v=v->in_scope)
4761                                 if (v->depth == 0 && v->type && v->type->check_args) {
4762                                         i += 1;
4763                                         if (i == target)
4764                                                 break;
4765                                 }
4766
4767                         if (target == -1) {
4768                                 target = i;
4769                         } else {
4770                                 struct value *val = var_value(&context, v);
4771                                 printf("func %.*s", v->name->name.len, v->name->name.txt);
4772                                 v->type->print_type_decl(v->type, stdout);
4773                                 if (brackets)
4774                                         print_exec(val->function, 0, brackets);
4775                                 else
4776                                         print_value(v->type, val);
4777                                 printf("/* frame size %d */\n", v->type->function.local_size);
4778                                 target -= 1;
4779                         }
4780                 }
4781         }
4782
4783 ###### core functions
4784
4785         static int analyse_funcs(struct parse_context *c)
4786         {
4787                 struct variable *v;
4788                 int all_ok = 1;
4789                 for (v = c->in_scope; v; v = v->in_scope) {
4790                         struct value *val;
4791                         int ok = 1;
4792                         if (v->depth != 0 || !v->type || !v->type->check_args)
4793                                 continue;
4794                         val = var_value(c, v);
4795                         do {
4796                                 ok = 1;
4797                                 propagate_types(val->function, c, &ok, Tnone, 0);
4798                         } while (ok == 2);
4799                         if (ok)
4800                                 /* Make sure everything is still consistent */
4801                                 propagate_types(val->function, c, &ok, Tnone, 0);
4802                         if (!ok)
4803                                 all_ok = 0;
4804                         v->type->function.local_size = scope_finalize(c);
4805                 }
4806                 return all_ok;
4807         }
4808
4809         static int analyse_main(struct type *type, struct parse_context *c)
4810         {
4811                 struct binode *bp = type->function.params;
4812                 struct binode *b;
4813                 int ok = 1;
4814                 int arg = 0;
4815                 struct type *argv_type;
4816                 struct text argv_type_name = { " argv", 5 };
4817
4818                 argv_type = add_type(c, argv_type_name, &array_prototype);
4819                 argv_type->array.member = Tstr;
4820                 argv_type->array.unspec = 1;
4821
4822                 for (b = bp; b; b = cast(binode, b->right)) {
4823                         ok = 1;
4824                         switch (arg++) {
4825                         case 0: /* argv */
4826                                 propagate_types(b->left, c, &ok, argv_type, 0);
4827                                 break;
4828                         default: /* invalid */  // NOTEST
4829                                 propagate_types(b->left, c, &ok, Tnone, 0);     // NOTEST
4830                         }
4831                         if (!ok)
4832                                 c->parse_error = 1;
4833                 }
4834
4835                 return !c->parse_error;
4836         }
4837
4838         static void interp_main(struct parse_context *c, int argc, char **argv)
4839         {
4840                 struct value *progp = NULL;
4841                 struct text main_name = { "main", 4 };
4842                 struct variable *mainv;
4843                 struct binode *al;
4844                 int anum = 0;
4845                 struct value v;
4846                 struct type *vtype;
4847
4848                 mainv = var_ref(c, main_name);
4849                 if (mainv)
4850                         progp = var_value(c, mainv);
4851                 if (!progp || !progp->function) {
4852                         fprintf(stderr, "oceani: no main function found.\n");
4853                         c->parse_error = 1;
4854                         return;
4855                 }
4856                 if (!analyse_main(mainv->type, c)) {
4857                         fprintf(stderr, "oceani: main has wrong type.\n");
4858                         c->parse_error = 1;
4859                         return;
4860                 }
4861                 al = mainv->type->function.params;
4862
4863                 c->local_size = mainv->type->function.local_size;
4864                 c->local = calloc(1, c->local_size);
4865                 while (al) {
4866                         struct var *v = cast(var, al->left);
4867                         struct value *vl = var_value(c, v->var);
4868                         struct value arg;
4869                         struct type *t;
4870                         mpq_t argcq;
4871                         int i;
4872
4873                         switch (anum++) {
4874                         case 0: /* argv */
4875                                 t = v->var->type;
4876                                 mpq_init(argcq);
4877                                 mpq_set_ui(argcq, argc, 1);
4878                                 memcpy(var_value(c, t->array.vsize), &argcq, sizeof(argcq));
4879                                 t->prepare_type(c, t, 0);
4880                                 array_init(v->var->type, vl);
4881                                 for (i = 0; i < argc; i++) {
4882                                         struct value *vl2 = vl->array + i * v->var->type->array.member->size;
4883
4884                                         arg.str.txt = argv[i];
4885                                         arg.str.len = strlen(argv[i]);
4886                                         free_value(Tstr, vl2);
4887                                         dup_value(Tstr, &arg, vl2);
4888                                 }
4889                                 break;
4890                         }
4891                         al = cast(binode, al->right);
4892                 }
4893                 v = interp_exec(c, progp->function, &vtype);
4894                 free_value(vtype, &v);
4895                 free(c->local);
4896                 c->local = NULL;
4897         }
4898
4899 ###### ast functions
4900         void free_variable(struct variable *v)
4901         {
4902         }
4903
4904 ## And now to test it out.
4905
4906 Having a language requires having a "hello world" program.  I'll
4907 provide a little more than that: a program that prints "Hello world"
4908 finds the GCD of two numbers, prints the first few elements of
4909 Fibonacci, performs a binary search for a number, and a few other
4910 things which will likely grow as the languages grows.
4911
4912 ###### File: oceani.mk
4913         demos :: sayhello
4914         sayhello : oceani
4915                 @echo "===== DEMO ====="
4916                 ./oceani --section "demo: hello" oceani.mdc 55 33
4917
4918 ###### demo: hello
4919
4920         const
4921                 pi ::= 3.141_592_6
4922                 four ::= 2 + 2 ; five ::= 10/2
4923         const pie ::= "I like Pie";
4924                 cake ::= "The cake is"
4925                   ++ " a lie"
4926
4927         struct fred
4928                 size:[four]number
4929                 name:string
4930                 alive:Boolean
4931
4932         func main(argv:[argc::]string)
4933                 print "Hello World, what lovely oceans you have!"
4934                 print "Are there", five, "?"
4935                 print pi, pie, "but", cake
4936
4937                 A := $argv[1]; B := $argv[2]
4938
4939                 /* When a variable is defined in both branches of an 'if',
4940                  * and used afterwards, the variables are merged.
4941                  */
4942                 if A > B:
4943                         bigger := "yes"
4944                 else
4945                         bigger := "no"
4946                 print "Is", A, "bigger than", B,"? ", bigger
4947                 /* If a variable is not used after the 'if', no
4948                  * merge happens, so types can be different
4949                  */
4950                 if A > B * 2:
4951                         double:string = "yes"
4952                         print A, "is more than twice", B, "?", double
4953                 else
4954                         double := B*2
4955                         print "double", B, "is", double
4956
4957                 a : number
4958                 a = A;
4959                 b:number = B
4960                 if a > 0 and then b > 0:
4961                         while a != b:
4962                                 if a < b:
4963                                         b = b - a
4964                                 else
4965                                         a = a - b
4966                         print "GCD of", A, "and", B,"is", a
4967                 else if a <= 0:
4968                         print a, "is not positive, cannot calculate GCD"
4969                 else
4970                         print b, "is not positive, cannot calculate GCD"
4971
4972                 for
4973                         togo := 10
4974                         f1 := 1; f2 := 1
4975                         print "Fibonacci:", f1,f2,
4976                 then togo = togo - 1
4977                 while togo > 0:
4978                         f3 := f1 + f2
4979                         print "", f3,
4980                         f1 = f2
4981                         f2 = f3
4982                 print ""
4983
4984                 /* Binary search... */
4985                 for
4986                         lo:= 0; hi := 100
4987                         target := 77
4988                 while
4989                         mid := (lo + hi) / 2
4990                         if mid == target:
4991                                 use Found
4992                         if mid < target:
4993                                 lo = mid
4994                         else
4995                                 hi = mid
4996                         if hi - lo < 1:
4997                                 lo = mid
4998                                 use GiveUp
4999                         use True
5000                 do pass
5001                 case Found:
5002                         print "Yay, I found", target
5003                 case GiveUp:
5004                         print "Closest I found was", lo
5005
5006                 size::= 10
5007                 list:[size]number
5008                 list[0] = 1234
5009                 // "middle square" PRNG.  Not particularly good, but one my
5010                 // Dad taught me - the first one I ever heard of.
5011                 for i:=1; then i = i + 1; while i < size:
5012                         n := list[i-1] * list[i-1]
5013                         list[i] = (n / 100) % 10 000
5014
5015                 print "Before sort:",
5016                 for i:=0; then i = i + 1; while i < size:
5017                         print "", list[i],
5018                 print
5019
5020                 for i := 1; then i=i+1; while i < size:
5021                         for j:=i-1; then j=j-1; while j >= 0:
5022                                 if list[j] > list[j+1]:
5023                                         t:= list[j]
5024                                         list[j] = list[j+1]
5025                                         list[j+1] = t
5026                 print " After sort:",
5027                 for i:=0; then i = i + 1; while i < size:
5028                         print "", list[i],
5029                 print
5030
5031                 if 1 == 2 then print "yes"; else print "no"
5032
5033                 bob:fred
5034                 bob.name = "Hello"
5035                 bob.alive = (bob.name == "Hello")
5036                 print "bob", "is" if  bob.alive else "isn't", "alive"