genie-stowed.c

     
   1  //! @file genie-stowed.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  //! Interpreter routines for STOWED values.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-frames.h"
  29  #include "a68g-prelude.h"
  30  #include "a68g-mp.h"
  31  #include "a68g-double.h"
  32  #include "a68g-parser.h"
  33  #include "a68g-transput.h"
  34  
  35  // Routines for handling stowed objects.
  36  // 
  37  // An A68G row is a reference to a descriptor in the heap:
  38  // 
  39  //                ...
  40  // A68_REF row -> A68_ARRAY ----+   ARRAY: Description of row, ref to elements
  41  //                A68_TUPLE 1   |   TUPLE: Bounds, one for every dimension
  42  //                ...           |
  43  //                A68_TUPLE dim |
  44  //                ...           |
  45  //                ...           |
  46  //                Element 1 <---+   Element: Sequential row elements, in the heap
  47  //                ...                        Not always contiguous - trims!
  48  //                Element n
  49  
  50  //! @brief Size of a row.
  51  
  52  int get_row_size (A68_TUPLE * tup, int dim)
  53  {
  54    int span = 1;
  55    for (int k = 0; k < dim; k++) {
  56      int stride = ROW_SIZE (&tup[k]);
  57      ABEND ((stride > 0 && span > A68_MAX_INT / stride), ERROR_INVALID_SIZE, __func__);
  58      span *= stride;
  59    }
  60    return span;
  61  }
  62  
  63  //! @brief Initialise index for FORALL constructs.
  64  
  65  void initialise_internal_index (A68_TUPLE * tup, int dim)
  66  {
  67    for (int k = 0; k < dim; k++) {
  68      A68_TUPLE *ref = &tup[k];
  69      K (ref) = LWB (ref);
  70    }
  71  }
  72  
  73  //! @brief Calculate index.
  74  
  75  ADDR_T calculate_internal_index (A68_TUPLE * tup, int dim)
  76  {
  77    ADDR_T idx = 0;
  78    for (int k = 0; k < dim; k++) {
  79      A68_TUPLE *ref = &tup[k];
  80  // Only consider non-empty rows.
  81      if (ROW_SIZE (ref) > 0) {
  82        idx += (SPAN (ref) * K (ref) - SHIFT (ref));
  83      }
  84    }
  85    return idx;
  86  }
  87  
  88  //! @brief Increment index for FORALL constructs.
  89  
  90  BOOL_T increment_internal_index (A68_TUPLE * tup, int dim)
  91  {
  92    BOOL_T carry = A68_TRUE;
  93    for (int k = dim - 1; k >= 0 && carry; k--) {
  94      A68_TUPLE *ref = &tup[k];
  95      if (K (ref) < UPB (ref)) {
  96        (K (ref))++;
  97        carry = A68_FALSE;
  98      } else {
  99        K (ref) = LWB (ref);
 100      }
 101    }
 102    return carry;
 103  }
 104  
 105  //! @brief Print index.
 106  
 107  void print_internal_index (FILE_T f, A68_TUPLE * tup, int dim)
 108  {
 109    for (int k = 0; k < dim; k++) {
 110      A68_TUPLE *ref = &tup[k];
 111      BUFFER buf;
 112      ASSERT (snprintf (buf, SNPRINTF_SIZE, A68_LD, K (ref)) >= 0);
 113      WRITE (f, buf);
 114      if (k < dim - 1) {
 115        WRITE (f, ", ");
 116      }
 117    }
 118  }
 119  
 120  //! @brief Convert C string to A68 [] CHAR.
 121  
 122  A68_REF c_string_to_row_char (NODE_T * p, char *str, int width)
 123  {
 124    A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup;
 125    NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, width);
 126    BYTE_T *base = ADDRESS (&row);
 127    int len = strlen (str);
 128    for (int k = 0; k < width; k++) {
 129      A68_CHAR *ch = (A68_CHAR *) & (base[k * SIZE_ALIGNED (A68_CHAR)]);
 130      STATUS (ch) = INIT_MASK;
 131      VALUE (ch) = (k < len ? TO_UCHAR (str[k]) : NULL_CHAR);
 132    }
 133    return z;
 134  }
 135  
 136  //! @brief Convert C string to A68 string.
 137  
 138  A68_REF c_to_a_string (NODE_T * p, char *str, int width)
 139  {
 140    if (str == NO_TEXT) {
 141      return empty_string (p);
 142    } else {
 143      if (width == DEFAULT_WIDTH) {
 144        return c_string_to_row_char (p, str, (int) strlen (str));
 145      } else {
 146        return c_string_to_row_char (p, str, (int) width);
 147      }
 148    }
 149  }
 150  
 151  //! @brief Size of a string.
 152  
 153  int a68_string_size (NODE_T * p, A68_REF row)
 154  {
 155    (void) p;
 156    if (INITIALISED (&row)) {
 157      A68_ARRAY *arr; A68_TUPLE *tup;
 158      GET_DESCRIPTOR (arr, tup, &row);
 159      return ROW_SIZE (tup);
 160    } else {
 161      return 0;
 162    }
 163  }
 164  
 165  //! @brief Convert A68 string to C string.
 166  
 167  char *a_to_c_string (NODE_T * p, char *str, A68_REF row)
 168  {
 169  // Assume "str" to be long enough - caller's responsibility!.
 170    (void) p;
 171    if (INITIALISED (&row)) {
 172      A68_ARRAY *arr; A68_TUPLE *tup;
 173      GET_DESCRIPTOR (arr, tup, &row);
 174      int size = ROW_SIZE (tup), n = 0;
 175      if (size > 0) {
 176        BYTE_T *base_address = ADDRESS (&ARRAY (arr));
 177        for (int k = LWB (tup); k <= UPB (tup); k++) {
 178          int addr = INDEX_1_DIM (arr, tup, k);
 179          A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]);
 180          CHECK_INIT (p, INITIALISED (ch), M_CHAR);
 181          str[n++] = (char) VALUE (ch);
 182        }
 183      }
 184      str[n] = NULL_CHAR;
 185      return str;
 186    } else {
 187      return NO_TEXT;
 188    }
 189  }
 190  
 191  //! @brief Return an empty row.
 192  
 193  A68_REF empty_row (NODE_T * p, MOID_T * u)
 194  {
 195    if (IS_FLEX (u)) {
 196      u = SUB (u);
 197    }
 198    MOID_T *v = SUB (u);
 199    int dim = DIM (u);
 200    A68_REF dsc; A68_ARRAY *arr; A68_TUPLE *tup;
 201    dsc = heap_generator (p, u, DESCRIPTOR_SIZE (dim));
 202    GET_DESCRIPTOR (arr, tup, &dsc);
 203    DIM (arr) = dim;
 204    MOID (arr) = SLICE (u);
 205    ELEM_SIZE (arr) = moid_size (SLICE (u));
 206    SLICE_OFFSET (arr) = 0;
 207    FIELD_OFFSET (arr) = 0;
 208    if (IS_ROW (v) || IS_FLEX (v)) {
 209  // [] AMODE or FLEX [] AMODE 
 210      ARRAY (arr) = heap_generator (p, v, A68_REF_SIZE);
 211      *DEREF (A68_REF, &ARRAY (arr)) = empty_row (p, v);
 212    } else {
 213      ARRAY (arr) = nil_ref;
 214    }
 215    STATUS (&ARRAY (arr)) = (STATUS_MASK_T) (INIT_MASK | IN_HEAP_MASK);
 216    for (int k = 0; k < dim; k++) {
 217      LWB (&tup[k]) = 1;
 218      UPB (&tup[k]) = 0;
 219      SPAN (&tup[k]) = 1;
 220      SHIFT (&tup[k]) = LWB (tup);
 221    }
 222    return dsc;
 223  }
 224  
 225  //! @brief An empty string, FLEX [1 : 0] CHAR.
 226  
 227  A68_REF empty_string (NODE_T * p)
 228  {
 229    return empty_row (p, M_STRING);
 230  }
 231  
 232  //! @brief Make [,, ..] MODE  from [, ..] MODE.
 233  
 234  A68_REF genie_make_rowrow (NODE_T * p, MOID_T * rmod, int len, ADDR_T sp)
 235  {
 236    MOID_T *nmod = IS_FLEX (rmod) ? SUB (rmod) : rmod;
 237    MOID_T *emod = SUB (nmod);
 238    int odim = DIM (nmod) - 1;
 239  // Make the new descriptor.
 240    A68_REF nrow; A68_ARRAY *new_arr; A68_TUPLE *new_tup;
 241    nrow = heap_generator (p, rmod, DESCRIPTOR_SIZE (DIM (nmod)));
 242    GET_DESCRIPTOR (new_arr, new_tup, &nrow);
 243    DIM (new_arr) = DIM (nmod);
 244    MOID (new_arr) = emod;
 245    ELEM_SIZE (new_arr) = SIZE (emod);
 246    SLICE_OFFSET (new_arr) = 0;
 247    FIELD_OFFSET (new_arr) = 0;
 248    if (len == 0) {
 249  // There is a vacuum on the stack.
 250      for (int k = 0; k < odim; k++) {
 251        LWB (&new_tup[k + 1]) = 1;
 252        UPB (&new_tup[k + 1]) = 0;
 253        SPAN (&new_tup[k + 1]) = 1;
 254        SHIFT (&new_tup[k + 1]) = LWB (&new_tup[k + 1]);
 255      }
 256      LWB (new_tup) = 1;
 257      UPB (new_tup) = 0;
 258      SPAN (new_tup) = 0;
 259      SHIFT (new_tup) = 0;
 260      ARRAY (new_arr) = nil_ref;
 261      return nrow;
 262    } else if (len > 0) {
 263      A68_ARRAY *x = NO_ARRAY;
 264  // Arrays in the stack must have equal bounds.
 265      for (int j = 1; j < len; j++) {
 266        A68_REF rrow = *(A68_REF *) STACK_ADDRESS (sp);
 267        A68_REF vrow = *(A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE);
 268        A68_TUPLE *vtup, *rtup;
 269        GET_DESCRIPTOR (x, rtup, &rrow);
 270        GET_DESCRIPTOR (x, vtup, &vrow);
 271        for (int k = 0; k < odim; k++, rtup++, vtup++) {
 272          if ((UPB (rtup) != UPB (vtup)) || (LWB (rtup) != LWB (vtup))) {
 273            diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
 274            exit_genie (p, A68_RUNTIME_ERROR);
 275          }
 276        }
 277      }
 278  // Fill descriptor of new row with info from (arbitrary) first one.
 279      A68_REF orow; A68_ARRAY *old_arr; A68_TUPLE *old_tup;
 280      orow = *(A68_REF *) STACK_ADDRESS (sp);
 281      GET_DESCRIPTOR (x, old_tup, &orow);
 282      int span = 1;
 283      for (int k = 0; k < odim; k++) {
 284        A68_TUPLE *nt = &new_tup[k + 1], *ot = &old_tup[k];
 285        LWB (nt) = LWB (ot);
 286        UPB (nt) = UPB (ot);
 287        SPAN (nt) = span;
 288        SHIFT (nt) = LWB (nt) * SPAN (nt);
 289        span *= ROW_SIZE (nt);
 290      }
 291      LWB (new_tup) = 1;
 292      UPB (new_tup) = len;
 293      SPAN (new_tup) = span;
 294      SHIFT (new_tup) = LWB (new_tup) * SPAN (new_tup);
 295      ARRAY (new_arr) = heap_generator (p, rmod, len * span * ELEM_SIZE (new_arr));
 296      for (int j = 0; j < len; j++) {
 297  // new[j,, ] := old[, ].
 298        GET_DESCRIPTOR (old_arr, old_tup, (A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE));
 299        if (LWB (old_tup) > UPB (old_tup)) {
 300          A68_REF dst = ARRAY (new_arr);
 301          ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], odim);
 302          OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
 303          A68_REF none = empty_row (p, SLICE (rmod));
 304          MOVE (ADDRESS (&dst), ADDRESS (&none), SIZE (emod));
 305        } else {
 306          initialise_internal_index (old_tup, odim);
 307          initialise_internal_index (&new_tup[1], odim);
 308          BOOL_T done = A68_FALSE;
 309          while (!done) {
 310            A68_REF src = ARRAY (old_arr), dst = ARRAY (new_arr);
 311            ADDR_T old_k = calculate_internal_index (old_tup, odim);
 312            ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], odim);
 313            OFFSET (&src) += ROW_ELEMENT (old_arr, old_k);
 314            OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
 315            if (HAS_ROWS (emod)) {
 316              A68_REF none = genie_clone (p, emod, (A68_REF *) & nil_ref, &src);
 317              MOVE (ADDRESS (&dst), ADDRESS (&none), SIZE (emod));
 318            } else {
 319              MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (emod));
 320            }
 321            done = increment_internal_index (old_tup, odim) | increment_internal_index (&new_tup[1], odim);
 322          }
 323        }
 324      }
 325    }
 326    return nrow;
 327  }
 328  
 329  //! @brief Make a row of 'len' objects that are in the stack.
 330  
 331  A68_REF genie_make_row (NODE_T * p, MOID_T * elem_mode, int len, ADDR_T sp)
 332  {
 333    A68_REF new_row, new_arr; A68_ARRAY arr; A68_TUPLE tup;
 334    NEW_ROW_1D (new_row, new_arr, arr, tup, MOID (p), elem_mode, len);
 335    for (int k = 0; k < len * ELEM_SIZE (&arr); k += ELEM_SIZE (&arr)) {
 336      A68_REF dst = new_arr, src;
 337      OFFSET (&dst) += k;
 338      STATUS (&src) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
 339      OFFSET (&src) = sp + k;
 340      REF_HANDLE (&src) = (A68_HANDLE *) & nil_handle;
 341      if (HAS_ROWS (elem_mode)) {
 342        A68_REF new_one = genie_clone (p, elem_mode, (A68_REF *) & nil_ref, &src);
 343        MOVE (ADDRESS (&dst), ADDRESS (&new_one), SIZE (elem_mode));
 344      } else {
 345        MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (elem_mode));
 346      }
 347    }
 348    return new_row;
 349  }
 350  
 351  //! @brief Make REF [1 : 1] [] MODE from REF [] MODE.
 352  
 353  A68_REF genie_make_ref_row_of_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp)
 354  {
 355    dst_mode = DEFLEX (dst_mode);
 356    src_mode = DEFLEX (src_mode);
 357    A68_REF array = *(A68_REF *) STACK_ADDRESS (sp);
 358  // ROWING NIL yields NIL.
 359    if (IS_NIL (array)) {
 360      return nil_ref;
 361    } else {
 362      A68_REF new_row = heap_generator (p, SUB (dst_mode), DESCRIPTOR_SIZE (1));
 363      A68_REF name = heap_generator (p, dst_mode, A68_REF_SIZE);
 364      A68_ARRAY *arr; A68_TUPLE *tup;
 365      GET_DESCRIPTOR (arr, tup, &new_row);
 366      DIM (arr) = 1;
 367      MOID (arr) = src_mode;
 368      ELEM_SIZE (arr) = SIZE (src_mode);
 369      SLICE_OFFSET (arr) = 0;
 370      FIELD_OFFSET (arr) = 0;
 371      ARRAY (arr) = array;
 372      LWB (tup) = 1;
 373      UPB (tup) = 1;
 374      SPAN (tup) = 1;
 375      SHIFT (tup) = LWB (tup);
 376      *DEREF (A68_REF, &name) = new_row;
 377      return name;
 378    }
 379  }
 380  
 381  //! @brief Make REF [1 : 1, ..] MODE from REF [..] MODE.
 382  
 383  A68_REF genie_make_ref_row_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp)
 384  {
 385    dst_mode = DEFLEX (dst_mode);
 386    src_mode = DEFLEX (src_mode);
 387    A68_REF name = *(A68_REF *) STACK_ADDRESS (sp);
 388  // ROWING NIL yields NIL.
 389    if (IS_NIL (name)) {
 390      return nil_ref;
 391    }
 392    A68_REF old_row = *DEREF (A68_REF, &name); A68_TUPLE *new_tup, *old_tup;
 393    A68_ARRAY *old_arr;
 394    GET_DESCRIPTOR (old_arr, old_tup, &old_row);
 395  // Make new descriptor.
 396    A68_REF new_row = heap_generator (p, dst_mode, DESCRIPTOR_SIZE (DIM (SUB (dst_mode))));
 397    A68_ARRAY *new_arr;
 398    name = heap_generator (p, dst_mode, A68_REF_SIZE);
 399    GET_DESCRIPTOR (new_arr, new_tup, &new_row);
 400    DIM (new_arr) = DIM (SUB (dst_mode));
 401    MOID (new_arr) = MOID (old_arr);
 402    ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr);
 403    SLICE_OFFSET (new_arr) = 0;
 404    FIELD_OFFSET (new_arr) = 0;
 405    ARRAY (new_arr) = ARRAY (old_arr);
 406  // Fill out the descriptor.
 407    LWB (&(new_tup[0])) = 1;
 408    UPB (&(new_tup[0])) = 1;
 409    SPAN (&(new_tup[0])) = 1;
 410    SHIFT (&(new_tup[0])) = LWB (&(new_tup[0]));
 411    for (int k = 0; k < DIM (SUB (src_mode)); k++) {
 412      new_tup[k + 1] = old_tup[k];
 413    }
 414  // Yield the new name.
 415    *DEREF (A68_REF, &name) = new_row;
 416    return name;
 417  }
 418  
 419  //! @brief Coercion to [1 : 1, ] MODE.
 420  
 421  PROP_T genie_rowing_row_row (NODE_T * p)
 422  {
 423    ADDR_T sp = A68_SP;
 424    EXECUTE_UNIT (SUB (p));
 425    STACK_DNS (p, MOID (SUB (p)), A68_FP);
 426    A68_REF row = genie_make_rowrow (p, MOID (p), 1, sp);
 427    A68_SP = sp;
 428    PUSH_REF (p, row);
 429    return GPROP (p);
 430  }
 431  
 432  //! @brief Coercion to [1 : 1] [] MODE.
 433  
 434  PROP_T genie_rowing_row_of_row (NODE_T * p)
 435  {
 436    ADDR_T sp = A68_SP;
 437    EXECUTE_UNIT (SUB (p));
 438    STACK_DNS (p, MOID (SUB (p)), A68_FP);
 439    A68_REF row = genie_make_row (p, SLICE (MOID (p)), 1, sp);
 440    A68_SP = sp;
 441    PUSH_REF (p, row);
 442    return GPROP (p);
 443  }
 444  
 445  //! @brief Coercion to REF [1 : 1, ..] MODE.
 446  
 447  PROP_T genie_rowing_ref_row_row (NODE_T * p)
 448  {
 449    ADDR_T sp = A68_SP;
 450    MOID_T *dst = MOID (p), *src = MOID (SUB (p));
 451    EXECUTE_UNIT (SUB (p));
 452    STACK_DNS (p, MOID (SUB (p)), A68_FP);
 453    A68_SP = sp;
 454    A68_REF name = genie_make_ref_row_row (p, dst, src, sp);
 455    PUSH_REF (p, name);
 456    return GPROP (p);
 457  }
 458  
 459  //! @brief REF [1 : 1] [] MODE from [] MODE
 460  
 461  PROP_T genie_rowing_ref_row_of_row (NODE_T * p)
 462  {
 463    ADDR_T sp = A68_SP;
 464    MOID_T *dst = MOID (p), *src = MOID (SUB (p));
 465    EXECUTE_UNIT (SUB (p));
 466    STACK_DNS (p, MOID (SUB (p)), A68_FP);
 467    A68_SP = sp;
 468    A68_REF name = genie_make_ref_row_of_row (p, dst, src, sp);
 469    PUSH_REF (p, name);
 470    return GPROP (p);
 471  }
 472  
 473  //! @brief Rowing coercion.
 474  
 475  PROP_T genie_rowing (NODE_T * p)
 476  {
 477    PROP_T self;
 478    if (IS_REF (MOID (p))) {
 479  // REF ROW, decide whether we want A->[] A or [] A->[,] A.
 480      MOID_T *mode = SUB_MOID (p);
 481      if (DIM (DEFLEX (mode)) >= 2) {
 482        (void) genie_rowing_ref_row_row (p);
 483        UNIT (&self) = genie_rowing_ref_row_row;
 484        SOURCE (&self) = p;
 485      } else {
 486        (void) genie_rowing_ref_row_of_row (p);
 487        UNIT (&self) = genie_rowing_ref_row_of_row;
 488        SOURCE (&self) = p;
 489      }
 490    } else {
 491  // ROW, decide whether we want A->[] A or [] A->[,] A.
 492      if (DIM (DEFLEX (MOID (p))) >= 2) {
 493        (void) genie_rowing_row_row (p);
 494        UNIT (&self) = genie_rowing_row_row;
 495        SOURCE (&self) = p;
 496      } else {
 497        (void) genie_rowing_row_of_row (p);
 498        UNIT (&self) = genie_rowing_row_of_row;
 499        SOURCE (&self) = p;
 500      }
 501    }
 502    return self;
 503  }
 504  
 505  //! @brief Clone a compounded value referred to by 'old'.
 506  
 507  A68_REF genie_clone (NODE_T * p, MOID_T * m, A68_REF * tmp, A68_REF * old)
 508  {
 509  // This complex routine is needed as arrays are not always contiguous.
 510  // The routine takes a REF to the value and returns a REF to the clone.
 511    if (m == M_SOUND) {
 512  // REF SOUND.
 513      A68_REF nsound = heap_generator (p, m, SIZE (m));
 514      A68_SOUND *w = DEREF (A68_SOUND, &nsound);
 515      int size = A68_SOUND_DATA_SIZE (w);
 516      COPY ((BYTE_T *) w, ADDRESS (old), SIZE (M_SOUND));
 517      BYTE_T *owd = ADDRESS (&(DATA (w)));
 518      DATA (w) = heap_generator (p, M_SOUND_DATA, size);
 519      COPY (ADDRESS (&(DATA (w))), owd, size);
 520      return nsound;
 521    } else if (IS_STRUCT (m)) {
 522  // REF STRUCT.
 523      A68_REF nstruct = heap_generator (p, m, SIZE (m));
 524      for (PACK_T *fds = PACK (m); fds != NO_PACK; FORWARD (fds)) {
 525        MOID_T *fm = MOID (fds);
 526        A68_REF of = *old, nf = nstruct, tf = *tmp;
 527        OFFSET (&of) += OFFSET (fds);
 528        OFFSET (&nf) += OFFSET (fds);
 529        if (!IS_NIL (tf)) {
 530          OFFSET (&tf) += OFFSET (fds);
 531        }
 532        if (HAS_ROWS (fm)) {
 533          A68_REF a68_clone = genie_clone (p, fm, &tf, &of);
 534          MOVE (ADDRESS (&nf), ADDRESS (&a68_clone), SIZE (fm));
 535        } else {
 536          MOVE (ADDRESS (&nf), ADDRESS (&of), SIZE (fm));
 537        }
 538      }
 539      return nstruct;
 540    } else if (IS_UNION (m)) {
 541  // REF UNION.
 542      A68_REF nunion = heap_generator (p, m, SIZE (m));
 543      A68_REF src = *old;
 544      A68_UNION *u = DEREF (A68_UNION, &src);
 545      MOID_T *um = (MOID_T *) VALUE (u);
 546      OFFSET (&src) += UNION_OFFSET;
 547      A68_REF dst = nunion;
 548      *DEREF (A68_UNION, &dst) = *u;
 549      OFFSET (&dst) += UNION_OFFSET;
 550  // A union has formal members, so tmp is irrelevant.
 551      A68_REF tmpu = nil_ref;
 552      if (um != NO_MOID && HAS_ROWS (um)) {
 553        A68_REF a68_clone = genie_clone (p, um, &tmpu, &src);
 554        MOVE (ADDRESS (&dst), ADDRESS (&a68_clone), SIZE (um));
 555      } else if (um != NO_MOID) {
 556        MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (um));
 557      }
 558      return nunion;
 559    } else if (IF_ROW (m)) {
 560  // REF [FLEX] [].
 561      MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
 562  // Make new array.
 563      A68_ARRAY *old_arr; A68_TUPLE *old_tup;
 564      GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old));
 565      A68_ARRAY *new_arr; A68_TUPLE *new_tup;
 566      A68_REF nrow = heap_generator (p, m, DESCRIPTOR_SIZE (DIM (old_arr)));
 567      GET_DESCRIPTOR (new_arr, new_tup, &nrow);
 568      DIM (new_arr) = DIM (old_arr);
 569      MOID (new_arr) = MOID (old_arr);
 570      ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr);
 571      SLICE_OFFSET (new_arr) = 0;
 572      FIELD_OFFSET (new_arr) = 0;
 573  // Get size and copy bounds; check in case of a row.
 574  // This is just song and dance to comply with the RR.
 575      BOOL_T check_bounds = A68_FALSE;
 576      A68_REF ntmp; A68_ARRAY *tarr; A68_TUPLE *ttup = NO_TUPLE;
 577      if (IS_NIL (*tmp)) {
 578        ntmp = nil_ref;
 579      } else {
 580        A68_REF *z = DEREF (A68_REF, tmp);
 581        if (!IS_NIL (*z)) {
 582          GET_DESCRIPTOR (tarr, ttup, z);
 583          ntmp = ARRAY (tarr);
 584          check_bounds = IS_ROW (m);
 585        }
 586      }
 587      int span = 1;
 588      for (int k = 0; k < DIM (old_arr); k++) {
 589        A68_TUPLE *op = &old_tup[k], *np = &new_tup[k];
 590        if (check_bounds) {
 591          A68_TUPLE *tp = &ttup[k];
 592          if (UPB (tp) >= LWB (tp) && UPB (op) >= LWB (op)) {
 593            if (UPB (tp) != UPB (op) || LWB (tp) != LWB (op)) {
 594              diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
 595              exit_genie (p, A68_RUNTIME_ERROR);
 596            }
 597          }
 598        }
 599        LWB (np) = LWB (op);
 600        UPB (np) = UPB (op);
 601        SPAN (np) = span;
 602        SHIFT (np) = LWB (np) * SPAN (np);
 603        span *= ROW_SIZE (np);
 604      }
 605  // Make a new array with at least a ghost element.
 606      if (span == 0) {
 607        ARRAY (new_arr) = heap_generator (p, em, ELEM_SIZE (new_arr));
 608      } else {
 609        ARRAY (new_arr) = heap_generator (p, em, span * ELEM_SIZE (new_arr));
 610      }
 611  // Copy the ghost element if there are no elements.
 612      if (span == 0) {
 613        if (IS_UNION (em)) {
 614  // UNION has formal members.
 615        } else if (HAS_ROWS (em)) {
 616          A68_REF old_ref, dst_ref, a68_clone;
 617          old_ref = ARRAY (old_arr);
 618          OFFSET (&old_ref) += ROW_ELEMENT (old_arr, 0);
 619          dst_ref = ARRAY (new_arr);
 620          OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, 0);
 621          a68_clone = genie_clone (p, em, &ntmp, &old_ref);
 622          MOVE (ADDRESS (&dst_ref), ADDRESS (&a68_clone), SIZE (em));
 623        }
 624      } else if (span > 0) {
 625  // The n-dimensional copier.
 626        initialise_internal_index (old_tup, DIM (old_arr));
 627        initialise_internal_index (new_tup, DIM (new_arr));
 628        BOOL_T done = A68_FALSE;
 629        while (!done) {
 630          A68_REF old_ref = ARRAY (old_arr), dst_ref = ARRAY (new_arr);
 631          ADDR_T old_k = calculate_internal_index (old_tup, DIM (old_arr));
 632          ADDR_T new_k = calculate_internal_index (new_tup, DIM (new_arr));
 633          OFFSET (&old_ref) += ROW_ELEMENT (old_arr, old_k);
 634          OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, new_k);
 635          if (HAS_ROWS (em)) {
 636            A68_REF a68_clone;
 637            a68_clone = genie_clone (p, em, &ntmp, &old_ref);
 638            MOVE (ADDRESS (&dst_ref), ADDRESS (&a68_clone), SIZE (em));
 639          } else {
 640            MOVE (ADDRESS (&dst_ref), ADDRESS (&old_ref), SIZE (em));
 641          }
 642  // Increase pointers.
 643          done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
 644        }
 645      }
 646      A68_REF heap = heap_generator (p, m, A68_REF_SIZE);
 647      *DEREF (A68_REF, &heap) = nrow;
 648      return heap;
 649    }
 650    return nil_ref;
 651  }
 652  
 653  //! @brief Store into a row, fi. trimmed destinations.
 654  
 655  A68_REF genie_store (NODE_T * p, MOID_T * m, A68_REF * dst, A68_REF * old)
 656  {
 657  // This complex routine is needed as arrays are not always contiguous.
 658  // The routine takes a REF to the value and returns a REF to the clone.
 659    if (IF_ROW (m)) {
 660  // REF [FLEX] [].
 661      A68_TUPLE *old_tup, *new_tup, *old_p, *new_p;
 662      MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
 663      BOOL_T done = A68_FALSE;
 664      A68_ARRAY *old_arr, *new_arr;
 665      GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old));
 666      GET_DESCRIPTOR (new_arr, new_tup, DEREF (A68_REF, dst));
 667  // Get size and check bounds.
 668  // This is just song and dance to comply with the RR.
 669      int span = 1;
 670      for (int k = 0; k < DIM (old_arr); k++) {
 671        old_p = &old_tup[k];
 672        new_p = &new_tup[k];
 673        if ((UPB (new_p) >= LWB (new_p) && UPB (old_p) >= LWB (old_p))) {
 674          if ((UPB (new_p) != UPB (old_p) || LWB (new_p) != LWB (old_p))) {
 675            diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
 676            exit_genie (p, A68_RUNTIME_ERROR);
 677          }
 678        }
 679        span *= ROW_SIZE (new_p);
 680      }
 681  // Destination is an empty row, inspect if the source has elements.
 682      if (span == 0) {
 683        span = 1;
 684        for (int k = 0; k < DIM (old_arr); k++) {
 685          span *= ROW_SIZE (old_p);
 686        }
 687        if (span > 0) {
 688          span = 1;
 689          for (int k = 0; k < DIM (old_arr); k++) {
 690            new_tup[k] = old_tup[k];
 691          }
 692          ARRAY (new_arr) = heap_generator (p, em, span * ELEM_SIZE (new_arr));
 693        }
 694      } 
 695      if (span > 0) {
 696        initialise_internal_index (old_tup, DIM (old_arr));
 697        initialise_internal_index (new_tup, DIM (new_arr));
 698        while (!done) {
 699          A68_REF new_old = ARRAY (old_arr), new_dst = ARRAY (new_arr);
 700          ADDR_T old_index = calculate_internal_index (old_tup, DIM (old_arr));
 701          ADDR_T new_index = calculate_internal_index (new_tup, DIM (new_arr));
 702          OFFSET (&new_old) += ROW_ELEMENT (old_arr, old_index);
 703          OFFSET (&new_dst) += ROW_ELEMENT (new_arr, new_index);
 704          MOVE (ADDRESS (&new_dst), ADDRESS (&new_old), SIZE (em));
 705          done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
 706        }
 707      }
 708      return *dst;
 709    }
 710    return nil_ref;
 711  }
 712  
 713  //! @brief Assignment of complex objects in the stack.
 714  
 715  void genie_clone_stack (NODE_T * p, MOID_T * srcm, A68_REF * dst, A68_REF * tmp)
 716  {
 717  // STRUCT, UNION, [FLEX] [] or SOUND.
 718    A68_REF stack;
 719    STATUS (&stack) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
 720    OFFSET (&stack) = A68_SP;
 721    REF_HANDLE (&stack) = (A68_HANDLE *) & nil_handle;
 722    A68_REF *src = DEREF (A68_REF, &stack);
 723    if (IS_ROW (srcm) && !IS_NIL (*tmp)) {
 724      if (STATUS (src) & SKIP_ROW_MASK) {
 725        return;
 726      }
 727      A68_REF a68_clone = genie_clone (p, srcm, tmp, &stack);
 728      (void) genie_store (p, srcm, dst, &a68_clone);
 729    } else {
 730      A68_REF a68_clone = genie_clone (p, srcm, tmp, &stack);
 731      MOVE (ADDRESS (dst), ADDRESS (&a68_clone), SIZE (srcm));
 732    }
 733  }
 734  
 735  //! @brief Strcmp for qsort.
 736  
 737  int qstrcmp (const void *a, const void *b)
 738  {
 739    return strcmp (*(char *const *) a, *(char *const *) b);
 740  }
 741  
 742  //! @brief Sort row of string.
 743  
 744  void genie_sort_row_string (NODE_T * p)
 745  {
 746    A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup;
 747    POP_REF (p, &z);
 748    ADDR_T pop_sp = A68_SP;
 749    CHECK_REF (p, z, M_ROW_STRING);
 750    GET_DESCRIPTOR (arr, tup, &z);
 751    int size = ROW_SIZE (tup);
 752    if (size > 0) {
 753      BYTE_T *base = ADDRESS (&ARRAY (arr));
 754      char **ptrs = (char **) a68_alloc ((size_t) (size * (int) sizeof (char *)), __func__, __LINE__);
 755      if (ptrs == NO_VAR) {
 756        diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 757        exit_genie (p, A68_RUNTIME_ERROR);
 758      }
 759  // Copy C-strings into the stack and sort.
 760      for (int j = 0, k = LWB (tup); k <= UPB (tup); j++, k++) {
 761        int addr = INDEX_1_DIM (arr, tup, k);
 762        A68_REF ref = *(A68_REF *) & (base[addr]);
 763        CHECK_REF (p, ref, M_STRING);
 764        int len = A68_ALIGN (a68_string_size (p, ref) + 1);
 765        if (A68_SP + len > A68 (expr_stack_limit)) {
 766          diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);
 767          exit_genie (p, A68_RUNTIME_ERROR);
 768        }
 769        ptrs[j] = (char *) STACK_TOP;
 770        ASSERT (a_to_c_string (p, (char *) STACK_TOP, ref) != NO_TEXT);
 771        INCREMENT_STACK_POINTER (p, len);
 772      }
 773      qsort (ptrs, (size_t) size, sizeof (char *), qstrcmp);
 774  // Construct an array of sorted strings.
 775      A68_REF row; A68_ARRAY arrn; A68_TUPLE tupn;
 776      NEW_ROW_1D (z, row, arrn, tupn, M_ROW_STRING, M_STRING, size);
 777      A68_REF *base_ref = DEREF (A68_REF, &row);
 778      for (int k = 0; k < size; k++) {
 779        base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH);
 780      }
 781      a68_free (ptrs);
 782      A68_SP = pop_sp;
 783      PUSH_REF (p, z);
 784    } else {
 785  // This is how we sort an empty row of strings ...
 786      A68_SP = pop_sp;
 787      PUSH_REF (p, empty_row (p, M_ROW_STRING));
 788    }
 789  }
 790  
 791  //! @brief Construct a descriptor "ref_new" for a trim of "ref_old".
 792  
 793  void genie_trimmer (NODE_T * p, BYTE_T * *ref_new, BYTE_T * *ref_old, INT_T * offset)
 794  {
 795    if (p != NO_NODE) {
 796      if (IS (p, UNIT)) {
 797        EXECUTE_UNIT (p);
 798        A68_INT k;
 799        POP_OBJECT (p, &k, A68_INT);
 800        A68_TUPLE *t = (A68_TUPLE *) * ref_old;
 801        CHECK_INDEX (p, &k, t);
 802        (*offset) += SPAN (t) * VALUE (&k) - SHIFT (t);
 803        (*ref_old) += sizeof (A68_TUPLE);
 804      } else if (IS (p, TRIMMER)) {
 805        A68_TUPLE *old_tup = (A68_TUPLE *) * ref_old;
 806        A68_TUPLE *new_tup = (A68_TUPLE *) * ref_new;
 807  // TRIMMER is (l:u@r) with all units optional or (empty).
 808        INT_T L, U, D;
 809        NODE_T *q = SUB (p);
 810        if (q == NO_NODE) {
 811          L = LWB (old_tup);
 812          U = UPB (old_tup);
 813          D = 0;
 814        } else {
 815          BOOL_T absent = A68_TRUE;
 816  // Lower index.
 817          if (q != NO_NODE && IS (q, UNIT)) {
 818            EXECUTE_UNIT (q);
 819            A68_INT k;
 820            POP_OBJECT (p, &k, A68_INT);
 821            if (VALUE (&k) < LWB (old_tup)) {
 822              diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
 823              exit_genie (p, A68_RUNTIME_ERROR);
 824            }
 825            L = VALUE (&k);
 826            FORWARD (q);
 827            absent = A68_FALSE;
 828          } else {
 829            L = LWB (old_tup);
 830          }
 831          if (q != NO_NODE && (IS (q, COLON_SYMBOL)
 832                               || IS (q, DOTDOT_SYMBOL))) {
 833            FORWARD (q);
 834            absent = A68_FALSE;
 835          }
 836  // Upper index.
 837          if (q != NO_NODE && IS (q, UNIT)) {
 838            EXECUTE_UNIT (q);
 839            A68_INT k;
 840            POP_OBJECT (p, &k, A68_INT);
 841            if (VALUE (&k) > UPB (old_tup)) {
 842              diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
 843              exit_genie (p, A68_RUNTIME_ERROR);
 844            }
 845            U = VALUE (&k);
 846            FORWARD (q);
 847            absent = A68_FALSE;
 848          } else {
 849            U = UPB (old_tup);
 850          }
 851          if (q != NO_NODE && IS (q, AT_SYMBOL)) {
 852            FORWARD (q);
 853          }
 854  // Revised lower bound.
 855          if (q != NO_NODE && IS (q, UNIT)) {
 856            EXECUTE_UNIT (q);
 857            A68_INT k;
 858            POP_OBJECT (p, &k, A68_INT);
 859            D = L - VALUE (&k);
 860            FORWARD (q);
 861          } else {
 862            D = (absent ? 0 : L - 1);
 863          }
 864        }
 865        LWB (new_tup) = L - D;
 866        UPB (new_tup) = U - D;    // (L - D) + (U - L)
 867        SPAN (new_tup) = SPAN (old_tup);
 868        SHIFT (new_tup) = SHIFT (old_tup) - D * SPAN (new_tup);
 869        (*ref_old) += sizeof (A68_TUPLE);
 870        (*ref_new) += sizeof (A68_TUPLE);
 871      } else {
 872        genie_trimmer (SUB (p), ref_new, ref_old, offset);
 873        genie_trimmer (NEXT (p), ref_new, ref_old, offset);
 874      }
 875    }
 876  }
 877  
 878  //! @brief Calculation of subscript.
 879  
 880  void genie_subscript (NODE_T * p, A68_TUPLE ** tup, INT_T * sum, NODE_T ** seq)
 881  {
 882    for (; p != NO_NODE; FORWARD (p)) {
 883      switch (ATTRIBUTE (p)) {
 884      case UNIT:
 885        {
 886          EXECUTE_UNIT (p);
 887          A68_INT *k;
 888          POP_ADDRESS (p, k, A68_INT);
 889          A68_TUPLE *t = *tup;
 890          CHECK_INDEX (p, k, t);
 891          (*tup)++;
 892          (*sum) += (SPAN (t) * VALUE (k) - SHIFT (t));
 893          SEQUENCE (*seq) = p;
 894          (*seq) = p;
 895          return;
 896        }
 897      case GENERIC_ARGUMENT:
 898      case GENERIC_ARGUMENT_LIST:
 899        {
 900          genie_subscript (SUB (p), tup, sum, seq);
 901        }
 902      }
 903    }
 904  }
 905  
 906  //! @brief Slice REF [] A to REF A.
 907  
 908  PROP_T genie_slice_name_quick (NODE_T * p)
 909  {
 910    NODE_T *q, *pr = SUB (p);
 911    A68_REF *z = (A68_REF *) STACK_TOP;
 912    A68_ARRAY *a; A68_TUPLE *t;
 913  // Get row and save row from garbage collector.
 914    EXECUTE_UNIT (pr);
 915    CHECK_REF (p, *z, MOID (SUB (p)));
 916    GET_DESCRIPTOR (a, t, DEREF (A68_ROW, z));
 917    ADDR_T pop_sp = A68_SP;
 918    INT_T sindex = 0;
 919    for (q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) {
 920      A68_INT *j = (A68_INT *) STACK_TOP;
 921      INT_T k;
 922      EXECUTE_UNIT (q);
 923      k = VALUE (j);
 924      if (k < LWB (t) || k > UPB (t)) {
 925        diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
 926        exit_genie (q, A68_RUNTIME_ERROR);
 927      }
 928      sindex += (SPAN (t) * k - SHIFT (t));
 929      A68_SP = pop_sp;
 930    }
 931  // Leave reference to element on the stack, preserving scope.
 932    ADDR_T scope = REF_SCOPE (z);
 933    *z = ARRAY (a);
 934    OFFSET (z) += ROW_ELEMENT (a, sindex);
 935    REF_SCOPE (z) = scope;
 936    return GPROP (p);
 937  }
 938  
 939  //! @brief Push slice of a rowed object.
 940  
 941  PROP_T genie_slice (NODE_T * p)
 942  {
 943    ADDR_T pop_sp, scope = PRIMAL_SCOPE;
 944    BOOL_T slice_of_name = (BOOL_T) (IS_REF (MOID (SUB (p))));
 945    MOID_T *result_mode = slice_of_name ? SUB_MOID (p) : MOID (p);
 946    NODE_T *indexer = NEXT_SUB (p);
 947    PROP_T self;
 948    UNIT (&self) = genie_slice;
 949    SOURCE (&self) = p;
 950    pop_sp = A68_SP;
 951  // Get row.
 952    PROP_T primary;
 953    EXECUTE_UNIT_2 (SUB (p), primary);
 954  // In case of slicing a REF [], we need the [] internally, so dereference.
 955    if (slice_of_name) {
 956      A68_REF z;
 957      POP_REF (p, &z);
 958      CHECK_REF (p, z, MOID (SUB (p)));
 959      scope = REF_SCOPE (&z);
 960      PUSH_REF (p, *DEREF (A68_REF, &z));
 961    }
 962    if (ANNOTATION (indexer) == SLICE) {
 963  // SLICING subscripts one element from an array.
 964      A68_REF z; A68_ARRAY *a; A68_TUPLE *t;
 965      POP_REF (p, &z);
 966      CHECK_REF (p, z, MOID (SUB (p)));
 967      GET_DESCRIPTOR (a, t, &z);
 968      INT_T sindex;
 969      if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
 970        NODE_T top_seq;
 971        NODE_T *seq = &top_seq;
 972        GINFO_T g;
 973        GINFO (&top_seq) = &g;
 974        sindex = 0;
 975        genie_subscript (indexer, &t, &sindex, &seq);
 976        SEQUENCE (p) = SEQUENCE (&top_seq);
 977        STATUS_SET (p, SEQUENCE_MASK);
 978      } else {
 979        NODE_T *q;
 980        for (sindex = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) {
 981          A68_INT *j = (A68_INT *) STACK_TOP;
 982          INT_T k;
 983          EXECUTE_UNIT (q);
 984          k = VALUE (j);
 985          if (k < LWB (t) || k > UPB (t)) {
 986            diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
 987            exit_genie (q, A68_RUNTIME_ERROR);
 988          }
 989          sindex += (SPAN (t) * k - SHIFT (t));
 990        }
 991      }
 992  // Slice of a name yields a name.
 993      A68_SP = pop_sp;
 994      if (slice_of_name) {
 995        A68_REF name = ARRAY (a);
 996        OFFSET (&name) += ROW_ELEMENT (a, sindex);
 997        REF_SCOPE (&name) = scope;
 998        PUSH_REF (p, name);
 999        if (STATUS_TEST (p, SEQUENCE_MASK)) {
1000          UNIT (&self) = genie_slice_name_quick;
1001          SOURCE (&self) = p;
1002        }
1003      } else {
1004        BYTE_T *stack_top = STACK_TOP;
1005        PUSH (p, &((ADDRESS (&(ARRAY (a))))[ROW_ELEMENT (a, sindex)]), SIZE (result_mode));
1006        genie_check_initialisation (p, stack_top, result_mode);
1007      }
1008      return self;
1009    } else if (ANNOTATION (indexer) == TRIMMER) {
1010  // Trimming selects a subarray from an array.
1011      int dim = DIM (DEFLEX (result_mode));
1012      A68_REF ref_desc_copy = heap_generator (p, MOID (p), DESCRIPTOR_SIZE (dim));
1013  // Get descriptor.
1014      A68_REF z;
1015      POP_REF (p, &z);
1016  // Get indexer.
1017      CHECK_REF (p, z, MOID (SUB (p)));
1018      A68_ARRAY *old_des = DEREF (A68_ARRAY, &z), *new_des = DEREF (A68_ARRAY, &ref_desc_copy);
1019      BYTE_T *ref_old = ADDRESS (&z) + SIZE_ALIGNED (A68_ARRAY);
1020      BYTE_T *ref_new = ADDRESS (&ref_desc_copy) + SIZE_ALIGNED (A68_ARRAY);
1021      DIM (new_des) = dim;
1022      MOID (new_des) = MOID (old_des);
1023      ELEM_SIZE (new_des) = ELEM_SIZE (old_des);
1024      INT_T offset = SLICE_OFFSET (old_des);
1025      genie_trimmer (indexer, &ref_new, &ref_old, &offset);
1026      SLICE_OFFSET (new_des) = offset;
1027      FIELD_OFFSET (new_des) = FIELD_OFFSET (old_des);
1028      ARRAY (new_des) = ARRAY (old_des);
1029  // Trim of a name is a name.
1030      if (slice_of_name) {
1031        A68_REF ref_new2 = heap_generator (p, MOID (p), A68_REF_SIZE);
1032        *DEREF (A68_REF, &ref_new2) = ref_desc_copy;
1033        REF_SCOPE (&ref_new2) = scope;
1034        PUSH_REF (p, ref_new2);
1035      } else {
1036        PUSH_REF (p, ref_desc_copy);
1037      }
1038      return self;
1039    } else {
1040      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1041      return self;
1042    }
1043    (void) primary;
1044  }
1045  
1046  //! @brief SELECTION from a value
1047  
1048  PROP_T genie_selection_value_quick (NODE_T * p)
1049  {
1050    NODE_T *selector = SUB (p);
1051    MOID_T *result_mode = MOID (selector);
1052    ADDR_T pop_sp = A68_SP;
1053    int size = SIZE (result_mode);
1054    INT_T offset = OFFSET (NODE_PACK (SUB (selector)));
1055    EXECUTE_UNIT (NEXT (selector));
1056    A68_SP = pop_sp;
1057    if (offset > 0) {
1058      MOVE (STACK_TOP, STACK_OFFSET (offset), (unt) size);
1059      genie_check_initialisation (p, STACK_TOP, result_mode);
1060    }
1061    INCREMENT_STACK_POINTER (selector, size);
1062    return GPROP (p);
1063  }
1064  
1065  //! @brief SELECTION from a name
1066  
1067  PROP_T genie_selection_name_quick (NODE_T * p)
1068  {
1069    NODE_T *selector = SUB (p);
1070    MOID_T *struct_mode = MOID (NEXT (selector));
1071    A68_REF *z = (A68_REF *) STACK_TOP;
1072    EXECUTE_UNIT (NEXT (selector));
1073    CHECK_REF (selector, *z, struct_mode);
1074    OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
1075    return GPROP (p);
1076  }
1077  
1078  //! @brief Push selection from secondary.
1079  
1080  PROP_T genie_selection (NODE_T * p)
1081  {
1082    NODE_T *selector = SUB (p);
1083    MOID_T *struct_mode = MOID (NEXT (selector)), *result_mode = MOID (selector);
1084    BOOL_T selection_of_name = (BOOL_T) (IS_REF (struct_mode));
1085    PROP_T self;
1086    SOURCE (&self) = p;
1087    UNIT (&self) = genie_selection;
1088    EXECUTE_UNIT (NEXT (selector));
1089  // Multiple selections.
1090    if (selection_of_name && (IS_FLEX (SUB (struct_mode)) || IS_ROW (SUB (struct_mode)))) {
1091      A68_REF *row1;
1092      POP_ADDRESS (selector, row1, A68_REF);
1093      CHECK_REF (p, *row1, struct_mode);
1094      row1 = DEREF (A68_REF, row1);
1095      int dims = DIM (DEFLEX (SUB (struct_mode)));
1096      int desc_size = DESCRIPTOR_SIZE (dims);
1097      A68_REF row2 = heap_generator (selector, result_mode, desc_size);
1098      MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unt) desc_size);
1099      MOID ((DEREF (A68_ARRAY, &row2))) = SUB_SUB (result_mode);
1100      FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector)));
1101      A68_REF row3 = heap_generator (selector, result_mode, A68_REF_SIZE);
1102      *DEREF (A68_REF, &row3) = row2;
1103      PUSH_REF (selector, row3);
1104      UNIT (&self) = genie_selection;
1105    } else if (struct_mode != NO_MOID && (IS_FLEX (struct_mode) || IS_ROW (struct_mode))) {
1106      A68_REF *row1;
1107      POP_ADDRESS (selector, row1, A68_REF);
1108      int dims = DIM (DEFLEX (struct_mode));
1109      int desc_size = DESCRIPTOR_SIZE (dims);
1110      A68_REF row2 = heap_generator (selector, result_mode, desc_size);
1111      MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unt) desc_size);
1112      MOID ((DEREF (A68_ARRAY, &row2))) = SUB (result_mode);
1113      FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector)));
1114      PUSH_REF (selector, row2);
1115      UNIT (&self) = genie_selection;
1116    }
1117  // Normal selections.
1118    else if (selection_of_name && IS_STRUCT (SUB (struct_mode))) {
1119      A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE));
1120      CHECK_REF (selector, *z, struct_mode);
1121      OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
1122      UNIT (&self) = genie_selection_name_quick;
1123    } else if (IS_STRUCT (struct_mode)) {
1124      DECREMENT_STACK_POINTER (selector, SIZE (struct_mode));
1125      MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (SUB (selector)))), (unt) SIZE (result_mode));
1126      genie_check_initialisation (p, STACK_TOP, result_mode);
1127      INCREMENT_STACK_POINTER (selector, SIZE (result_mode));
1128      UNIT (&self) = genie_selection_value_quick;
1129    }
1130    return self;
1131  }
1132  
1133  //! @brief Push selection from primary.
1134  
1135  PROP_T genie_field_selection (NODE_T * p)
1136  {
1137    ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
1138    NODE_T *entry = p;
1139    A68_REF *z = (A68_REF *) STACK_TOP;
1140    A68_PROCEDURE *w = (A68_PROCEDURE *) STACK_TOP;
1141    PROP_T self;
1142    SOURCE (&self) = entry;
1143    UNIT (&self) = genie_field_selection;
1144    EXECUTE_UNIT (SUB (p));
1145    for (p = SEQUENCE (SUB (p)); p != NO_NODE; p = SEQUENCE (p)) {
1146      MOID_T *m = MOID (p);
1147      MOID_T *result_mode = MOID (NODE_PACK (p));
1148      BOOL_T coerce = A68_TRUE;
1149      while (coerce) {
1150        if (IS_REF (m) && ISNT (SUB (m), STRUCT_SYMBOL)) {
1151          int size = SIZE (SUB (m));
1152          A68_SP = pop_sp;
1153          CHECK_REF (p, *z, m);
1154          PUSH (p, ADDRESS (z), size);
1155          genie_check_initialisation (p, STACK_OFFSET (-size), MOID (p));
1156          m = SUB (m);
1157        } else if (IS (m, PROC_SYMBOL)) {
1158          genie_check_initialisation (p, (BYTE_T *) w, m);
1159          genie_call_procedure (p, m, m, M_VOID, w, pop_sp, pop_fp);
1160          STACK_DNS (p, MOID (p), A68_FP);
1161          m = SUB (m);
1162        } else {
1163          coerce = A68_FALSE;
1164        }
1165      }
1166      if (IS_REF (m) && IS (SUB (m), STRUCT_SYMBOL)) {
1167        CHECK_REF (p, *z, m);
1168        OFFSET (z) += OFFSET (NODE_PACK (p));
1169      } else if (IS_STRUCT (m)) {
1170        A68_SP = pop_sp;
1171        MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (p))), (unt) SIZE (result_mode));
1172        INCREMENT_STACK_POINTER (p, SIZE (result_mode));
1173      }
1174    }
1175    return self;
1176  }
1177