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