genie-coerce.c

     
   1  //! @file genie-coerce.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 mode coercion routines.
  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  //! @brief Unite value in the stack and push result.
  36  
  37  PROP_T genie_uniting (NODE_T * p)
  38  {
  39    PROP_T self;
  40    ADDR_T sp = A68_SP;
  41    MOID_T *u = MOID (p), *v = MOID (SUB (p));
  42    int size = SIZE (u);
  43    if (ATTRIBUTE (v) != UNION_SYMBOL) {
  44      MOID_T *w = unites_to (v, u);
  45      PUSH_UNION (p, (void *) w);
  46      EXECUTE_UNIT (SUB (p));
  47      STACK_DNS (p, SUB (v), A68_FP);
  48    } else {
  49      A68_UNION *m = (A68_UNION *) STACK_TOP;
  50      EXECUTE_UNIT (SUB (p));
  51      STACK_DNS (p, SUB (v), A68_FP);
  52      VALUE (m) = (void *) unites_to ((MOID_T *) VALUE (m), u);
  53    }
  54    A68_SP = sp + size;
  55    UNIT (&self) = genie_uniting;
  56    SOURCE (&self) = p;
  57    return self;
  58  }
  59  
  60  //! @brief Store widened constant as a constant.
  61  
  62  void make_constant_widening (NODE_T * p, MOID_T * m, PROP_T * self)
  63  {
  64    if (SUB (p) != NO_NODE && CONSTANT (GINFO (SUB (p))) != NO_CONSTANT) {
  65      int size = SIZE (m);
  66      UNIT (self) = genie_constant;
  67      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
  68      SIZE (GINFO (p)) = size;
  69      COPY (CONSTANT (GINFO (p)), (void *) (STACK_OFFSET (-size)), size);
  70    }
  71  }
  72  
  73  //! @brief (optimised) push INT widened to REAL
  74  
  75  PROP_T genie_widen_int_to_real (NODE_T * p)
  76  {
  77    A68_INT *i = (A68_INT *) STACK_TOP;
  78    A68_REAL *z = (A68_REAL *) STACK_TOP;
  79    EXECUTE_UNIT (SUB (p));
  80    INCREMENT_STACK_POINTER (p, SIZE_ALIGNED (A68_REAL) - SIZE (M_INT));
  81    VALUE (z) = (REAL_T) VALUE (i);
  82    STATUS (z) = INIT_MASK;
  83    return GPROP (p);
  84  }
  85  
  86  //! @brief Widen value in the stack.
  87  
  88  PROP_T genie_widen (NODE_T * p)
  89  {
  90  #define COERCE_FROM_TO(p, a, b) (MOID (p) == (b) && MOID (SUB (p)) == (a))
  91    PROP_T self;
  92    UNIT (&self) = genie_widen;
  93    SOURCE (&self) = p;
  94  // INT widenings.
  95    if (COERCE_FROM_TO (p, M_INT, M_REAL)) {
  96      (void) genie_widen_int_to_real (p);
  97      UNIT (&self) = genie_widen_int_to_real;
  98      make_constant_widening (p, M_REAL, &self);
  99    } else if (COERCE_FROM_TO (p, M_INT, M_LONG_INT)) {
 100      EXECUTE_UNIT (SUB (p));
 101  #if (A68_LEVEL >= 3)
 102      genie_lengthen_int_to_double_int (p);
 103  #else
 104      genie_lengthen_int_to_mp (p);
 105  #endif
 106      make_constant_widening (p, M_LONG_INT, &self);
 107    } else if (COERCE_FROM_TO (p, M_LONG_INT, M_LONG_LONG_INT)) {
 108      EXECUTE_UNIT (SUB (p));
 109  #if (A68_LEVEL >= 3)
 110      genie_lengthen_double_int_to_mp (p);
 111  #else
 112      genie_lengthen_mp_to_long_mp (p);
 113  #endif
 114      make_constant_widening (p, M_LONG_LONG_INT, &self);
 115    } else if (COERCE_FROM_TO (p, M_LONG_INT, M_LONG_REAL)) {
 116  #if (A68_LEVEL >= 3)
 117      (void) genie_widen_double_int_to_double_real (p);
 118  #else
 119  // 1-1 mapping.
 120      EXECUTE_UNIT (SUB (p));
 121  #endif
 122      make_constant_widening (p, M_LONG_REAL, &self);
 123    } else if (COERCE_FROM_TO (p, M_LONG_LONG_INT, M_LONG_LONG_REAL)) {
 124      EXECUTE_UNIT (SUB (p));
 125  // 1-1 mapping.
 126      make_constant_widening (p, M_LONG_LONG_REAL, &self);
 127    }
 128  // REAL widenings.
 129    else if (COERCE_FROM_TO (p, M_REAL, M_LONG_REAL)) {
 130      EXECUTE_UNIT (SUB (p));
 131  #if (A68_LEVEL >= 3)
 132      genie_lengthen_real_to_double_real (p);
 133  #else
 134      genie_lengthen_real_to_mp (p);
 135  #endif
 136      make_constant_widening (p, M_LONG_REAL, &self);
 137    } else if (COERCE_FROM_TO (p, M_LONG_REAL, M_LONG_LONG_REAL)) {
 138      EXECUTE_UNIT (SUB (p));
 139  #if (A68_LEVEL >= 3)
 140      genie_lengthen_double_real_to_mp (p);
 141  #else
 142      genie_lengthen_mp_to_long_mp (p);
 143  #endif
 144      make_constant_widening (p, M_LONG_LONG_REAL, &self);
 145    } else if (COERCE_FROM_TO (p, M_REAL, M_COMPLEX)) {
 146      EXECUTE_UNIT (SUB (p));
 147      PUSH_VALUE (p, 0.0, A68_REAL);
 148      make_constant_widening (p, M_COMPLEX, &self);
 149    } else if (COERCE_FROM_TO (p, M_LONG_REAL, M_LONG_COMPLEX)) {
 150  #if (A68_LEVEL >= 3)
 151      DOUBLE_NUM_T z;
 152      z.f = 0.0q;
 153      EXECUTE_UNIT (SUB (p));
 154      PUSH_VALUE (p, z, A68_LONG_REAL);
 155  #else
 156      EXECUTE_UNIT (SUB (p));
 157      (void) nil_mp (p, DIGITS (M_LONG_REAL));
 158      make_constant_widening (p, M_LONG_COMPLEX, &self);
 159  #endif
 160    } else if (COERCE_FROM_TO (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX)) {
 161      EXECUTE_UNIT (SUB (p));
 162      (void) nil_mp (p, DIGITS (M_LONG_LONG_REAL));
 163      make_constant_widening (p, M_LONG_LONG_COMPLEX, &self);
 164    } else if (COERCE_FROM_TO (p, M_COMPLEX, M_LONG_COMPLEX)) {
 165  // COMPLEX widenings.
 166      EXECUTE_UNIT (SUB (p));
 167  #if (A68_LEVEL >= 3)
 168      genie_lengthen_complex_to_double_compl (p);
 169  #else
 170      genie_lengthen_complex_to_mp_complex (p);
 171  #endif
 172      make_constant_widening (p, M_LONG_COMPLEX, &self);
 173    } else if (COERCE_FROM_TO (p, M_LONG_COMPLEX, M_LONG_LONG_COMPLEX)) {
 174      EXECUTE_UNIT (SUB (p));
 175  #if (A68_LEVEL >= 3)
 176      genie_lengthen_double_compl_to_long_mp_complex (p);
 177  #else
 178      genie_lengthen_mp_complex_to_long_mp_complex (p);
 179  #endif
 180      make_constant_widening (p, M_LONG_LONG_COMPLEX, &self);
 181    } else if (COERCE_FROM_TO (p, M_BITS, M_LONG_BITS)) {
 182  // BITS widenings.
 183      EXECUTE_UNIT (SUB (p));
 184  #if (A68_LEVEL >= 3)
 185      genie_lengthen_bits_to_double_bits (p);
 186  #else
 187      genie_lengthen_int_to_mp (p);
 188  #endif
 189      make_constant_widening (p, M_LONG_BITS, &self);
 190    } else if (COERCE_FROM_TO (p, M_LONG_BITS, M_LONG_LONG_BITS)) {
 191  #if (A68_LEVEL >= 3)
 192      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 193  #else
 194      EXECUTE_UNIT (SUB (p));
 195      genie_lengthen_mp_to_long_mp (p);
 196      make_constant_widening (p, M_LONG_LONG_BITS, &self);
 197  #endif
 198    } else if (COERCE_FROM_TO (p, M_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_BITS, M_FLEX_ROW_BOOL)) {
 199      A68_BITS x;
 200      A68_REF z, row;
 201      A68_ARRAY arr;
 202      A68_TUPLE tup;
 203      int k;
 204      UNSIGNED_T bit;
 205      BYTE_T *base;
 206      EXECUTE_UNIT (SUB (p));
 207      POP_OBJECT (p, &x, A68_BITS);
 208      NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, BITS_WIDTH);
 209      base = ADDRESS (&row) + SIZE (M_BOOL) * (BITS_WIDTH - 1);
 210      bit = 1;
 211      for (k = BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) {
 212        STATUS ((A68_BOOL *) base) = INIT_MASK;
 213        VALUE ((A68_BOOL *) base) = (BOOL_T) ((VALUE (&x) & bit) != 0 ? A68_TRUE : A68_FALSE);
 214      }
 215      PUSH_REF (p, z);
 216    } else if (COERCE_FROM_TO (p, M_LONG_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_LONG_BITS, M_FLEX_ROW_BOOL)) {
 217  #if (A68_LEVEL >= 3)
 218      A68_LONG_BITS x;
 219      A68_REF z, row;
 220      A68_ARRAY arr;
 221      A68_TUPLE tup;
 222      int k;
 223      UNSIGNED_T bit;
 224      BYTE_T *base;
 225      EXECUTE_UNIT (SUB (p));
 226      POP_OBJECT (p, &x, A68_LONG_BITS);
 227      NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, LONG_BITS_WIDTH);
 228      base = ADDRESS (&row) + SIZE (M_BOOL) * (LONG_BITS_WIDTH - 1);
 229      bit = 1;
 230      for (k = BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) {
 231        STATUS ((A68_BOOL *) base) = INIT_MASK;
 232        VALUE ((A68_BOOL *) base) = (BOOL_T) ((LW (VALUE (&x)) & bit) != 0 ? A68_TRUE : A68_FALSE);
 233      }
 234      bit = 1;
 235      for (k = BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) {
 236        STATUS ((A68_BOOL *) base) = INIT_MASK;
 237        VALUE ((A68_BOOL *) base) = (BOOL_T) ((HW (VALUE (&x)) & bit) != 0 ? A68_TRUE : A68_FALSE);
 238      }
 239      PUSH_REF (p, z);
 240  #else
 241      EXECUTE_UNIT (SUB (p));
 242      genie_lengthen_long_bits_to_row_bool (p);
 243  #endif
 244    } else if (COERCE_FROM_TO (p, M_LONG_LONG_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_LONG_LONG_BITS, M_FLEX_ROW_BOOL)) {
 245  #if (A68_LEVEL <= 2)
 246      EXECUTE_UNIT (SUB (p));
 247      genie_lengthen_long_bits_to_row_bool (p);
 248  #endif
 249    } else if (COERCE_FROM_TO (p, M_BYTES, M_ROW_CHAR) || COERCE_FROM_TO (p, M_BYTES, M_FLEX_ROW_CHAR)) {
 250      A68_BYTES z;
 251      EXECUTE_UNIT (SUB (p));
 252      POP_OBJECT (p, &z, A68_BYTES);
 253      PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), BYTES_WIDTH));
 254    } else if (COERCE_FROM_TO (p, M_LONG_BYTES, M_ROW_CHAR) || COERCE_FROM_TO (p, M_LONG_BYTES, M_FLEX_ROW_CHAR)) {
 255      A68_LONG_BYTES z;
 256      EXECUTE_UNIT (SUB (p));
 257      POP_OBJECT (p, &z, A68_LONG_BYTES);
 258      PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), LONG_BYTES_WIDTH));
 259    } else {
 260      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CANNOT_WIDEN, MOID (SUB (p)), MOID (p));
 261      exit_genie (p, A68_RUNTIME_ERROR);
 262    }
 263    return self;
 264  #undef COERCE_FROM_TO
 265  }
 266  
 267  //! @brief Cast a jump to a PROC VOID without executing the jump.
 268  
 269  void genie_proceduring (NODE_T * p)
 270  {
 271    A68_PROCEDURE z;
 272    NODE_T *jump = SUB (p);
 273    NODE_T *q = SUB (jump);
 274    NODE_T *label = (IS (q, GOTO_SYMBOL) ? NEXT (q) : q);
 275    STATUS (&z) = INIT_MASK;
 276    NODE (&(BODY (&z))) = jump;
 277    STATIC_LINK_FOR_FRAME (ENVIRON (&z), 1 + TAG_LEX_LEVEL (TAX (label)));
 278    LOCALE (&z) = NO_HANDLE;
 279    MOID (&z) = M_PROC_VOID;
 280    PUSH_PROCEDURE (p, z);
 281  }
 282  
 283  //! @brief (optimised) dereference value of a unit
 284  
 285  PROP_T genie_dereferencing_quick (NODE_T * p)
 286  {
 287    A68_REF *z = (A68_REF *) STACK_TOP;
 288    ADDR_T pop_sp = A68_SP;
 289    BYTE_T *stack_top = STACK_TOP;
 290    EXECUTE_UNIT (SUB (p));
 291    A68_SP = pop_sp;
 292    CHECK_REF (p, *z, MOID (SUB (p)));
 293    PUSH (p, ADDRESS (z), SIZE (MOID (p)));
 294    genie_check_initialisation (p, stack_top, MOID (p));
 295    return GPROP (p);
 296  }
 297  
 298  //! @brief Dereference an identifier.
 299  
 300  PROP_T genie_dereference_frame_identifier (NODE_T * p)
 301  {
 302    A68_REF *z;
 303    MOID_T *deref = SUB_MOID (p);
 304    BYTE_T *stack_top = STACK_TOP;
 305    FRAME_GET (z, A68_REF, p);
 306    PUSH (p, ADDRESS (z), SIZE (deref));
 307    genie_check_initialisation (p, stack_top, deref);
 308    return GPROP (p);
 309  }
 310  
 311  //! @brief Dereference an identifier.
 312  
 313  PROP_T genie_dereference_generic_identifier (NODE_T * p)
 314  {
 315    A68_REF *z;
 316    MOID_T *deref = SUB_MOID (p);
 317    BYTE_T *stack_top = STACK_TOP;
 318    FRAME_GET (z, A68_REF, p);
 319    CHECK_REF (p, *z, MOID (SUB (p)));
 320    PUSH (p, ADDRESS (z), SIZE (deref));
 321    genie_check_initialisation (p, stack_top, deref);
 322    return GPROP (p);
 323  }
 324  
 325  //! @brief Slice REF [] A to A.
 326  
 327  PROP_T genie_dereference_slice_name_quick (NODE_T * p)
 328  {
 329    NODE_T *q, *prim = SUB (p);
 330    A68_ARRAY *a;
 331    A68_TUPLE *t;
 332    A68_REF *z;
 333    MOID_T *ref_mode = MOID (p);
 334    MOID_T *deref_mode = SUB (ref_mode);
 335    int size = SIZE (deref_mode), row_index;
 336    ADDR_T pop_sp = A68_SP;
 337    BYTE_T *stack_top = STACK_TOP;
 338  // Get REF [].
 339    z = (A68_REF *) STACK_TOP;
 340    EXECUTE_UNIT (prim);
 341    A68_SP = pop_sp;
 342    CHECK_REF (p, *z, ref_mode);
 343    GET_DESCRIPTOR (a, t, DEREF (A68_ROW, z));
 344    for (row_index = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) {
 345      A68_INT *j = (A68_INT *) STACK_TOP;
 346      int k;
 347      EXECUTE_UNIT (q);
 348      k = VALUE (j);
 349      if (k < LWB (t) || k > UPB (t)) {
 350        diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
 351        exit_genie (q, A68_RUNTIME_ERROR);
 352      }
 353      row_index += (SPAN (t) * k - SHIFT (t));
 354      A68_SP = pop_sp;
 355    }
 356  // Push element.
 357    PUSH (p, &((ADDRESS (&(ARRAY (a))))[ROW_ELEMENT (a, row_index)]), size);
 358    genie_check_initialisation (p, stack_top, deref_mode);
 359    return GPROP (p);
 360  }
 361  
 362  //! @brief Dereference SELECTION from a name.
 363  
 364  PROP_T genie_dereference_selection_name_quick (NODE_T * p)
 365  {
 366    NODE_T *selector = SUB (p);
 367    MOID_T *struct_mode = MOID (NEXT (selector));
 368    MOID_T *result_mode = SUB_MOID (selector);
 369    int size = SIZE (result_mode);
 370    A68_REF *z = (A68_REF *) STACK_TOP;
 371    ADDR_T pop_sp = A68_SP;
 372    BYTE_T *stack_top;
 373    EXECUTE_UNIT (NEXT (selector));
 374    CHECK_REF (selector, *z, struct_mode);
 375    OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
 376    A68_SP = pop_sp;
 377    stack_top = STACK_TOP;
 378    PUSH (p, ADDRESS (z), size);
 379    genie_check_initialisation (p, stack_top, result_mode);
 380    return GPROP (p);
 381  }
 382  
 383  //! @brief Dereference name in the stack.
 384  
 385  PROP_T genie_dereferencing (NODE_T * p)
 386  {
 387    A68_REF z;
 388    PROP_T self;
 389    EXECUTE_UNIT_2 (SUB (p), self);
 390    POP_REF (p, &z);
 391    CHECK_REF (p, z, MOID (SUB (p)));
 392    PUSH (p, ADDRESS (&z), SIZE (MOID (p)));
 393    genie_check_initialisation (p, STACK_OFFSET (-SIZE (MOID (p))), MOID (p));
 394    if (UNIT (&self) == genie_frame_identifier) {
 395      if (IS_IN_FRAME (&z)) {
 396        UNIT (&self) = genie_dereference_frame_identifier;
 397      } else {
 398        UNIT (&self) = genie_dereference_generic_identifier;
 399      }
 400      UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self);
 401    } else if (UNIT (&self) == genie_slice_name_quick) {
 402      UNIT (&self) = genie_dereference_slice_name_quick;
 403      UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self);
 404    } else if (UNIT (&self) == genie_selection_name_quick) {
 405      UNIT (&self) = genie_dereference_selection_name_quick;
 406      UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self);
 407    } else {
 408      UNIT (&self) = genie_dereferencing_quick;
 409      SOURCE (&self) = p;
 410    }
 411    return self;
 412  }
 413  
 414  //! @brief Deprocedure PROC in the stack.
 415  
 416  PROP_T genie_deproceduring (NODE_T * p)
 417  {
 418    PROP_T self;
 419    A68_PROCEDURE *z;
 420    ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
 421    NODE_T *proc = SUB (p);
 422    MOID_T *proc_mode = MOID (proc);
 423    UNIT (&self) = genie_deproceduring;
 424    SOURCE (&self) = p;
 425  // Get procedure.
 426    z = (A68_PROCEDURE *) STACK_TOP;
 427    EXECUTE_UNIT (proc);
 428    A68_SP = pop_sp;
 429    genie_check_initialisation (p, (BYTE_T *) z, proc_mode);
 430    genie_call_procedure (p, proc_mode, proc_mode, M_VOID, z, pop_sp, pop_fp);
 431    STACK_DNS (p, MOID (p), A68_FP);
 432    return self;
 433  }
 434  
 435  //! @brief Voiden value in the stack.
 436  
 437  PROP_T genie_voiding (NODE_T * p)
 438  {
 439    PROP_T self, source;
 440    ADDR_T sp_for_voiding = A68_SP;
 441    SOURCE (&self) = p;
 442    EXECUTE_UNIT_2 (SUB (p), source);
 443    A68_SP = sp_for_voiding;
 444    if (UNIT (&source) == genie_assignation_quick) {
 445      UNIT (&self) = genie_voiding_assignation;
 446      SOURCE (&self) = SOURCE (&source);
 447    } else if (UNIT (&source) == genie_assignation_constant) {
 448      UNIT (&self) = genie_voiding_assignation_constant;
 449      SOURCE (&self) = SOURCE (&source);
 450    } else {
 451      UNIT (&self) = genie_voiding;
 452    }
 453    return self;
 454  }
 455  
 456  //! @brief Coerce value in the stack.
 457  
 458  PROP_T genie_coercion (NODE_T * p)
 459  {
 460    PROP_T self;
 461    UNIT (&self) = genie_coercion;
 462    SOURCE (&self) = p;
 463    switch (ATTRIBUTE (p)) {
 464    case VOIDING:
 465      {
 466        self = genie_voiding (p);
 467        break;
 468      }
 469    case UNITING:
 470      {
 471        self = genie_uniting (p);
 472        break;
 473      }
 474    case WIDENING:
 475      {
 476        self = genie_widen (p);
 477        break;
 478      }
 479    case ROWING:
 480      {
 481        self = genie_rowing (p);
 482        break;
 483      }
 484    case DEREFERENCING:
 485      {
 486        self = genie_dereferencing (p);
 487        break;
 488      }
 489    case DEPROCEDURING:
 490      {
 491        self = genie_deproceduring (p);
 492        break;
 493      }
 494    case PROCEDURING:
 495      {
 496        genie_proceduring (p);
 497        break;
 498      }
 499    }
 500    GPROP (p) = self;
 501    return self;
 502  }