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

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