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