single.c

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


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