parser-modes.c

     
   1  //! @file parser-modes.c
   2  //! @author J. Marcel van der Veer
   3  //!
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
   8  //!
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis
  23  //!
  24  //! Mode table management.
  25  
  26  #include "a68g.h"
  27  #include "a68g-postulates.h"
  28  #include "a68g-parser.h"
  29  #include "a68g-prelude.h"
  30  
  31  // Mode collection, equivalencing and derived modes.
  32  
  33  // Mode service routines.
  34  
  35  //! @brief Count bounds in declarer in tree.
  36  
  37  int count_bounds (NODE_T * p)
  38  {
  39    if (p == NO_NODE) {
  40      return 0;
  41    } else {
  42      if (IS (p, BOUND)) {
  43        return 1 + count_bounds (NEXT (p));
  44      } else {
  45        return count_bounds (NEXT (p)) + count_bounds (SUB (p));
  46      }
  47    }
  48  }
  49  
  50  //! @brief Count number of SHORTs or LONGs.
  51  
  52  int count_sizety (NODE_T * p)
  53  {
  54    if (p == NO_NODE) {
  55      return 0;
  56    } else if (IS (p, LONGETY)) {
  57      return count_sizety (SUB (p)) + count_sizety (NEXT (p));
  58    } else if (IS (p, SHORTETY)) {
  59      return count_sizety (SUB (p)) + count_sizety (NEXT (p));
  60    } else if (IS (p, LONG_SYMBOL)) {
  61      return 1;
  62    } else if (IS (p, SHORT_SYMBOL)) {
  63      return -1;
  64    } else {
  65      return 0;
  66    }
  67  }
  68  
  69  //! @brief Count moids in a pack.
  70  
  71  int count_pack_members (PACK_T * u)
  72  {
  73    int k = 0;
  74    for (; u != NO_PACK; FORWARD (u)) {
  75      k++;
  76    }
  77    return k;
  78  }
  79  
  80  //! @brief Replace a mode by its equivalent mode.
  81  
  82  void resolve_equivalent (MOID_T ** m)
  83  {
  84    while ((*m) != NO_MOID && EQUIVALENT ((*m)) != NO_MOID && (*m) != EQUIVALENT (*m)) {
  85      (*m) = EQUIVALENT (*m);
  86    }
  87  }
  88  
  89  //! @brief Reset moid.
  90  
  91  void reset_moid_tree (NODE_T * p)
  92  {
  93    for (; p != NO_NODE; FORWARD (p)) {
  94      MOID (p) = NO_MOID;
  95      reset_moid_tree (SUB (p));
  96    }
  97  }
  98  
  99  //! @brief Renumber moids.
 100  
 101  void renumber_moids (MOID_T * p, int n)
 102  {
 103    if (p != NO_MOID) {
 104      NUMBER (p) = n;
 105      renumber_moids (NEXT (p), n + 1);
 106    }
 107  }
 108  
 109  //! @brief Register mode in the global mode table, if mode is unique.
 110  
 111  MOID_T *register_extra_mode (MOID_T ** z, MOID_T * u)
 112  {
 113    MOID_T *head = TOP_MOID (&A68_JOB);
 114  // If we already know this mode, return the existing entry; otherwise link it in.
 115    for (; head != NO_MOID; FORWARD (head)) {
 116      if (prove_moid_equivalence (head, u)) {
 117        return head;
 118      }
 119    }
 120  // Link to chain and exit.
 121    NUMBER (u) = A68 (mode_count)++;
 122    NEXT (u) = (*z);
 123    return *z = u;
 124  }
 125  
 126  //! @brief Add mode "sub" to chain "z".
 127  
 128  MOID_T *add_mode (MOID_T ** z, int att, int dim, NODE_T * node, MOID_T * sub, PACK_T * pack)
 129  {
 130    MOID_T *new_mode = new_moid ();
 131    if (sub == NO_MOID) {
 132      ABEND (att == REF_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__);
 133      ABEND (att == FLEX_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__);
 134      ABEND (att == ROW_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__);
 135    }
 136    USE (new_mode) = A68_FALSE;
 137    SIZE (new_mode) = 0;
 138    ATTRIBUTE (new_mode) = att;
 139    DIM (new_mode) = dim;
 140    NODE (new_mode) = node;
 141    HAS_ROWS (new_mode) = (BOOL_T) (att == ROW_SYMBOL);
 142    SUB (new_mode) = sub;
 143    PACK (new_mode) = pack;
 144    NEXT (new_mode) = NO_MOID;
 145    EQUIVALENT (new_mode) = NO_MOID;
 146    SLICE (new_mode) = NO_MOID;
 147    DEFLEXED (new_mode) = NO_MOID;
 148    NAME (new_mode) = NO_MOID;
 149    MULTIPLE (new_mode) = NO_MOID;
 150    ROWED (new_mode) = NO_MOID;
 151    return register_extra_mode (z, new_mode);
 152  }
 153  
 154  //! @brief Contract a UNION.
 155  
 156  void contract_union (MOID_T * u)
 157  {
 158    PACK_T *s = PACK (u);
 159    for (; s != NO_PACK; FORWARD (s)) {
 160      PACK_T *t = s;
 161      while (t != NO_PACK) {
 162        if (NEXT (t) != NO_PACK && MOID (NEXT (t)) == MOID (s)) {
 163          MOID (t) = MOID (t);
 164          NEXT (t) = NEXT_NEXT (t);
 165        } else {
 166          FORWARD (t);
 167        }
 168      }
 169    }
 170  }
 171  
 172  //! @brief Absorb UNION pack.
 173  
 174  PACK_T *absorb_union_pack (PACK_T * u)
 175  {
 176    BOOL_T go_on;
 177    PACK_T *t, *z;
 178    do {
 179      z = NO_PACK;
 180      go_on = A68_FALSE;
 181      for (t = u; t != NO_PACK; FORWARD (t)) {
 182        if (IS (MOID (t), UNION_SYMBOL)) {
 183          PACK_T *s;
 184          go_on = A68_TRUE;
 185          for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) {
 186            (void) add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
 187          }
 188        } else {
 189          (void) add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
 190        }
 191      }
 192      u = z;
 193    } while (go_on);
 194    return z;
 195  }
 196  
 197  //! @brief Add row and its slices to chain, recursively.
 198  
 199  MOID_T *add_row (MOID_T ** p, int dim, MOID_T * sub, NODE_T * n, BOOL_T derivate)
 200  {
 201    MOID_T *q = add_mode (p, ROW_SYMBOL, dim, n, sub, NO_PACK);
 202    DERIVATE (q) |= derivate;
 203    if (dim > 1) {
 204      SLICE (q) = add_row (&NEXT (q), dim - 1, sub, n, derivate);
 205    } else {
 206      SLICE (q) = sub;
 207    }
 208    return q;
 209  }
 210  
 211  //! @brief Add a moid to a pack, maybe with a (field) name.
 212  
 213  void add_mode_to_pack (PACK_T ** p, MOID_T * m, char *text, NODE_T * node)
 214  {
 215    PACK_T *z = new_pack ();
 216    MOID (z) = m;
 217    TEXT (z) = text;
 218    NODE (z) = node;
 219    NEXT (z) = *p;
 220    PREVIOUS (z) = NO_PACK;
 221    if (NEXT (z) != NO_PACK) {
 222      PREVIOUS (NEXT (z)) = z;
 223    }
 224  // Link in chain.
 225    *p = z;
 226  }
 227  
 228  //! @brief Add a moid to a pack, maybe with a (field) name.
 229  
 230  void add_mode_to_pack_end (PACK_T ** p, MOID_T * m, char *text, NODE_T * node)
 231  {
 232    PACK_T *z = new_pack ();
 233    MOID (z) = m;
 234    TEXT (z) = text;
 235    NODE (z) = node;
 236    NEXT (z) = NO_PACK;
 237    if (NEXT (z) != NO_PACK) {
 238      PREVIOUS (NEXT (z)) = z;
 239    }
 240  // Link in chain.
 241    while ((*p) != NO_PACK) {
 242      p = &(NEXT (*p));
 243    }
 244    PREVIOUS (z) = (*p);
 245    (*p) = z;
 246  }
 247  
 248  //! @brief Absorb UNION members.
 249  
 250  void absorb_unions (MOID_T * m)
 251  {
 252  // UNION (A, UNION (B, C)) = UNION (A, B, C) or
 253  // UNION (A, UNION (A, B)) = UNION (A, B).
 254    for (; m != NO_MOID; FORWARD (m)) {
 255      if (IS (m, UNION_SYMBOL)) {
 256        PACK (m) = absorb_union_pack (PACK (m));
 257      }
 258    }
 259  }
 260  
 261  //! @brief Contract UNIONs .
 262  
 263  void contract_unions (MOID_T * m)
 264  {
 265  // UNION (A, B, A) -> UNION (A, B).
 266    for (; m != NO_MOID; FORWARD (m)) {
 267      if (IS (m, UNION_SYMBOL) && EQUIVALENT (m) == NO_MOID) {
 268        contract_union (m);
 269      }
 270    }
 271  }
 272  
 273  // Routines to collect MOIDs from the program text.
 274  
 275  //! @brief Search standard mode in standard environ.
 276  
 277  MOID_T *search_standard_mode (int sizety, NODE_T * indicant)
 278  {
 279    MOID_T *p = TOP_MOID (&A68_JOB);
 280  // Search standard mode.
 281    for (; p != NO_MOID; FORWARD (p)) {
 282      if (IS (p, STANDARD) && DIM (p) == sizety && NSYMBOL (NODE (p)) == NSYMBOL (indicant)) {
 283        return p;
 284      }
 285    }
 286  // Sanity check
 287  //if (sizety == -2 || sizety == 2) {
 288  //  return NO_MOID;
 289  //}
 290  // Map onto greater precision.
 291    if (sizety < 0) {
 292      return search_standard_mode (sizety + 1, indicant);
 293    } else if (sizety > 0) {
 294      return search_standard_mode (sizety - 1, indicant);
 295    } else {
 296      return NO_MOID;
 297    }
 298  }
 299  
 300  //! @brief Collect mode from STRUCT field.
 301  
 302  void get_mode_from_struct_field (NODE_T * p, PACK_T ** u)
 303  {
 304    if (p != NO_NODE) {
 305      if (IS (p, IDENTIFIER)) {
 306        ATTRIBUTE (p) = FIELD_IDENTIFIER;
 307        (void) add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p);
 308      } else if (IS (p, DECLARER)) {
 309        MOID_T *new_one = get_mode_from_declarer (p);
 310        PACK_T *t;
 311        get_mode_from_struct_field (NEXT (p), u);
 312        for (t = *u; t && MOID (t) == NO_MOID; FORWARD (t)) {
 313          MOID (t) = new_one;
 314          MOID (NODE (t)) = new_one;
 315        }
 316      } else {
 317        get_mode_from_struct_field (NEXT (p), u);
 318        get_mode_from_struct_field (SUB (p), u);
 319      }
 320    }
 321  }
 322  
 323  //! @brief Collect MODE from formal pack.
 324  
 325  void get_mode_from_formal_pack (NODE_T * p, PACK_T ** u)
 326  {
 327    if (p != NO_NODE) {
 328      if (IS (p, DECLARER)) {
 329        MOID_T *z;
 330        get_mode_from_formal_pack (NEXT (p), u);
 331        z = get_mode_from_declarer (p);
 332        (void) add_mode_to_pack (u, z, NO_TEXT, p);
 333      } else {
 334        get_mode_from_formal_pack (NEXT (p), u);
 335        get_mode_from_formal_pack (SUB (p), u);
 336      }
 337    }
 338  }
 339  
 340  //! @brief Collect MODE or VOID from formal UNION pack.
 341  
 342  void get_mode_from_union_pack (NODE_T * p, PACK_T ** u)
 343  {
 344    if (p != NO_NODE) {
 345      if (IS (p, DECLARER) || IS (p, VOID_SYMBOL)) {
 346        MOID_T *z;
 347        get_mode_from_union_pack (NEXT (p), u);
 348        z = get_mode_from_declarer (p);
 349        (void) add_mode_to_pack (u, z, NO_TEXT, p);
 350      } else {
 351        get_mode_from_union_pack (NEXT (p), u);
 352        get_mode_from_union_pack (SUB (p), u);
 353      }
 354    }
 355  }
 356  
 357  //! @brief Collect mode from PROC, OP pack.
 358  
 359  void get_mode_from_routine_pack (NODE_T * p, PACK_T ** u)
 360  {
 361    if (p != NO_NODE) {
 362      if (IS (p, IDENTIFIER)) {
 363        (void) add_mode_to_pack (u, NO_MOID, NO_TEXT, p);
 364      } else if (IS (p, DECLARER)) {
 365        MOID_T *z = get_mode_from_declarer (p);
 366        PACK_T *t = *u;
 367        for (; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t)) {
 368          MOID (t) = z;
 369          MOID (NODE (t)) = z;
 370        }
 371        (void) add_mode_to_pack (u, z, NO_TEXT, p);
 372      } else {
 373        get_mode_from_routine_pack (NEXT (p), u);
 374        get_mode_from_routine_pack (SUB (p), u);
 375      }
 376    }
 377  }
 378  
 379  //! @brief Collect MODE from DECLARER.
 380  
 381  MOID_T *get_mode_from_declarer (NODE_T * p)
 382  {
 383    if (p == NO_NODE) {
 384      return NO_MOID;
 385    } else {
 386      if (IS (p, DECLARER)) {
 387        if (MOID (p) != NO_MOID) {
 388          return MOID (p);
 389        } else {
 390          return MOID (p) = get_mode_from_declarer (SUB (p));
 391        }
 392      } else {
 393        if (IS (p, VOID_SYMBOL)) {
 394          MOID (p) = M_VOID;
 395          return MOID (p);
 396        } else if (IS (p, LONGETY)) {
 397          if (whether (p, LONGETY, INDICANT, STOP)) {
 398            int k = count_sizety (SUB (p));
 399            MOID (p) = search_standard_mode (k, NEXT (p));
 400            return MOID (p);
 401          } else {
 402            return NO_MOID;
 403          }
 404        } else if (IS (p, SHORTETY)) {
 405          if (whether (p, SHORTETY, INDICANT, STOP)) {
 406            int k = count_sizety (SUB (p));
 407            MOID (p) = search_standard_mode (k, NEXT (p));
 408            return MOID (p);
 409          } else {
 410            return NO_MOID;
 411          }
 412        } else if (IS (p, INDICANT)) {
 413          MOID_T *q = search_standard_mode (0, p);
 414          if (q != NO_MOID) {
 415            MOID (p) = q;
 416          } else {
 417  // Position of definition tells indicants apart.
 418            TAG_T *y = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
 419            if (y == NO_TAG) {
 420              diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG_2, NSYMBOL (p));
 421            } else {
 422              MOID (p) = add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y), NO_MOID, NO_PACK);
 423            }
 424          }
 425          return MOID (p);
 426        } else if (IS_REF (p)) {
 427          MOID_T *new_one = get_mode_from_declarer (NEXT (p));
 428          MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
 429          return MOID (p);
 430        } else if (IS_FLEX (p)) {
 431          MOID_T *new_one = get_mode_from_declarer (NEXT (p));
 432          MOID (p) = add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, p, new_one, NO_PACK);
 433          SLICE (MOID (p)) = SLICE (new_one);
 434          return MOID (p);
 435        } else if (IS (p, FORMAL_BOUNDS)) {
 436          MOID_T *new_one = get_mode_from_declarer (NEXT (p));
 437          MOID (p) = add_row (&TOP_MOID (&A68_JOB), 1 + count_formal_bounds (SUB (p)), new_one, p, A68_FALSE);
 438          return MOID (p);
 439        } else if (IS (p, BOUNDS)) {
 440          MOID_T *new_one = get_mode_from_declarer (NEXT (p));
 441          MOID (p) = add_row (&TOP_MOID (&A68_JOB), count_bounds (SUB (p)), new_one, p, A68_FALSE);
 442          return MOID (p);
 443        } else if (IS (p, STRUCT_SYMBOL)) {
 444          PACK_T *u = NO_PACK;
 445          get_mode_from_struct_field (NEXT (p), &u);
 446          MOID (p) = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (u), p, NO_MOID, u);
 447          return MOID (p);
 448        } else if (IS (p, UNION_SYMBOL)) {
 449          PACK_T *u = NO_PACK;
 450          get_mode_from_union_pack (NEXT (p), &u);
 451          MOID (p) = add_mode (&TOP_MOID (&A68_JOB), UNION_SYMBOL, count_pack_members (u), p, NO_MOID, u);
 452          return MOID (p);
 453        } else if (IS (p, PROC_SYMBOL)) {
 454          NODE_T *save = p;
 455          PACK_T *u = NO_PACK;
 456          MOID_T *new_one;
 457          if (IS (NEXT (p), FORMAL_DECLARERS)) {
 458            get_mode_from_formal_pack (SUB_NEXT (p), &u);
 459            FORWARD (p);
 460          }
 461          new_one = get_mode_from_declarer (NEXT (p));
 462          MOID (p) = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), save, new_one, u);
 463          MOID (save) = MOID (p);
 464          return MOID (p);
 465        } else {
 466          return NO_MOID;
 467        }
 468      }
 469    }
 470  }
 471  
 472  //! @brief Collect MODEs from a routine-text header.
 473  
 474  MOID_T *get_mode_from_routine_text (NODE_T * p)
 475  {
 476    PACK_T *u = NO_PACK;
 477    MOID_T *n;
 478    NODE_T *q = p;
 479    if (IS (p, PARAMETER_PACK)) {
 480      get_mode_from_routine_pack (SUB (p), &u);
 481      FORWARD (p);
 482    }
 483    n = get_mode_from_declarer (p);
 484    return add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), q, n, u);
 485  }
 486  
 487  //! @brief Collect modes from operator-plan.
 488  
 489  MOID_T *get_mode_from_operator (NODE_T * p)
 490  {
 491    PACK_T *u = NO_PACK;
 492    MOID_T *new_one;
 493    NODE_T *save = p;
 494    if (IS (NEXT (p), FORMAL_DECLARERS)) {
 495      get_mode_from_formal_pack (SUB_NEXT (p), &u);
 496      FORWARD (p);
 497    }
 498    new_one = get_mode_from_declarer (NEXT (p));
 499    MOID (p) = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), save, new_one, u);
 500    return MOID (p);
 501  }
 502  
 503  //! @brief Collect mode from denotation.
 504  
 505  void get_mode_from_denotation (NODE_T * p, int sizety)
 506  {
 507    if (p != NO_NODE) {
 508      if (IS (p, ROW_CHAR_DENOTATION)) {
 509        if (strlen (NSYMBOL (p)) == 1) {
 510          MOID (p) = M_CHAR;
 511        } else {
 512          MOID (p) = M_ROW_CHAR;
 513        }
 514      } else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL)) {
 515        MOID (p) = M_BOOL;
 516      } else if (IS (p, INT_DENOTATION)) {
 517        if (sizety == 0) {
 518          MOID (p) = M_INT;
 519        } else if (sizety == 1) {
 520          MOID (p) = M_LONG_INT;
 521        } else if (sizety == 2) {
 522          MOID (p) = M_LONG_LONG_INT;
 523        } else {
 524          MOID (p) = (sizety > 0 ? M_LONG_LONG_INT : M_INT);
 525        }
 526      } else if (IS (p, REAL_DENOTATION)) {
 527        if (sizety == 0) {
 528          MOID (p) = M_REAL;
 529        } else if (sizety == 1) {
 530          MOID (p) = M_LONG_REAL;
 531        } else if (sizety == 2) {
 532          MOID (p) = M_LONG_LONG_REAL;
 533        } else {
 534          MOID (p) = (sizety > 0 ? M_LONG_LONG_REAL : M_REAL);
 535        }
 536      } else if (IS (p, BITS_DENOTATION)) {
 537        if (sizety == 0) {
 538          MOID (p) = M_BITS;
 539        } else if (sizety == 1) {
 540          MOID (p) = M_LONG_BITS;
 541        } else if (sizety == 2) {
 542          MOID (p) = M_LONG_LONG_BITS;
 543        } else {
 544          MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS);
 545        }
 546      } else if (IS (p, LONGETY) || IS (p, SHORTETY)) {
 547        get_mode_from_denotation (NEXT (p), count_sizety (SUB (p)));
 548        MOID (p) = MOID (NEXT (p));
 549      } else if (IS (p, EMPTY_SYMBOL)) {
 550        MOID (p) = M_VOID;
 551      }
 552    }
 553  }
 554  
 555  //! @brief Collect modes from the syntax tree.
 556  
 557  void get_modes_from_tree (NODE_T * p, int attribute)
 558  {
 559    NODE_T *q;
 560    for (q = p; q != NO_NODE; FORWARD (q)) {
 561      if (IS (q, VOID_SYMBOL)) {
 562        MOID (q) = M_VOID;
 563      } else if (IS (q, DECLARER)) {
 564        if (attribute == VARIABLE_DECLARATION) {
 565          MOID_T *new_one = get_mode_from_declarer (q);
 566          MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
 567        } else {
 568          MOID (q) = get_mode_from_declarer (q);
 569        }
 570      } else if (IS (q, ROUTINE_TEXT)) {
 571        MOID (q) = get_mode_from_routine_text (SUB (q));
 572      } else if (IS (q, OPERATOR_PLAN)) {
 573        MOID (q) = get_mode_from_operator (SUB (q));
 574      } else if (is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) {
 575        if (attribute == GENERATOR) {
 576          MOID_T *new_one = get_mode_from_declarer (NEXT (q));
 577          MOID (NEXT (q)) = new_one;
 578          MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
 579        }
 580      } else {
 581        if (attribute == DENOTATION) {
 582          get_mode_from_denotation (q, 0);
 583        }
 584      }
 585    }
 586    if (attribute != DENOTATION) {
 587      for (q = p; q != NO_NODE; FORWARD (q)) {
 588        if (SUB (q) != NO_NODE) {
 589          get_modes_from_tree (SUB (q), ATTRIBUTE (q));
 590        }
 591      }
 592    }
 593  }
 594  
 595  //! @brief Collect modes from proc variables.
 596  
 597  void get_mode_from_proc_variables (NODE_T * p)
 598  {
 599    if (p != NO_NODE) {
 600      if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
 601        get_mode_from_proc_variables (SUB (p));
 602        get_mode_from_proc_variables (NEXT (p));
 603      } else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL)) {
 604        get_mode_from_proc_variables (NEXT (p));
 605      } else if (IS (p, DEFINING_IDENTIFIER)) {
 606        MOID_T *new_one = MOID (NEXT_NEXT (p));
 607        MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
 608      }
 609    }
 610  }
 611  
 612  //! @brief Collect modes from proc variable declarations.
 613  
 614  void get_mode_from_proc_var_declarations_tree (NODE_T * p)
 615  {
 616    for (; p != NO_NODE; FORWARD (p)) {
 617      get_mode_from_proc_var_declarations_tree (SUB (p));
 618      if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
 619        get_mode_from_proc_variables (p);
 620      }
 621    }
 622  }
 623  
 624  // Various routines to test modes.
 625  
 626  //! @brief Whether a mode declaration refers to self or relates to void.
 627  
 628  BOOL_T is_well_formed (MOID_T * def, MOID_T * z, BOOL_T yin, BOOL_T yang, BOOL_T video)
 629  {
 630    if (z == NO_MOID) {
 631      return A68_FALSE;
 632    } else if (yin && yang) {
 633      return z == M_VOID ? video : A68_TRUE;
 634    } else if (z == M_VOID) {
 635      return video;
 636    } else if (IS (z, STANDARD)) {
 637      return A68_TRUE;
 638    } else if (IS (z, INDICANT)) {
 639      if (def == NO_MOID) {
 640  // Check an applied indicant for relation to VOID.
 641        while (z != NO_MOID) {
 642          z = EQUIVALENT (z);
 643        }
 644        if (z == M_VOID) {
 645          return video;
 646        } else {
 647          return A68_TRUE;
 648        }
 649      } else {
 650        if (z == def || USE (z)) {
 651          return yin && yang;
 652        } else {
 653          BOOL_T wwf;
 654          USE (z) = A68_TRUE;
 655          wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video);
 656          USE (z) = A68_FALSE;
 657          return wwf;
 658        }
 659      }
 660    } else if (IS_REF (z)) {
 661      return is_well_formed (def, SUB (z), A68_TRUE, yang, A68_FALSE);
 662    } else if (IS (z, PROC_SYMBOL)) {
 663      return PACK (z) != NO_PACK ? A68_TRUE : is_well_formed (def, SUB (z), A68_TRUE, yang, A68_TRUE);
 664    } else if (IS_ROW (z)) {
 665      return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
 666    } else if (IS_FLEX (z)) {
 667      return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
 668    } else if (IS (z, STRUCT_SYMBOL)) {
 669      PACK_T *s = PACK (z);
 670      for (; s != NO_PACK; FORWARD (s)) {
 671        if (!is_well_formed (def, MOID (s), yin, A68_TRUE, A68_FALSE)) {
 672          return A68_FALSE;
 673        }
 674      }
 675      return A68_TRUE;
 676    } else if (IS (z, UNION_SYMBOL)) {
 677      PACK_T *s = PACK (z);
 678      for (; s != NO_PACK; FORWARD (s)) {
 679        if (!is_well_formed (def, MOID (s), yin, yang, A68_TRUE)) {
 680          return A68_FALSE;
 681        }
 682      }
 683      return A68_TRUE;
 684    } else {
 685      return A68_FALSE;
 686    }
 687  }
 688  
 689  //! @brief Replace a mode by its equivalent mode (walk chain).
 690  
 691  void resolve_eq_members (MOID_T * q)
 692  {
 693    PACK_T *p;
 694    resolve_equivalent (&SUB (q));
 695    resolve_equivalent (&DEFLEXED (q));
 696    resolve_equivalent (&MULTIPLE (q));
 697    resolve_equivalent (&NAME (q));
 698    resolve_equivalent (&SLICE (q));
 699    resolve_equivalent (&TRIM (q));
 700    resolve_equivalent (&ROWED (q));
 701    for (p = PACK (q); p != NO_PACK; FORWARD (p)) {
 702      resolve_equivalent (&MOID (p));
 703    }
 704  }
 705  
 706  //! @brief Track equivalent tags.
 707  
 708  void resolve_eq_tags (TAG_T * z)
 709  {
 710    for (; z != NO_TAG; FORWARD (z)) {
 711      if (MOID (z) != NO_MOID) {
 712        resolve_equivalent (&MOID (z));
 713      }
 714    }
 715  }
 716  
 717  //! @brief Bind modes in syntax tree.
 718  
 719  void bind_modes (NODE_T * p)
 720  {
 721    for (; p != NO_NODE; FORWARD (p)) {
 722      resolve_equivalent (&MOID (p));
 723      if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
 724        TABLE_T *s = TABLE (SUB (p));
 725        TAG_T *z = INDICANTS (s);
 726        for (; z != NO_TAG; FORWARD (z)) {
 727          if (NODE (z) != NO_NODE) {
 728            resolve_equivalent (&MOID (NEXT_NEXT (NODE (z))));
 729            MOID (z) = MOID (NEXT_NEXT (NODE (z)));
 730            MOID (NODE (z)) = MOID (z);
 731          }
 732        }
 733      }
 734      bind_modes (SUB (p));
 735    }
 736  }
 737  
 738  // Routines for calculating subordinates for selections, for instance selection
 739  // from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A) yields
 740  // [] A fields.
 741  
 742  //! @brief Make name pack.
 743  
 744  void make_name_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p)
 745  {
 746    if (src != NO_PACK) {
 747      MOID_T *z;
 748      make_name_pack (NEXT (src), dst, p);
 749      z = add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK);
 750      (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
 751    }
 752  }
 753  
 754  //! @brief Make flex multiple row pack.
 755  
 756  void make_flex_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
 757  {
 758    if (src != NO_PACK) {
 759      MOID_T *z;
 760      make_flex_multiple_row_pack (NEXT (src), dst, p, dim);
 761      z = add_row (p, dim, MOID (src), NO_NODE, A68_FALSE);
 762      z = add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK);
 763      (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
 764    }
 765  }
 766  
 767  //! @brief Make name struct.
 768  
 769  MOID_T *make_name_struct (MOID_T * m, MOID_T ** p)
 770  {
 771    PACK_T *u = NO_PACK;
 772    make_name_pack (PACK (m), &u, p);
 773    return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
 774  }
 775  
 776  //! @brief Make name row.
 777  
 778  MOID_T *make_name_row (MOID_T * m, MOID_T ** p)
 779  {
 780    if (SLICE (m) != NO_MOID) {
 781      return add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK);
 782    } else if (SUB (m) != NO_MOID) {
 783      return add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK);
 784    } else {
 785      return NO_MOID;             // weird, FLEX INT or so ...
 786    }
 787  }
 788  
 789  //! @brief Make multiple row pack.
 790  
 791  void make_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
 792  {
 793    if (src != NO_PACK) {
 794      make_multiple_row_pack (NEXT (src), dst, p, dim);
 795      (void) add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, A68_FALSE), TEXT (src), NODE (src));
 796    }
 797  }
 798  
 799  //! @brief Make flex multiple struct.
 800  
 801  MOID_T *make_flex_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
 802  {
 803    PACK_T *u = NO_PACK;
 804    make_flex_multiple_row_pack (PACK (m), &u, p, dim);
 805    return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
 806  }
 807  
 808  //! @brief Make multiple struct.
 809  
 810  MOID_T *make_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
 811  {
 812    PACK_T *u = NO_PACK;
 813    make_multiple_row_pack (PACK (m), &u, p, dim);
 814    return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
 815  }
 816  
 817  //! @brief Whether mode has row.
 818  
 819  BOOL_T is_mode_has_row (MOID_T * m)
 820  {
 821    if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) {
 822      BOOL_T k = A68_FALSE;
 823      PACK_T *p = PACK (m);
 824      for (; p != NO_PACK && k == A68_FALSE; FORWARD (p)) {
 825        HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p));
 826        k |= (HAS_ROWS (MOID (p)));
 827      }
 828      return k;
 829    } else {
 830      return (BOOL_T) (HAS_ROWS (m) || IS_ROW (m) || IS_FLEX (m));
 831    }
 832  }
 833  
 834  //! @brief Compute derived modes.
 835  
 836  void compute_derived_modes (MODULE_T * mod)
 837  {
 838    MOID_T *z;
 839    int k, len = 0, nlen = 1;
 840  // UNION things.
 841    absorb_unions (TOP_MOID (mod));
 842    contract_unions (TOP_MOID (mod));
 843  // The for-statement below prevents an endless loop.
 844    for (k = 1; k <= 10 && len != nlen; k++) {
 845  // Make deflexed modes.
 846      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 847        if (SUB (z) != NO_MOID) {
 848          if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID) {
 849            DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB_SUB (z)), NO_PACK);
 850          } else if (IS_REF (z) && DEFLEXED (SUB (z)) != NO_MOID) {
 851            DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB (z)), NO_PACK);
 852          } else if (IS_ROW (z) && DEFLEXED (SUB (z)) != NO_MOID) {
 853            DEFLEXED (z) = add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z), DEFLEXED (SUB (z)), NO_PACK);
 854          } else if (IS_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID) {
 855            DEFLEXED (z) = DEFLEXED (SUB (z));
 856          } else if (IS_FLEX (z)) {
 857            DEFLEXED (z) = SUB (z);
 858          } else {
 859            DEFLEXED (z) = z;
 860          }
 861        }
 862      }
 863  // Derived modes for stowed modes.
 864      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 865        if (NAME (z) == NO_MOID && IS_REF (z)) {
 866          if (IS (SUB (z), STRUCT_SYMBOL)) {
 867            NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod));
 868          } else if (IS_ROW (SUB (z))) {
 869            NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod));
 870          } else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID) {
 871            NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod));
 872          }
 873        }
 874        if (MULTIPLE (z) != NO_MOID) {
 875          ;
 876        } else if (IS_REF (z)) {
 877          if (MULTIPLE (SUB (z)) != NO_MOID) {
 878            MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod));
 879          }
 880        } else if (IS_ROW (z)) {
 881          if (IS (SUB (z), STRUCT_SYMBOL)) {
 882            MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z));
 883          }
 884        }
 885      }
 886      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 887        if (TRIM (z) == NO_MOID && IS_FLEX (z)) {
 888          TRIM (z) = SUB (z);
 889        }
 890        if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) {
 891          TRIM (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK);
 892        }
 893      }
 894  // Fill out stuff for rows, f.i. inverse relations.
 895      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 896        if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z)) {
 897          (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), A68_TRUE);
 898        } else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z))) {
 899          MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), A68_TRUE);
 900          MOID_T *y = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK);
 901          NAME (y) = z;
 902        }
 903      }
 904      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 905        if (IS_ROW (z) && SLICE (z) != NO_MOID) {
 906          ROWED (SLICE (z)) = z;
 907        }
 908        if (IS_REF (z)) {
 909          MOID_T *y = SUB (z);
 910          if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID) {
 911            ROWED (NAME (z)) = z;
 912          }
 913        }
 914      }
 915      bind_modes (TOP_NODE (mod));
 916      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 917        if (IS (z, INDICANT) && NODE (z) != NO_NODE) {
 918          EQUIVALENT (z) = MOID (NODE (z));
 919        }
 920      }
 921      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 922        resolve_eq_members (z);
 923      }
 924      resolve_eq_tags (INDICANTS (A68_STANDENV));
 925      resolve_eq_tags (IDENTIFIERS (A68_STANDENV));
 926      resolve_eq_tags (OPERATORS (A68_STANDENV));
 927      resolve_equivalent (&M_STRING);
 928      resolve_equivalent (&M_COMPLEX);
 929      resolve_equivalent (&M_COMPL);
 930      resolve_equivalent (&M_LONG_COMPLEX);
 931      resolve_equivalent (&M_LONG_COMPL);
 932      resolve_equivalent (&M_LONG_LONG_COMPLEX);
 933      resolve_equivalent (&M_LONG_LONG_COMPL);
 934      resolve_equivalent (&M_SEMA);
 935      resolve_equivalent (&M_PIPE);
 936  // UNION members could be resolved.
 937      absorb_unions (TOP_MOID (mod));
 938      contract_unions (TOP_MOID (mod));
 939  // FLEX INDICANT could be resolved.
 940      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 941        if (IS_FLEX (z) && SUB (z) != NO_MOID) {
 942          if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL)) {
 943            MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z)));
 944          }
 945        }
 946      }
 947  // See what new known modes we have generated by resolving..
 948      for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z)) {
 949        MOID_T *v;
 950        for (v = NEXT (z); v != NO_MOID; FORWARD (v)) {
 951          if (prove_moid_equivalence (z, v)) {
 952            EQUIVALENT (z) = v;
 953            EQUIVALENT (v) = NO_MOID;
 954          }
 955        }
 956      }
 957  // Count the modes to check self consistency.
 958      len = nlen;
 959      for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 960        nlen++;
 961      }
 962    }
 963    ABEND (M_STRING != M_FLEX_ROW_CHAR, ERROR_INTERNAL_CONSISTENCY, __func__);
 964  // Find out what modes contain rows.
 965    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 966      HAS_ROWS (z) = is_mode_has_row (z);
 967    }
 968  // Check flexible modes.
 969    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 970      if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL)) {
 971        diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
 972      }
 973    }
 974  // Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is wrong.
 975    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 976      if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
 977        PACK_T *s = PACK (z);
 978        for (; s != NO_PACK; FORWARD (s)) {
 979          PACK_T *t = NEXT (s);
 980          BOOL_T x = A68_TRUE;
 981          for (t = NEXT (s); t != NO_PACK && x; FORWARD (t)) {
 982            if (TEXT (s) == TEXT (t)) {
 983              diagnostic (A68_ERROR, NODE (z), ERROR_MULTIPLE_FIELD);
 984              while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t)) {
 985                FORWARD (s);
 986              }
 987              x = A68_FALSE;
 988            }
 989          }
 990        }
 991      }
 992    }
 993  // Various union test.
 994    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
 995      if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
 996        PACK_T *s = PACK (z);
 997  // Discard unions with one member.
 998        if (count_pack_members (s) == 1) {
 999          diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_NUMBER, z);
1000        }
1001  // Discard incestuous unions with firmly related modes.
1002        for (; s != NO_PACK; FORWARD (s)) {
1003          PACK_T *t;
1004          for (t = NEXT (s); t != NO_PACK; FORWARD (t)) {
1005            if (MOID (t) != MOID (s)) {
1006              if (is_firm (MOID (s), MOID (t))) {
1007                diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_RELATED, z);
1008              }
1009            }
1010          }
1011        }
1012  // Discard incestuous unions with firmly related subsets.
1013        for (s = PACK (z); s != NO_PACK; FORWARD (s)) {
1014          MOID_T *n = depref_completely (MOID (s));
1015          if (IS (n, UNION_SYMBOL) && is_subset (n, z, NO_DEFLEXING)) {
1016            diagnostic (A68_ERROR, NODE (z), ERROR_SUBSET_RELATED, z, n);
1017          }
1018        }
1019      }
1020    }
1021  // Wrap up and exit.
1022    free_postulate_list (A68 (top_postulate), NO_POSTULATE);
1023    A68 (top_postulate) = NO_POSTULATE;
1024  }
1025  
1026  //! @brief Make list of all modes in the program.
1027  
1028  void make_moid_list (MODULE_T * mod)
1029  {
1030    MOID_T *z;
1031    BOOL_T cont = A68_TRUE;
1032  // Collect modes from the syntax tree.
1033    reset_moid_tree (TOP_NODE (mod));
1034    get_modes_from_tree (TOP_NODE (mod), STOP);
1035    get_mode_from_proc_var_declarations_tree (TOP_NODE (mod));
1036  // Connect indicants to their declarers.
1037    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1038      if (IS (z, INDICANT)) {
1039        NODE_T *u = NODE (z);
1040        ABEND (NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1041        ABEND (NEXT_NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1042        ABEND (MOID (NEXT_NEXT (u)) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1043        EQUIVALENT (z) = MOID (NEXT_NEXT (u));
1044      }
1045    }
1046  // Checks on wrong declarations.
1047    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1048      USE (z) = A68_FALSE;
1049    }
1050    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1051      if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1052        if (!is_well_formed (z, EQUIVALENT (z), A68_FALSE, A68_FALSE, A68_TRUE)) {
1053          diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1054          cont = A68_FALSE;
1055        }
1056      }
1057    }
1058    for (z = TOP_MOID (mod); cont && z != NO_MOID; FORWARD (z)) {
1059      if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1060        ;
1061      } else if (NODE (z) != NO_NODE) {
1062        if (!is_well_formed (NO_MOID, z, A68_FALSE, A68_FALSE, A68_TRUE)) {
1063          diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1064        }
1065      }
1066    }
1067    for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1068      ABEND (USE (z), ERROR_INTERNAL_CONSISTENCY, __func__);
1069    }
1070    if (ERROR_COUNT (mod) != 0) {
1071      return;
1072    }
1073    compute_derived_modes (mod);
1074    init_postulates ();
1075  }