single.c

     
   1  //! @file single.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  //! INT, REAL, COMPLEX and BITS routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-double.h"
  30  #include "a68g-numbers.h"
  31  #include "a68g-stddef.h"
  32  
  33  // INT operations.
  34  
  35  // OP - = (INT) INT.
  36  
  37  A68_MONAD (genie_minus_int, A68_INT, -);
  38  
  39  // OP ABS = (INT) INT
  40  
  41  void genie_abs_int (NODE_T * p)
  42  {
  43    A68_INT *j;
  44    POP_OPERAND_ADDRESS (p, j, A68_INT);
  45    VALUE (j) = ABS (VALUE (j));
  46  }
  47  
  48  // OP SIGN = (INT) INT
  49  
  50  void genie_sign_int (NODE_T * p)
  51  {
  52    A68_INT *j;
  53    POP_OPERAND_ADDRESS (p, j, A68_INT);
  54    VALUE (j) = SIGN (VALUE (j));
  55  }
  56  
  57  // OP ODD = (INT) BOOL
  58  
  59  void genie_odd_int (NODE_T * p)
  60  {
  61    A68_INT j;
  62    POP_OBJECT (p, &j, A68_INT);
  63    PUSH_VALUE (p, (BOOL_T) ((VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)) % 2 == 1), A68_BOOL);
  64  }
  65  
  66  // OP + = (INT, INT) INT
  67  
  68  void genie_add_int (NODE_T * p)
  69  {
  70    A68_INT *i, *j;
  71    POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
  72    errno = 0;
  73    VALUE (i) = a68_add_int (VALUE (i), VALUE (j));
  74    MATH_RTE (p, errno != 0, M_INT, "M overflow");
  75  }
  76  
  77  // OP - = (INT, INT) INT
  78  
  79  void genie_sub_int (NODE_T * p)
  80  {
  81    A68_INT *i, *j;
  82    POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
  83    errno = 0;
  84    VALUE (i) = a68_sub_int (VALUE (i), VALUE (j));
  85    MATH_RTE (p, errno != 0, M_INT, "M overflow");
  86  }
  87  
  88  // OP * = (INT, INT) INT
  89  
  90  void genie_mul_int (NODE_T * p)
  91  {
  92    A68_INT *i, *j;
  93    POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
  94    errno = 0;
  95    VALUE (i) = a68_mul_int (VALUE (i), VALUE (j));
  96    MATH_RTE (p, errno != 0, M_INT, "M overflow");
  97  }
  98  
  99  // OP OVER = (INT, INT) INT
 100  
 101  void genie_over_int (NODE_T * p)
 102  {
 103    A68_INT *i, *j;
 104    POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
 105    errno = 0;
 106    VALUE (i) = a68_over_int (VALUE (i), VALUE (j));
 107    MATH_RTE (p, errno != 0, M_INT, ERROR_DIVISION_BY_ZERO);
 108  }
 109  
 110  // OP MOD = (INT, INT) INT
 111  
 112  void genie_mod_int (NODE_T * p)
 113  {
 114    A68_INT *i, *j;
 115    POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
 116    errno = 0;
 117    VALUE (i) = a68_mod_int (VALUE (i), VALUE (j));
 118    MATH_RTE (p, errno != 0, M_INT, ERROR_DIVISION_BY_ZERO);
 119  }
 120  
 121  // OP / = (INT, INT) REAL
 122  
 123  void genie_div_int (NODE_T * p)
 124  {
 125    A68_INT i, j;
 126    POP_OBJECT (p, &j, A68_INT);
 127    POP_OBJECT (p, &i, A68_INT);
 128    errno = 0;
 129    PUSH_VALUE (p, a68_div_int (VALUE (&i), VALUE (&j)), A68_REAL);
 130    MATH_RTE (p, errno != 0, M_INT, "M division by zero");
 131  }
 132  
 133  // OP ** = (INT, INT) INT
 134  
 135  void genie_pow_int (NODE_T * p)
 136  {
 137    A68_INT i, j;
 138    POP_OBJECT (p, &j, A68_INT);
 139    PRELUDE_ERROR (VALUE (&j) < 0, p, ERROR_EXPONENT_INVALID, M_INT);
 140    POP_OBJECT (p, &i, A68_INT);
 141    errno = 0;
 142    PUSH_VALUE (p, a68_m_up_n (VALUE (&i), VALUE (&j)), A68_INT);
 143    MATH_RTE (p, errno != 0, M_INT, "M overflow");
 144  }
 145  
 146  // OP (INT, INT) BOOL.
 147  
 148  #define A68_CMP_INT(n, OP)\
 149  void n (NODE_T * p) {\
 150    A68_INT i, j;\
 151    POP_OBJECT (p, &j, A68_INT);\
 152    POP_OBJECT (p, &i, A68_INT);\
 153    PUSH_VALUE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\
 154    }
 155  
 156  A68_CMP_INT (genie_eq_int, ==);
 157  A68_CMP_INT (genie_ne_int, !=);
 158  A68_CMP_INT (genie_lt_int, <);
 159  A68_CMP_INT (genie_gt_int, >);
 160  A68_CMP_INT (genie_le_int, <=);
 161  A68_CMP_INT (genie_ge_int, >=);
 162  
 163  // OP +:= = (REF INT, INT) REF INT
 164  
 165  void genie_plusab_int (NODE_T * p)
 166  {
 167    genie_f_and_becomes (p, M_REF_INT, genie_add_int);
 168  }
 169  
 170  // OP -:= = (REF INT, INT) REF INT
 171  
 172  void genie_minusab_int (NODE_T * p)
 173  {
 174    genie_f_and_becomes (p, M_REF_INT, genie_sub_int);
 175  }
 176  
 177  // OP *:= = (REF INT, INT) REF INT
 178  
 179  void genie_timesab_int (NODE_T * p)
 180  {
 181    genie_f_and_becomes (p, M_REF_INT, genie_mul_int);
 182  }
 183  
 184  // OP %:= = (REF INT, INT) REF INT
 185  
 186  void genie_overab_int (NODE_T * p)
 187  {
 188    genie_f_and_becomes (p, M_REF_INT, genie_over_int);
 189  }
 190  
 191  // OP %*:= = (REF INT, INT) REF INT
 192  
 193  void genie_modab_int (NODE_T * p)
 194  {
 195    genie_f_and_becomes (p, M_REF_INT, genie_mod_int);
 196  }
 197  
 198  // REAL operations.
 199  
 200  // OP - = (REAL) REAL.
 201  
 202  A68_MONAD (genie_minus_real, A68_REAL, -);
 203  
 204  // OP ABS = (REAL) REAL
 205  
 206  void genie_abs_real (NODE_T * p)
 207  {
 208    A68_REAL *x;
 209    POP_OPERAND_ADDRESS (p, x, A68_REAL);
 210    VALUE (x) = ABS (VALUE (x));
 211  }
 212  
 213  // OP ROUND = (REAL) INT
 214  
 215  void genie_round_real (NODE_T * p)
 216  {
 217    A68_REAL x;
 218    POP_OBJECT (p, &x, A68_REAL);
 219    PRELUDE_ERROR (VALUE (&x) < -(REAL_T) A68_MAX_INT || VALUE (&x) > (REAL_T) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, M_INT);
 220    PUSH_VALUE (p, a68_round (VALUE (&x)), A68_INT);
 221  }
 222  
 223  // OP ENTIER = (REAL) INT
 224  
 225  void genie_entier_real (NODE_T * p)
 226  {
 227    A68_REAL x;
 228    POP_OBJECT (p, &x, A68_REAL);
 229    PRELUDE_ERROR (VALUE (&x) < -(REAL_T) A68_MAX_INT || VALUE (&x) > (REAL_T) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, M_INT);
 230    PUSH_VALUE (p, (INT_T) floor (VALUE (&x)), A68_INT);
 231  }
 232  
 233  // OP SIGN = (REAL) INT
 234  
 235  void genie_sign_real (NODE_T * p)
 236  {
 237    A68_REAL x;
 238    POP_OBJECT (p, &x, A68_REAL);
 239    PUSH_VALUE (p, SIGN (VALUE (&x)), A68_INT);
 240  }
 241  
 242  // OP + = (REAL, REAL) REAL
 243  
 244  void genie_add_real (NODE_T * p)
 245  {
 246    A68_REAL *x, *y;
 247    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
 248    VALUE (x) += VALUE (y);
 249    CHECK_REAL (p, VALUE (x));
 250  }
 251  
 252  // OP - = (REAL, REAL) REAL
 253  
 254  void genie_sub_real (NODE_T * p)
 255  {
 256    A68_REAL *x, *y;
 257    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
 258    VALUE (x) -= VALUE (y);
 259    CHECK_REAL (p, VALUE (x));
 260  }
 261  
 262  // OP * = (REAL, REAL) REAL
 263  
 264  void genie_mul_real (NODE_T * p)
 265  {
 266    A68_REAL *x, *y;
 267    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
 268    VALUE (x) *= VALUE (y);
 269    CHECK_REAL (p, VALUE (x));
 270  }
 271  
 272  // OP / = (REAL, REAL) REAL
 273  
 274  void genie_div_real (NODE_T * p)
 275  {
 276    A68_REAL *x, *y;
 277    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
 278    PRELUDE_ERROR (VALUE (y) == 0.0, p, ERROR_DIVISION_BY_ZERO, M_REAL);
 279    VALUE (x) /= VALUE (y);
 280  }
 281  
 282  // OP ** = (REAL, INT) REAL
 283  
 284  void genie_pow_real_int (NODE_T * p)
 285  {
 286    A68_INT j;
 287    A68_REAL x;
 288    REAL_T z;
 289    POP_OBJECT (p, &j, A68_INT);
 290    POP_OBJECT (p, &x, A68_REAL);
 291    z = a68_x_up_n (VALUE (&x), VALUE (&j));
 292    CHECK_REAL (p, z);
 293    PUSH_VALUE (p, z, A68_REAL);
 294  }
 295  
 296  // OP ** = (REAL, REAL) REAL
 297  
 298  void genie_pow_real (NODE_T * p)
 299  {
 300    A68_REAL x, y;
 301    REAL_T z = 0;
 302    POP_OBJECT (p, &y, A68_REAL);
 303    POP_OBJECT (p, &x, A68_REAL);
 304    errno = 0;
 305    z = a68_x_up_y (VALUE (&x), VALUE (&y));
 306    MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);
 307    PUSH_VALUE (p, z, A68_REAL);
 308  }
 309  
 310  // OP (REAL, REAL) BOOL.
 311  
 312  #define A68_CMP_REAL(n, OP)\
 313  void n (NODE_T * p) {\
 314    A68_REAL i, j;\
 315    POP_OBJECT (p, &j, A68_REAL);\
 316    POP_OBJECT (p, &i, A68_REAL);\
 317    PUSH_VALUE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\
 318    }
 319  
 320  A68_CMP_REAL (genie_eq_real, ==);
 321  A68_CMP_REAL (genie_ne_real, !=);
 322  A68_CMP_REAL (genie_lt_real, <);
 323  A68_CMP_REAL (genie_gt_real, >);
 324  A68_CMP_REAL (genie_le_real, <=);
 325  A68_CMP_REAL (genie_ge_real, >=);
 326  
 327  // OP +:= = (REF REAL, REAL) REF REAL
 328  
 329  void genie_plusab_real (NODE_T * p)
 330  {
 331    genie_f_and_becomes (p, M_REF_REAL, genie_add_real);
 332  }
 333  
 334  // OP -:= = (REF REAL, REAL) REF REAL
 335  
 336  void genie_minusab_real (NODE_T * p)
 337  {
 338    genie_f_and_becomes (p, M_REF_REAL, genie_sub_real);
 339  }
 340  
 341  // OP *:= = (REF REAL, REAL) REF REAL
 342  
 343  void genie_timesab_real (NODE_T * p)
 344  {
 345    genie_f_and_becomes (p, M_REF_REAL, genie_mul_real);
 346  }
 347  
 348  // OP /:= = (REF REAL, REAL) REF REAL
 349  
 350  void genie_divab_real (NODE_T * p)
 351  {
 352    genie_f_and_becomes (p, M_REF_REAL, genie_div_real);
 353  }
 354  
 355  // @brief PROC (INT) VOID first random
 356  
 357  void genie_first_random (NODE_T * p)
 358  {
 359    A68_INT i;
 360    POP_OBJECT (p, &i, A68_INT);
 361    init_rng ((unt) VALUE (&i));
 362  }
 363  
 364  // @brief PROC REAL next random
 365  
 366  void genie_next_random (NODE_T * p)
 367  {
 368    PUSH_VALUE (p, a68_unif_rand (), A68_REAL);
 369  }
 370  
 371  // @brief PROC REAL rnd
 372  
 373  void genie_next_rnd (NODE_T * p)
 374  {
 375    PUSH_VALUE (p, 2 * a68_unif_rand () - 1, A68_REAL);
 376  }
 377  
 378  // BITS operations.
 379  
 380  // BITS max bits
 381  
 382  void genie_max_bits (NODE_T * p)
 383  {
 384    PUSH_VALUE (p, A68_MAX_BITS, A68_BITS);
 385  }
 386  
 387  // OP NOT = (BITS) BITS.
 388  A68_MONAD (genie_not_bits, A68_BITS, ~);
 389  
 390  // OP AND = (BITS, BITS) BITS
 391  
 392  void genie_and_bits (NODE_T * p)
 393  {
 394    A68_BITS *i, *j;
 395    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 396    VALUE (i) = VALUE (i) & VALUE (j);
 397  }
 398  
 399  // OP OR = (BITS, BITS) BITS
 400  
 401  void genie_or_bits (NODE_T * p)
 402  {
 403    A68_BITS *i, *j;
 404    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 405    VALUE (i) = VALUE (i) | VALUE (j);
 406  }
 407  
 408  // OP XOR = (BITS, BITS) BITS
 409  
 410  void genie_xor_bits (NODE_T * p)
 411  {
 412    A68_BITS *i, *j;
 413    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 414    VALUE (i) = VALUE (i) ^ VALUE (j);
 415  }
 416  
 417  // OP + = (BITS, BITS) BITS
 418  
 419  void genie_add_bits (NODE_T * p)
 420  {
 421    A68_BITS *i, *j;
 422    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 423    CHECK_BITS_ADDITION (p, VALUE (i), VALUE (j));
 424    VALUE (i) = VALUE (i) + VALUE (j);
 425  }
 426  
 427  // OP - = (BITS, BITS) BITS
 428  
 429  void genie_sub_bits (NODE_T * p)
 430  {
 431    A68_BITS *i, *j;
 432    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 433    CHECK_BITS_SUBTRACTION (p, VALUE (i), VALUE (j));
 434    VALUE (i) = VALUE (i) - VALUE (j);
 435  }
 436  
 437  // OP * = (BITS, BITS) BITS
 438  
 439  void genie_times_bits (NODE_T * p)
 440  {
 441    A68_BITS *i, *j;
 442    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 443    CHECK_BITS_MULTIPLICATION (p, VALUE (i), VALUE (j));
 444    VALUE (i) = VALUE (i) * VALUE (j);
 445  }
 446  
 447  // OP OVER = (BITS, BITS) BITS
 448  
 449  void genie_over_bits (NODE_T * p)
 450  {
 451    A68_BITS *i, *j;
 452    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 453    PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, M_BITS);
 454    VALUE (i) = VALUE (i) / VALUE (j);
 455  }
 456  
 457  // OP MOD = (BITS, BITS) BITS
 458  
 459  void genie_mod_bits (NODE_T * p)
 460  {
 461    A68_BITS *i, *j;
 462    POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
 463    PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, M_BITS);
 464    VALUE (i) = VALUE (i) % VALUE (j);
 465  }
 466  
 467  // OP = = (BITS, BITS) BOOL.
 468  
 469  #define A68_CMP_BITS(n, OP)\
 470  void n (NODE_T * p) {\
 471    A68_BITS i, j;\
 472    POP_OBJECT (p, &j, A68_BITS);\
 473    POP_OBJECT (p, &i, A68_BITS);\
 474    PUSH_VALUE (p, (BOOL_T) ((UNSIGNED_T) VALUE (&i) OP (UNSIGNED_T) VALUE (&j)), A68_BOOL);\
 475    }
 476  
 477  A68_CMP_BITS (genie_eq_bits, ==);
 478  A68_CMP_BITS (genie_ne_bits, !=);
 479  
 480  // OP <= = (BITS, BITS) BOOL
 481  
 482  void genie_le_bits (NODE_T * p)
 483  {
 484    A68_BITS i, j;
 485    POP_OBJECT (p, &j, A68_BITS);
 486    POP_OBJECT (p, &i, A68_BITS);
 487    PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL);
 488  }
 489  
 490  // OP >= = (BITS, BITS) BOOL
 491  
 492  void genie_ge_bits (NODE_T * p)
 493  {
 494    A68_BITS i, j;
 495    POP_OBJECT (p, &j, A68_BITS);
 496    POP_OBJECT (p, &i, A68_BITS);
 497    PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL);
 498  }
 499  
 500  #if (A68_LEVEL >= 3)
 501  
 502  // OP < = (BITS, BITS) BOOL
 503  
 504  void genie_lt_bits (NODE_T * p)
 505  {
 506    A68_BITS i, j;
 507    POP_OBJECT (p, &j, A68_BITS);
 508    POP_OBJECT (p, &i, A68_BITS);
 509    if (VALUE (&i) == VALUE (&j)) {
 510      PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 511    } else {
 512      PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL);
 513    }
 514  }
 515  
 516  // OP >= = (BITS, BITS) BOOL
 517  
 518  void genie_gt_bits (NODE_T * p)
 519  {
 520    A68_BITS i, j;
 521    POP_OBJECT (p, &j, A68_BITS);
 522    POP_OBJECT (p, &i, A68_BITS);
 523    if (VALUE (&i) == VALUE (&j)) {
 524      PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 525    } else {
 526      PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL);
 527    }
 528  }
 529  
 530  #endif
 531  
 532  // OP SHL = (BITS, INT) BITS
 533  
 534  void genie_shl_bits (NODE_T * p)
 535  {
 536    A68_BITS i;
 537    A68_INT j;
 538    POP_OBJECT (p, &j, A68_INT);
 539    POP_OBJECT (p, &i, A68_BITS);
 540    if (VALUE (&j) >= 0) {
 541      int k;
 542      UNSIGNED_T z = VALUE (&i);
 543      for (k = 0; k < VALUE (&j); k++) {
 544        PRELUDE_ERROR (!MODULAR_MATH (p) && (z & D_SIGN), p, ERROR_MATH, M_BITS);
 545        z = z << 1;
 546      }
 547      PUSH_VALUE (p, z, A68_BITS);
 548    } else {
 549      PUSH_VALUE (p, VALUE (&i) >> -VALUE (&j), A68_BITS);
 550    }
 551  }
 552  
 553  // OP SHR = (BITS, INT) BITS
 554  
 555  void genie_shr_bits (NODE_T * p)
 556  {
 557    A68_INT *j;
 558    POP_OPERAND_ADDRESS (p, j, A68_INT);
 559    VALUE (j) = -VALUE (j);
 560    genie_shl_bits (p);           // Conform RR
 561  }
 562  
 563  // OP ROL = (BITS, INT) BITS
 564  
 565  void genie_rol_bits (NODE_T * p)
 566  {
 567    A68_BITS i;
 568    A68_INT j;
 569    int k, n;
 570    UNSIGNED_T w;
 571    POP_OBJECT (p, &j, A68_INT);
 572    POP_OBJECT (p, &i, A68_BITS);
 573    CHECK_INT_SHORTEN (p, VALUE (&j));
 574    w = VALUE (&i);
 575    n = VALUE (&j);
 576    if (n >= 0) {
 577      for (k = 0; k < n; k++) {
 578        UNSIGNED_T carry = (w & D_SIGN ? 0x1 : 0x0);
 579        w = (w << 1) | carry;
 580      }
 581    } else {
 582      n = -n;
 583      for (k = 0; k < n; k++) {
 584        UNSIGNED_T carry = (w & 0x1 ? D_SIGN : 0x0);
 585        w = (w >> 1) | carry;
 586      }
 587    }
 588    PUSH_VALUE (p, w, A68_BITS);
 589  }
 590  
 591  // OP ROR = (BITS, INT) BITS
 592  
 593  void genie_ror_bits (NODE_T * p)
 594  {
 595    A68_INT *j;
 596    POP_OPERAND_ADDRESS (p, j, A68_INT);
 597    VALUE (j) = -VALUE (j);
 598    genie_rol_bits (p);
 599  }
 600  
 601  // OP ELEM = (INT, BITS) BOOL
 602  
 603  void genie_elem_bits (NODE_T * p)
 604  {
 605    A68_BITS j;
 606    A68_INT i;
 607    int n;
 608    UNSIGNED_T mask = 0x1;
 609    POP_OBJECT (p, &j, A68_BITS);
 610    POP_OBJECT (p, &i, A68_INT);
 611    PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
 612    for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
 613      mask = mask << 1;
 614    }
 615    PUSH_VALUE (p, (BOOL_T) ((VALUE (&j) & mask) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
 616  }
 617  
 618  // OP SET = (INT, BITS) BITS
 619  
 620  void genie_set_bits (NODE_T * p)
 621  {
 622    A68_BITS j;
 623    A68_INT i;
 624    int n;
 625    UNSIGNED_T mask = 0x1;
 626    POP_OBJECT (p, &j, A68_BITS);
 627    POP_OBJECT (p, &i, A68_INT);
 628    PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
 629    for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
 630      mask = mask << 1;
 631    }
 632    PUSH_VALUE (p, VALUE (&j) | mask, A68_BITS);
 633  }
 634  
 635  // OP CLEAR = (INT, BITS) BITS
 636  
 637  void genie_clear_bits (NODE_T * p)
 638  {
 639    A68_BITS j;
 640    A68_INT i;
 641    int n;
 642    UNSIGNED_T mask = 0x1;
 643    POP_OBJECT (p, &j, A68_BITS);
 644    POP_OBJECT (p, &i, A68_INT);
 645    PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
 646    for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
 647      mask = mask << 1;
 648    }
 649    PUSH_VALUE (p, VALUE (&j) & ~mask, A68_BITS);
 650  }
 651  
 652  // OP ABS = (BITS) INT
 653  
 654  void genie_abs_bits (NODE_T * p)
 655  {
 656    A68_BITS i;
 657    POP_OBJECT (p, &i, A68_BITS);
 658    PUSH_VALUE (p, (INT_T) (VALUE (&i)), A68_INT);
 659  }
 660  
 661  // OP BIN = (INT) BITS
 662  
 663  void genie_bin_int (NODE_T * p)
 664  {
 665    A68_INT i;
 666    POP_OBJECT (p, &i, A68_INT);
 667    if (!MODULAR_MATH (p) && VALUE (&i) < 0) {
 668  // RR does not convert negative numbers.
 669      errno = EDOM;
 670      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS);
 671      exit_genie (p, A68_RUNTIME_ERROR);
 672    }
 673    PUSH_VALUE (p, (UNSIGNED_T) (VALUE (&i)), A68_BITS);
 674  }
 675  
 676  // @brief PROC ([] BOOL) BITS bits pack
 677  
 678  void genie_bits_pack (NODE_T * p)
 679  {
 680    A68_REF z;
 681    A68_BITS b;
 682    A68_ARRAY *arr;
 683    A68_TUPLE *tup;
 684    BYTE_T *base;
 685    int size, k;
 686    UNSIGNED_T bit;
 687    POP_REF (p, &z);
 688    CHECK_REF (p, z, M_ROW_BOOL);
 689    GET_DESCRIPTOR (arr, tup, &z);
 690    size = ROW_SIZE (tup);
 691    PRELUDE_ERROR (size < 0 || size > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_ROW_BOOL);
 692    VALUE (&b) = 0x0;
 693    if (ROW_SIZE (tup) > 0) {
 694      base = DEREF (BYTE_T, &ARRAY (arr));
 695      bit = 0x1;
 696      for (k = UPB (tup); k >= LWB (tup); k--) {
 697        int addr = INDEX_1_DIM (arr, tup, k);
 698        A68_BOOL *boo = (A68_BOOL *) & (base[addr]);
 699        CHECK_INIT (p, INITIALISED (boo), M_BOOL);
 700        if (VALUE (boo)) {
 701          VALUE (&b) |= bit;
 702        }
 703        bit <<= 1;
 704      }
 705    }
 706    STATUS (&b) = INIT_MASK;
 707    PUSH_OBJECT (p, b, A68_BITS);
 708  }
 709  
 710  // @brief PROC (REAL) REAL sqrt
 711  
 712  void genie_sqrt_real (NODE_T * p)
 713  {
 714    C_FUNCTION (p, sqrt);
 715  }
 716  
 717  // @brief PROC (REAL) REAL curt
 718  
 719  void genie_curt_real (NODE_T * p)
 720  {
 721    C_FUNCTION (p, cbrt);
 722  }
 723  
 724  // @brief PROC (REAL) REAL exp
 725  
 726  void genie_exp_real (NODE_T * p)
 727  {
 728    A68_REAL *x;
 729    POP_OPERAND_ADDRESS (p, x, A68_REAL);
 730    if (VALUE (x) > LOG_DBL_MAX) {
 731      errno = EDOM;
 732    } else if (VALUE (x) < LOG_DBL_MIN) {
 733      errno = EDOM;
 734    } else {
 735      errno = 0;
 736      VALUE (x) = exp (VALUE (x));
 737    }
 738    MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);
 739  }
 740  
 741  // @brief PROC (REAL) REAL ln
 742  
 743  void genie_ln_real (NODE_T * p)
 744  {
 745    C_FUNCTION (p, a68_ln);
 746  }
 747  
 748  // @brief PROC (REAL) REAL ln1p
 749  
 750  void genie_ln1p_real (NODE_T * p)
 751  {
 752    C_FUNCTION (p, a68_ln1p);
 753  }
 754  
 755  // @brief PROC (REAL) REAL log
 756  
 757  void genie_log_real (NODE_T * p)
 758  {
 759    C_FUNCTION (p, log10);
 760  }
 761  
 762  // @brief PROC (REAL) REAL sin
 763  
 764  void genie_sin_real (NODE_T * p)
 765  {
 766    C_FUNCTION (p, sin);
 767  }
 768  
 769  // @brief PROC (REAL) REAL arcsin
 770  
 771  void genie_asin_real (NODE_T * p)
 772  {
 773    C_FUNCTION (p, asin);
 774  }
 775  
 776  // @brief PROC (REAL) REAL cos
 777  
 778  void genie_cos_real (NODE_T * p)
 779  {
 780    C_FUNCTION (p, cos);
 781  }
 782  
 783  // @brief PROC (REAL) REAL arccos
 784  
 785  void genie_acos_real (NODE_T * p)
 786  {
 787    C_FUNCTION (p, acos);
 788  }
 789  
 790  // @brief PROC (REAL) REAL tan
 791  
 792  void genie_tan_real (NODE_T * p)
 793  {
 794    C_FUNCTION (p, tan);
 795  }
 796  
 797  // @brief PROC (REAL) REAL csc 
 798  
 799  void genie_csc_real (NODE_T * p)
 800  {
 801    C_FUNCTION (p, a68_csc);
 802  }
 803  
 804  // @brief PROC (REAL) REAL acsc
 805  
 806  void genie_acsc_real (NODE_T * p)
 807  {
 808    C_FUNCTION (p, a68_acsc);
 809  }
 810  
 811  // @brief PROC (REAL) REAL sec 
 812  
 813  void genie_sec_real (NODE_T * p)
 814  {
 815    C_FUNCTION (p, a68_sec);
 816  }
 817  
 818  // @brief PROC (REAL) REAL asec
 819  
 820  void genie_asec_real (NODE_T * p)
 821  {
 822    C_FUNCTION (p, a68_asec);
 823  }
 824  
 825  // @brief PROC (REAL) REAL cot 
 826  
 827  void genie_cot_real (NODE_T * p)
 828  {
 829    C_FUNCTION (p, a68_cot);
 830  }
 831  
 832  // @brief PROC (REAL) REAL acot
 833  
 834  void genie_acot_real (NODE_T * p)
 835  {
 836    C_FUNCTION (p, a68_acot);
 837  }
 838  
 839  // @brief PROC (REAL) REAL arctan
 840  
 841  void genie_atan_real (NODE_T * p)
 842  {
 843    C_FUNCTION (p, atan);
 844  }
 845  
 846  // @brief PROC (REAL, REAL) REAL arctan2
 847  
 848  void genie_atan2_real (NODE_T * p)
 849  {
 850    A68_REAL *x, *y;
 851    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
 852    errno = 0;
 853    PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL);
 854    VALUE (x) = a68_atan2 (VALUE (y), VALUE (x));
 855    PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
 856  }
 857  
 858  // @brief PROC (REAL) REAL sindg
 859  
 860  void genie_sindg_real (NODE_T * p)
 861  {
 862    C_FUNCTION (p, a68_sindg);
 863  }
 864  
 865  // @brief PROC (REAL) REAL arcsindg
 866  
 867  void genie_asindg_real (NODE_T * p)
 868  {
 869    C_FUNCTION (p, a68_asindg);
 870  }
 871  
 872  // @brief PROC (REAL) REAL cosdg
 873  
 874  void genie_cosdg_real (NODE_T * p)
 875  {
 876    C_FUNCTION (p, a68_cosdg);
 877  }
 878  
 879  // @brief PROC (REAL) REAL arccosdg
 880  
 881  void genie_acosdg_real (NODE_T * p)
 882  {
 883    C_FUNCTION (p, a68_acosdg);
 884  }
 885  
 886  // @brief PROC (REAL) REAL tandg
 887  
 888  void genie_tandg_real (NODE_T * p)
 889  {
 890    C_FUNCTION (p, a68_tandg);
 891  }
 892  
 893  // @brief PROC (REAL) REAL arctandg
 894  
 895  void genie_atandg_real (NODE_T * p)
 896  {
 897    C_FUNCTION (p, a68_atandg);
 898  }
 899  
 900  // @brief PROC (REAL) REAL cotdg 
 901  
 902  void genie_cotdg_real (NODE_T * p)
 903  {
 904    C_FUNCTION (p, a68_cotdg);
 905  }
 906  
 907  // @brief PROC (REAL) REAL acotdg
 908  
 909  void genie_acotdg_real (NODE_T * p)
 910  {
 911    C_FUNCTION (p, a68_acotdg);
 912  }
 913  
 914  // @brief PROC (REAL, REAL) REAL arctan2dg
 915  
 916  void genie_atan2dg_real (NODE_T * p)
 917  {
 918    A68_REAL *x, *y;
 919    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
 920    errno = 0;
 921    PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL);
 922    VALUE (x) = CONST_180_OVER_PI * a68_atan2 (VALUE (y), VALUE (x));
 923    PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
 924  }
 925  
 926  // @brief PROC (REAL) REAL sinpi
 927  
 928  void genie_sinpi_real (NODE_T * p)
 929  {
 930    C_FUNCTION (p, a68_sinpi);
 931  }
 932  
 933  // @brief PROC (REAL) REAL cospi
 934  
 935  void genie_cospi_real (NODE_T * p)
 936  {
 937    C_FUNCTION (p, a68_cospi);
 938  }
 939  
 940  // @brief PROC (REAL) REAL tanpi
 941  
 942  void genie_tanpi_real (NODE_T * p)
 943  {
 944    C_FUNCTION (p, a68_tanpi);
 945  }
 946  
 947  // @brief PROC (REAL) REAL cotpi 
 948  
 949  void genie_cotpi_real (NODE_T * p)
 950  {
 951    C_FUNCTION (p, a68_cotpi);
 952  }
 953  
 954  // @brief PROC (REAL) REAL sinh
 955  
 956  void genie_sinh_real (NODE_T * p)
 957  {
 958    C_FUNCTION (p, sinh);
 959  }
 960  
 961  // @brief PROC (REAL) REAL cosh
 962  
 963  void genie_cosh_real (NODE_T * p)
 964  {
 965    C_FUNCTION (p, cosh);
 966  }
 967  
 968  // @brief PROC (REAL) REAL tanh
 969  
 970  void genie_tanh_real (NODE_T * p)
 971  {
 972    C_FUNCTION (p, tanh);
 973  }
 974  
 975  // @brief PROC (REAL) REAL asinh
 976  
 977  void genie_asinh_real (NODE_T * p)
 978  {
 979    C_FUNCTION (p, a68_asinh);
 980  }
 981  
 982  // @brief PROC (REAL) REAL acosh
 983  
 984  void genie_acosh_real (NODE_T * p)
 985  {
 986    C_FUNCTION (p, a68_acosh);
 987  }
 988  
 989  // @brief PROC (REAL) REAL atanh
 990  
 991  void genie_atanh_real (NODE_T * p)
 992  {
 993    C_FUNCTION (p, a68_atanh);
 994  }
 995  
 996  // @brief PROC (REAL) REAL erf
 997  
 998  void genie_erf_real (NODE_T * p)
 999  {
1000    C_FUNCTION (p, erf);
1001  }
1002  
1003  // @brief PROC (REAL) REAL inverf
1004  
1005  void genie_inverf_real (NODE_T * p)
1006  {
1007    C_FUNCTION (p, a68_inverf);
1008  }
1009  
1010  // @brief PROC (REAL) REAL erfc
1011  
1012  void genie_erfc_real (NODE_T * p)
1013  {
1014    C_FUNCTION (p, erfc);
1015  }
1016  
1017  // @brief PROC (REAL) REAL inverfc
1018  
1019  void genie_inverfc_real (NODE_T * p)
1020  {
1021    C_FUNCTION (p, a68_inverfc);
1022  }
1023  
1024  // @brief PROC (REAL) REAL gamma
1025  
1026  void genie_gamma_real (NODE_T * p)
1027  {
1028    C_FUNCTION (p, tgamma);
1029  }
1030  
1031  // @brief PROC (REAL) REAL ln gamma
1032  
1033  void genie_ln_gamma_real (NODE_T * p)
1034  {
1035    C_FUNCTION (p, lgamma);
1036  }
1037  
1038  // @brief PROC (REAL, REAL) REAL beta
1039  
1040  void genie_beta_real (NODE_T * p)
1041  {
1042    A68_REAL *x, *y;
1043    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
1044    errno = 0;
1045    VALUE (x) = a68_beta (VALUE (x), VALUE (y));
1046    PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1047  }
1048  
1049  // @brief PROC (REAL, REAL) REAL ln beta
1050  
1051  void genie_ln_beta_real (NODE_T * p)
1052  {
1053    A68_REAL *x, *y;
1054    POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
1055    errno = 0;
1056    VALUE (x) = a68_ln_beta (VALUE (x), VALUE (y));
1057    PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1058  }
1059  
1060  // @brief PROC (REAL, REAL, REAL) REAL cf beta inc
1061  
1062  void genie_beta_inc_cf_real (NODE_T * p)
1063  {
1064    A68_REAL *s, *t, *x;
1065    POP_3_OPERAND_ADDRESSES (p, s, t, x, A68_REAL);
1066    errno = 0;
1067    VALUE (s) = a68_beta_inc (VALUE (s), VALUE (t), VALUE (x));
1068    PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1069  }
1070  
1071  // @brief PROC (REAL, REAL, REAL) REAL lj e 12 6
1072  
1073  void genie_lj_e_12_6 (NODE_T * p)
1074  {
1075    A68_REAL *e, *s, *r;
1076    REAL_T u, u2, u6;
1077    POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL);
1078    PRELUDE_ERROR (VALUE (r) == 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1079    u = (VALUE (s) / VALUE (r));
1080    u2 = u * u;
1081    u6 = u2 * u2 * u2;
1082    VALUE (e) = 4.0 * VALUE (e) * u6 * (u6 - 1.0);
1083  }
1084  
1085  // @brief PROC (REAL, REAL, REAL) REAL lj f 12 6
1086  
1087  void genie_lj_f_12_6 (NODE_T * p)
1088  {
1089    A68_REAL *e, *s, *r;
1090    REAL_T u, u2, u6;
1091    POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL);
1092    PRELUDE_ERROR (VALUE (r) == 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1093    u = (VALUE (s) / VALUE (r));
1094    u2 = u * u;
1095    u6 = u2 * u2 * u2;
1096    VALUE (e) = 24.0 * VALUE (e) * u * u6 * (1.0 - 2.0 * u6);
1097  }
1098  
1099  // This file also contains Algol68G's standard environ for complex numbers.
1100  // Some of the LONG operations are generic for LONG and LONG LONG.
1101  // 
1102  // Some routines are based on
1103  //   GNU Scientific Library
1104  //   Abramowitz and Stegun.
1105  
1106  // OP +* = (REAL, REAL) COMPLEX
1107  
1108  void genie_i_complex (NODE_T * p)
1109  {
1110  // This function must exist so the code generator recognises it!
1111    (void) p;
1112  }
1113  
1114  // OP +* = (INT, INT) COMPLEX
1115  
1116  void genie_i_int_complex (NODE_T * p)
1117  {
1118    A68_INT re, im;
1119    POP_OBJECT (p, &im, A68_INT);
1120    POP_OBJECT (p, &re, A68_INT);
1121    PUSH_VALUE (p, (REAL_T) VALUE (&re), A68_REAL);
1122    PUSH_VALUE (p, (REAL_T) VALUE (&im), A68_REAL);
1123  }
1124  
1125  // OP RE = (COMPLEX) REAL
1126  
1127  void genie_re_complex (NODE_T * p)
1128  {
1129    DECREMENT_STACK_POINTER (p, SIZE (M_REAL));
1130  }
1131  
1132  // OP IM = (COMPLEX) REAL
1133  
1134  void genie_im_complex (NODE_T * p)
1135  {
1136    A68_REAL im;
1137    POP_OBJECT (p, &im, A68_REAL);
1138    *(A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL))) = im;
1139  }
1140  
1141  // OP - = (COMPLEX) COMPLEX
1142  
1143  void genie_minus_complex (NODE_T * p)
1144  {
1145    A68_REAL *re_x, *im_x;
1146    im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL)));
1147    re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL)));
1148    VALUE (im_x) = -VALUE (im_x);
1149    VALUE (re_x) = -VALUE (re_x);
1150    (void) p;
1151  }
1152  
1153  // ABS = (COMPLEX) REAL
1154  
1155  void genie_abs_complex (NODE_T * p)
1156  {
1157    A68_REAL re_x, im_x;
1158    POP_COMPLEX (p, &re_x, &im_x);
1159    PUSH_VALUE (p, a68_hypot (VALUE (&re_x), VALUE (&im_x)), A68_REAL);
1160  }
1161  
1162  // OP ARG = (COMPLEX) REAL
1163  
1164  void genie_arg_complex (NODE_T * p)
1165  {
1166    A68_REAL re_x, im_x;
1167    POP_COMPLEX (p, &re_x, &im_x);
1168    PRELUDE_ERROR (VALUE (&re_x) == 0.0 && VALUE (&im_x) == 0.0, p, ERROR_INVALID_ARGUMENT, M_COMPLEX);
1169    PUSH_VALUE (p, atan2 (VALUE (&im_x), VALUE (&re_x)), A68_REAL);
1170  }
1171  
1172  // OP CONJ = (COMPLEX) COMPLEX
1173  
1174  void genie_conj_complex (NODE_T * p)
1175  {
1176    A68_REAL *im;
1177    POP_OPERAND_ADDRESS (p, im, A68_REAL);
1178    VALUE (im) = -VALUE (im);
1179  }
1180  
1181  // OP + = (COMPLEX, COMPLEX) COMPLEX
1182  
1183  void genie_add_complex (NODE_T * p)
1184  {
1185    A68_REAL *re_x, *im_x, re_y, im_y;
1186    POP_COMPLEX (p, &re_y, &im_y);
1187    im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL)));
1188    re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL)));
1189    VALUE (im_x) += VALUE (&im_y);
1190    VALUE (re_x) += VALUE (&re_y);
1191    CHECK_COMPLEX (p, VALUE (re_x), VALUE (im_x));
1192  }
1193  
1194  // OP - = (COMPLEX, COMPLEX) COMPLEX
1195  
1196  void genie_sub_complex (NODE_T * p)
1197  {
1198    A68_REAL *re_x, *im_x, re_y, im_y;
1199    POP_COMPLEX (p, &re_y, &im_y);
1200    im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL)));
1201    re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL)));
1202    VALUE (im_x) -= VALUE (&im_y);
1203    VALUE (re_x) -= VALUE (&re_y);
1204    CHECK_COMPLEX (p, VALUE (re_x), VALUE (im_x));
1205  }
1206  
1207  // OP * = (COMPLEX, COMPLEX) COMPLEX
1208  
1209  void genie_mul_complex (NODE_T * p)
1210  {
1211    A68_REAL re_x, im_x, re_y, im_y;
1212    REAL_T re, im;
1213    POP_COMPLEX (p, &re_y, &im_y);
1214    POP_COMPLEX (p, &re_x, &im_x);
1215    re = VALUE (&re_x) * VALUE (&re_y) - VALUE (&im_x) * VALUE (&im_y);
1216    im = VALUE (&im_x) * VALUE (&re_y) + VALUE (&re_x) * VALUE (&im_y);
1217    CHECK_COMPLEX (p, re, im);
1218    PUSH_COMPLEX (p, re, im);
1219  }
1220  
1221  // OP / = (COMPLEX, COMPLEX) COMPLEX
1222  
1223  void genie_div_complex (NODE_T * p)
1224  {
1225    A68_REAL re_x, im_x, re_y, im_y;
1226    REAL_T re = 0.0, im = 0.0;
1227    POP_COMPLEX (p, &re_y, &im_y);
1228    POP_COMPLEX (p, &re_x, &im_x);
1229  #if !defined (HAVE_IEEE_754)
1230    PRELUDE_ERROR (VALUE (&re_y) == 0.0 && VALUE (&im_y) == 0.0, p, ERROR_DIVISION_BY_ZERO, M_COMPLEX);
1231  #endif
1232    if (ABS (VALUE (&re_y)) >= ABS (VALUE (&im_y))) {
1233      REAL_T r = VALUE (&im_y) / VALUE (&re_y), den = VALUE (&re_y) + r * VALUE (&im_y);
1234      re = (VALUE (&re_x) + r * VALUE (&im_x)) / den;
1235      im = (VALUE (&im_x) - r * VALUE (&re_x)) / den;
1236    } else {
1237      REAL_T r = VALUE (&re_y) / VALUE (&im_y), den = VALUE (&im_y) + r * VALUE (&re_y);
1238      re = (VALUE (&re_x) * r + VALUE (&im_x)) / den;
1239      im = (VALUE (&im_x) * r - VALUE (&re_x)) / den;
1240    }
1241    CHECK_COMPLEX (p, re, im);
1242    PUSH_COMPLEX (p, re, im);
1243  }
1244  
1245  // OP ** = (COMPLEX, INT) COMPLEX
1246  
1247  void genie_pow_complex_int (NODE_T * p)
1248  {
1249    A68_REAL re_x, im_x;
1250    REAL_T re_y, im_y, re_z, im_z, rea;
1251    A68_INT j;
1252    INT_T expo;
1253    BOOL_T negative;
1254    POP_OBJECT (p, &j, A68_INT);
1255    POP_COMPLEX (p, &re_x, &im_x);
1256    re_z = 1.0;
1257    im_z = 0.0;
1258    re_y = VALUE (&re_x);
1259    im_y = VALUE (&im_x);
1260    expo = 1;
1261    negative = (BOOL_T) (VALUE (&j) < 0);
1262    if (negative) {
1263      VALUE (&j) = -VALUE (&j);
1264    }
1265    while ((UNSIGNED_T) expo <= (UNSIGNED_T) (VALUE (&j))) {
1266      if (expo & VALUE (&j)) {
1267        rea = re_z * re_y - im_z * im_y;
1268        im_z = re_z * im_y + im_z * re_y;
1269        re_z = rea;
1270      }
1271      rea = re_y * re_y - im_y * im_y;
1272      im_y = im_y * re_y + re_y * im_y;
1273      re_y = rea;
1274      expo <<= 1;
1275    }
1276    CHECK_COMPLEX (p, re_z, im_z);
1277    if (negative) {
1278      PUSH_VALUE (p, 1.0, A68_REAL);
1279      PUSH_VALUE (p, 0.0, A68_REAL);
1280      PUSH_VALUE (p, re_z, A68_REAL);
1281      PUSH_VALUE (p, im_z, A68_REAL);
1282      genie_div_complex (p);
1283    } else {
1284      PUSH_VALUE (p, re_z, A68_REAL);
1285      PUSH_VALUE (p, im_z, A68_REAL);
1286    }
1287  }
1288  
1289  // OP = = (COMPLEX, COMPLEX) BOOL
1290  
1291  void genie_eq_complex (NODE_T * p)
1292  {
1293    A68_REAL re_x, im_x, re_y, im_y;
1294    POP_COMPLEX (p, &re_y, &im_y);
1295    POP_COMPLEX (p, &re_x, &im_x);
1296    PUSH_VALUE (p, (BOOL_T) ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL);
1297  }
1298  
1299  // OP /= = (COMPLEX, COMPLEX) BOOL
1300  
1301  void genie_ne_complex (NODE_T * p)
1302  {
1303    A68_REAL re_x, im_x, re_y, im_y;
1304    POP_COMPLEX (p, &re_y, &im_y);
1305    POP_COMPLEX (p, &re_x, &im_x);
1306    PUSH_VALUE (p, (BOOL_T) ! ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL);
1307  }
1308  
1309  // OP +:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1310  
1311  void genie_plusab_complex (NODE_T * p)
1312  {
1313    genie_f_and_becomes (p, M_REF_COMPLEX, genie_add_complex);
1314  }
1315  
1316  // OP -:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1317  
1318  void genie_minusab_complex (NODE_T * p)
1319  {
1320    genie_f_and_becomes (p, M_REF_COMPLEX, genie_sub_complex);
1321  }
1322  
1323  // OP *:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1324  
1325  void genie_timesab_complex (NODE_T * p)
1326  {
1327    genie_f_and_becomes (p, M_REF_COMPLEX, genie_mul_complex);
1328  }
1329  
1330  // OP /:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1331  
1332  void genie_divab_complex (NODE_T * p)
1333  {
1334    genie_f_and_becomes (p, M_REF_COMPLEX, genie_div_complex);
1335  }
1336  
1337  #define C_C_FUNCTION(p, f)\
1338    A68_REAL re, im;\
1339    COMPLEX_T z;\
1340    POP_OBJECT (p, &im, A68_REAL);\
1341    POP_OBJECT (p, &re, A68_REAL);\
1342    errno = 0;\
1343    z = VALUE (&re) + VALUE (&im) * _Complex_I;\
1344    z = f (z);\
1345    PUSH_VALUE (p, (REAL_T) creal (z), A68_REAL);\
1346    PUSH_VALUE (p, (REAL_T) cimag (z), A68_REAL);\
1347    MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);
1348  
1349  // @brief PROC (COMPLEX) COMPLEX csqrt
1350  
1351  void genie_sqrt_complex (NODE_T * p)
1352  {
1353    C_C_FUNCTION (p, csqrt);
1354  }
1355  
1356  // @brief PROC (COMPLEX) COMPLEX cexp
1357  
1358  void genie_exp_complex (NODE_T * p)
1359  {
1360    C_C_FUNCTION (p, cexp);
1361  }
1362  
1363  // @brief PROC (COMPLEX) COMPLEX cln
1364  
1365  void genie_ln_complex (NODE_T * p)
1366  {
1367    C_C_FUNCTION (p, clog);
1368  }
1369  
1370  // @brief PROC (COMPLEX) COMPLEX csin
1371  
1372  void genie_sin_complex (NODE_T * p)
1373  {
1374    C_C_FUNCTION (p, csin);
1375  }
1376  
1377  // @brief PROC (COMPLEX) COMPLEX ccos
1378  
1379  void genie_cos_complex (NODE_T * p)
1380  {
1381    C_C_FUNCTION (p, ccos);
1382  }
1383  
1384  // @brief PROC (COMPLEX) COMPLEX ctan
1385  
1386  void genie_tan_complex (NODE_T * p)
1387  {
1388    C_C_FUNCTION (p, ctan);
1389  }
1390  
1391  // @brief PROC carcsin= (COMPLEX) COMPLEX
1392  
1393  void genie_asin_complex (NODE_T * p)
1394  {
1395    C_C_FUNCTION (p, casin);
1396  }
1397  
1398  // @brief PROC (COMPLEX) COMPLEX carccos
1399  
1400  void genie_acos_complex (NODE_T * p)
1401  {
1402    C_C_FUNCTION (p, cacos);
1403  }
1404  
1405  // @brief PROC (COMPLEX) COMPLEX carctan
1406  
1407  void genie_atan_complex (NODE_T * p)
1408  {
1409    C_C_FUNCTION (p, catan);
1410  }
1411  
1412  // @brief PROC (COMPLEX) COMPLEX csinh
1413  
1414  void genie_sinh_complex (NODE_T * p)
1415  {
1416    C_C_FUNCTION (p, csinh);
1417  }
1418  
1419  // @brief PROC (COMPLEX) COMPLEX ccosh
1420  
1421  void genie_cosh_complex (NODE_T * p)
1422  {
1423    C_C_FUNCTION (p, ccosh);
1424  }
1425  
1426  // @brief PROC (COMPLEX) COMPLEX ctanh
1427  
1428  void genie_tanh_complex (NODE_T * p)
1429  {
1430    C_C_FUNCTION (p, ctanh);
1431  }
1432  
1433  // @brief PROC (COMPLEX) COMPLEX carcsinh
1434  
1435  void genie_asinh_complex (NODE_T * p)
1436  {
1437    C_C_FUNCTION (p, casinh);
1438  }
1439  
1440  // @brief PROC (COMPLEX) COMPLEX carccosh
1441  
1442  void genie_acosh_complex (NODE_T * p)
1443  {
1444    C_C_FUNCTION (p, cacosh);
1445  }
1446  
1447  // @brief PROC (COMPLEX) COMPLEX carctanh
1448  
1449  void genie_atanh_complex (NODE_T * p)
1450  {
1451    C_C_FUNCTION (p, catanh);
1452  }
1453  
1454  #define C_C_INLINE(z, x, f)\
1455    COMPLEX_T u = RE (x) + IM (x) * _Complex_I;\
1456    COMPLEX_T v = f (u);\
1457    STATUS_RE (z) = INIT_MASK;\
1458    STATUS_IM (z) = INIT_MASK;\
1459    RE (z) = creal (v);\
1460    IM (z) = cimag (v);\
1461  
1462  //! @brief PROC (COMPLEX) COMPLEX csqrt
1463  
1464  void a68_sqrt_complex (A68_REAL * z, A68_REAL * x)
1465  {
1466    C_C_INLINE (z, x, csqrt);
1467  }
1468  
1469  //! @brief PROC (COMPLEX) COMPLEX cexp
1470  
1471  void a68_exp_complex (A68_REAL * z, A68_REAL * x)
1472  {
1473    C_C_INLINE (z, x, cexp);
1474  }
1475  
1476  //! @brief PROC (COMPLEX) COMPLEX cln
1477  
1478  void a68_ln_complex (A68_REAL * z, A68_REAL * x)
1479  {
1480    C_C_INLINE (z, x, clog);
1481  }
1482  
1483  //! @brief PROC (COMPLEX) COMPLEX csin
1484  
1485  void a68_sin_complex (A68_REAL * z, A68_REAL * x)
1486  {
1487    C_C_INLINE (z, x, csin);
1488  }
1489  
1490  //! @brief PROC (COMPLEX) COMPLEX ccos
1491  
1492  void a68_cos_complex (A68_REAL * z, A68_REAL * x)
1493  {
1494    C_C_INLINE (z, x, ccos);
1495  }
1496  
1497  //! @brief PROC (COMPLEX) COMPLEX ctan
1498  
1499  void a68_tan_complex (A68_REAL * z, A68_REAL * x)
1500  {
1501    C_C_INLINE (z, x, ctan);
1502  }
1503  
1504  //! @brief PROC (COMPLEX) COMPLEX casin
1505  
1506  void a68_asin_complex (A68_REAL * z, A68_REAL * x)
1507  {
1508    C_C_INLINE (z, x, casin);
1509  }
1510  
1511  //! @brief PROC (COMPLEX) COMPLEX cacos
1512  
1513  void a68_acos_complex (A68_REAL * z, A68_REAL * x)
1514  {
1515    C_C_INLINE (z, x, cacos);
1516  }
1517  
1518  //! @brief PROC (COMPLEX) COMPLEX catan
1519  
1520  void a68_atan_complex (A68_REAL * z, A68_REAL * x)
1521  {
1522    C_C_INLINE (z, x, catan);
1523  }
1524  
1525  //! @brief PROC (COMPLEX) COMPLEX csinh
1526  
1527  void a68_sinh_complex (A68_REAL * z, A68_REAL * x)
1528  {
1529    C_C_INLINE (z, x, csinh);
1530  }
1531  
1532  //! @brief PROC (COMPLEX) COMPLEX ccosh
1533  
1534  void a68_cosh_complex (A68_REAL * z, A68_REAL * x)
1535  {
1536    C_C_INLINE (z, x, ccosh);
1537  }
1538  
1539  //! @brief PROC (COMPLEX) COMPLEX ctanh
1540  
1541  void a68_tanh_complex (A68_REAL * z, A68_REAL * x)
1542  {
1543    C_C_INLINE (z, x, ctanh);
1544  }
1545  
1546  //! @brief PROC (COMPLEX) COMPLEX casinh
1547  
1548  void a68_asinh_complex (A68_REAL * z, A68_REAL * x)
1549  {
1550    C_C_INLINE (z, x, casinh);
1551  }
1552  
1553  //! @brief PROC (COMPLEX) COMPLEX cacosh
1554  
1555  void a68_acosh_complex (A68_REAL * z, A68_REAL * x)
1556  {
1557    C_C_INLINE (z, x, cacosh);
1558  }
1559  
1560  //! @brief PROC (COMPLEX) COMPLEX catanh
1561  
1562  void a68_atanh_complex (A68_REAL * z, A68_REAL * x)
1563  {
1564    C_C_INLINE (z, x, catanh);
1565  }
1566  
1567  //! @brief PROC (INT, INT) REAL choose
1568  
1569  void genie_fact_real (NODE_T * p)
1570  {
1571    A68_INT n;
1572    POP_OBJECT (p, &n, A68_INT);
1573    errno = 0;
1574    PUSH_VALUE (p, a68_fact (VALUE (&n)), A68_REAL);
1575    MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1576  }
1577  
1578  //! @brief PROC (INT, INT) REAL ln fact
1579  
1580  void genie_ln_fact_real (NODE_T * p)
1581  {
1582    A68_INT n;
1583    POP_OBJECT (p, &n, A68_INT);
1584    errno = 0;
1585    PUSH_VALUE (p, a68_ln_fact (VALUE (&n)), A68_REAL);
1586    MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1587  }
1588  
1589  void genie_choose_real (NODE_T * p)
1590  {
1591    A68_INT n, m;
1592    POP_OBJECT (p, &m, A68_INT);
1593    POP_OBJECT (p, &n, A68_INT);
1594    errno = 0;
1595    PUSH_VALUE (p, a68_choose (VALUE (&n), VALUE (&m)), A68_REAL);
1596    MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1597  }
1598  
1599  //! @brief PROC (INT, INT) REAL ln choose
1600  
1601  void genie_ln_choose_real (NODE_T * p)
1602  {
1603    A68_INT n, m;
1604    POP_OBJECT (p, &m, A68_INT);
1605    POP_OBJECT (p, &n, A68_INT);
1606    errno = 0;
1607    PUSH_VALUE (p, a68_ln_choose (VALUE (&n), VALUE (&m)), A68_REAL);
1608    MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1609  }
1610  
1611  // OP / = (COMPLEX, COMPLEX) COMPLEX
1612  
1613  void a68_div_complex (A68_REAL * z, A68_REAL * x, A68_REAL * y)
1614  {
1615    STATUS_RE (z) = INIT_MASK;
1616    STATUS_IM (z) = INIT_MASK;
1617    if (RE (y) == 0 && IM (y) == 0) {
1618      RE (z) = 0.0;
1619      IM (z) = 0.0;
1620      errno = EDOM;
1621    } else if (fabs (RE (y)) >= fabs (IM (y))) {
1622      REAL_T r = IM (y) / RE (y), den = RE (y) + r * IM (y);
1623      RE (z) = (RE (x) + r * IM (x)) / den;
1624      IM (z) = (IM (x) - r * RE (x)) / den;
1625    } else {
1626      REAL_T r = RE (y) / IM (y), den = IM (y) + r * RE (y);
1627      RE (z) = (RE (x) * r + IM (x)) / den;
1628      IM (z) = (IM (x) * r - RE (x)) / den;
1629    }
1630  }