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

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