plugin-gen.c

     
   1  //! @file plugin-gen.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  //! Plugin compiler generator routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-prelude.h"
  28  #include "a68g-genie.h"
  29  #include "a68g-listing.h"
  30  #include "a68g-mp.h"
  31  #include "a68g-optimiser.h"
  32  #include "a68g-plugin.h"
  33  #include "a68g-parser.h"
  34  #include "a68g-transput.h"
  35  
  36  //! @brief Compile code clause.
  37  
  38  void embed_code_clause (NODE_T * p, FILE_T out)
  39  {
  40    for (; p != NO_NODE; FORWARD (p)) {
  41      if (IS (p, ROW_CHAR_DENOTATION)) {
  42        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s\n", NSYMBOL (p)));
  43      }
  44      embed_code_clause (SUB (p), out);
  45    }
  46  }
  47  
  48  //! @brief Compile push.
  49  
  50  void gen_push (NODE_T * p, FILE_T out)
  51  {
  52    if (primitive_mode (MOID (p))) {
  53      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
  54      inline_unit (p, out, L_YIELD);
  55      undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
  56    } else if (basic_mode (MOID (p))) {
  57      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) STACK_TOP, (void *) "));
  58      inline_unit (p, out, L_YIELD);
  59      undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
  60      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP += %d;\n", SIZE (MOID (p))));
  61    } else {
  62      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, moid_to_string (MOID (p), 80, NO_NODE));
  63    }
  64  }
  65  
  66  //! @brief Compile assign (C source to C destination).
  67  
  68  void gen_assign (NODE_T * p, FILE_T out, char *dst)
  69  {
  70    if (primitive_mode (MOID (p))) {
  71      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", dst));
  72      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = ", dst));
  73      inline_unit (p, out, L_YIELD);
  74      undent (out, ";\n");
  75    } else if (basic_mode (MOID (p))) {
  76      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", dst));
  77      inline_unit (p, out, L_YIELD);
  78      undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
  79    } else {
  80      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, moid_to_string (MOID (p), 80, NO_NODE));
  81    }
  82  }
  83  
  84  //! @brief Compile denotation.
  85  
  86  char *gen_denotation (NODE_T * p, FILE_T out, int compose_fun)
  87  {
  88    if (primitive_mode (MOID (p))) {
  89      if (compose_fun == A68_MAKE_FUNCTION) {
  90        return compile_denotation (p, out);
  91      } else {
  92        static char fn[NAME_SIZE];
  93        comment_source (p, out);
  94        (void) make_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", NUMBER (p));
  95        A68_OPT (root_idf) = NO_DEC;
  96        inline_unit (p, out, L_DECLARE);
  97        print_declarations (out, A68_OPT (root_idf));
  98        inline_unit (p, out, L_EXECUTE);
  99        if (primitive_mode (MOID (p))) {
 100          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
 101          inline_unit (p, out, L_YIELD);
 102          undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
 103        } else {
 104          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH (p, "));
 105          inline_unit (p, out, L_YIELD);
 106          undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
 107        }
 108        return fn;
 109      }
 110    } else {
 111      return NO_TEXT;
 112    }
 113  }
 114  
 115  //! @brief Compile cast.
 116  
 117  char *gen_cast (NODE_T * p, FILE_T out, int compose_fun)
 118  {
 119    if (compose_fun == A68_MAKE_FUNCTION) {
 120      return compile_cast (p, out);
 121    } else if (basic_unit (p)) {
 122      static char fn[NAME_SIZE];
 123      comment_source (p, out);
 124      (void) make_name (fn, moid_with_name ("", MOID (p), "_cast"), "", NUMBER (p));
 125      A68_OPT (root_idf) = NO_DEC;
 126      inline_unit (NEXT_SUB (p), out, L_DECLARE);
 127      print_declarations (out, A68_OPT (root_idf));
 128      inline_unit (NEXT_SUB (p), out, L_EXECUTE);
 129      gen_push (NEXT_SUB (p), out);
 130      return fn;
 131    } else {
 132      return NO_TEXT;
 133    }
 134  }
 135  
 136  //! @brief Compile identifier.
 137  
 138  char *gen_identifier (NODE_T * p, FILE_T out, int compose_fun)
 139  {
 140    if (compose_fun == A68_MAKE_FUNCTION) {
 141      return compile_identifier (p, out);
 142    } else if (basic_mode (MOID (p))) {
 143      static char fn[NAME_SIZE];
 144      (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", NUMBER (p));
 145      comment_source (p, out);
 146      A68_OPT (root_idf) = NO_DEC;
 147      inline_unit (p, out, L_DECLARE);
 148      print_declarations (out, A68_OPT (root_idf));
 149      inline_unit (p, out, L_EXECUTE);
 150      gen_push (p, out);
 151      return fn;
 152    } else {
 153      return NO_TEXT;
 154    }
 155  }
 156  
 157  //! @brief Compile dereference identifier.
 158  
 159  char *gen_dereference_identifier (NODE_T * p, FILE_T out, int compose_fun)
 160  {
 161    if (compose_fun == A68_MAKE_FUNCTION) {
 162      return compile_dereference_identifier (p, out);
 163    } else if (basic_mode (MOID (p))) {
 164      static char fn[NAME_SIZE];
 165      comment_source (p, out);
 166      (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", NUMBER (p));
 167      A68_OPT (root_idf) = NO_DEC;
 168      inline_unit (p, out, L_DECLARE);
 169      print_declarations (out, A68_OPT (root_idf));
 170      inline_unit (p, out, L_EXECUTE);
 171      gen_push (p, out);
 172      return fn;
 173    } else {
 174      return NO_TEXT;
 175    }
 176  }
 177  
 178  //! @brief Compile slice.
 179  
 180  char *gen_slice (NODE_T * p, FILE_T out, int compose_fun)
 181  {
 182    if (basic_mode (MOID (p)) && basic_unit (p)) {
 183      static char fn[NAME_SIZE];
 184      comment_source (p, out);
 185      (void) make_name (fn, moid_with_name ("", MOID (p), "_slice"), "", NUMBER (p));
 186      if (compose_fun == A68_MAKE_FUNCTION) {
 187        write_fun_prelude (p, out, fn);
 188      }
 189      A68_OPT (root_idf) = NO_DEC;
 190      inline_unit (p, out, L_DECLARE);
 191      print_declarations (out, A68_OPT (root_idf));
 192      inline_unit (p, out, L_EXECUTE);
 193      gen_push (p, out);
 194      if (compose_fun == A68_MAKE_FUNCTION) {
 195        write_fun_postlude (p, out, fn);
 196      }
 197      return fn;
 198    } else {
 199      return NO_TEXT;
 200    }
 201  }
 202  
 203  //! @brief Compile slice.
 204  
 205  char *gen_dereference_slice (NODE_T * p, FILE_T out, int compose_fun)
 206  {
 207    if (basic_mode (MOID (p)) && basic_unit (p)) {
 208      static char fn[NAME_SIZE];
 209      comment_source (p, out);
 210      (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_slice"), "", NUMBER (p));
 211      if (compose_fun == A68_MAKE_FUNCTION) {
 212        write_fun_prelude (p, out, fn);
 213      }
 214      A68_OPT (root_idf) = NO_DEC;
 215      inline_unit (p, out, L_DECLARE);
 216      print_declarations (out, A68_OPT (root_idf));
 217      inline_unit (p, out, L_EXECUTE);
 218      gen_push (p, out);
 219      if (compose_fun == A68_MAKE_FUNCTION) {
 220        write_fun_postlude (p, out, fn);
 221      }
 222      return fn;
 223    } else {
 224      return NO_TEXT;
 225    }
 226  }
 227  
 228  //! @brief Compile selection.
 229  
 230  char *gen_selection (NODE_T * p, FILE_T out, int compose_fun)
 231  {
 232    if (basic_mode (MOID (p)) && basic_unit (p)) {
 233      static char fn[NAME_SIZE];
 234      comment_source (p, out);
 235      (void) make_name (fn, moid_with_name ("", MOID (p), "_select"), "", NUMBER (p));
 236      if (compose_fun == A68_MAKE_FUNCTION) {
 237        write_fun_prelude (p, out, fn);
 238      }
 239      A68_OPT (root_idf) = NO_DEC;
 240      inline_unit (p, out, L_DECLARE);
 241      print_declarations (out, A68_OPT (root_idf));
 242      inline_unit (p, out, L_EXECUTE);
 243      gen_push (p, out);
 244      if (compose_fun == A68_MAKE_FUNCTION) {
 245        write_fun_postlude (p, out, fn);
 246      }
 247      return fn;
 248    } else {
 249      return NO_TEXT;
 250    }
 251  }
 252  
 253  //! @brief Compile selection.
 254  
 255  char *gen_dereference_selection (NODE_T * p, FILE_T out, int compose_fun)
 256  {
 257    if (basic_mode (MOID (p)) && basic_unit (p)) {
 258      static char fn[NAME_SIZE];
 259      comment_source (p, out);
 260      (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_select"), "", NUMBER (p));
 261      if (compose_fun == A68_MAKE_FUNCTION) {
 262        write_fun_prelude (p, out, fn);
 263      }
 264      A68_OPT (root_idf) = NO_DEC;
 265      inline_unit (p, out, L_DECLARE);
 266      print_declarations (out, A68_OPT (root_idf));
 267      inline_unit (p, out, L_EXECUTE);
 268      gen_push (p, out);
 269      if (compose_fun == A68_MAKE_FUNCTION) {
 270        write_fun_postlude (p, out, fn);
 271      }
 272      return fn;
 273    } else {
 274      return NO_TEXT;
 275    }
 276  }
 277  
 278  //! @brief Compile formula.
 279  
 280  char *gen_formula (NODE_T * p, FILE_T out, int compose_fun)
 281  {
 282    if (basic_unit (p)) {
 283      static char fn[NAME_SIZE];
 284      comment_source (p, out);
 285      (void) make_name (fn, moid_with_name ("", MOID (p), "_formula"), "", NUMBER (p));
 286      if (compose_fun == A68_MAKE_FUNCTION) {
 287        write_fun_prelude (p, out, fn);
 288      }
 289      A68_OPT (root_idf) = NO_DEC;
 290      inline_unit (p, out, L_DECLARE);
 291      print_declarations (out, A68_OPT (root_idf));
 292      if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
 293        if (MOID (p) == M_REAL || MOID (p) == M_COMPLEX) {
 294          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "errno = 0;\n"));
 295        }
 296      }
 297      inline_unit (p, out, L_EXECUTE);
 298      gen_push (p, out);
 299      if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
 300        if (MOID (p) == M_REAL) {
 301          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);\n"));
 302        }
 303        if (MOID (p) == M_COMPLEX) {
 304          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);\n"));
 305        }
 306      }
 307      if (compose_fun == A68_MAKE_FUNCTION) {
 308        write_fun_postlude (p, out, fn);
 309      }
 310      return fn;
 311    } else {
 312      return NO_TEXT;
 313    }
 314  }
 315  
 316  //! @brief Compile voiding formula.
 317  
 318  char *gen_voiding_formula (NODE_T * p, FILE_T out, int compose_fun)
 319  {
 320    if (basic_unit (p)) {
 321      static char fn[NAME_SIZE];
 322      char pop[NAME_SIZE];
 323      (void) make_name (pop, PUP, "", NUMBER (p));
 324      comment_source (p, out);
 325      (void) make_name (fn, moid_with_name ("void_", MOID (p), "_formula"), "", NUMBER (p));
 326      if (compose_fun == A68_MAKE_FUNCTION) {
 327        write_fun_prelude (p, out, fn);
 328      }
 329      A68_OPT (root_idf) = NO_DEC;
 330      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 331      inline_unit (p, out, L_DECLARE);
 332      print_declarations (out, A68_OPT (root_idf));
 333      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 334      inline_unit (p, out, L_EXECUTE);
 335      indent (out, "(void) (");
 336      inline_unit (p, out, L_YIELD);
 337      undent (out, ");\n");
 338      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 339      if (compose_fun == A68_MAKE_FUNCTION) {
 340        write_fun_postlude (p, out, fn);
 341      }
 342      return fn;
 343    } else {
 344      return NO_TEXT;
 345    }
 346  }
 347  
 348  //! @brief Compile uniting.
 349  
 350  char *gen_uniting (NODE_T * p, FILE_T out, int compose_fun)
 351  {
 352    MOID_T *u = MOID (p), *v = MOID (SUB (p));
 353    NODE_T *q = SUB (p);
 354    if (basic_unit (q) && ATTRIBUTE (v) != UNION_SYMBOL && primitive_mode (v)) {
 355      static char fn[NAME_SIZE];
 356      char pop0[NAME_SIZE];
 357      (void) make_name (pop0, PUP, "0", NUMBER (p));
 358      comment_source (p, out);
 359      (void) make_name (fn, moid_with_name ("", MOID (p), "_unite"), "", NUMBER (p));
 360      if (compose_fun == A68_MAKE_FUNCTION) {
 361        write_fun_prelude (p, out, fn);
 362      }
 363      A68_OPT (root_idf) = NO_DEC;
 364      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop0);
 365      inline_unit (q, out, L_DECLARE);
 366      print_declarations (out, A68_OPT (root_idf));
 367      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop0));
 368      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_UNION (_NODE_ (%d), %s);\n", NUMBER (p), internal_mode (v)));
 369      inline_unit (q, out, L_EXECUTE);
 370      gen_push (q, out);
 371      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s + %d;\n", pop0, SIZE (u)));
 372      if (compose_fun == A68_MAKE_FUNCTION) {
 373        write_fun_postlude (p, out, fn);
 374      }
 375      return fn;
 376    } else {
 377      return NO_TEXT;
 378    }
 379  }
 380  
 381  //! @brief Compile deproceduring.
 382  
 383  char *gen_deproceduring (NODE_T * p, FILE_T out, int compose_fun)
 384  {
 385    NODE_T *idf = stems_from (SUB (p), IDENTIFIER);
 386    if (idf == NO_NODE) {
 387      return NO_TEXT;
 388    } else if (!(SUB_MOID (idf) == M_VOID || basic_mode (SUB_MOID (idf)))) {
 389      return NO_TEXT;
 390    } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
 391      return NO_TEXT;
 392    } else {
 393      static char fn[NAME_SIZE];
 394      char fun[NAME_SIZE];
 395      (void) make_name (fun, FUN, "", NUMBER (idf));
 396      comment_source (p, out);
 397      (void) make_name (fn, moid_with_name ("", MOID (p), "_deproc"), "", NUMBER (p));
 398      if (compose_fun == A68_MAKE_FUNCTION) {
 399        write_fun_prelude (p, out, fn);
 400      }
 401  // Declare.
 402      A68_OPT (root_idf) = NO_DEC;
 403      (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun);
 404      (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
 405      print_declarations (out, A68_OPT (root_idf));
 406  // Initialise.
 407      get_stack (idf, out, fun, "A68_PROCEDURE");
 408      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
 409      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
 410      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
 411  // Execute procedure.
 412      indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n");
 413      indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
 414      A68_OPT (indentation)++;
 415      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
 416      A68_OPT (indentation)--;
 417      indent (out, "}\n");
 418      indent (out, "CLOSE_FRAME;\n");
 419      if (compose_fun == A68_MAKE_FUNCTION) {
 420        write_fun_postlude (p, out, fn);
 421      }
 422      return fn;
 423    }
 424  }
 425  
 426  //! @brief Compile deproceduring.
 427  
 428  char *gen_voiding_deproceduring (NODE_T * p, FILE_T out, int compose_fun)
 429  {
 430    NODE_T *idf = stems_from (SUB_SUB (p), IDENTIFIER);
 431    if (idf == NO_NODE) {
 432      return NO_TEXT;
 433    } else if (!(SUB_MOID (idf) == M_VOID || basic_mode (SUB_MOID (idf)))) {
 434      return NO_TEXT;
 435    } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
 436      return NO_TEXT;
 437    } else {
 438      static char fn[NAME_SIZE];
 439      char fun[NAME_SIZE], pop[NAME_SIZE];
 440      (void) make_name (fun, FUN, "", NUMBER (idf));
 441      (void) make_name (pop, PUP, "", NUMBER (p));
 442      comment_source (p, out);
 443      (void) make_name (fn, moid_with_name ("void_", MOID (p), "_deproc"), "", NUMBER (p));
 444      if (compose_fun == A68_MAKE_FUNCTION) {
 445        write_fun_prelude (p, out, fn);
 446      }
 447  // Declare.
 448      A68_OPT (root_idf) = NO_DEC;
 449      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 450      (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun);
 451      (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
 452      print_declarations (out, A68_OPT (root_idf));
 453  // Initialise.
 454      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 455      if (compose_fun != A68_MAKE_NOTHING) {
 456      }
 457      get_stack (idf, out, fun, "A68_PROCEDURE");
 458      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
 459      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
 460      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
 461  // Execute procedure.
 462      indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n");
 463      indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
 464      A68_OPT (indentation)++;
 465      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
 466      A68_OPT (indentation)--;
 467      indent (out, "}\n");
 468      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 469      indent (out, "CLOSE_FRAME;\n");
 470      if (compose_fun == A68_MAKE_FUNCTION) {
 471        write_fun_postlude (p, out, fn);
 472      }
 473      return fn;
 474    }
 475  }
 476  
 477  //! @brief Compile call.
 478  
 479  char *gen_call (NODE_T * p, FILE_T out, int compose_fun)
 480  {
 481    NODE_T *proc = SUB (p);
 482    NODE_T *args = NEXT (proc);
 483    NODE_T *idf = stems_from (proc, IDENTIFIER);
 484    if (idf == NO_NODE) {
 485      return NO_TEXT;
 486    } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) {
 487      return NO_TEXT;
 488    } else if (DIM (MOID (proc)) == 0) {
 489      return NO_TEXT;
 490    } else if (A68_STANDENV_PROC (TAX (idf))) {
 491      if (basic_call (p)) {
 492        static char fun[NAME_SIZE];
 493        comment_source (p, out);
 494        (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
 495        if (compose_fun == A68_MAKE_FUNCTION) {
 496          write_fun_prelude (p, out, fun);
 497        }
 498        A68_OPT (root_idf) = NO_DEC;
 499        inline_unit (p, out, L_DECLARE);
 500        print_declarations (out, A68_OPT (root_idf));
 501        inline_unit (p, out, L_EXECUTE);
 502        gen_push (p, out);
 503        if (compose_fun == A68_MAKE_FUNCTION) {
 504          write_fun_postlude (p, out, fun);
 505        }
 506        return fun;
 507      } else {
 508        return NO_TEXT;
 509      }
 510    } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
 511      return NO_TEXT;
 512    } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
 513      return NO_TEXT;
 514    } else if (!basic_argument (args)) {
 515      return NO_TEXT;
 516    } else {
 517      static char fun[NAME_SIZE];
 518      char body[NAME_SIZE], pop[NAME_SIZE];
 519      int size;
 520  // Declare.
 521      (void) make_name (body, FUN, "", NUMBER (proc));
 522      (void) make_name (pop, PUP, "", NUMBER (p));
 523      comment_source (p, out);
 524      (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
 525      if (compose_fun == A68_MAKE_FUNCTION) {
 526        write_fun_prelude (p, out, fun);
 527      }
 528  // Compute arguments.
 529      size = 0;
 530      A68_OPT (root_idf) = NO_DEC;
 531      inline_arguments (args, out, L_DECLARE, &size);
 532      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 533      (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, body);
 534      (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
 535      print_declarations (out, A68_OPT (root_idf));
 536  // Initialise.
 537      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 538      inline_arguments (args, out, L_INITIALISE, &size);
 539      get_stack (idf, out, body, "A68_PROCEDURE");
 540      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", body));
 541      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", body));
 542      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
 543      size = 0;
 544      inline_arguments (args, out, L_EXECUTE, &size);
 545      size = 0;
 546      inline_arguments (args, out, L_YIELD, &size);
 547  // Execute procedure.
 548      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 549      indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
 550      indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
 551      A68_OPT (indentation)++;
 552      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
 553      A68_OPT (indentation)--;
 554      indent (out, "}\n");
 555      indent (out, "CLOSE_FRAME;\n");
 556      if (compose_fun == A68_MAKE_FUNCTION) {
 557        write_fun_postlude (p, out, fun);
 558      }
 559      return fun;
 560    }
 561  }
 562  
 563  //! @brief Compile call.
 564  
 565  char *gen_voiding_call (NODE_T * p, FILE_T out, int compose_fun)
 566  {
 567    NODE_T *proc = SUB (stems_from (p, CALL));
 568    NODE_T *args = NEXT (proc);
 569    NODE_T *idf = stems_from (proc, IDENTIFIER);
 570    if (idf == NO_NODE) {
 571      return NO_TEXT;
 572    } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) {
 573      return NO_TEXT;
 574    } else if (DIM (MOID (proc)) == 0) {
 575      return NO_TEXT;
 576    } else if (A68_STANDENV_PROC (TAX (idf))) {
 577      return NO_TEXT;
 578    } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
 579      return NO_TEXT;
 580    } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
 581      return NO_TEXT;
 582    } else if (!basic_argument (args)) {
 583      return NO_TEXT;
 584    } else {
 585      static char fun[NAME_SIZE];
 586      char body[NAME_SIZE], pop[NAME_SIZE];
 587      int size;
 588  // Declare.
 589      (void) make_name (body, FUN, "", NUMBER (proc));
 590      (void) make_name (pop, PUP, "", NUMBER (p));
 591      comment_source (p, out);
 592      (void) make_name (fun, moid_with_name ("void_", SUB_MOID (proc), "_call"), "", NUMBER (p));
 593      if (compose_fun == A68_MAKE_FUNCTION) {
 594        write_fun_prelude (p, out, fun);
 595      }
 596  // Compute arguments.
 597      size = 0;
 598      A68_OPT (root_idf) = NO_DEC;
 599      inline_arguments (args, out, L_DECLARE, &size);
 600      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 601      (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, body);
 602      (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
 603      print_declarations (out, A68_OPT (root_idf));
 604  // Initialise.
 605      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 606      inline_arguments (args, out, L_INITIALISE, &size);
 607      get_stack (idf, out, body, "A68_PROCEDURE");
 608      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", body));
 609      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", body));
 610      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
 611      size = 0;
 612      inline_arguments (args, out, L_EXECUTE, &size);
 613      size = 0;
 614      inline_arguments (args, out, L_YIELD, &size);
 615  // Execute procedure.
 616      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 617      indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
 618      indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
 619      A68_OPT (indentation)++;
 620      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
 621      A68_OPT (indentation)--;
 622      indent (out, "}\n");
 623      indent (out, "CLOSE_FRAME;\n");
 624      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 625      if (compose_fun == A68_MAKE_FUNCTION) {
 626        write_fun_postlude (p, out, fun);
 627      }
 628      return fun;
 629    }
 630  }
 631  
 632  //! @brief Compile voiding assignation.
 633  
 634  char *gen_voiding_assignation_selection (NODE_T * p, FILE_T out, int compose_fun)
 635  {
 636    NODE_T *dst = SUB (stems_from (p, ASSIGNATION));
 637    NODE_T *src = NEXT_NEXT (dst);
 638    if (BASIC (dst, SELECTION) && basic_unit (src) && basic_mode_non_row (MOID (dst))) {
 639      NODE_T *field = SUB (stems_from (dst, SELECTION));
 640      NODE_T *sec = NEXT (field);
 641      NODE_T *idf = stems_from (sec, IDENTIFIER);
 642      char sel[NAME_SIZE], ref[NAME_SIZE], pop[NAME_SIZE];
 643      char *field_idf = NSYMBOL (SUB (field));
 644      static char fn[NAME_SIZE];
 645      comment_source (p, out);
 646      (void) make_name (pop, PUP, "", NUMBER (p));
 647      (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p));
 648      if (compose_fun == A68_MAKE_FUNCTION) {
 649        write_fun_prelude (p, out, fn);
 650      }
 651  // Declare.
 652      A68_OPT (root_idf) = NO_DEC;
 653      if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)) == NO_BOOK) {
 654        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 655        (void) make_name (sel, SEL, "", NUMBER (field));
 656        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_REF * %s; /* %s */\n", ref, NSYMBOL (idf)));
 657        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s * %s;\n", inline_mode (SUB_MOID (field)), sel));
 658        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 659      } else {
 660        int n = NUMBER (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)));
 661        (void) make_name (ref, NSYMBOL (idf), "", n);
 662        (void) make_name (sel, SEL, "", n);
 663      }
 664      inline_unit (src, out, L_DECLARE);
 665      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 666      print_declarations (out, A68_OPT (root_idf));
 667      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 668  // Initialise.
 669      if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)) == NO_BOOK) {
 670        get_stack (idf, out, ref, "A68_REF");
 671        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
 672        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 673      }
 674      inline_unit (src, out, L_EXECUTE);
 675  // Generate.
 676      gen_assign (src, out, sel);
 677      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 678      if (compose_fun == A68_MAKE_FUNCTION) {
 679        write_fun_postlude (p, out, fn);
 680      }
 681      return fn;
 682    } else {
 683      return NO_TEXT;
 684    }
 685  }
 686  
 687  //! @brief Compile voiding assignation.
 688  
 689  char *gen_voiding_assignation_slice (NODE_T * p, FILE_T out, int compose_fun)
 690  {
 691    NODE_T *dst = SUB (stems_from (p, ASSIGNATION));
 692    NODE_T *src = NEXT_NEXT (dst);
 693    NODE_T *slice = stems_from (SUB (dst), SLICE);
 694    NODE_T *prim = SUB (slice);
 695    MOID_T *mode = SUB_MOID (dst);
 696    MOID_T *row_mode = DEFLEX (MOID (prim));
 697    if (IS (row_mode, REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src))) {
 698      NODE_T *indx = NEXT (prim);
 699      char *symbol = NSYMBOL (SUB (prim));
 700      char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], pop[NAME_SIZE];
 701      static char fn[NAME_SIZE];
 702      INT_T k;
 703      comment_source (p, out);
 704      (void) make_name (pop, PUP, "", NUMBER (p));
 705      (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p));
 706      if (compose_fun == A68_MAKE_FUNCTION) {
 707        write_fun_prelude (p, out, fn);
 708      }
 709  // Declare.
 710      A68_OPT (root_idf) = NO_DEC;
 711      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 712      if (signed_in (BOOK_DECL, L_DECLARE, symbol) == NO_BOOK) {
 713        (void) make_name (idf, symbol, "", NUMBER (prim));
 714        (void) make_name (arr, ARR, "", NUMBER (prim));
 715        (void) make_name (tup, TUP, "", NUMBER (prim));
 716        (void) make_name (elm, ELM, "", NUMBER (prim));
 717        (void) make_name (drf, DRF, "", NUMBER (prim));
 718        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
 719        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
 720        (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr);
 721        (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup);
 722        (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
 723        sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
 724      } else {
 725        int n = NUMBER (signed_in (BOOK_DECL, L_EXECUTE, symbol));
 726        (void) make_name (idf, symbol, "", n);
 727        (void) make_name (arr, ARR, "", n);
 728        (void) make_name (tup, TUP, "", n);
 729        (void) make_name (elm, ELM, "", n);
 730        (void) make_name (drf, DRF, "", n);
 731      }
 732      k = 0;
 733      inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
 734      inline_unit (src, out, L_DECLARE);
 735      print_declarations (out, A68_OPT (root_idf));
 736  // Initialise.
 737      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 738      if (signed_in (BOOK_DECL, L_EXECUTE, symbol) == NO_BOOK) {
 739        NODE_T *pidf = stems_from (prim, IDENTIFIER);
 740        get_stack (pidf, out, idf, "A68_REF");
 741        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
 742        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
 743        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
 744      }
 745      k = 0;
 746      inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
 747      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
 748      k = 0;
 749      inline_indexer (indx, out, L_YIELD, &k, tup);
 750      undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
 751      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
 752      inline_unit (src, out, L_EXECUTE);
 753  // Generate.
 754      gen_assign (src, out, drf);
 755      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 756      if (compose_fun == A68_MAKE_FUNCTION) {
 757        write_fun_postlude (p, out, fn);
 758      }
 759      return fn;
 760    } else {
 761      return NO_TEXT;
 762    }
 763  }
 764  
 765  //! @brief Compile voiding assignation.
 766  
 767  char *gen_voiding_assignation_identifier (NODE_T * p, FILE_T out, int compose_fun)
 768  {
 769    NODE_T *dst = SUB (stems_from (p, ASSIGNATION));
 770    NODE_T *src = NEXT_NEXT (dst);
 771    if (BASIC (dst, IDENTIFIER) && basic_unit (src) && basic_mode_non_row (MOID (src))) {
 772      static char fn[NAME_SIZE];
 773      char idf[NAME_SIZE], pop[NAME_SIZE];
 774      NODE_T *q = stems_from (dst, IDENTIFIER);
 775  // Declare.
 776      (void) make_name (pop, PUP, "", NUMBER (p));
 777      comment_source (p, out);
 778      (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p));
 779      if (compose_fun == A68_MAKE_FUNCTION) {
 780        write_fun_prelude (p, out, fn);
 781      }
 782      A68_OPT (root_idf) = NO_DEC;
 783      if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) == NO_BOOK) {
 784        (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
 785        (void) add_declaration (&A68_OPT (root_idf), inline_mode (SUB_MOID (dst)), 1, idf);
 786        sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q), NULL, NUMBER (p));
 787      } else {
 788        (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p))));
 789      }
 790      inline_unit (dst, out, L_DECLARE);
 791      inline_unit (src, out, L_DECLARE);
 792      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 793      print_declarations (out, A68_OPT (root_idf));
 794  // Initialise.
 795      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 796      inline_unit (dst, out, L_EXECUTE);
 797      if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) == NO_BOOK) {
 798        if (BODY (TAX (q)) != NO_TAG) {
 799          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (SUB_MOID (dst))));
 800          inline_unit (dst, out, L_YIELD);
 801          undent (out, ");\n");
 802          sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p));
 803        } else {
 804          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (SUB_MOID (dst))));
 805          inline_unit (dst, out, L_YIELD);
 806          undent (out, ");\n");
 807          sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p));
 808        }
 809      }
 810      inline_unit (src, out, L_EXECUTE);
 811      gen_assign (src, out, idf);
 812      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 813      if (compose_fun == A68_MAKE_FUNCTION) {
 814        write_fun_postlude (p, out, fn);
 815      }
 816      return fn;
 817    } else {
 818      return NO_TEXT;
 819    }
 820  }
 821  
 822  //! @brief Compile identity-relation.
 823  
 824  char *gen_identity_relation (NODE_T * p, FILE_T out, int compose_fun)
 825  {
 826  #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((p), IDENTIFIER)), REF_SYMBOL))
 827    NODE_T *lhs = SUB (p);
 828    NODE_T *op = NEXT (lhs);
 829    NODE_T *rhs = NEXT (op);
 830    if (GOOD (lhs) && GOOD (rhs)) {
 831      static char fn[NAME_SIZE];
 832      comment_source (p, out);
 833      (void) make_name (fn, moid_with_name ("", MOID (p), "_identity"), "", NUMBER (p));
 834      if (compose_fun == A68_MAKE_FUNCTION) {
 835        write_fun_prelude (p, out, fn);
 836      }
 837      A68_OPT (root_idf) = NO_DEC;
 838      inline_identity_relation (p, out, L_DECLARE);
 839      print_declarations (out, A68_OPT (root_idf));
 840      inline_identity_relation (p, out, L_EXECUTE);
 841      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
 842      inline_identity_relation (p, out, L_YIELD);
 843      undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", A68_BOOL);\n"));
 844      if (compose_fun == A68_MAKE_FUNCTION) {
 845        write_fun_postlude (p, out, fn);
 846      }
 847      return fn;
 848    } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) {
 849      static char fn[NAME_SIZE];
 850      comment_source (p, out);
 851      (void) make_name (fn, moid_with_name ("", MOID (p), "_identity"), "", NUMBER (p));
 852      if (compose_fun == A68_MAKE_FUNCTION) {
 853        write_fun_prelude (p, out, fn);
 854      }
 855      A68_OPT (root_idf) = NO_DEC;
 856      inline_identity_relation (p, out, L_DECLARE);
 857      print_declarations (out, A68_OPT (root_idf));
 858      inline_identity_relation (p, out, L_EXECUTE);
 859      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
 860      inline_identity_relation (p, out, L_YIELD);
 861      undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", A68_BOOL);\n"));
 862      if (compose_fun == A68_MAKE_FUNCTION) {
 863        write_fun_postlude (p, out, fn);
 864      }
 865      return fn;
 866    } else {
 867      return NO_TEXT;
 868    }
 869  #undef GOOD
 870  }
 871  
 872  //! @brief Compile closed clause.
 873  
 874  void gen_declaration_list (NODE_T * p, FILE_T out, int *decs, char *pop)
 875  {
 876    for (; p != NO_NODE; FORWARD (p)) {
 877      switch (ATTRIBUTE (p)) {
 878      case MODE_DECLARATION:
 879      case PROCEDURE_DECLARATION:
 880      case BRIEF_OPERATOR_DECLARATION:
 881      case PRIORITY_DECLARATION:
 882        {
 883  // No action needed.
 884          (*decs)++;
 885          return;
 886        }
 887      case OPERATOR_DECLARATION:
 888        {
 889          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_operator_dec (_NODE_ (%d));", NUMBER (SUB (p))));
 890          inline_comment_source (p, out);
 891          undent (out, NEWLINE_STRING);
 892          (*decs)++;
 893          break;
 894        }
 895      case IDENTITY_DECLARATION:
 896        {
 897          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_identity_dec (_NODE_ (%d));", NUMBER (SUB (p))));
 898          inline_comment_source (p, out);
 899          undent (out, NEWLINE_STRING);
 900          (*decs)++;
 901          break;
 902        }
 903      case VARIABLE_DECLARATION:
 904        {
 905          char declarer[NAME_SIZE];
 906          (void) make_name (declarer, DEC, "", NUMBER (SUB (p)));
 907          indent (out, "{");
 908          inline_comment_source (p, out);
 909          undent (out, NEWLINE_STRING);
 910          A68_OPT (indentation)++;
 911          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "NODE_T *%s = NO_NODE;\n", declarer));
 912          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_variable_dec (_NODE_ (%d), &%s, A68_SP);\n", NUMBER (SUB (p)), declarer));
 913          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 914          A68_OPT (indentation)--;
 915          indent (out, "}\n");
 916          (*decs)++;
 917          break;
 918        }
 919      case PROCEDURE_VARIABLE_DECLARATION:
 920        {
 921          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_proc_variable_dec (_NODE_ (%d));", NUMBER (SUB (p))));
 922          inline_comment_source (p, out);
 923          undent (out, NEWLINE_STRING);
 924          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 925          (*decs)++;
 926          break;
 927        }
 928      default:
 929        {
 930          gen_declaration_list (SUB (p), out, decs, pop);
 931          break;
 932        }
 933      }
 934    }
 935  }
 936  
 937  //! @brief Compile closed clause.
 938  
 939  void gen_serial_clause (NODE_T * p, FILE_T out, NODE_T ** last, int *units, int *decs, char *pop, int compose_fun)
 940  {
 941    for (; p != NO_NODE && A68_OPT (code_errors) == 0; FORWARD (p)) {
 942      if (compose_fun == A68_MAKE_OTHERS) {
 943        if (IS (p, UNIT)) {
 944          (*units)++;
 945        }
 946        if (IS (p, DECLARATION_LIST)) {
 947          (*decs)++;
 948        }
 949        if (IS (p, UNIT) || IS (p, DECLARATION_LIST)) {
 950          if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
 951            if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) {
 952              gen_units (SUB_SUB (p), out);
 953            } else {
 954              gen_units (SUB (p), out);
 955            }
 956          } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
 957            COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
 958            a68_free (COMPILE_NAME (GINFO (p)));
 959            COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
 960          }
 961          return;
 962        } else {
 963          gen_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun);
 964        }
 965      } else
 966        switch (ATTRIBUTE (p)) {
 967        case UNIT:
 968          {
 969            (*last) = p;
 970            CODE_EXECUTE (p);
 971            inline_comment_source (p, out);
 972            undent (out, NEWLINE_STRING);
 973            (*units)++;
 974            return;
 975          }
 976        case SEMI_SYMBOL:
 977          {
 978            if (IS (*last, UNIT) && MOID (*last) == M_VOID) {
 979              break;
 980            } else if (IS (*last, DECLARATION_LIST)) {
 981              break;
 982            } else {
 983              indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 984            }
 985            break;
 986          }
 987        case DECLARATION_LIST:
 988          {
 989            (*last) = p;
 990            gen_declaration_list (SUB (p), out, decs, pop);
 991            break;
 992          }
 993        default:
 994          {
 995            gen_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun);
 996            break;
 997          }
 998        }
 999    }
1000  }
1001  
1002  //! @brief Embed serial clause.
1003  
1004  void embed_serial_clause (NODE_T * p, FILE_T out, char *pop)
1005  {
1006    NODE_T *last = NO_NODE;
1007    int units = 0, decs = 0;
1008    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (p)));
1009    init_static_frame (out, p);
1010    gen_serial_clause (p, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION);
1011    indent (out, "CLOSE_FRAME;\n");
1012  }
1013  
1014  //! @brief Compile code clause.
1015  
1016  char *gen_code_clause (NODE_T * p, FILE_T out, int compose_fun)
1017  {
1018    static char fn[NAME_SIZE];
1019    comment_source (p, out);
1020    (void) make_name (fn, "code", "", NUMBER (p));
1021    if (compose_fun == A68_MAKE_FUNCTION) {
1022      write_fun_prelude (p, out, fn);
1023    }
1024    embed_code_clause (SUB (p), out);
1025    if (compose_fun == A68_MAKE_FUNCTION) {
1026      (void) make_name (fn, "code", "", NUMBER (p));
1027      write_fun_postlude (p, out, fn);
1028    }
1029    return fn;
1030  }
1031  
1032  //! @brief Compile closed clause.
1033  
1034  char *gen_closed_clause (NODE_T * p, FILE_T out, int compose_fun)
1035  {
1036    NODE_T *sc = NEXT_SUB (p);
1037    if (MOID (p) == M_VOID && LABELS (TABLE (sc)) == NO_TAG) {
1038      static char fn[NAME_SIZE];
1039      char pop[NAME_SIZE];
1040      int units = 0, decs = 0;
1041      NODE_T *last = NO_NODE;
1042      gen_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1043      (void) make_name (pop, PUP, "", NUMBER (p));
1044      comment_source (p, out);
1045      (void) make_name (fn, "closed", "", NUMBER (p));
1046      if (compose_fun == A68_MAKE_FUNCTION) {
1047        write_fun_prelude (p, out, fn);
1048      }
1049      A68_OPT (root_idf) = NO_DEC;
1050      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1051      print_declarations (out, A68_OPT (root_idf));
1052      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1053      embed_serial_clause (sc, out, pop);
1054      if (compose_fun == A68_MAKE_FUNCTION) {
1055        (void) make_name (fn, "closed", "", NUMBER (p));
1056        write_fun_postlude (p, out, fn);
1057      }
1058      return fn;
1059    } else {
1060      return NO_TEXT;
1061    }
1062  }
1063  
1064  //! @brief Compile collateral clause.
1065  
1066  char *gen_collateral_clause (NODE_T * p, FILE_T out, int compose_fun)
1067  {
1068    if (basic_unit (p) && IS (MOID (p), STRUCT_SYMBOL)) {
1069      static char fn[NAME_SIZE];
1070      comment_source (p, out);
1071      (void) make_name (fn, "collateral", "", NUMBER (p));
1072      if (compose_fun == A68_MAKE_FUNCTION) {
1073        write_fun_prelude (p, out, fn);
1074      }
1075      A68_OPT (root_idf) = NO_DEC;
1076      inline_collateral_units (NEXT_SUB (p), out, L_DECLARE);
1077      print_declarations (out, A68_OPT (root_idf));
1078      inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE);
1079      inline_collateral_units (NEXT_SUB (p), out, L_YIELD);
1080      if (compose_fun == A68_MAKE_FUNCTION) {
1081        (void) make_name (fn, "collateral", "", NUMBER (p));
1082        write_fun_postlude (p, out, fn);
1083      }
1084      return fn;
1085    } else {
1086      return NO_TEXT;
1087    }
1088  }
1089  
1090  //! @brief Compile conditional clause.
1091  
1092  char *gen_basic_conditional (NODE_T * p, FILE_T out, int compose_fun)
1093  {
1094    static char fn[NAME_SIZE];
1095    NODE_T *q = SUB (p);
1096    if (!(basic_mode (MOID (p)) || MOID (p) == M_VOID)) {
1097      return NO_TEXT;
1098    }
1099    p = q;
1100    if (!basic_conditional (p)) {
1101      return NO_TEXT;
1102    }
1103    comment_source (p, out);
1104    (void) make_name (fn, "conditional", "", NUMBER (q));
1105    if (compose_fun == A68_MAKE_FUNCTION) {
1106      write_fun_prelude (q, out, fn);
1107    }
1108  // Collect declarations.
1109    if (IS (p, IF_PART) || IS (p, OPEN_PART)) {
1110      A68_OPT (root_idf) = NO_DEC;
1111      inline_unit (SUB (NEXT_SUB (p)), out, L_DECLARE);
1112      print_declarations (out, A68_OPT (root_idf));
1113      inline_unit (SUB (NEXT_SUB (p)), out, L_EXECUTE);
1114      indent (out, "if (");
1115      inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD);
1116      undent (out, ") {\n");
1117      A68_OPT (indentation)++;
1118    } else {
1119      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1120    }
1121    FORWARD (p);
1122    if (IS (p, THEN_PART) || IS (p, CHOICE)) {
1123      int pop = A68_OPT (cse_pointer);
1124      (void) gen_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING);
1125      A68_OPT (indentation)--;
1126      A68_OPT (cse_pointer) = pop;
1127    } else {
1128      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1129    }
1130    FORWARD (p);
1131    if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
1132      int pop = A68_OPT (cse_pointer);
1133      indent (out, "} else {\n");
1134      A68_OPT (indentation)++;
1135      (void) gen_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING);
1136      A68_OPT (indentation)--;
1137      A68_OPT (cse_pointer) = pop;
1138    }
1139  // Done.
1140    indent (out, "}\n");
1141    if (compose_fun == A68_MAKE_FUNCTION) {
1142      (void) make_name (fn, "conditional", "", NUMBER (q));
1143      write_fun_postlude (q, out, fn);
1144    }
1145    return fn;
1146  }
1147  
1148  //! @brief Compile conditional clause.
1149  
1150  char *gen_conditional_clause (NODE_T * p, FILE_T out, int compose_fun)
1151  {
1152    static char fn[NAME_SIZE];
1153    char pop[NAME_SIZE];
1154    int units = 0, decs = 0;
1155    NODE_T *q, *last;
1156  // We only compile IF basic unit or ELIF basic unit, so we save on opening frames.
1157  // Check worthiness of the clause.
1158    if (MOID (p) != M_VOID) {
1159      return NO_TEXT;
1160    }
1161    q = SUB (p);
1162    while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1163      if (!basic_serial (NEXT_SUB (q), 1)) {
1164        return NO_TEXT;
1165      }
1166      FORWARD (q);
1167      while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1168        if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) {
1169          return NO_TEXT;
1170        }
1171        FORWARD (q);
1172      }
1173      if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1174        q = SUB (q);
1175      } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1176        FORWARD (q);
1177      }
1178    }
1179  // Generate embedded units.
1180    q = SUB (p);
1181    while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1182      FORWARD (q);
1183      while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1184        last = NO_NODE;
1185        units = decs = 0;
1186        gen_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1187        FORWARD (q);
1188      }
1189      if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1190        q = SUB (q);
1191      } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1192        FORWARD (q);
1193      }
1194    }
1195  // Prep and Dec.
1196    (void) make_name (fn, "conditional", "", NUMBER (p));
1197    (void) make_name (pop, PUP, "", NUMBER (p));
1198    comment_source (p, out);
1199    if (compose_fun == A68_MAKE_FUNCTION) {
1200      write_fun_prelude (p, out, fn);
1201    }
1202    A68_OPT (root_idf) = NO_DEC;
1203    q = SUB (p);
1204    while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1205      inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE);
1206      FORWARD (q);
1207      while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1208        FORWARD (q);
1209      }
1210      if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1211        q = SUB (q);
1212      } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1213        FORWARD (q);
1214      }
1215    }
1216    (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1217    print_declarations (out, A68_OPT (root_idf));
1218  // Generate the function body.
1219    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1220    q = SUB (p);
1221    while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1222      inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE);
1223      FORWARD (q);
1224      while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1225        FORWARD (q);
1226      }
1227      if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1228        q = SUB (q);
1229      } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1230        FORWARD (q);
1231      }
1232    }
1233    q = SUB (p);
1234    while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1235      BOOL_T else_part = A68_FALSE;
1236      if (is_one_of (q, IF_PART, OPEN_PART, STOP)) {
1237        indent (out, "if (");
1238      } else {
1239        indent (out, "} else if (");
1240      }
1241      inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD);
1242      undent (out, ") {\n");
1243      FORWARD (q);
1244      while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1245        if (else_part) {
1246          indent (out, "} else {\n");
1247        }
1248        A68_OPT (indentation)++;
1249        embed_serial_clause (NEXT_SUB (q), out, pop);
1250        A68_OPT (indentation)--;
1251        else_part = A68_TRUE;
1252        FORWARD (q);
1253      }
1254      if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1255        q = SUB (q);
1256      } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1257        FORWARD (q);
1258      }
1259    }
1260    indent (out, "}\n");
1261    if (compose_fun == A68_MAKE_FUNCTION) {
1262      (void) make_name (fn, "conditional", "", NUMBER (p));
1263      write_fun_postlude (p, out, fn);
1264    }
1265    return fn;
1266  }
1267  
1268  //! @brief Compile unit from integral-case in-part.
1269  
1270  BOOL_T gen_int_case_units (NODE_T * p, FILE_T out, NODE_T * sym, int k, int *count, int compose_fun)
1271  {
1272    if (p == NO_NODE) {
1273      return A68_FALSE;
1274    } else {
1275      if (IS (p, UNIT)) {
1276        if (k == *count) {
1277          if (compose_fun == A68_MAKE_FUNCTION) {
1278            indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "case %d: {\n", k));
1279            A68_OPT (indentation)++;
1280            indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (sym)));
1281            CODE_EXECUTE (p);
1282            inline_comment_source (p, out);
1283            undent (out, NEWLINE_STRING);
1284            indent (out, "CLOSE_FRAME;\n");
1285            indent (out, "break;\n");
1286            A68_OPT (indentation)--;
1287            indent (out, "}\n");
1288          } else if (compose_fun == A68_MAKE_OTHERS) {
1289            if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
1290              if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) {
1291                gen_units (SUB_SUB (p), out);
1292              } else {
1293                gen_units (SUB (p), out);
1294              }
1295            } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1296              COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1297              a68_free (COMPILE_NAME (GINFO (p)));
1298              COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
1299            }
1300          }
1301          return A68_TRUE;
1302        } else {
1303          (*count)++;
1304          return A68_FALSE;
1305        }
1306      } else {
1307        if (gen_int_case_units (SUB (p), out, sym, k, count, compose_fun)) {
1308          return A68_TRUE;
1309        } else {
1310          return gen_int_case_units (NEXT (p), out, sym, k, count, compose_fun);
1311        }
1312      }
1313    }
1314  }
1315  
1316  //! @brief Compile integral-case-clause.
1317  
1318  char *gen_int_case_clause (NODE_T * p, FILE_T out, int compose_fun)
1319  {
1320    static char fn[NAME_SIZE];
1321    char pop[NAME_SIZE];
1322    int units = 0, decs = 0, k = 0, count = 0;
1323    NODE_T *q, *last;
1324  // We only compile CASE basic unit.
1325  // Check worthiness of the clause.
1326    if (MOID (p) != M_VOID) {
1327      return NO_TEXT;
1328    }
1329    q = SUB (p);
1330    if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) {
1331      if (!basic_serial (NEXT_SUB (q), 1)) {
1332        return NO_TEXT;
1333      }
1334      FORWARD (q);
1335    } else {
1336      return NO_TEXT;
1337    }
1338    while (q != NO_NODE && is_one_of (q, CASE_IN_PART, OUT_PART, CHOICE, STOP)) {
1339      if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) {
1340        return NO_TEXT;
1341      }
1342      FORWARD (q);
1343    }
1344    if (q != NO_NODE && is_one_of (q, ESAC_SYMBOL, CLOSE_SYMBOL, STOP)) {
1345      FORWARD (q);
1346    } else {
1347      return NO_TEXT;
1348    }
1349  // Generate embedded units.
1350    q = SUB (p);
1351    if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) {
1352      FORWARD (q);
1353      if (q != NO_NODE && is_one_of (q, CASE_IN_PART, CHOICE, STOP)) {
1354        last = NO_NODE;
1355        units = decs = 0;
1356        k = 0;
1357        do {
1358          count = 1;
1359          k++;
1360        } while (gen_int_case_units (NEXT_SUB (q), out, NO_NODE, k, &count, A68_MAKE_OTHERS));
1361        FORWARD (q);
1362      }
1363      if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) {
1364        last = NO_NODE;
1365        units = decs = 0;
1366        gen_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1367        FORWARD (q);
1368      }
1369    }
1370  // Prep and Dec.
1371    (void) make_name (pop, PUP, "", NUMBER (p));
1372    comment_source (p, out);
1373    (void) make_name (fn, "case", "", NUMBER (p));
1374    if (compose_fun == A68_MAKE_FUNCTION) {
1375      write_fun_prelude (p, out, fn);
1376    }
1377    A68_OPT (root_idf) = NO_DEC;
1378    q = SUB (p);
1379    inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE);
1380    (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1381    print_declarations (out, A68_OPT (root_idf));
1382  // Generate the function body.
1383    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1384    q = SUB (p);
1385    inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE);
1386    indent (out, "switch (");
1387    inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD);
1388    undent (out, ") {\n");
1389    A68_OPT (indentation)++;
1390    FORWARD (q);
1391    k = 0;
1392    do {
1393      count = 1;
1394      k++;
1395    } while (gen_int_case_units (NEXT_SUB (q), out, SUB (q), k, &count, A68_MAKE_FUNCTION));
1396    FORWARD (q);
1397    if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) {
1398      indent (out, "default: {\n");
1399      A68_OPT (indentation)++;
1400      embed_serial_clause (NEXT_SUB (q), out, pop);
1401      indent (out, "break;\n");
1402      A68_OPT (indentation)--;
1403      indent (out, "}\n");
1404    }
1405    A68_OPT (indentation)--;
1406    indent (out, "}\n");
1407    if (compose_fun == A68_MAKE_FUNCTION) {
1408      (void) make_name (fn, "case", "", NUMBER (p));
1409      write_fun_postlude (p, out, fn);
1410    }
1411    return fn;
1412  }
1413  
1414  //! @brief Compile loop clause.
1415  
1416  char *gen_loop_clause (NODE_T * p, FILE_T out, int compose_fun)
1417  {
1418    NODE_T *for_part = NO_NODE, *from_part = NO_NODE, *by_part = NO_NODE, *to_part = NO_NODE, *downto_part = NO_NODE, *while_part = NO_NODE, *sc;
1419    static char fn[NAME_SIZE];
1420    char idf[NAME_SIZE], z[NAME_SIZE], pop[NAME_SIZE];
1421    NODE_T *q = SUB (p), *last = NO_NODE;
1422    int units, decs;
1423    BOOL_T gc, need_reinit;
1424  // FOR identifier.
1425    if (IS (q, FOR_PART)) {
1426      for_part = NEXT_SUB (q);
1427      FORWARD (q);
1428    }
1429  // FROM unit.
1430    if (IS (p, FROM_PART)) {
1431      from_part = NEXT_SUB (q);
1432      if (!basic_unit (from_part)) {
1433        return NO_TEXT;
1434      }
1435      FORWARD (q);
1436    }
1437  // BY unit.
1438    if (IS (q, BY_PART)) {
1439      by_part = NEXT_SUB (q);
1440      if (!basic_unit (by_part)) {
1441        return NO_TEXT;
1442      }
1443      FORWARD (q);
1444    }
1445  // TO unit, DOWNTO unit.
1446    if (IS (q, TO_PART)) {
1447      if (IS (SUB (q), TO_SYMBOL)) {
1448        to_part = NEXT_SUB (q);
1449        if (!basic_unit (to_part)) {
1450          return NO_TEXT;
1451        }
1452      } else if (IS (SUB (q), DOWNTO_SYMBOL)) {
1453        downto_part = NEXT_SUB (q);
1454        if (!basic_unit (downto_part)) {
1455          return NO_TEXT;
1456        }
1457      }
1458      FORWARD (q);
1459    }
1460  // WHILE DO OD is not yet supported.
1461    if (IS (q, WHILE_PART)) {
1462      return NO_TEXT;
1463    }
1464  // DO UNTIL OD is not yet supported.
1465    if (IS (q, DO_PART) || IS (q, ALT_DO_PART)) {
1466      sc = q = NEXT_SUB (q);
1467      if (IS (q, SERIAL_CLAUSE)) {
1468        FORWARD (q);
1469      }
1470      if (q != NO_NODE && IS (q, UNTIL_PART)) {
1471        return NO_TEXT;
1472      }
1473    } else {
1474      return NO_TEXT;
1475    }
1476    if (LABELS (TABLE (sc)) != NO_TAG) {
1477      return NO_TEXT;
1478    }
1479  // Loop clause is compiled.
1480    units = decs = 0;
1481    gen_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1482    gc = (decs > 0);
1483    comment_source (p, out);
1484    (void) make_name (fn, "loop", "", NUMBER (p));
1485    if (compose_fun == A68_MAKE_FUNCTION) {
1486      write_fun_prelude (p, out, fn);
1487    }
1488    A68_OPT (root_idf) = NO_DEC;
1489    (void) make_name (idf, "k", "", NUMBER (p));
1490    (void) add_declaration (&A68_OPT (root_idf), "INT_T", 0, idf);
1491    if (for_part != NO_NODE) {
1492      (void) make_name (z, "z", "", NUMBER (p));
1493      (void) add_declaration (&A68_OPT (root_idf), "A68_INT", 1, z);
1494    }
1495    if (from_part != NO_NODE) {
1496      inline_unit (from_part, out, L_DECLARE);
1497    }
1498    if (by_part != NO_NODE) {
1499      inline_unit (by_part, out, L_DECLARE);
1500    }
1501    if (to_part != NO_NODE) {
1502      inline_unit (to_part, out, L_DECLARE);
1503    }
1504    if (downto_part != NO_NODE) {
1505      inline_unit (downto_part, out, L_DECLARE);
1506    }
1507    if (while_part != NO_NODE) {
1508      inline_unit (SUB (NEXT_SUB (while_part)), out, L_DECLARE);
1509    }
1510    (void) make_name (pop, PUP, "", NUMBER (p));
1511    (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1512    print_declarations (out, A68_OPT (root_idf));
1513    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1514    if (from_part != NO_NODE) {
1515      inline_unit (from_part, out, L_EXECUTE);
1516    }
1517    if (by_part != NO_NODE) {
1518      inline_unit (by_part, out, L_EXECUTE);
1519    }
1520    if (to_part != NO_NODE) {
1521      inline_unit (to_part, out, L_EXECUTE);
1522    }
1523    if (downto_part != NO_NODE) {
1524      inline_unit (downto_part, out, L_EXECUTE);
1525    }
1526    if (while_part != NO_NODE) {
1527      inline_unit (SUB (NEXT_SUB (while_part)), out, L_EXECUTE);
1528    }
1529    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (sc)));
1530    init_static_frame (out, sc);
1531    if (for_part != NO_NODE) {
1532      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (_NODE_ (%d)))));\n", z, NUMBER (for_part)));
1533    }
1534  // The loop in C.
1535  // Initialisation.
1536    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "for (%s = ", idf));
1537    if (from_part == NO_NODE) {
1538      undent (out, "1");
1539    } else {
1540      inline_unit (from_part, out, L_YIELD);
1541    }
1542    undent (out, "; ");
1543  // Condition.
1544    if (to_part == NO_NODE && downto_part == NO_NODE && while_part == NO_NODE) {
1545      undent (out, "A68_TRUE");
1546    } else {
1547      undent (out, idf);
1548      if (to_part != NO_NODE) {
1549        undent (out, " <= ");
1550      } else if (downto_part != NO_NODE) {
1551        undent (out, " >= ");
1552      }
1553      inline_unit (to_part, out, L_YIELD);
1554    }
1555    undent (out, "; ");
1556  // Increment.
1557    if (by_part == NO_NODE) {
1558      undent (out, idf);
1559      if (to_part != NO_NODE) {
1560        undent (out, " ++");
1561      } else if (downto_part != NO_NODE) {
1562        undent (out, " --");
1563      } else {
1564        undent (out, " ++");
1565      }
1566    } else {
1567      undent (out, idf);
1568      if (to_part != NO_NODE) {
1569        undent (out, " += ");
1570      } else if (downto_part != NO_NODE) {
1571        undent (out, " -= ");
1572      } else {
1573        undent (out, " += ");
1574      }
1575      inline_unit (by_part, out, L_YIELD);
1576    }
1577    undent (out, ") {\n");
1578    A68_OPT (indentation)++;
1579    if (gc) {
1580      indent (out, "// genie_preemptive_gc_heap (p);\n");
1581    }
1582    if (for_part != NO_NODE) {
1583      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", z));
1584      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = %s;\n", z, idf));
1585    }
1586    units = decs = 0;
1587    gen_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION);
1588  // Re-initialise if necessary.
1589    need_reinit = (BOOL_T) (AP_INCREMENT (TABLE (sc)) > 0 || need_initialise_frame (sc));
1590    if (need_reinit) {
1591      indent (out, "if (");
1592      if (to_part == NO_NODE && downto_part == NO_NODE) {
1593        undent (out, "A68_TRUE");
1594      } else {
1595        undent (out, idf);
1596        if (to_part != NO_NODE) {
1597          undent (out, " < ");
1598        } else if (downto_part != NO_NODE) {
1599          undent (out, " > ");
1600        }
1601        inline_unit (to_part, out, L_YIELD);
1602      }
1603      undent (out, ") {\n");
1604      A68_OPT (indentation)++;
1605      if (AP_INCREMENT (TABLE (sc)) > 0) {
1606  #if (A68_LEVEL >= 3)
1607        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (%llu);\n", AP_INCREMENT (TABLE (sc))));
1608  #else
1609        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (%u);\n", AP_INCREMENT (TABLE (sc))));
1610  #endif
1611      }
1612      if (need_initialise_frame (sc)) {
1613        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "initialise_frame (_NODE_ (%d));\n", NUMBER (sc)));
1614      }
1615      A68_OPT (indentation)--;
1616      indent (out, "}\n");
1617    }
1618  // End of loop.
1619    A68_OPT (indentation)--;
1620    indent (out, "}\n");
1621    indent (out, "CLOSE_FRAME;\n");
1622    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
1623    if (compose_fun == A68_MAKE_FUNCTION) {
1624      (void) make_name (fn, "loop", "", NUMBER (p));
1625      write_fun_postlude (p, out, fn);
1626    }
1627    return fn;
1628  }
1629  
1630  //! @brief Optimise units.
1631  
1632  char *gen_unit (NODE_T * p, FILE_T out, BOOL_T compose_fun)
1633  {
1634  #define COMPILE(p, out, fun, compose_fun) {\
1635    char * fn = (fun) (p, out, compose_fun);\
1636    if (compose_fun == A68_MAKE_FUNCTION && fn != NO_TEXT) {\
1637      ABEND (strlen (fn) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);\
1638      COMPILE_NAME (GINFO (p)) = new_string (fn, NO_TEXT);\
1639      if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {\
1640        COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));\
1641      } else {\
1642        COMPILE_NODE (GINFO (p)) = NUMBER (p);\
1643      }\
1644      return COMPILE_NAME (GINFO (p));\
1645    } else {\
1646      COMPILE_NAME (GINFO (p)) = NO_TEXT;\
1647      COMPILE_NODE (GINFO (p)) = 0;\
1648      return NO_TEXT;\
1649    }}
1650  
1651    LOW_SYSTEM_STACK_ALERT (p);
1652    if (p == NO_NODE) {
1653      return NO_TEXT;
1654    } else if (COMPILE_NAME (GINFO (p)) != NO_TEXT) {
1655      return NO_TEXT;
1656    } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) {
1657      COMPILE (SUB (p), out, gen_unit, compose_fun);
1658    }
1659    if (A68_OPT (OPTION_CODE_LEVEL) >= 3) {
1660  // Control structure.
1661      if (IS (p, CLOSED_CLAUSE)) {
1662        COMPILE (p, out, gen_closed_clause, compose_fun);
1663      } else if (IS (p, COLLATERAL_CLAUSE)) {
1664        COMPILE (p, out, gen_collateral_clause, compose_fun);
1665      } else if (IS (p, CONDITIONAL_CLAUSE)) {
1666        char *fn2 = gen_basic_conditional (p, out, compose_fun);
1667        if (compose_fun == A68_MAKE_FUNCTION && fn2 != NO_TEXT) {
1668          ABEND (strlen (fn2) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);
1669          COMPILE_NAME (GINFO (p)) = new_string (fn2, NO_TEXT);
1670          if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1671            COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1672          } else {
1673            COMPILE_NODE (GINFO (p)) = NUMBER (p);
1674          }
1675          return COMPILE_NAME (GINFO (p));
1676        } else {
1677          COMPILE (p, out, gen_conditional_clause, compose_fun);
1678        }
1679      } else if (IS (p, CASE_CLAUSE)) {
1680        COMPILE (p, out, gen_int_case_clause, compose_fun);
1681      } else if (IS (p, LOOP_CLAUSE)) {
1682        COMPILE (p, out, gen_loop_clause, compose_fun);
1683      }
1684    }
1685    if (A68_OPT (OPTION_CODE_LEVEL) >= 2) {
1686  // Simple constructions.
1687      if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), IDENTIFIER) != NO_NODE) {
1688        COMPILE (p, out, gen_voiding_assignation_identifier, compose_fun);
1689      } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SLICE) != NO_NODE) {
1690        COMPILE (p, out, gen_voiding_assignation_slice, compose_fun);
1691      } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SELECTION) != NO_NODE) {
1692        COMPILE (p, out, gen_voiding_assignation_selection, compose_fun);
1693      } else if (IS (p, SLICE)) {
1694        COMPILE (p, out, gen_slice, compose_fun);
1695      } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE) != NO_NODE) {
1696        COMPILE (p, out, gen_dereference_slice, compose_fun);
1697      } else if (IS (p, SELECTION)) {
1698        COMPILE (p, out, gen_selection, compose_fun);
1699      } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SELECTION) != NO_NODE) {
1700        COMPILE (p, out, gen_dereference_selection, compose_fun);
1701      } else if (IS (p, VOIDING) && IS (SUB (p), FORMULA)) {
1702        COMPILE (SUB (p), out, gen_voiding_formula, compose_fun);
1703      } else if (IS (p, VOIDING) && IS (SUB (p), MONADIC_FORMULA)) {
1704        COMPILE (SUB (p), out, gen_voiding_formula, compose_fun);
1705      } else if (IS (p, DEPROCEDURING)) {
1706        COMPILE (p, out, gen_deproceduring, compose_fun);
1707      } else if (IS (p, VOIDING) && IS (SUB (p), DEPROCEDURING)) {
1708        COMPILE (p, out, gen_voiding_deproceduring, compose_fun);
1709      } else if (IS (p, VOIDING) && IS (SUB (p), CALL)) {
1710        COMPILE (p, out, gen_voiding_call, compose_fun);
1711      } else if (IS (p, IDENTITY_RELATION)) {
1712        COMPILE (p, out, gen_identity_relation, compose_fun);
1713      } else if (IS (p, UNITING)) {
1714        COMPILE (p, out, gen_uniting, compose_fun);
1715      }
1716    }
1717    if (A68_OPT (OPTION_CODE_LEVEL) >= 1) {
1718  // Most basic stuff.
1719      if (IS (p, VOIDING)) {
1720        COMPILE (SUB (p), out, gen_unit, compose_fun);
1721      } else if (IS (p, DENOTATION)) {
1722        COMPILE (p, out, gen_denotation, compose_fun);
1723      } else if (IS (p, CAST)) {
1724        COMPILE (p, out, gen_cast, compose_fun);
1725      } else if (IS (p, IDENTIFIER)) {
1726        COMPILE (p, out, gen_identifier, compose_fun);
1727      } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) {
1728        COMPILE (p, out, gen_dereference_identifier, compose_fun);
1729      } else if (IS (p, MONADIC_FORMULA)) {
1730        COMPILE (p, out, gen_formula, compose_fun);
1731      } else if (IS (p, FORMULA)) {
1732        COMPILE (p, out, gen_formula, compose_fun);
1733      } else if (IS (p, CALL)) {
1734        COMPILE (p, out, gen_call, compose_fun);
1735      }
1736    }
1737    if (IS (p, CODE_CLAUSE)) {
1738      COMPILE (p, out, gen_code_clause, compose_fun);
1739    }
1740    return NO_TEXT;
1741  #undef COMPILE
1742  }
1743  
1744  //! @brief Compile unit.
1745  
1746  char *gen_basic (NODE_T * p, FILE_T out)
1747  {
1748  #define COMPILE(p, out, fun) {\
1749    char * fn = (fun) (p, out);\
1750    if (fn != NO_TEXT) {\
1751      ABEND (strlen (fn) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);\
1752      COMPILE_NAME (GINFO (p)) = new_string (fn, NO_TEXT);\
1753      if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {\
1754        COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));\
1755      } else {\
1756        COMPILE_NODE (GINFO (p)) = NUMBER (p);\
1757      }\
1758      return COMPILE_NAME (GINFO (p));\
1759    } else {\
1760      COMPILE_NAME (GINFO (p)) = NO_TEXT;\
1761      COMPILE_NODE (GINFO (p)) = 0;\
1762      return NO_TEXT;\
1763    }}
1764  
1765    LOW_SYSTEM_STACK_ALERT (p);
1766    if (p == NO_NODE) {
1767      return NO_TEXT;
1768    } else if (COMPILE_NAME (GINFO (p)) != NO_TEXT) {
1769      return NO_TEXT;
1770    } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) {
1771      COMPILE (SUB (p), out, gen_basic);
1772    }
1773  // Most basic stuff.
1774    if (IS (p, VOIDING)) {
1775      COMPILE (SUB (p), out, gen_basic);
1776    } else if (IS (p, DENOTATION)) {
1777      COMPILE (p, out, compile_denotation);
1778    } else if (IS (p, CAST)) {
1779      COMPILE (p, out, compile_cast);
1780    } else if (IS (p, IDENTIFIER)) {
1781      COMPILE (p, out, compile_identifier);
1782    } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) {
1783      COMPILE (p, out, compile_dereference_identifier);
1784    } else if (IS (p, FORMULA)) {
1785      COMPILE (p, out, compile_formula);
1786    } else if (IS (p, CALL)) {
1787      COMPILE (p, out, compile_call);
1788    }
1789    return NO_TEXT;
1790  #undef COMPILE
1791  }
1792  
1793  //! @brief Optimise units.
1794  
1795  void gen_units (NODE_T * p, FILE_T out)
1796  {
1797    for (; p != NO_NODE; FORWARD (p)) {
1798      if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) {
1799        if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
1800          gen_units (SUB (p), out);
1801        } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1802          COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1803          COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
1804        }
1805      } else {
1806        gen_units (SUB (p), out);
1807      }
1808    }
1809  }
1810  
1811  //! @brief Compile units.
1812  
1813  void gen_basics (NODE_T * p, FILE_T out)
1814  {
1815    for (; p != NO_NODE; FORWARD (p)) {
1816      if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) {
1817        if (gen_basic (p, out) == NO_TEXT) {
1818          gen_basics (SUB (p), out);
1819        } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1820          COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1821          COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
1822        }
1823      } else {
1824        gen_basics (SUB (p), out);
1825      }
1826    }
1827  }