ocean-lang.org Git - ocean/blob - csrc/oceani.mdc

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