rts-stowed.c

     
   1  //! @file rts-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-2025 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-prelude.h"
  29  
  30  // Routines for handling stowed objects.
  31  // 
  32  // An A68G row is a reference to a descriptor in the heap:
  33  // 
  34  //                ...
  35  // A68G_REF row -> A68G_ARRAY ----+   ARRAY: Description of row, ref to elements.
  36  //                A68G_TUPLE 1   |   TUPLE: Bounds, one for every dimension.
  37  //                ...           |
  38  //                A68G_TUPLE dim |
  39  //                ...           |
  40  //                ...           |
  41  //                Element 1 <---+   Sequential row elements in the heap.
  42  //                ...
  43  //                Element n
  44  
  45  //! @brief Size of a row.
  46  
  47  int get_row_size (A68G_TUPLE * tup, int dim)
  48  {
  49    int span = 1;
  50    for (int k = 0; k < dim; k++) {
  51      int stride = ROW_SIZE (&tup[k]);
  52      ABEND ((stride > 0 && span > A68G_MAX_INT / stride), ERROR_INVALID_SIZE, __func__);
  53      span *= stride;
  54    }
  55    return span;
  56  }
  57  
  58  //! @brief Initialise index for FORALL constructs.
  59  
  60  void initialise_internal_index (A68G_TUPLE * tup, int dim)
  61  {
  62    for (int k = 0; k < dim; k++) {
  63      A68G_TUPLE *ref = &tup[k];
  64      K (ref) = LWB (ref);
  65    }
  66  }
  67  
  68  //! @brief Calculate index.
  69  
  70  ADDR_T calculate_internal_index (A68G_TUPLE * tup, int dim)
  71  {
  72    ADDR_T idx = 0;
  73    for (int k = 0; k < dim; k++) {
  74      A68G_TUPLE *ref = &tup[k];
  75  // Only consider non-empty rows.
  76      if (ROW_SIZE (ref) > 0) {
  77        idx += (SPAN (ref) * K (ref) - SHIFT (ref));
  78      }
  79    }
  80    return idx;
  81  }
  82  
  83  //! @brief Increment index for FORALL constructs.
  84  
  85  BOOL_T increment_internal_index (A68G_TUPLE * tup, int dim)
  86  {
  87    BOOL_T carry = A68G_TRUE;
  88    for (int k = dim - 1; k >= 0 && carry; k--) {
  89      A68G_TUPLE *ref = &tup[k];
  90      if (K (ref) < UPB (ref)) {
  91        (K (ref))++;
  92        carry = A68G_FALSE;
  93      } else {
  94        K (ref) = LWB (ref);
  95      }
  96    }
  97    return carry;
  98  }
  99  
 100  //! @brief Print index.
 101  
 102  void print_internal_index (FILE_T f, A68G_TUPLE * tup, int dim)
 103  {
 104    for (int k = 0; k < dim; k++) {
 105      A68G_TUPLE *ref = &tup[k];
 106      BUFFER buf;
 107      BUFCLR (buf);
 108      ASSERT (a68g_bufprt (buf, SNPRINTF_SIZE, A68G_LD, K (ref)) >= 0);
 109      WRITE (f, buf);
 110      if (k < dim - 1) {
 111        WRITE (f, ", ");
 112      }
 113    }
 114  }
 115  
 116  //! @brief Convert C string to A68 [] CHAR.
 117  
 118  A68G_REF c_string_to_row_char (NODE_T * p, char *str, size_t width)
 119  {
 120    A68G_REF z, row; A68G_ARRAY arr; A68G_TUPLE tup;
 121    NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, width);
 122    BYTE_T *base = ADDRESS (&row);
 123    size_t len = strlen (str);
 124    for (int k = 0; k < width; k++) {
 125      A68G_CHAR *ch = (A68G_CHAR *) & (base[k * SIZE_ALIGNED (A68G_CHAR)]);
 126      STATUS (ch) = INIT_MASK;
 127      VALUE (ch) = (k < len ? TO_UCHAR (str[k]) : NULL_CHAR);
 128    }
 129    return z;
 130  }
 131  
 132  //! @brief Convert C string to A68 string.
 133  
 134  A68G_REF c_to_a_string (NODE_T * p, char *str, size_t width)
 135  {
 136    if (str == NO_TEXT) {
 137      return empty_string (p);
 138    } else {
 139      if (width == DEFAULT_WIDTH) {
 140        return c_string_to_row_char (p, str, strlen (str));
 141      } else {
 142        return c_string_to_row_char (p, str, width);
 143      }
 144    }
 145  }
 146  
 147  //! @brief Size of a string.
 148  
 149  int a68g_string_size (NODE_T * p, A68G_REF row)
 150  {
 151    (void) p;
 152    if (INITIALISED (&row)) {
 153      A68G_ARRAY *arr; A68G_TUPLE *tup;
 154      GET_DESCRIPTOR (arr, tup, &row);
 155      return ROW_SIZE (tup);
 156    } else {
 157      return 0;
 158    }
 159  }
 160  
 161  //! @brief Convert A68 string to C string.
 162  
 163  char *a_to_c_string (NODE_T * p, char *str, A68G_REF row)
 164  {
 165  // Assume "str" to be long enough - caller's responsibility!.
 166    (void) p;
 167    if (INITIALISED (&row)) {
 168      A68G_ARRAY *arr; A68G_TUPLE *tup;
 169      GET_DESCRIPTOR (arr, tup, &row);
 170      size_t size = ROW_SIZE (tup), n = 0;
 171      if (size > 0) {
 172        BYTE_T *base_address = ADDRESS (&ARRAY (arr));
 173        for (int k = LWB (tup); k <= UPB (tup); k++) {
 174          int addr = INDEX_1_DIM (arr, tup, k);
 175          A68G_CHAR *ch = (A68G_CHAR *) & (base_address[addr]);
 176          CHECK_INIT (p, INITIALISED (ch), M_CHAR);
 177          str[n++] = (char) VALUE (ch);
 178        }
 179      }
 180      str[n] = NULL_CHAR;
 181      return str;
 182    } else {
 183      return NO_TEXT;
 184    }
 185  }
 186  
 187  //! @brief Return an empty row.
 188  
 189  A68G_REF empty_row (NODE_T * p, MOID_T * m_row)
 190  {
 191    if (IS_FLEX (m_row)) {
 192      m_row = SUB (m_row);
 193    }
 194    MOID_T *m_elem = SUB (m_row);
 195    int dim = DIM (m_row);
 196    A68G_REF dsc; A68G_ARRAY *arr; A68G_TUPLE *tup;
 197    dsc = heap_generator (p, m_row, DESCRIPTOR_SIZE (dim));
 198    GET_DESCRIPTOR (arr, tup, &dsc);
 199    DIM (arr) = dim;
 200    MOID (arr) = SLICE (m_row);
 201    ELEM_SIZE (arr) = moid_size (SLICE (m_row));
 202    SLICE_OFFSET (arr) = 0;
 203    FIELD_OFFSET (arr) = 0;
 204    if (IS_ROW (m_elem) || IS_FLEX (m_elem)) {
 205  // [] AMODE or FLEX [] AMODE 
 206      ARRAY (arr) = heap_generator (p, m_elem, A68G_REF_SIZE);
 207      *DEREF (A68G_REF, &ARRAY (arr)) = empty_row (p, m_elem);
 208    } else {
 209      ARRAY (arr) = nil_ref;
 210    }
 211    STATUS (&ARRAY (arr)) = (STATUS_MASK_T) (INIT_MASK | IN_HEAP_MASK);
 212    for (int k = 0; k < dim; k++) {
 213      LWB (&tup[k]) = 1;
 214      UPB (&tup[k]) = 0;
 215      SPAN (&tup[k]) = 1;
 216      SHIFT (&tup[k]) = LWB (tup);
 217    }
 218    return dsc;
 219  }
 220  
 221  //! @brief An empty string, FLEX [1 : 0] CHAR.
 222  
 223  A68G_REF empty_string (NODE_T * p)
 224  {
 225    return empty_row (p, M_STRING);
 226  }
 227  
 228  //! @brief Make [,, ..] MODE  from [, ..] MODE.
 229  
 230  A68G_REF genie_make_rowrow (NODE_T *p, MOID_T * m_row, int len, ADDR_T pop_sp)
 231  {
 232    MOID_T *m_deflex = IS_FLEX (m_row) ? SUB (m_row) : m_row;
 233    int old_dim = DIM (m_deflex) - 1;
 234  // Make the new descriptor.
 235    A68G_ARRAY *new_arr; A68G_TUPLE *new_tup;
 236    A68G_REF new_row = heap_generator (p, m_row, DESCRIPTOR_SIZE (DIM (m_deflex)));
 237    GET_DESCRIPTOR (new_arr, new_tup, &new_row);
 238    DIM (new_arr) = DIM (m_deflex);
 239    MOID_T *m_elem = SUB (m_deflex);
 240    MOID (new_arr) = m_elem;
 241    ELEM_SIZE (new_arr) = SIZE (m_elem);
 242    SLICE_OFFSET (new_arr) = 0;
 243    FIELD_OFFSET (new_arr) = 0;
 244    if (len == 0) {
 245  // There is a vacuum on the stack.
 246      for (int k = 0; k < old_dim; k++) {
 247        LWB (&new_tup[k + 1]) = 1;
 248        UPB (&new_tup[k + 1]) = 0;
 249        SPAN (&new_tup[k + 1]) = 1;
 250        SHIFT (&new_tup[k + 1]) = LWB (&new_tup[k + 1]);
 251      }
 252      LWB (new_tup) = 1;
 253      UPB (new_tup) = 0;
 254      SPAN (new_tup) = 0;
 255      SHIFT (new_tup) = 0;
 256      ARRAY (new_arr) = nil_ref;
 257      return new_row;
 258    } else if (len > 0) {
 259      A68G_ARRAY *tmp = NO_ARRAY;
 260  // Arrays in the stack must have equal bounds.
 261      A68G_REF row_0 = *(A68G_REF *) STACK_ADDRESS (pop_sp);
 262      A68G_TUPLE *tup_0;
 263      GET_DESCRIPTOR (tmp, tup_0, &row_0);
 264      for (int j = 1; j < len; j++) {
 265        A68G_REF row_j = *(A68G_REF *) STACK_ADDRESS (pop_sp + j * A68G_REF_SIZE);
 266        A68G_TUPLE *tup_j;
 267        GET_DESCRIPTOR (tmp, tup_j, &row_j);
 268        for (int k = 0; k < old_dim; k++) {
 269          if ((UPB (&tup_0[k]) != UPB (&tup_j[k])) || (LWB (&tup_0[k]) != LWB (&tup_j[k]))) {
 270            diagnostic (A68G_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
 271            exit_genie (p, A68G_RUNTIME_ERROR);
 272          }
 273        }
 274      }
 275  // Fill descriptor of new row with info from (arbitrary) first one.
 276      A68G_ARRAY *old_arr; A68G_TUPLE *old_tup;
 277      A68G_REF old_row = *(A68G_REF *) STACK_ADDRESS (pop_sp);
 278      GET_DESCRIPTOR (tmp, old_tup, &old_row);
 279      int span = 1;
 280      for (int k = 0; k < old_dim; k++) {
 281        A68G_TUPLE *tup = &new_tup[k + 1];
 282        LWB (tup) = LWB (&old_tup[k]);
 283        UPB (tup) = UPB (&old_tup[k]);
 284        SPAN (tup) = span;
 285        SHIFT (tup) = LWB (tup) * SPAN (tup);
 286        span *= ROW_SIZE (tup);
 287      }
 288      LWB (new_tup) = 1;
 289      UPB (new_tup) = len;
 290      SPAN (new_tup) = span;
 291      SHIFT (new_tup) = LWB (new_tup) * SPAN (new_tup);
 292      ARRAY (new_arr) = heap_generator_2 (p, m_row, len, span * ELEM_SIZE (new_arr));
 293      for (int j = 0; j < len; j++) {
 294  // Copy new[j,, ] := old[, ].
 295        GET_DESCRIPTOR (old_arr, old_tup, (A68G_REF *) STACK_ADDRESS (pop_sp + j * A68G_REF_SIZE));
 296        if (LWB (old_tup) > UPB (old_tup)) {
 297          A68G_REF dst = ARRAY (new_arr);
 298          ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], old_dim);
 299          OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
 300          A68G_REF clone = empty_row (p, SLICE (m_row));
 301          MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_elem));
 302        } else {
 303          initialise_internal_index (old_tup, old_dim);
 304          initialise_internal_index (&new_tup[1], old_dim);
 305          BOOL_T done = A68G_FALSE;
 306          while (!done) {
 307            A68G_REF src = ARRAY (old_arr), dst = ARRAY (new_arr);
 308            ADDR_T old_k = calculate_internal_index (old_tup, old_dim);
 309            ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], old_dim);
 310            OFFSET (&src) += ROW_ELEMENT (old_arr, old_k);
 311            OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
 312            if (HAS_ROWS (m_elem)) {
 313              A68G_REF clone = genie_clone (p, m_elem, (A68G_REF *) & nil_ref, &src);
 314              MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_elem));
 315            } else {
 316              MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (m_elem));
 317            }
 318            done = increment_internal_index (old_tup, old_dim) | increment_internal_index (&new_tup[1], old_dim);
 319          }
 320        }
 321      }
 322    }
 323    return new_row;
 324  }
 325  
 326  //! @brief Make a row of 'len' objects that are in the stack.
 327  
 328  A68G_REF genie_make_row (NODE_T * p, MOID_T * m_elem, int len, ADDR_T pop_sp)
 329  {
 330    A68G_REF new_row, new_arr; A68G_ARRAY arr; A68G_TUPLE tup;
 331    NEW_ROW_1D (new_row, new_arr, arr, tup, MOID (p), m_elem, len);
 332    for (int k = 0; k < len * ELEM_SIZE (&arr); k += ELEM_SIZE (&arr)) {
 333      A68G_REF dst = new_arr, src;
 334      OFFSET (&dst) += k;
 335      STATUS (&src) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
 336      OFFSET (&src) = pop_sp + k;
 337      REF_HANDLE (&src) = (A68G_HANDLE *) & nil_handle;
 338      if (HAS_ROWS (m_elem)) {
 339        A68G_REF clone = genie_clone (p, m_elem, (A68G_REF *) & nil_ref, &src);
 340        MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_elem));
 341      } else {
 342        MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (m_elem));
 343      }
 344    }
 345    return new_row;
 346  }
 347  
 348  //! @brief Make REF [1 : 1] [] MODE from REF [] MODE.
 349  
 350  A68G_REF genie_make_ref_row_of_row (NODE_T * p, MOID_T * m_dst, MOID_T * m_src, ADDR_T pop_sp)
 351  {
 352    m_dst = DEFLEX (m_dst);
 353    m_src = DEFLEX (m_src);
 354    A68G_REF array = *(A68G_REF *) STACK_ADDRESS (pop_sp);
 355  // ROWING NIL yields NIL.
 356    if (IS_NIL (array)) {
 357      return nil_ref;
 358    } else {
 359      A68G_REF new_row = heap_generator (p, SUB (m_dst), DESCRIPTOR_SIZE (1));
 360      A68G_REF name = heap_generator (p, m_dst, A68G_REF_SIZE);
 361      A68G_ARRAY *arr; A68G_TUPLE *tup;
 362      GET_DESCRIPTOR (arr, tup, &new_row);
 363      DIM (arr) = 1;
 364      MOID (arr) = m_src;
 365      ELEM_SIZE (arr) = SIZE (m_src);
 366      SLICE_OFFSET (arr) = 0;
 367      FIELD_OFFSET (arr) = 0;
 368      ARRAY (arr) = array;
 369      LWB (tup) = 1;
 370      UPB (tup) = 1;
 371      SPAN (tup) = 1;
 372      SHIFT (tup) = LWB (tup);
 373      *DEREF (A68G_REF, &name) = new_row;
 374      return name;
 375    }
 376  }
 377  
 378  //! @brief Make REF [1 : 1, ..] MODE from REF [..] MODE.
 379  
 380  A68G_REF genie_make_ref_row_row (NODE_T * p, MOID_T * m_dst, MOID_T * m_src, ADDR_T pop_sp)
 381  {
 382    m_dst = DEFLEX (m_dst);
 383    m_src = DEFLEX (m_src);
 384    A68G_REF name = *(A68G_REF *) STACK_ADDRESS (pop_sp);
 385  // ROWING NIL yields NIL.
 386    if (IS_NIL (name)) {
 387      return nil_ref;
 388    }
 389    A68G_REF old_row = *DEREF (A68G_REF, &name); A68G_TUPLE *new_tup, *old_tup;
 390    A68G_ARRAY *old_arr;
 391    GET_DESCRIPTOR (old_arr, old_tup, &old_row);
 392  // Make new descriptor.
 393    A68G_REF new_row = heap_generator (p, m_dst, DESCRIPTOR_SIZE (DIM (SUB (m_dst))));
 394    A68G_ARRAY *new_arr;
 395    name = heap_generator (p, m_dst, A68G_REF_SIZE);
 396    GET_DESCRIPTOR (new_arr, new_tup, &new_row);
 397    DIM (new_arr) = DIM (SUB (m_dst));
 398    MOID (new_arr) = MOID (old_arr);
 399    ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr);
 400    SLICE_OFFSET (new_arr) = 0;
 401    FIELD_OFFSET (new_arr) = 0;
 402    ARRAY (new_arr) = ARRAY (old_arr);
 403  // Fill out the descriptor.
 404    LWB (&(new_tup[0])) = 1;
 405    UPB (&(new_tup[0])) = 1;
 406    SPAN (&(new_tup[0])) = 1;
 407    SHIFT (&(new_tup[0])) = LWB (&(new_tup[0]));
 408    for (int k = 0; k < DIM (SUB (m_src)); k++) {
 409      new_tup[k + 1] = old_tup[k];
 410    }
 411  // Yield the new name.
 412    *DEREF (A68G_REF, &name) = new_row;
 413    return name;
 414  }
 415  
 416  //! @brief Coercion to [1 : 1, ] MODE.
 417  
 418  PROP_T genie_rowing_row_row (NODE_T * p)
 419  {
 420    ADDR_T pop_sp = A68G_SP;
 421    GENIE_UNIT_NO_GC (SUB (p));
 422    STACK_DNS (p, MOID (SUB (p)), A68G_FP);
 423    A68G_REF row = genie_make_rowrow (p, MOID (p), 1, pop_sp);
 424    A68G_SP = pop_sp;
 425    PUSH_REF (p, row);
 426    return GPROP (p);
 427  }
 428  
 429  //! @brief Coercion to [1 : 1] [] MODE.
 430  
 431  PROP_T genie_rowing_row_of_row (NODE_T * p)
 432  {
 433    ADDR_T pop_sp = A68G_SP;
 434    GENIE_UNIT_NO_GC (SUB (p));
 435    STACK_DNS (p, MOID (SUB (p)), A68G_FP);
 436    A68G_REF row = genie_make_row (p, SLICE (MOID (p)), 1, pop_sp);
 437    A68G_SP = pop_sp;
 438    PUSH_REF (p, row);
 439    return GPROP (p);
 440  }
 441  
 442  //! @brief Coercion to REF [1 : 1, ..] MODE.
 443  
 444  PROP_T genie_rowing_ref_row_row (NODE_T * p)
 445  {
 446    ADDR_T pop_sp = A68G_SP;
 447    MOID_T *dst = MOID (p), *src = MOID (SUB (p));
 448    GENIE_UNIT_NO_GC (SUB (p));
 449    STACK_DNS (p, MOID (SUB (p)), A68G_FP);
 450    A68G_SP = pop_sp;
 451    A68G_REF name = genie_make_ref_row_row (p, dst, src, pop_sp);
 452    PUSH_REF (p, name);
 453    return GPROP (p);
 454  }
 455  
 456  //! @brief REF [1 : 1] [] MODE from [] MODE
 457  
 458  PROP_T genie_rowing_ref_row_of_row (NODE_T * p)
 459  {
 460    ADDR_T pop_sp = A68G_SP;
 461    MOID_T *m_dst = MOID (p), *src = MOID (SUB (p));
 462    GENIE_UNIT_NO_GC (SUB (p));
 463    STACK_DNS (p, MOID (SUB (p)), A68G_FP);
 464    A68G_SP = pop_sp;
 465    A68G_REF name = genie_make_ref_row_of_row (p, m_dst, src, pop_sp);
 466    PUSH_REF (p, name);
 467    return GPROP (p);
 468  }
 469  
 470  //! @brief Rowing coercion.
 471  
 472  PROP_T genie_rowing (NODE_T * p)
 473  {
 474    PROP_T self;
 475    if (IS_REF (MOID (p))) {
 476  // REF ROW, decide whether we want A->[] A or [] A->[,] A.
 477      MOID_T *mode = SUB_MOID (p);
 478      if (DIM (DEFLEX (mode)) >= 2) {
 479        (void) genie_rowing_ref_row_row (p);
 480        UNIT (&self) = genie_rowing_ref_row_row;
 481        SOURCE (&self) = p;
 482      } else {
 483        (void) genie_rowing_ref_row_of_row (p);
 484        UNIT (&self) = genie_rowing_ref_row_of_row;
 485        SOURCE (&self) = p;
 486      }
 487    } else {
 488  // ROW, decide whether we want A->[] A or [] A->[,] A.
 489      if (DIM (DEFLEX (MOID (p))) >= 2) {
 490        (void) genie_rowing_row_row (p);
 491        UNIT (&self) = genie_rowing_row_row;
 492        SOURCE (&self) = p;
 493      } else {
 494        (void) genie_rowing_row_of_row (p);
 495        UNIT (&self) = genie_rowing_row_of_row;
 496        SOURCE (&self) = p;
 497      }
 498    }
 499    return self;
 500  }
 501  
 502  //! @brief Clone a compounded value referred to by 'old'.
 503  
 504  A68G_REF genie_clone (NODE_T * p, MOID_T * m, A68G_REF * tmp, A68G_REF * old)
 505  {
 506  // This complex routine is needed as arrays are not always contiguous.
 507  // The routine takes a REF to the value and returns a REF to the clone.
 508    if (m == M_SOUND) {
 509  // REF SOUND.
 510      A68G_REF new_snd = heap_generator (p, m, SIZE (M_SOUND));
 511      A68G_SOUND *ns = DEREF (A68G_SOUND, &new_snd);
 512      A68G_SOUND *os = DEREF (A68G_SOUND, old);
 513      COPY ((BYTE_T *) ns, (BYTE_T *) os, SIZE (M_SOUND));
 514      BYTE_T *nd = ADDRESS (&(DATA (ns)));
 515      BYTE_T *od = ADDRESS (&(DATA (os)));
 516      size_t size = A68G_SOUND_DATA_SIZE (os);
 517      DATA (ns) = heap_generator (p, M_SOUND_DATA, size);
 518      COPY ((BYTE_T *) nd, (BYTE_T *) od, size);
 519      return new_snd;
 520    } else if (IS_STRUCT (m)) {
 521  // REF STRUCT.
 522      A68G_REF new_str = heap_generator (p, m, SIZE (m));
 523      for (PACK_T *field = PACK (m); field != NO_PACK; FORWARD (field)) {
 524        MOID_T *m_f = MOID (field);
 525        A68G_REF old_f = *old, new_f = new_str;
 526        OFFSET (&old_f) += OFFSET (field);
 527        OFFSET (&new_f) += OFFSET (field);
 528        A68G_REF tmp_f = *tmp;
 529        if (!IS_NIL (tmp_f)) {
 530          OFFSET (&tmp_f) += OFFSET (field);
 531        }
 532        if (HAS_ROWS (m_f)) {
 533          A68G_REF clone = genie_clone (p, m_f, &tmp_f, &old_f);
 534          MOVE (ADDRESS (&new_f), ADDRESS (&clone), SIZE (m_f));
 535        } else {
 536          MOVE (ADDRESS (&new_f), ADDRESS (&old_f), SIZE (m_f));
 537        }
 538      }
 539      return new_str;
 540    } else if (IS_UNION (m)) {
 541  // REF UNION.
 542      A68G_REF new_uni = heap_generator (p, m, SIZE (m));
 543      A68G_REF src = *old;
 544      A68G_UNION *u = DEREF (A68G_UNION, &src);
 545      MOID_T *m_u = (MOID_T *) VALUE (u);
 546      OFFSET (&src) += UNION_OFFSET;
 547      A68G_REF dst = new_uni;
 548      *DEREF (A68G_UNION, &dst) = *u;
 549      OFFSET (&dst) += UNION_OFFSET;
 550  // A union has formal members, so 'tmp' is irrelevant.
 551      A68G_REF tmp_u = nil_ref;
 552      if (m_u != NO_MOID && HAS_ROWS (m_u)) {
 553        A68G_REF clone = genie_clone (p, m_u, &tmp_u, &src);
 554        MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_u));
 555      } else if (m_u != NO_MOID) {
 556        MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (m_u));
 557      }
 558      return new_uni;
 559    } else if (IS_FLEXETY_ROW (m)) {
 560  // REF [FLEX] [].
 561      MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
 562  // Make new array.
 563      A68G_ARRAY *old_arr; A68G_TUPLE *old_tup;
 564      GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68G_REF, old));
 565      A68G_ARRAY *new_arr; A68G_TUPLE *new_tup;
 566      A68G_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 = A68G_FALSE;
 576      A68G_REF ntmp; A68G_ARRAY *tarr; A68G_TUPLE *ttup = NO_TUPLE;
 577      if (IS_NIL (*tmp)) {
 578        ntmp = nil_ref;
 579      } else {
 580        A68G_REF *z = DEREF (A68G_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        A68G_TUPLE *op = &old_tup[k], *np = &new_tup[k];
 590        if (check_bounds) {
 591          A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
 595              exit_genie (p, A68G_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_2 (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          A68G_REF old_ref, dst_ref, 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          clone = genie_clone (p, em, &ntmp, &old_ref);
 622          MOVE (ADDRESS (&dst_ref), ADDRESS (&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 = A68G_FALSE;
 629        while (!done) {
 630          A68G_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            A68G_REF clone;
 637            clone = genie_clone (p, em, &ntmp, &old_ref);
 638            MOVE (ADDRESS (&dst_ref), ADDRESS (&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      A68G_REF heap = heap_generator (p, m, A68G_REF_SIZE);
 647      *DEREF (A68G_REF, &heap) = nrow;
 648      return heap;
 649    }
 650    return nil_ref;
 651  }
 652  
 653  //! @brief Store into a row, fi. trimmed destinations.
 654  
 655  A68G_REF genie_store (NODE_T * p, MOID_T * m, A68G_REF * dst, A68G_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 (IS_FLEXETY_ROW (m)) {
 660  // REF [FLEX] [].
 661      A68G_TUPLE *old_tup, *new_tup, *old_p, *new_p;
 662      MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
 663      BOOL_T done = A68G_FALSE;
 664      A68G_ARRAY *old_arr, *new_arr;
 665      GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68G_REF, old));
 666      GET_DESCRIPTOR (new_arr, new_tup, DEREF (A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
 676            exit_genie (p, A68G_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          for (int k = 0; k < DIM (old_arr); k++) {
 689            new_tup[k] = old_tup[k];
 690          }
 691          ARRAY (new_arr) = heap_generator_2 (p, em, span, ELEM_SIZE (new_arr));
 692        }
 693      } 
 694      if (span > 0) {
 695        initialise_internal_index (old_tup, DIM (old_arr));
 696        initialise_internal_index (new_tup, DIM (new_arr));
 697        while (!done) {
 698          A68G_REF new_old = ARRAY (old_arr), new_dst = ARRAY (new_arr);
 699          ADDR_T old_index = calculate_internal_index (old_tup, DIM (old_arr));
 700          ADDR_T new_index = calculate_internal_index (new_tup, DIM (new_arr));
 701          OFFSET (&new_old) += ROW_ELEMENT (old_arr, old_index);
 702          OFFSET (&new_dst) += ROW_ELEMENT (new_arr, new_index);
 703          MOVE (ADDRESS (&new_dst), ADDRESS (&new_old), SIZE (em));
 704          done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
 705        }
 706      }
 707      return *dst;
 708    }
 709    return nil_ref;
 710  }
 711  
 712  //! @brief Assignment of complex objects in the stack.
 713  
 714  void genie_clone_stack (NODE_T * p, MOID_T * srcm, A68G_REF * dst, A68G_REF * tmp)
 715  {
 716  // STRUCT, UNION, [FLEX] [] or SOUND.
 717    A68G_REF stack;
 718    STATUS (&stack) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
 719    OFFSET (&stack) = A68G_SP;
 720    REF_HANDLE (&stack) = (A68G_HANDLE *) & nil_handle;
 721    A68G_REF *src = DEREF (A68G_REF, &stack);
 722    if (IS_ROW (srcm) && !IS_NIL (*tmp)) {
 723      if (STATUS (src) & SKIP_ROW_MASK) {
 724        return;
 725      }
 726      A68G_REF clone = genie_clone (p, srcm, tmp, &stack);
 727      (void) genie_store (p, srcm, dst, &clone);
 728    } else {
 729      A68G_REF clone = genie_clone (p, srcm, tmp, &stack);
 730      MOVE (ADDRESS (dst), ADDRESS (&clone), SIZE (srcm));
 731    }
 732  }
 733  
 734  //! @brief Strcmp for qsort.
 735  
 736  int qstrcmp (const void *a, const void *b)
 737  {
 738    return strcmp (*(char *const *) a, *(char *const *) b);
 739  }
 740  
 741  //! @brief Sort row of string.
 742  
 743  void genie_sort_row_string (NODE_T * p)
 744  {
 745    A68G_REF z; A68G_ARRAY *arr; A68G_TUPLE *tup;
 746    POP_REF (p, &z);
 747    ADDR_T pop_sp = A68G_SP;
 748    CHECK_REF (p, z, M_ROW_STRING);
 749    GET_DESCRIPTOR (arr, tup, &z);
 750    size_t size = ROW_SIZE (tup);
 751    if (size > 0) {
 752      BYTE_T *base = ADDRESS (&ARRAY (arr));
 753      char **ptrs = (char **) a68g_alloc ((size_t) (size * (int) sizeof (char *)), __func__, __LINE__);
 754      if (ptrs == NO_REF) {
 755        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 756        exit_genie (p, A68G_RUNTIME_ERROR);
 757      }
 758  // Copy C-strings into the stack and sort.
 759      for (int j = 0, k = LWB (tup); k <= UPB (tup); j++, k++) {
 760        int addr = INDEX_1_DIM (arr, tup, k);
 761        A68G_REF ref = *(A68G_REF *) & (base[addr]);
 762        CHECK_REF (p, ref, M_STRING);
 763        int len = A68G_ALIGN (a68g_string_size (p, ref) + 1);
 764        if (A68G_SP + len > A68G (expr_stack_limit)) {
 765          diagnostic (A68G_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);
 766          exit_genie (p, A68G_RUNTIME_ERROR);
 767        }
 768        ptrs[j] = (char *) STACK_TOP;
 769        ASSERT (a_to_c_string (p, (char *) STACK_TOP, ref) != NO_TEXT);
 770        INCREMENT_STACK_POINTER (p, len);
 771      }
 772      qsort (ptrs, (size_t) size, sizeof (char *), qstrcmp);
 773  // Construct an array of sorted strings.
 774      A68G_REF row; A68G_ARRAY arrn; A68G_TUPLE tupn;
 775      NEW_ROW_1D (z, row, arrn, tupn, M_ROW_STRING, M_STRING, size);
 776      A68G_REF *base_ref = DEREF (A68G_REF, &row);
 777      for (int k = 0; k < size; k++) {
 778        base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH);
 779      }
 780      a68g_free (ptrs);
 781      A68G_SP = pop_sp;
 782      PUSH_REF (p, z);
 783    } else {
 784  // This is how we sort an empty row of strings ...
 785      A68G_SP = pop_sp;
 786      PUSH_REF (p, empty_row (p, M_ROW_STRING));
 787    }
 788  }
     


© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)