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