mp-genie.c

     
   1  //! @file mp-misc.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  //! Multi-precision interpreter routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-double.h"
  30  #include "a68g-mp.h"
  31  
  32  //! brief LONG REAL long infinity
  33  
  34  void genie_infinity_mp (NODE_T *p)
  35  {
  36    int digs = DIGITS (MOID (p));
  37    MP_T *z = nil_mp (p, digs);
  38    MP_STATUS (z) = (PLUS_INF_MASK | INIT_MASK);
  39  }
  40  
  41  //! brief LONG REAL long minus infinity
  42  
  43  void genie_minus_infinity_mp (NODE_T *p)
  44  {
  45    int digs = DIGITS (MOID (p));
  46    MP_T *z = nil_mp (p, digs);
  47    MP_STATUS (z) = (MINUS_INF_MASK | INIT_MASK);
  48  }
  49  
  50  //! @brief LONG INT long max int
  51  
  52  void genie_long_max_int (NODE_T * p)
  53  {
  54    int digs = DIGITS (M_LONG_INT);
  55    MP_T *z = nil_mp (p, digs);
  56    MP_STATUS (z) = (MP_T) INIT_MASK;
  57    MP_EXPONENT (z) = (MP_T) (digs - 1);
  58    for (unt k = 1; k <= digs; k++) {
  59      MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1);
  60    }
  61  }
  62  
  63  //! @brief LONG LONG INT long long max int
  64  
  65  void genie_long_mp_max_int (NODE_T * p)
  66  {
  67    int digs = DIGITS (M_LONG_LONG_INT);
  68    MP_T *z = nil_mp (p, digs);
  69    MP_STATUS (z) = (MP_T) INIT_MASK;
  70    MP_EXPONENT (z) = (MP_T) (digs - 1);
  71    for (unt k = 1; k <= digs; k++) {
  72      MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1);
  73    }
  74  }
  75  
  76  //! @brief LONG REAL long max real
  77  
  78  void genie_long_max_real (NODE_T * p)
  79  {
  80    unt digs = DIGITS (M_LONG_REAL);
  81    MP_T *z = nil_mp (p, digs);
  82    MP_STATUS (z) = (MP_T) INIT_MASK;
  83    MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1);
  84    for (unt k = 1; k <= digs; k++) {
  85      MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1);
  86    }
  87  }
  88  
  89  //! @brief LONG LONG REAL long long max real
  90  
  91  void genie_long_mp_max_real (NODE_T * p)
  92  {
  93    unt digs = DIGITS (M_LONG_LONG_REAL);
  94    MP_T *z = nil_mp (p, digs);
  95    MP_STATUS (z) = (MP_T) INIT_MASK;
  96    MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1);
  97    for (unt k = 1; k <= digs; k++) {
  98      MP_DIGIT (z, k) = (MP_T) (MP_RADIX - 1);
  99    }
 100  }
 101  
 102  //! @brief LONG REAL min long real
 103  
 104  void genie_long_min_real (NODE_T * p)
 105  {
 106    (void) lit_mp (p, 1, -MAX_MP_EXPONENT, DIGITS (M_LONG_REAL));
 107  }
 108  
 109  //! @brief LONG LONG REAL min long long real
 110  
 111  void genie_long_mp_min_real (NODE_T * p)
 112  {
 113    (void) lit_mp (p, 1, -MAX_MP_EXPONENT, DIGITS (M_LONG_LONG_REAL));
 114  }
 115  
 116  //! @brief LONG REAL small long real
 117  
 118  void genie_long_small_real (NODE_T * p)
 119  {
 120    int digs = DIGITS (M_LONG_REAL);
 121    (void) lit_mp (p, 1, 1 - digs, digs);
 122  }
 123  
 124  //! @brief LONG LONG REAL small long long real
 125  
 126  void genie_long_mp_small_real (NODE_T * p)
 127  {
 128    int digs = DIGITS (M_LONG_LONG_REAL);
 129    (void) lit_mp (p, 1, 1 - digs, digs);
 130  }
 131  
 132  //! @brief OP LENG = (INT) LONG INT
 133  
 134  void genie_lengthen_int_to_mp (NODE_T * p)
 135  {
 136    int digs = DIGITS (M_LONG_INT);
 137    A68_INT k;
 138    POP_OBJECT (p, &k, A68_INT);
 139    MP_T *z = nil_mp (p, digs);
 140    (void) int_to_mp (p, z, VALUE (&k), digs);
 141    MP_STATUS (z) = (MP_T) INIT_MASK;
 142  }
 143  
 144  //! @brief OP SHORTEN = (LONG INT) INT
 145  
 146  void genie_shorten_mp_to_int (NODE_T * p)
 147  {
 148    MOID_T *mode = LHS_MODE (p);
 149    int digs = DIGITS (mode), size = SIZE (mode);
 150    MP_T *z;
 151    DECREMENT_STACK_POINTER (p, size);
 152    z = (MP_T *) STACK_TOP;
 153    MP_STATUS (z) = (MP_T) INIT_MASK;
 154    PUSH_VALUE (p, mp_to_int (p, z, digs), A68_INT);
 155  }
 156  
 157  //! @brief OP LENG = (REAL) LONG REAL
 158  
 159  void genie_lengthen_real_to_mp (NODE_T * p)
 160  {
 161    int digs = DIGITS (M_LONG_REAL);
 162    A68_REAL x;
 163    POP_OBJECT (p, &x, A68_REAL);
 164    MP_T *z = nil_mp (p, digs);
 165    (void) real_to_mp (p, z, VALUE (&x), digs);
 166    MP_STATUS (z) = (MP_T) INIT_MASK;
 167  }
 168  
 169  //! @brief OP SHORTEN = (LONG REAL) REAL
 170  
 171  void genie_shorten_mp_to_real (NODE_T * p)
 172  {
 173    MOID_T *mode = LHS_MODE (p);
 174    int digs = DIGITS (mode), size = SIZE (mode);
 175    MP_T *z;
 176    DECREMENT_STACK_POINTER (p, size);
 177    z = (MP_T *) STACK_TOP;
 178    MP_STATUS (z) = (MP_T) INIT_MASK;
 179    PUSH_VALUE (p, mp_to_real (p, z, digs), A68_REAL);
 180  }
 181  
 182  //! @brief OP ENTIER = (LONG REAL) LONG INT
 183  
 184  void genie_entier_mp (NODE_T * p)
 185  {
 186    int digs = DIGITS (LHS_MODE (p)), size = SIZE (LHS_MODE (p));
 187    ADDR_T pop_sp = A68_SP;
 188    MP_T *z = (MP_T *) STACK_OFFSET (-size);
 189    (void) entier_mp (p, z, z, digs);
 190    A68_SP = pop_sp;
 191  }
 192  
 193  #define C_L_FUNCTION(p, f)\
 194    int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));\
 195    ADDR_T pop_sp = A68_SP;\
 196    MP_T *x = (MP_T *) STACK_OFFSET (-size);\
 197    errno = 0;\
 198    PRELUDE_ERROR (f (p, x, x, digs) == NaN_MP || errno != 0, p, ERROR_INVALID_ARGUMENT, MOID (p));\
 199    MP_STATUS (x) = (MP_T) INIT_MASK;\
 200    A68_SP = pop_sp;
 201  
 202  //! @brief PROC (LONG REAL) LONG REAL long sqrt
 203  
 204  void genie_sqrt_mp (NODE_T * p)
 205  {
 206    C_L_FUNCTION (p, sqrt_mp);
 207  }
 208  
 209  //! @brief PROC (LONG REAL) LONG REAL long curt
 210  
 211  void genie_curt_mp (NODE_T * p)
 212  {
 213    C_L_FUNCTION (p, curt_mp);
 214  }
 215  
 216  //! @brief PROC (LONG REAL) LONG REAL long exp
 217  
 218  void genie_exp_mp (NODE_T * p)
 219  {
 220    C_L_FUNCTION (p, exp_mp);
 221  }
 222  
 223  //! @brief PROC (LONG REAL) LONG REAL long erf
 224  
 225  void genie_erf_mp (NODE_T * p)
 226  {
 227    C_L_FUNCTION (p, erf_mp);
 228  }
 229  
 230  //! @brief PROC (LONG REAL) LONG REAL long inverf
 231  
 232  void genie_inverf_mp (NODE_T * p)
 233  {
 234    C_L_FUNCTION (p, inverf_mp);
 235  }
 236  
 237  //! @brief PROC (LONG REAL) LONG REAL long erfc
 238  
 239  void genie_erfc_mp (NODE_T * p)
 240  {
 241    C_L_FUNCTION (p, erfc_mp);
 242  }
 243  
 244  //! @brief PROC (LONG REAL) LONG REAL long inverfc
 245  
 246  void genie_inverfc_mp (NODE_T * p)
 247  {
 248    C_L_FUNCTION (p, inverfc_mp);
 249  }
 250  
 251  //! @brief PROC (LONG REAL) LONG REAL long gamma
 252  
 253  void genie_gamma_mp (NODE_T * p)
 254  {
 255    C_L_FUNCTION (p, gamma_mp);
 256  }
 257  
 258  //! @brief PROC (LONG REAL) LONG REAL long ln gamma
 259  
 260  void genie_lngamma_mp (NODE_T * p)
 261  {
 262    C_L_FUNCTION (p, lngamma_mp);
 263  }
 264  
 265  //! @brief PROC (LONG REAL) LONG REAL long beta
 266  
 267  void genie_beta_mp (NODE_T * p)
 268  {
 269    int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
 270    MP_T *b = (MP_T *) STACK_OFFSET (-size);
 271    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 272    PRELUDE_ERROR (beta_mp (p, a, a, b, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
 273    A68_SP -= size;
 274    MP_STATUS (a) = (MP_T) INIT_MASK;
 275  }
 276  
 277  //! @brief PROC (LONG REAL) LONG REAL long ln beta
 278  
 279  void genie_lnbeta_mp (NODE_T * p)
 280  {
 281    int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
 282    MP_T *b = (MP_T *) STACK_OFFSET (-size);
 283    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 284    PRELUDE_ERROR (lnbeta_mp (p, a, a, b, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
 285    A68_SP -= size;
 286    MP_STATUS (a) = (MP_T) INIT_MASK;
 287  }
 288  
 289  //! @brief PROC (LONG REAL) LONG REAL long beta
 290  
 291  void genie_beta_inc_mp (NODE_T * p)
 292  {
 293    int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
 294    MP_T *x = (MP_T *) STACK_OFFSET (-size);
 295    MP_T *t = (MP_T *) STACK_OFFSET (-2 * size);
 296    MP_T *s = (MP_T *) STACK_OFFSET (-3 * size);
 297    PRELUDE_ERROR (beta_inc_mp (p, s, s, t, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
 298    A68_SP -= 2 * size;
 299    MP_STATUS (s) = (MP_T) INIT_MASK;
 300  }
 301  
 302  //! @brief PROC (LONG REAL) LONG REAL long ln
 303  
 304  void genie_ln_mp (NODE_T * p)
 305  {
 306    C_L_FUNCTION (p, ln_mp);
 307  }
 308  
 309  //! @brief PROC (LONG REAL) LONG REAL long log
 310  
 311  void genie_log_mp (NODE_T * p)
 312  {
 313    C_L_FUNCTION (p, log_mp);
 314  }
 315  
 316  //! @brief PROC (LONG REAL) LONG REAL long sinh
 317  
 318  void genie_sinh_mp (NODE_T * p)
 319  {
 320    C_L_FUNCTION (p, sinh_mp);
 321  }
 322  
 323  //! @brief PROC (LONG REAL) LONG REAL long cosh
 324  
 325  void genie_cosh_mp (NODE_T * p)
 326  {
 327    C_L_FUNCTION (p, cosh_mp);
 328  }
 329  
 330  //! @brief PROC (LONG REAL) LONG REAL long tanh
 331  
 332  void genie_tanh_mp (NODE_T * p)
 333  {
 334    C_L_FUNCTION (p, tanh_mp);
 335  }
 336  
 337  //! @brief PROC (LONG REAL) LONG REAL long arcsinh
 338  
 339  void genie_asinh_mp (NODE_T * p)
 340  {
 341    C_L_FUNCTION (p, asinh_mp);
 342  }
 343  
 344  //! @brief PROC (LONG REAL) LONG REAL long arccosh
 345  
 346  void genie_acosh_mp (NODE_T * p)
 347  {
 348    C_L_FUNCTION (p, acosh_mp);
 349  }
 350  
 351  //! @brief PROC (LONG REAL) LONG REAL long arctanh
 352  
 353  void genie_atanh_mp (NODE_T * p)
 354  {
 355    C_L_FUNCTION (p, atanh_mp);
 356  }
 357  
 358  //! @brief PROC (LONG REAL) LONG REAL long sin
 359  
 360  void genie_sin_mp (NODE_T * p)
 361  {
 362    C_L_FUNCTION (p, sin_mp);
 363  }
 364  
 365  //! @brief PROC (LONG REAL) LONG REAL long cos
 366  
 367  void genie_cos_mp (NODE_T * p)
 368  {
 369    C_L_FUNCTION (p, cos_mp);
 370  }
 371  
 372  //! @brief PROC (LONG REAL) LONG REAL long tan
 373  
 374  void genie_tan_mp (NODE_T * p)
 375  {
 376    C_L_FUNCTION (p, tan_mp);
 377  }
 378  
 379  //! @brief PROC (LONG REAL) LONG REAL long arcsin
 380  
 381  void genie_asin_mp (NODE_T * p)
 382  {
 383    C_L_FUNCTION (p, asin_mp);
 384  }
 385  
 386  //! @brief PROC (LONG REAL) LONG REAL long arccos
 387  
 388  void genie_acos_mp (NODE_T * p)
 389  {
 390    C_L_FUNCTION (p, acos_mp);
 391  }
 392  
 393  //! @brief PROC (LONG REAL) LONG REAL long arctan
 394  
 395  void genie_atan_mp (NODE_T * p)
 396  {
 397    C_L_FUNCTION (p, atan_mp);
 398  }
 399  
 400  //! @brief PROC (LONG REAL, LONG REAL) LONG REAL long arctan2
 401  
 402  void genie_atan2_mp (NODE_T * p)
 403  {
 404    int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
 405    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 406    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 407    PRELUDE_ERROR (atan2_mp (p, x, y, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
 408    A68_SP -= size;
 409    MP_STATUS (x) = (MP_T) INIT_MASK;
 410  }
 411  
 412  // Arithmetic operations.
 413  
 414  //! @brief OP LENG = (LONG MODE) LONG LONG MODE
 415  
 416  void genie_lengthen_mp_to_long_mp (NODE_T * p)
 417  {
 418    DECREMENT_STACK_POINTER (p, (int) size_mp ());
 419    MP_T *z = (MP_T *) STACK_ADDRESS (A68_SP);
 420    z = len_mp (p, z, mp_digits (), long_mp_digits ());
 421    MP_STATUS (z) = (MP_T) INIT_MASK;
 422  }
 423  
 424  //! @brief OP SHORTEN = (LONG LONG MODE) LONG MODE
 425  
 426  void genie_shorten_long_mp_to_mp (NODE_T * p)
 427  {
 428    MOID_T *m = SUB_MOID (p);
 429    DECREMENT_STACK_POINTER (p, (int) size_long_mp ());
 430    MP_T *z = empty_mp (p, mp_digits ());
 431    if (m == M_LONG_INT) {
 432      PRELUDE_ERROR (MP_EXPONENT (z) > LONG_MP_DIGITS - 1, p, ERROR_OUT_OF_BOUNDS, m);
 433    }
 434    (void) shorten_mp (p, z, mp_digits (), z, long_mp_digits ());
 435    MP_STATUS (z) = (MP_T) INIT_MASK;
 436  }
 437  
 438  //! @brief OP - = (LONG MODE) LONG MODE
 439  
 440  void genie_minus_mp (NODE_T * p)
 441  {
 442    int size = SIZE (LHS_MODE (p));
 443    MP_T *z = (MP_T *) STACK_OFFSET (-size);
 444    MP_STATUS (z) = (MP_T) INIT_MASK;
 445    MP_DIGIT (z, 1) = -MP_DIGIT (z, 1);
 446  }
 447  
 448  //! @brief OP ABS = (LONG MODE) LONG MODE
 449  
 450  void genie_abs_mp (NODE_T * p)
 451  {
 452    int size = SIZE (LHS_MODE (p));
 453    MP_T *z = (MP_T *) STACK_OFFSET (-size);
 454    MP_STATUS (z) = (MP_T) INIT_MASK;
 455    MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
 456  }
 457  
 458  //! @brief OP SIGN = (LONG MODE) INT
 459  
 460  void genie_sign_mp (NODE_T * p)
 461  {
 462    int size = SIZE (LHS_MODE (p));
 463    MP_T *z = (MP_T *) STACK_OFFSET (-size);
 464    DECREMENT_STACK_POINTER (p, size);
 465    PUSH_VALUE (p, SIGN (MP_DIGIT (z, 1)), A68_INT);
 466  }
 467  
 468  //! @brief OP + = (LONG MODE, LONG MODE) LONG MODE
 469  
 470  void genie_add_mp (NODE_T * p)
 471  {
 472    MOID_T *mode = RHS_MODE (p);
 473    int digs = DIGITS (mode), size = SIZE (mode);
 474    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 475    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 476    (void) add_mp (p, x, x, y, digs);
 477    MP_STATUS (x) = (MP_T) INIT_MASK;
 478    DECREMENT_STACK_POINTER (p, size);
 479  }
 480  
 481  //! @brief OP - = (LONG MODE, LONG MODE) LONG MODE
 482  
 483  void genie_sub_mp (NODE_T * p)
 484  {
 485    MOID_T *mode = RHS_MODE (p);
 486    int digs = DIGITS (mode), size = SIZE (mode);
 487    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 488    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 489    (void) sub_mp (p, x, x, y, digs);
 490    MP_STATUS (x) = (MP_T) INIT_MASK;
 491    DECREMENT_STACK_POINTER (p, size);
 492  }
 493  
 494  //! @brief OP * = (LONG MODE, LONG MODE) LONG MODE
 495  
 496  void genie_mul_mp (NODE_T * p)
 497  {
 498    MOID_T *mode = RHS_MODE (p);
 499    int digs = DIGITS (mode), size = SIZE (mode);
 500    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 501    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 502    (void) mul_mp (p, x, x, y, digs);
 503    MP_STATUS (x) = (MP_T) INIT_MASK;
 504    DECREMENT_STACK_POINTER (p, size);
 505  }
 506  
 507  //! @brief OP / = (LONG MODE, LONG MODE) LONG MODE
 508  
 509  void genie_div_mp (NODE_T * p)
 510  {
 511    MOID_T *mode = RHS_MODE (p);
 512    int digs = DIGITS (mode), size = SIZE (mode);
 513    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 514    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 515    PRELUDE_ERROR (div_mp (p, x, x, y, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
 516    MP_STATUS (x) = (MP_T) INIT_MASK;
 517    DECREMENT_STACK_POINTER (p, size);
 518  }
 519  
 520  //! @brief OP % = (LONG MODE, LONG MODE) LONG MODE
 521  
 522  void genie_over_mp (NODE_T * p)
 523  {
 524    MOID_T *mode = RHS_MODE (p);
 525    int digs = DIGITS (mode), size = SIZE (mode);
 526    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 527    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 528    PRELUDE_ERROR (over_mp (p, x, x, y, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
 529    MP_STATUS (x) = (MP_T) INIT_MASK;
 530    DECREMENT_STACK_POINTER (p, size);
 531  }
 532  
 533  //! @brief OP %* = (LONG MODE, LONG MODE) LONG MODE
 534  
 535  void genie_mod_mp (NODE_T * p)
 536  {
 537    MOID_T *mode = RHS_MODE (p);
 538    int digs = DIGITS (mode), size = SIZE (mode);
 539    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 540    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 541    PRELUDE_ERROR (mod_mp (p, x, x, y, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
 542    if (MP_DIGIT (x, 1) < 0) {
 543      MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1));
 544      (void) add_mp (p, x, x, y, digs);
 545    }
 546    MP_STATUS (x) = (MP_T) INIT_MASK;
 547    DECREMENT_STACK_POINTER (p, size);
 548  }
 549  
 550  //! @brief OP +:= = (REF LONG MODE, LONG MODE) REF LONG MODE
 551  
 552  void genie_plusab_mp (NODE_T * p)
 553  {
 554    MOID_T *mode = LHS_MODE (p);
 555    genie_f_and_becomes (p, mode, genie_add_mp);
 556  }
 557  
 558  //! @brief OP -:= = (REF LONG MODE, LONG MODE) REF LONG MODE
 559  
 560  void genie_minusab_mp (NODE_T * p)
 561  {
 562    MOID_T *mode = LHS_MODE (p);
 563    genie_f_and_becomes (p, mode, genie_sub_mp);
 564  }
 565  
 566  //! @brief OP *:= = (REF LONG MODE, LONG MODE) REF LONG MODE
 567  
 568  void genie_timesab_mp (NODE_T * p)
 569  {
 570    MOID_T *mode = LHS_MODE (p);
 571    genie_f_and_becomes (p, mode, genie_mul_mp);
 572  }
 573  
 574  //! @brief OP /:= = (REF LONG MODE, LONG MODE) REF LONG MODE
 575  
 576  void genie_divab_mp (NODE_T * p)
 577  {
 578    MOID_T *mode = LHS_MODE (p);
 579    genie_f_and_becomes (p, mode, genie_div_mp);
 580  }
 581  
 582  //! @brief OP %:= = (REF LONG MODE, LONG MODE) REF LONG MODE
 583  
 584  void genie_overab_mp (NODE_T * p)
 585  {
 586    MOID_T *mode = LHS_MODE (p);
 587    genie_f_and_becomes (p, mode, genie_over_mp);
 588  }
 589  
 590  //! @brief OP %*:= = (REF LONG MODE, LONG MODE) REF LONG MODE
 591  
 592  void genie_modab_mp (NODE_T * p)
 593  {
 594    MOID_T *mode = LHS_MODE (p);
 595    genie_f_and_becomes (p, mode, genie_mod_mp);
 596  }
 597  
 598  // OP (LONG MODE, LONG MODE) BOOL.
 599  
 600  #define A68_CMP_LONG(n, OP)\
 601  void n (NODE_T * p) {\
 602    MOID_T *mode = LHS_MODE (p);\
 603    A68_BOOL z;\
 604    int digs = DIGITS (mode), size = SIZE (mode);\
 605    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);\
 606    MP_T *y = (MP_T *) STACK_OFFSET (-size);\
 607    OP (p, &z, x, y, digs);\
 608    DECREMENT_STACK_POINTER (p, 2 * size);\
 609    PUSH_VALUE (p, VALUE (&z), A68_BOOL);\
 610  }
 611  
 612  A68_CMP_LONG (genie_eq_mp, eq_mp);
 613  A68_CMP_LONG (genie_ne_mp, ne_mp);
 614  A68_CMP_LONG (genie_lt_mp, lt_mp);
 615  A68_CMP_LONG (genie_gt_mp, gt_mp);
 616  A68_CMP_LONG (genie_le_mp, le_mp);
 617  A68_CMP_LONG (genie_ge_mp, ge_mp);
 618  
 619  //! @brief OP ** = (LONG MODE, INT) LONG MODE
 620  
 621  void genie_pow_mp_int (NODE_T * p)
 622  {
 623    MOID_T *mode = LHS_MODE (p);
 624    int digs = DIGITS (mode), size = SIZE (mode);
 625    A68_INT k;
 626    MP_T *x;
 627    POP_OBJECT (p, &k, A68_INT);
 628    x = (MP_T *) STACK_OFFSET (-size);
 629    (void) pow_mp_int (p, x, x, VALUE (&k), digs);
 630    MP_STATUS (x) = (MP_T) INIT_MASK;
 631  }
 632  
 633  //! @brief OP ** = (LONG MODE, LONG MODE) LONG MODE
 634  
 635  void genie_pow_mp (NODE_T * p)
 636  {
 637    MOID_T *mode = LHS_MODE (p);
 638    int digs = DIGITS (mode), size = SIZE (mode);
 639    ADDR_T pop_sp = A68_SP;
 640    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 641    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 642    if (IS_ZERO_MP (x)) {
 643      if (MP_DIGIT (y, 1) < (MP_T) 0) {
 644        PRELUDE_ERROR (A68_TRUE, p, ERROR_INVALID_ARGUMENT, MOID (p));
 645      } else if (IS_ZERO_MP (y)) {
 646        SET_MP_ONE (x, digs);
 647      }
 648    } else {
 649      (void) pow_mp (p, x, x, y, digs);
 650    }
 651    A68_SP = pop_sp - size;
 652    MP_STATUS (x) = (MP_T) INIT_MASK;
 653  }
 654  
 655  //! @brief OP ODD = (LONG INT) BOOL
 656  
 657  void genie_odd_mp (NODE_T * p)
 658  {
 659    MOID_T *mode = LHS_MODE (p);
 660    int digs = DIGITS (mode), size = SIZE (mode);
 661    MP_T *z = (MP_T *) STACK_OFFSET (-size);
 662    DECREMENT_STACK_POINTER (p, size);
 663    if (MP_EXPONENT (z) <= (MP_T) (digs - 1)) {
 664      PUSH_VALUE (p, (BOOL_T) ! EVEN ((MP_INT_T) (z[(int) (2 + MP_EXPONENT (z))])), A68_BOOL);
 665    } else {
 666      PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 667    }
 668  }
 669  
 670  //! @brief Test whether z is a valid LONG INT.
 671  
 672  void test_mp_int_range (NODE_T * p, MP_T * z, MOID_T * m)
 673  {
 674    PRELUDE_ERROR (!check_mp_int (z, m), p, ERROR_OUT_OF_BOUNDS, m);
 675  }
 676  
 677  //! @brief OP + = (LONG INT, LONG INT) LONG INT
 678  
 679  void genie_add_mp_int (NODE_T * p)
 680  {
 681    MOID_T *m = RHS_MODE (p);
 682    int digs = DIGITS (m), size = SIZE (m);
 683    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 684    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 685    (void) add_mp (p, x, x, y, digs);
 686    test_mp_int_range (p, x, m);
 687    MP_STATUS (x) = (MP_T) INIT_MASK;
 688    DECREMENT_STACK_POINTER (p, size);
 689  }
 690  
 691  //! @brief OP - = (LONG INT, LONG INT) LONG INT
 692  
 693  void genie_sub_mp_int (NODE_T * p)
 694  {
 695    MOID_T *m = RHS_MODE (p);
 696    int digs = DIGITS (m), size = SIZE (m);
 697    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 698    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 699    (void) sub_mp (p, x, x, y, digs);
 700    test_mp_int_range (p, x, m);
 701    MP_STATUS (x) = (MP_T) INIT_MASK;
 702    DECREMENT_STACK_POINTER (p, size);
 703  }
 704  
 705  //! @brief OP * = (LONG INT, LONG INT) LONG INT
 706  
 707  void genie_mul_mp_int (NODE_T * p)
 708  {
 709    MOID_T *m = RHS_MODE (p);
 710    int digs = DIGITS (m), size = SIZE (m);
 711    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
 712    MP_T *y = (MP_T *) STACK_OFFSET (-size);
 713    (void) mul_mp (p, x, x, y, digs);
 714    test_mp_int_range (p, x, m);
 715    MP_STATUS (x) = (MP_T) INIT_MASK;
 716    DECREMENT_STACK_POINTER (p, size);
 717  }
 718  
 719  //! @brief OP ** = (LONG MODE, INT) LONG INT
 720  
 721  void genie_pow_mp_int_int (NODE_T * p)
 722  {
 723    MOID_T *m = LHS_MODE (p);
 724    int digs = DIGITS (m), size = SIZE (m);
 725    A68_INT k;
 726    MP_T *x;
 727    POP_OBJECT (p, &k, A68_INT);
 728    x = (MP_T *) STACK_OFFSET (-size);
 729    (void) pow_mp_int (p, x, x, VALUE (&k), digs);
 730    test_mp_int_range (p, x, m);
 731    MP_STATUS (x) = (MP_T) INIT_MASK;
 732  }
 733  
 734  //! @brief OP +:= = (REF LONG INT, LONG INT) REF LONG INT
 735  
 736  void genie_plusab_mp_int (NODE_T * p)
 737  {
 738    MOID_T *mode = LHS_MODE (p);
 739    genie_f_and_becomes (p, mode, genie_add_mp_int);
 740  }
 741  
 742  //! @brief OP -:= = (REF LONG INT, LONG INT) REF LONG INT
 743  
 744  void genie_minusab_mp_int (NODE_T * p)
 745  {
 746    MOID_T *mode = LHS_MODE (p);
 747    genie_f_and_becomes (p, mode, genie_sub_mp_int);
 748  }
 749  
 750  //! @brief OP *:= = (REF LONG INT, LONG INT) REF LONG INT
 751  
 752  void genie_timesab_mp_int (NODE_T * p)
 753  {
 754    MOID_T *mode = LHS_MODE (p);
 755    genie_f_and_becomes (p, mode, genie_mul_mp_int);
 756  }
 757  
 758  //! @brief OP ROUND = (LONG REAL) LONG INT
 759  
 760  void genie_round_mp (NODE_T * p)
 761  {
 762    MOID_T *mode = LHS_MODE (p);
 763    int digs = DIGITS (mode), size = SIZE (mode);
 764    ADDR_T pop_sp = A68_SP;
 765    MP_T *z = (MP_T *) STACK_OFFSET (-size);
 766    (void) round_mp (p, z, z, digs);
 767    A68_SP = pop_sp;
 768  }
 769  
 770  #define C_CL_FUNCTION(p, f)\
 771    MOID_T *mode = MOID (p);\
 772    int digs = DIGITSC (mode), size = SIZEC (mode);\
 773    ADDR_T pop_sp = A68_SP;\
 774    MP_T *im = (MP_T *) STACK_OFFSET (-size);\
 775    MP_T *re = (MP_T *) STACK_OFFSET (-2 * size);\
 776    errno = 0;\
 777    (void) f(p, re, im, digs);\
 778    A68_SP = pop_sp;\
 779    MP_STATUS (re) = (MP_T) INIT_MASK;\
 780    MP_STATUS (im) = (MP_T) INIT_MASK;\
 781    MATH_RTE (p, errno != 0, mode, NO_TEXT);\
 782  
 783  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csqrt
 784  
 785  void genie_sqrt_mp_complex (NODE_T * p)
 786  {
 787    C_CL_FUNCTION (p, csqrt_mp);
 788  }
 789  
 790  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long cexp
 791  
 792  void genie_exp_mp_complex (NODE_T * p)
 793  {
 794    C_CL_FUNCTION (p, cexp_mp);
 795  }
 796  
 797  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long cln
 798  
 799  void genie_ln_mp_complex (NODE_T * p)
 800  {
 801    C_CL_FUNCTION (p, cln_mp);
 802  }
 803  
 804  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csin
 805  
 806  void genie_sin_mp_complex (NODE_T * p)
 807  {
 808    C_CL_FUNCTION (p, csin_mp);
 809  }
 810  
 811  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ccos
 812  
 813  void genie_cos_mp_complex (NODE_T * p)
 814  {
 815    C_CL_FUNCTION (p, ccos_mp);
 816  }
 817  
 818  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ctan
 819  
 820  void genie_tan_mp_complex (NODE_T * p)
 821  {
 822    C_CL_FUNCTION (p, ctan_mp);
 823  }
 824  
 825  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long arcsin
 826  
 827  void genie_asin_mp_complex (NODE_T * p)
 828  {
 829    C_CL_FUNCTION (p, casin_mp);
 830  }
 831  
 832  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carccos
 833  
 834  void genie_acos_mp_complex (NODE_T * p)
 835  {
 836    C_CL_FUNCTION (p, cacos_mp);
 837  }
 838  
 839  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long catan
 840  
 841  void genie_atan_mp_complex (NODE_T * p)
 842  {
 843    C_CL_FUNCTION (p, catan_mp);
 844  }
 845  
 846  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csinh
 847  
 848  void genie_sinh_mp_complex (NODE_T * p)
 849  {
 850    C_CL_FUNCTION (p, csinh_mp);
 851  }
 852  
 853  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ccosh
 854  
 855  void genie_cosh_mp_complex (NODE_T * p)
 856  {
 857    C_CL_FUNCTION (p, ccosh_mp);
 858  }
 859  
 860  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ctanh
 861  
 862  void genie_tanh_mp_complex (NODE_T * p)
 863  {
 864    C_CL_FUNCTION (p, ctanh_mp);
 865  }
 866  
 867  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carcsinh
 868  
 869  void genie_asinh_mp_complex (NODE_T * p)
 870  {
 871    C_CL_FUNCTION (p, casinh_mp);
 872  }
 873  
 874  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carccosh
 875  
 876  void genie_acosh_mp_complex (NODE_T * p)
 877  {
 878    C_CL_FUNCTION (p, cacosh_mp);
 879  }
 880  
 881  //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carctanh
 882  
 883  void genie_atanh_mp_complex (NODE_T * p)
 884  {
 885    C_CL_FUNCTION (p, catanh_mp);
 886  }
 887  
 888  //! @brief OP LENG = (COMPLEX) LONG COMPLEX
 889  
 890  void genie_lengthen_complex_to_mp_complex (NODE_T * p)
 891  {
 892    int digs = DIGITS (M_LONG_REAL);
 893    A68_REAL a, b;
 894    POP_OBJECT (p, &b, A68_REAL);
 895    POP_OBJECT (p, &a, A68_REAL);
 896    MP_T *z = nil_mp (p, digs);
 897    (void) real_to_mp (p, z, VALUE (&a), digs);
 898    MP_STATUS (z) = (MP_T) INIT_MASK;
 899    z = nil_mp (p, digs);
 900    (void) real_to_mp (p, z, VALUE (&b), digs);
 901    MP_STATUS (z) = (MP_T) INIT_MASK;
 902  }
 903  
 904  //! @brief OP SHORTEN = (LONG COMPLEX) COMPLEX
 905  
 906  void genie_shorten_mp_complex_to_complex (NODE_T * p)
 907  {
 908    int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
 909    MP_T *b = (MP_T *) STACK_OFFSET (-size);
 910    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 911    DECREMENT_STACK_POINTER (p, 2 * size);
 912    PUSH_VALUE (p, mp_to_real (p, a, digs), A68_REAL);
 913    PUSH_VALUE (p, mp_to_real (p, b, digs), A68_REAL);
 914  }
 915  
 916  //! @brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX
 917  
 918  void genie_lengthen_mp_complex_to_long_mp_complex (NODE_T * p)
 919  {
 920    int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
 921    int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL);
 922    ADDR_T pop_sp = A68_SP;
 923    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 924    MP_T *b = (MP_T *) STACK_OFFSET (-size);
 925    MP_T *c = len_mp (p, a, digs, gdigs);
 926    MP_T *d = len_mp (p, b, digs, gdigs);
 927    (void) move_mp (a, c, gdigs);
 928    (void) move_mp (&a[LEN_MP (gdigs)], d, gdigs);
 929    A68_SP = pop_sp;
 930    INCREMENT_STACK_POINTER (p, 2 * (size_g - size));
 931  }
 932  
 933  //! @brief OP SHORTEN = (LONG LONG COMPLEX) LONG COMPLEX
 934  
 935  void genie_shorten_long_mp_complex_to_mp_complex (NODE_T * p)
 936  {
 937    int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
 938    int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL);
 939    ADDR_T pop_sp = A68_SP;
 940    MP_T *a, *b;
 941    b = (MP_T *) STACK_OFFSET (-size_g);
 942    a = (MP_T *) STACK_OFFSET (-2 * size_g);
 943    (void) shorten_mp (p, a, digs, a, gdigs);
 944    (void) shorten_mp (p, &a[LEN_MP (digs)], digs, b, gdigs);
 945    A68_SP = pop_sp;
 946    MP_STATUS (a) = (MP_T) INIT_MASK;
 947    MP_STATUS (&a[LEN_MP (digs)]) = (MP_T) INIT_MASK;
 948    DECREMENT_STACK_POINTER (p, 2 * (size_g - size));
 949  }
 950  
 951  //! @brief OP RE = (LONG COMPLEX) LONG REAL
 952  
 953  void genie_re_mp_complex (NODE_T * p)
 954  {
 955    int size = SIZE (SUB_MOID (p));
 956    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 957    MP_STATUS (a) = (MP_T) INIT_MASK;
 958    DECREMENT_STACK_POINTER (p, size);
 959  }
 960  
 961  //! @brief OP IM = (LONG COMPLEX) LONG REAL
 962  
 963  void genie_im_mp_complex (NODE_T * p)
 964  {
 965    MOID_T *mode = SUB_MOID (p);
 966    int digs = DIGITS (mode), size = SIZE (mode);
 967    MP_T *b = (MP_T *) STACK_OFFSET (-size);
 968    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 969    (void) move_mp (a, b, digs);
 970    MP_STATUS (a) = (MP_T) INIT_MASK;
 971    DECREMENT_STACK_POINTER (p, size);
 972  }
 973  
 974  //! @brief OP - = (LONG COMPLEX) LONG COMPLEX
 975  
 976  void genie_minus_mp_complex (NODE_T * p)
 977  {
 978    int size = SIZEC (SUB_MOID (p));
 979    MP_T *b = (MP_T *) STACK_OFFSET (-size);
 980    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 981    MP_DIGIT (a, 1) = -MP_DIGIT (a, 1);
 982    MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
 983    MP_STATUS (a) = (MP_T) INIT_MASK;
 984    MP_STATUS (b) = (MP_T) INIT_MASK;
 985  }
 986  
 987  //! @brief OP CONJ = (LONG COMPLEX) LONG COMPLEX
 988  
 989  void genie_conj_mp_complex (NODE_T * p)
 990  {
 991    int size = SIZEC (SUB_MOID (p));
 992    MP_T *b = (MP_T *) STACK_OFFSET (-size);
 993    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
 994    MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
 995    MP_STATUS (a) = (MP_T) INIT_MASK;
 996    MP_STATUS (b) = (MP_T) INIT_MASK;
 997  }
 998  
 999  //! @brief OP ABS = (LONG COMPLEX) LONG REAL
1000  
1001  void genie_abs_mp_complex (NODE_T * p)
1002  {
1003    MOID_T *mode = SUB_MOID (p);
1004    int digs = DIGITS (mode), size = SIZE (mode);
1005    ADDR_T pop_sp = A68_SP;
1006    MP_T *b = (MP_T *) STACK_OFFSET (-size);
1007    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
1008    MP_T *z = nil_mp (p, digs);
1009    errno = 0;
1010    (void) hypot_mp (p, z, a, b, digs);
1011    A68_SP = pop_sp;
1012    DECREMENT_STACK_POINTER (p, size);
1013    (void) move_mp (a, z, digs);
1014    MP_STATUS (a) = (MP_T) INIT_MASK;
1015    MATH_RTE (p, errno != 0, mode, NO_TEXT);
1016  }
1017  
1018  //! @brief OP ARG = (LONG COMPLEX) LONG REAL
1019  
1020  void genie_arg_mp_complex (NODE_T * p)
1021  {
1022    MOID_T *mode = SUB_MOID (p);
1023    int digs = DIGITS (mode), size = SIZE (mode);
1024    ADDR_T pop_sp = A68_SP;
1025    MP_T *b = (MP_T *) STACK_OFFSET (-size);
1026    MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
1027    MP_T *z = nil_mp (p, digs);
1028    errno = 0;
1029    (void) atan2_mp (p, z, a, b, digs);
1030    A68_SP = pop_sp;
1031    DECREMENT_STACK_POINTER (p, size);
1032    (void) move_mp (a, z, digs);
1033    MP_STATUS (a) = (MP_T) INIT_MASK;
1034    MATH_RTE (p, errno != 0, mode, NO_TEXT);
1035  }
1036  
1037  //! @brief OP + = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1038  
1039  void genie_add_mp_complex (NODE_T * p)
1040  {
1041    MOID_T *mode = SUB_MOID (p);
1042    int digs = DIGITSC (mode), size = SIZEC (mode);
1043    ADDR_T pop_sp = A68_SP;
1044    MP_T *d = (MP_T *) STACK_OFFSET (-size);
1045    MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1046    MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1047    MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1048    (void) add_mp (p, b, b, d, digs);
1049    (void) add_mp (p, a, a, c, digs);
1050    MP_STATUS (a) = (MP_T) INIT_MASK;
1051    MP_STATUS (b) = (MP_T) INIT_MASK;
1052    A68_SP = pop_sp;
1053    DECREMENT_STACK_POINTER (p, 2 * size);
1054  }
1055  
1056  //! @brief OP - = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1057  
1058  void genie_sub_mp_complex (NODE_T * p)
1059  {
1060    MOID_T *mode = SUB_MOID (p);
1061    int digs = DIGITSC (mode), size = SIZEC (mode);
1062    ADDR_T pop_sp = A68_SP;
1063    MP_T *d = (MP_T *) STACK_OFFSET (-size);
1064    MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1065    MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1066    MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1067    (void) sub_mp (p, b, b, d, digs);
1068    (void) sub_mp (p, a, a, c, digs);
1069    MP_STATUS (a) = (MP_T) INIT_MASK;
1070    MP_STATUS (b) = (MP_T) INIT_MASK;
1071    A68_SP = pop_sp;
1072    DECREMENT_STACK_POINTER (p, 2 * size);
1073  }
1074  
1075  //! @brief OP * = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1076  
1077  void genie_mul_mp_complex (NODE_T * p)
1078  {
1079    MOID_T *mode = SUB_MOID (p);
1080    int digs = DIGITSC (mode), size = SIZEC (mode);
1081    ADDR_T pop_sp = A68_SP;
1082    MP_T *d = (MP_T *) STACK_OFFSET (-size);
1083    MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1084    MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1085    MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1086    (void) cmul_mp (p, a, b, c, d, digs);
1087    MP_STATUS (a) = (MP_T) INIT_MASK;
1088    MP_STATUS (b) = (MP_T) INIT_MASK;
1089    A68_SP = pop_sp;
1090    DECREMENT_STACK_POINTER (p, 2 * size);
1091  }
1092  
1093  //! @brief OP / = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1094  
1095  void genie_div_mp_complex (NODE_T * p)
1096  {
1097    MOID_T *mode = SUB_MOID (p);
1098    int digs = DIGITSC (mode), size = SIZEC (mode);
1099    ADDR_T pop_sp = A68_SP;
1100    MP_T *d = (MP_T *) STACK_OFFSET (-size);
1101    MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1102    MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1103    MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1104    PRELUDE_ERROR (cdiv_mp (p, a, b, c, d, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
1105    MP_STATUS (a) = (MP_T) INIT_MASK;
1106    MP_STATUS (b) = (MP_T) INIT_MASK;
1107    A68_SP = pop_sp;
1108    DECREMENT_STACK_POINTER (p, 2 * size);
1109  }
1110  
1111  //! @brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX
1112  
1113  void genie_pow_mp_complex_int (NODE_T * p)
1114  {
1115    MOID_T *mode = SUB_MOID (p);
1116    int digs = DIGITSC (mode), size = SIZEC (mode);
1117    ADDR_T pop_sp;
1118    A68_INT j;
1119    int expo;
1120    BOOL_T negative;
1121    POP_OBJECT (p, &j, A68_INT);
1122    pop_sp = A68_SP;
1123    MP_T *im_x = (MP_T *) STACK_OFFSET (-size);
1124    MP_T *re_x = (MP_T *) STACK_OFFSET (-2 * size);
1125    MP_T *re_z = lit_mp (p, 1, 0, digs);
1126    MP_T *im_z = nil_mp (p, digs);
1127    MP_T *re_y = nil_mp (p, digs);
1128    MP_T *im_y = nil_mp (p, digs);
1129    (void) move_mp (re_y, re_x, digs);
1130    (void) move_mp (im_y, im_x, digs);
1131    MP_T *rea = nil_mp (p, digs);
1132    MP_T *acc = nil_mp (p, digs);
1133    expo = 1;
1134    negative = (BOOL_T) (VALUE (&j) < 0);
1135    if (negative) {
1136      VALUE (&j) = -VALUE (&j);
1137    }
1138    while ((int) expo <= (int) (VALUE (&j))) {
1139      if (expo & VALUE (&j)) {
1140        (void) mul_mp (p, acc, im_z, im_y, digs);
1141        (void) mul_mp (p, rea, re_z, re_y, digs);
1142        (void) sub_mp (p, rea, rea, acc, digs);
1143        (void) mul_mp (p, acc, im_z, re_y, digs);
1144        (void) mul_mp (p, im_z, re_z, im_y, digs);
1145        (void) add_mp (p, im_z, im_z, acc, digs);
1146        (void) move_mp (re_z, rea, digs);
1147      }
1148      (void) mul_mp (p, acc, im_y, im_y, digs);
1149      (void) mul_mp (p, rea, re_y, re_y, digs);
1150      (void) sub_mp (p, rea, rea, acc, digs);
1151      (void) mul_mp (p, acc, im_y, re_y, digs);
1152      (void) mul_mp (p, im_y, re_y, im_y, digs);
1153      (void) add_mp (p, im_y, im_y, acc, digs);
1154      (void) move_mp (re_y, rea, digs);
1155      expo <<= 1;
1156    }
1157    A68_SP = pop_sp;
1158    if (negative) {
1159      SET_MP_ONE (re_x, digs);
1160      SET_MP_ZERO (im_x, digs);
1161      INCREMENT_STACK_POINTER (p, 2 * size);
1162      genie_div_mp_complex (p);
1163    } else {
1164      (void) move_mp (re_x, re_z, digs);
1165      (void) move_mp (im_x, im_z, digs);
1166    }
1167    MP_STATUS (re_x) = (MP_T) INIT_MASK;
1168    MP_STATUS (im_x) = (MP_T) INIT_MASK;
1169  }
1170  
1171  //! @brief OP = = (LONG COMPLEX, LONG COMPLEX) BOOL
1172  
1173  void genie_eq_mp_complex (NODE_T * p)
1174  {
1175    int digs = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p));
1176    ADDR_T pop_sp = A68_SP;
1177    MP_T *d = (MP_T *) STACK_OFFSET (-size);
1178    MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1179    MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1180    MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1181    (void) sub_mp (p, b, b, d, digs);
1182    (void) sub_mp (p, a, a, c, digs);
1183    A68_SP = pop_sp;
1184    DECREMENT_STACK_POINTER (p, 4 * size);
1185    PUSH_VALUE (p, (BOOL_T) (MP_DIGIT (a, 1) == 0 && MP_DIGIT (b, 1) == 0), A68_BOOL);
1186  }
1187  
1188  //! @brief OP /= = (LONG COMPLEX, LONG COMPLEX) BOOL
1189  
1190  void genie_ne_mp_complex (NODE_T * p)
1191  {
1192    int digs = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p));
1193    ADDR_T pop_sp = A68_SP;
1194    MP_T *d = (MP_T *) STACK_OFFSET (-size);
1195    MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1196    MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1197    MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1198    (void) sub_mp (p, b, b, d, digs);
1199    (void) sub_mp (p, a, a, c, digs);
1200    A68_SP = pop_sp;
1201    DECREMENT_STACK_POINTER (p, 4 * size);
1202    PUSH_VALUE (p, (BOOL_T) (MP_DIGIT (a, 1) != 0 || MP_DIGIT (b, 1) != 0), A68_BOOL);
1203  }
1204  
1205  //! @brief OP +:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1206  
1207  void genie_plusab_mp_complex (NODE_T * p)
1208  {
1209    MOID_T *mode = LHS_MODE (p);
1210    genie_f_and_becomes (p, mode, genie_add_mp_complex);
1211  }
1212  
1213  //! @brief OP -:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1214  
1215  void genie_minusab_mp_complex (NODE_T * p)
1216  {
1217    MOID_T *mode = LHS_MODE (p);
1218    genie_f_and_becomes (p, mode, genie_sub_mp_complex);
1219  }
1220  
1221  //! @brief OP *:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1222  
1223  void genie_timesab_mp_complex (NODE_T * p)
1224  {
1225    MOID_T *mode = LHS_MODE (p);
1226    genie_f_and_becomes (p, mode, genie_mul_mp_complex);
1227  }
1228  
1229  //! @brief OP /:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1230  
1231  void genie_divab_mp_complex (NODE_T * p)
1232  {
1233    MOID_T *mode = LHS_MODE (p);
1234    genie_f_and_becomes (p, mode, genie_div_mp_complex);
1235  }
1236  
1237  //! @brief PROC LONG REAL next long random
1238  
1239  void genie_long_next_random (NODE_T * p)
1240  {
1241  // This is 'real width' precision only.
1242    genie_next_random (p);
1243    genie_lengthen_real_to_mp (p);
1244    if (MOID (p) == M_LONG_LONG_REAL) {
1245      genie_lengthen_mp_to_long_mp (p);
1246    }
1247  }
1248  
1249  //! @brief PROC (LONG REAL) LONG REAL long
1250  
1251  void genie_csc_mp (NODE_T * p)
1252  {
1253    C_L_FUNCTION (p, csc_mp);
1254  }
1255  
1256  //! @brief PROC (LONG REAL) LONG REAL long
1257  
1258  void genie_acsc_mp (NODE_T * p)
1259  {
1260    C_L_FUNCTION (p, acsc_mp);
1261  }
1262  
1263  //! @brief PROC (LONG REAL) LONG REAL long
1264  
1265  void genie_sec_mp (NODE_T * p)
1266  {
1267    C_L_FUNCTION (p, sec_mp);
1268  }
1269  
1270  //! @brief PROC (LONG REAL) LONG REAL long
1271  
1272  void genie_asec_mp (NODE_T * p)
1273  {
1274    C_L_FUNCTION (p, asec_mp);
1275  }
1276  
1277  //! @brief PROC (LONG REAL) LONG REAL long
1278  
1279  void genie_cot_mp (NODE_T * p)
1280  {
1281    C_L_FUNCTION (p, cot_mp);
1282  }
1283  
1284  //! @brief PROC (LONG REAL) LONG REAL long
1285  
1286  void genie_acot_mp (NODE_T * p)
1287  {
1288    C_L_FUNCTION (p, acot_mp);
1289  }
1290  
1291  //! @brief PROC (LONG REAL) LONG REAL long
1292  
1293  void genie_sindg_mp (NODE_T * p)
1294  {
1295    C_L_FUNCTION (p, sindg_mp);
1296  }
1297  
1298  //! @brief PROC (LONG REAL) LONG REAL long
1299  
1300  void genie_cosdg_mp (NODE_T * p)
1301  {
1302    C_L_FUNCTION (p, cosdg_mp);
1303  }
1304  
1305  //! @brief PROC (LONG REAL) LONG REAL long
1306  
1307  void genie_tandg_mp (NODE_T * p)
1308  {
1309    C_L_FUNCTION (p, tandg_mp);
1310  }
1311  
1312  //! @brief PROC (LONG REAL) LONG REAL long
1313  
1314  void genie_cotdg_mp (NODE_T * p)
1315  {
1316    C_L_FUNCTION (p, cotdg_mp);
1317  }
1318  
1319  //! @brief PROC (LONG REAL) LONG REAL long
1320  
1321  void genie_asindg_mp (NODE_T * p)
1322  {
1323    C_L_FUNCTION (p, asindg_mp);
1324  }
1325  
1326  //! @brief PROC (LONG REAL) LONG REAL long
1327  
1328  void genie_acosdg_mp (NODE_T * p)
1329  {
1330    C_L_FUNCTION (p, acosdg_mp);
1331  }
1332  
1333  //! @brief PROC (LONG REAL) LONG REAL long
1334  
1335  void genie_atandg_mp (NODE_T * p)
1336  {
1337    C_L_FUNCTION (p, atandg_mp);
1338  }
1339  
1340  //! @brief PROC (LONG REAL) LONG REAL long
1341  
1342  void genie_acotdg_mp (NODE_T * p)
1343  {
1344    C_L_FUNCTION (p, acotdg_mp);
1345  }
1346  
1347  //! @brief PROC (LONG REAL, LONG REAL) LONG REAL long arctan2
1348  
1349  void genie_atan2dg_mp (NODE_T * p)
1350  {
1351    int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
1352    MP_T *y = (MP_T *) STACK_OFFSET (-size);
1353    MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
1354    PRELUDE_ERROR (atan2dg_mp (p, x, y, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
1355    A68_SP -= size;
1356    MP_STATUS (x) = (MP_T) INIT_MASK;
1357  }
1358  
1359  //! @brief PROC (LONG REAL) LONG REAL long
1360  
1361  void genie_sinpi_mp (NODE_T * p)
1362  {
1363    C_L_FUNCTION (p, sinpi_mp);
1364  }
1365  
1366  //! @brief PROC (LONG REAL) LONG REAL long
1367  
1368  void genie_cospi_mp (NODE_T * p)
1369  {
1370    C_L_FUNCTION (p, cospi_mp);
1371  }
1372  
1373  //! @brief PROC (LONG REAL) LONG REAL long
1374  
1375  void genie_cotpi_mp (NODE_T * p)
1376  {
1377    C_L_FUNCTION (p, cotpi_mp);
1378  }
1379  
1380  //! @brief PROC (LONG REAL) LONG REAL long
1381  
1382  void genie_tanpi_mp (NODE_T * p)
1383  {
1384    C_L_FUNCTION (p, tanpi_mp);
1385  }