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