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