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