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