mp-bits.c

     
   1  //! @file mp-bits.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  //! [LONG] LONG BITS routines, legacy MP implementation.
  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  #include "a68g-numbers.h"
  32  #include "a68g-transput.h"
  33  
  34  #if (A68_LEVEL <= 2)
  35  
  36  // This legacy code implements a quick-and-dirty LONG LONG BITS mode,
  37  // constructed on top of the LONG LONG INT/REAL/COMPLEX library.
  38  // It was essentially meant to have LONG LONG BITS for demonstration only. 
  39  // There are obvious possibilities to improve this code, but discussions 
  40  // suggested that workers needing long bit strings, in fields such as 
  41  // cryptography, would be better off implementing their own optimally
  42  // efficient tools, and investment in an efficient LONG LONG BITS library
  43  // would not be worth the while.
  44  // Hence in recent a68c versions, LONG BITS is a 128-bit quad word,
  45  // and LONG LONG BITS is mapped onto LONG BITS.
  46  //
  47  // Below code is left in a68g for reference purposes, and in case a build of
  48  // a version < 3 would be required.
  49  
  50  #define MP_BITS_WIDTH(k) ((int) ceil ((k) * LOG_MP_RADIX * CONST_LOG2_10) - 1)
  51  #define MP_BITS_WORDS(k) ((int) ceil ((REAL_T) MP_BITS_WIDTH (k) / (REAL_T) MP_BITS_BITS))
  52  
  53  //! @brief Length in bits of mode.
  54  
  55  int get_mp_bits_width (MOID_T * m)
  56  {
  57    if (m == M_LONG_BITS) {
  58      return MP_BITS_WIDTH (LONG_MP_DIGITS);
  59    } else if (m == M_LONG_LONG_BITS) {
  60      return MP_BITS_WIDTH (A68_MP (varying_mp_digits));
  61    }
  62    return 0;
  63  }
  64  
  65  //! @brief Length in words of mode.
  66  
  67  int get_mp_bits_words (MOID_T * m)
  68  {
  69    if (m == M_LONG_BITS) {
  70      return MP_BITS_WORDS (LONG_MP_DIGITS);
  71    } else if (m == M_LONG_LONG_BITS) {
  72      return MP_BITS_WORDS (A68_MP (varying_mp_digits));
  73    }
  74    return 0;
  75  }
  76  
  77  //! @brief Convert z to a row of MP_BITS_T in the stack.
  78  
  79  MP_BITS_T *stack_mp_bits (NODE_T * p, MP_T * z, MOID_T * m)
  80  {
  81    int digits = DIGITS (m), words = get_mp_bits_words (m), k, lim;
  82    MP_BITS_T *row, mask;
  83    row = (MP_BITS_T *) STACK_ADDRESS (A68_SP);
  84    INCREMENT_STACK_POINTER (p, words * SIZE_ALIGNED (MP_BITS_T));
  85    MP_T *u = nil_mp (p, digits);
  86    MP_T *v = nil_mp (p, digits);
  87    MP_T *w = nil_mp (p, digits);
  88    (void) move_mp (u, z, digits);
  89  // Argument check.
  90    if (MP_DIGIT (u, 1) < 0.0) {
  91      errno = EDOM;
  92      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, m);
  93      exit_genie (p, A68_RUNTIME_ERROR);
  94    }
  95  // Convert radix MP_BITS_RADIX number.
  96    for (k = words - 1; k >= 0; k--) {
  97      (void) move_mp (w, u, digits);
  98      (void) over_mp_digit (p, u, u, (MP_T) MP_BITS_RADIX, digits);
  99      (void) mul_mp_digit (p, v, u, (MP_T) MP_BITS_RADIX, digits);
 100      (void) sub_mp (p, v, w, v, digits);
 101      row[k] = (MP_BITS_T) MP_DIGIT (v, 1);
 102    }
 103  // Test on overflow: too many bits or not reduced to 0.
 104    mask = 0x1;
 105    lim = get_mp_bits_width (m) % MP_BITS_BITS;
 106    for (k = 1; k < lim; k++) {
 107      mask <<= 1;
 108      mask |= 0x1;
 109    }
 110    if ((row[0] & ~mask) != 0x0 || MP_DIGIT (u, 1) != 0.0) {
 111      errno = ERANGE;
 112      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, m);
 113      exit_genie (p, A68_RUNTIME_ERROR);
 114    }
 115  // Exit.
 116    return row;
 117  }
 118  
 119  //! @brief Convert row of MP_BITS_T to LONG BITS.
 120  
 121  MP_T *pack_mp_bits (NODE_T * p, MP_T * u, MP_BITS_T * row, MOID_T * m)
 122  {
 123    int digits = DIGITS (m), words = get_mp_bits_words (m), k, lim;
 124    ADDR_T pop_sp = A68_SP;
 125  // Discard excess bits.
 126    MP_BITS_T mask = 0x1, musk = 0x0;
 127    MP_T *v = nil_mp (p, digits);
 128    MP_T *w = nil_mp (p, digits);
 129    lim = get_mp_bits_width (m) % MP_BITS_BITS;
 130    for (k = 1; k < lim; k++) {
 131      mask <<= 1;
 132      mask |= 0x1;
 133    }
 134    row[0] &= mask;
 135    for (k = 1; k < (BITS_WIDTH - MP_BITS_BITS); k++) {
 136      musk <<= 1;
 137    }
 138    for (k = 0; k < MP_BITS_BITS; k++) {
 139      musk <<= 1;
 140      musk |= 0x1;
 141    }
 142  // Convert.
 143    SET_MP_ZERO (u, digits);
 144    SET_MP_ONE (v, digits);
 145    for (k = words - 1; k >= 0; k--) {
 146      (void) mul_mp_digit (p, w, v, (MP_T) (musk & row[k]), digits);
 147      (void) add_mp (p, u, u, w, digits);
 148      if (k != 0) {
 149        (void) mul_mp_digit (p, v, v, (MP_T) MP_BITS_RADIX, digits);
 150      }
 151    }
 152    MP_STATUS (u) = (MP_T) INIT_MASK;
 153    A68_SP = pop_sp;
 154    return u;
 155  }
 156  
 157  //! @brief Convert multi-precision number to unt.
 158  
 159  UNSIGNED_T mp_to_unt (NODE_T * p, MP_T * z, int digits)
 160  {
 161  // This routine looks a lot like "strtol". We do not use "mp_to_real" since int
 162  // could be wider than 2 ** 52.
 163    int j, expo = (int) MP_EXPONENT (z);
 164    UNSIGNED_T sum = 0, weight = 1;
 165    if (expo >= digits) {
 166      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MOID (p));
 167      exit_genie (p, A68_RUNTIME_ERROR);
 168    }
 169    for (j = 1 + expo; j >= 1; j--) {
 170      UNSIGNED_T term;
 171      if ((unt) MP_DIGIT (z, j) > UINT_MAX / weight) {
 172        diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS);
 173        exit_genie (p, A68_RUNTIME_ERROR);
 174      }
 175      term = (unt) MP_DIGIT (z, j) * weight;
 176      if (sum > UINT_MAX - term) {
 177        diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS);
 178        exit_genie (p, A68_RUNTIME_ERROR);
 179      }
 180      sum += term;
 181      weight *= MP_RADIX;
 182    }
 183    return sum;
 184  }
 185  
 186  //! @brief Whether LONG BITS value is in range.
 187  
 188  void check_long_bits_value (NODE_T * p, MP_T * u, MOID_T * m)
 189  {
 190    if (MP_EXPONENT (u) >= (MP_T) (DIGITS (m) - 1)) {
 191      ADDR_T pop_sp = A68_SP;
 192      (void) stack_mp_bits (p, u, m);
 193      A68_SP = pop_sp;
 194    }
 195  }
 196  
 197  //! @brief LONG BITS value of LONG BITS denotation
 198  
 199  void mp_strtou (NODE_T * p, MP_T * z, char *str, MOID_T * m)
 200  {
 201    int base = 0;
 202    char *radix = NO_TEXT;
 203    errno = 0;
 204    base = (int) a68_strtou (str, &radix, 10);
 205    if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) {
 206      int digits = DIGITS (m);
 207      ADDR_T pop_sp = A68_SP;
 208      char *q = radix;
 209      MP_T *v = nil_mp (p, digits);
 210      MP_T *w = nil_mp (p, digits);
 211      while (q[0] != NULL_CHAR) {
 212        q++;
 213      }
 214      SET_MP_ZERO (z, digits);
 215      SET_MP_ONE (w, digits);
 216      if (base < 2 || base > 16) {
 217        diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base);
 218        exit_genie (p, A68_RUNTIME_ERROR);
 219      }
 220      while ((--q) != radix) {
 221        int digit = char_value (q[0]);
 222        if (digit >= 0 && digit < base) {
 223          (void) mul_mp_digit (p, v, w, (MP_T) digit, digits);
 224          (void) add_mp (p, z, z, v, digits);
 225        } else {
 226          diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m);
 227          exit_genie (p, A68_RUNTIME_ERROR);
 228        }
 229        (void) mul_mp_digit (p, w, w, (MP_T) base, digits);
 230      }
 231      check_long_bits_value (p, z, m);
 232      A68_SP = pop_sp;
 233    } else {
 234      diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m);
 235      exit_genie (p, A68_RUNTIME_ERROR);
 236    }
 237  }
 238  
 239  //! @brief Convert to other radix, binary up to hexadecimal.
 240  
 241  BOOL_T convert_radix_mp (NODE_T * p, MP_T * u, int radix, int width, MOID_T * m, MP_T * v, MP_T * w)
 242  {
 243    static char *images = "0123456789abcdef";
 244    if (width > 0 && (radix >= 2 && radix <= 16)) {
 245      MP_INT_T digit;
 246      int digits = DIGITS (m);
 247      BOOL_T success;
 248      (void) move_mp (w, u, digits);
 249      (void) over_mp_digit (p, u, u, (MP_T) radix, digits);
 250      (void) mul_mp_digit (p, v, u, (MP_T) radix, digits);
 251      (void) sub_mp (p, v, w, v, digits);
 252      digit = (MP_INT_T) MP_DIGIT (v, 1);
 253      success = convert_radix_mp (p, u, radix, width - 1, m, v, w);
 254      plusab_transput_buffer (p, EDIT_BUFFER, images[digit]);
 255      return success;
 256    } else {
 257      return (BOOL_T) (MP_DIGIT (u, 1) == 0);
 258    }
 259  }
 260  
 261  //! @brief OP LENG = (BITS) LONG BITS
 262  
 263  void genie_lengthen_unt_to_mp (NODE_T * p)
 264  {
 265    int digits = DIGITS (M_LONG_INT);
 266    A68_BITS k;
 267    POP_OBJECT (p, &k, A68_BITS);
 268    MP_T *z = nil_mp (p, digits);
 269    (void) unt_to_mp (p, z, (UNSIGNED_T) VALUE (&k), digits);
 270    MP_STATUS (z) = (MP_T) INIT_MASK;
 271  }
 272  
 273  //! @brief OP BIN = (LONG INT) LONG BITS
 274  
 275  void genie_bin_mp (NODE_T * p)
 276  {
 277    MOID_T *mode = SUB_MOID (p);
 278    int size = SIZE (mode);
 279    ADDR_T pop_sp = A68_SP;
 280    MP_T *u = (MP_T *) STACK_OFFSET (-size);
 281  // We convert just for the operand check.
 282    (void) stack_mp_bits (p, u, mode);
 283    MP_STATUS (u) = (MP_T) INIT_MASK;
 284    A68_SP = pop_sp;
 285  }
 286  
 287  //! @brief OP NOT = (LONG BITS) LONG BITS
 288  
 289  void genie_not_mp (NODE_T * p)
 290  {
 291    MOID_T *mode = LHS_MODE (p);
 292    int size = SIZE (mode);
 293    ADDR_T pop_sp = A68_SP;
 294    int k, words = get_mp_bits_words (mode);
 295    MP_T *u = (MP_T *) STACK_OFFSET (-size);
 296    MP_BITS_T *row = stack_mp_bits (p, u, mode);
 297    for (k = 0; k < words; k++) {
 298      row[k] = ~row[k];
 299    }
 300    (void) pack_mp_bits (p, u, row, mode);
 301    A68_SP = pop_sp;
 302  }
 303  
 304  //! @brief OP SHORTEN = (LONG BITS) BITS
 305  
 306  void genie_shorten_mp_to_bits (NODE_T * p)
 307  {
 308    MOID_T *mode = LHS_MODE (p);
 309    int digits = DIGITS (mode), size = SIZE (mode);
 310    MP_T *z = (MP_T *) STACK_OFFSET (-size);
 311    DECREMENT_STACK_POINTER (p, size);
 312    PUSH_VALUE (p, mp_to_unt (p, z, digits), A68_BITS);
 313  }
 314  
 315  //! @brief Get bit from LONG BITS.
 316  
 317  unt elem_long_bits (NODE_T * p, ADDR_T k, MP_T * z, MOID_T * m)
 318  {
 319    int n;
 320    ADDR_T pop_sp = A68_SP;
 321    MP_BITS_T *words = stack_mp_bits (p, z, m), mask = 0x1;
 322    k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1);
 323    for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) {
 324      mask = mask << 1;
 325    }
 326    A68_SP = pop_sp;
 327    return (words[k / MP_BITS_BITS]) & mask;
 328  }
 329  
 330  //! @brief OP ELEM = (INT, LONG BITS) BOOL
 331  
 332  void genie_elem_long_bits (NODE_T * p)
 333  {
 334    A68_INT *i;
 335    MP_T *z;
 336    MP_BITS_T w;
 337    int bits = get_mp_bits_width (M_LONG_BITS), size = SIZE (M_LONG_BITS);
 338    z = (MP_T *) STACK_OFFSET (-size);
 339    i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT)));
 340    PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT);
 341    w = elem_long_bits (p, VALUE (i), z, M_LONG_BITS);
 342    DECREMENT_STACK_POINTER (p, size + SIZE (M_INT));
 343    PUSH_VALUE (p, (BOOL_T) (w != 0), A68_BOOL);
 344  }
 345  
 346  //! @brief OP ELEM = (INT, LONG LONG BITS) BOOL
 347  
 348  void genie_elem_long_mp_bits (NODE_T * p)
 349  {
 350    A68_INT *i;
 351    MP_T *z;
 352    MP_BITS_T w;
 353    int bits = get_mp_bits_width (M_LONG_LONG_BITS), size = SIZE (M_LONG_LONG_BITS);
 354    z = (MP_T *) STACK_OFFSET (-size);
 355    i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT)));
 356    PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT);
 357    w = elem_long_bits (p, VALUE (i), z, M_LONG_LONG_BITS);
 358    DECREMENT_STACK_POINTER (p, size + SIZE (M_INT));
 359    PUSH_VALUE (p, (BOOL_T) (w != 0), A68_BOOL);
 360  }
 361  
 362  //! @brief Set bit in LONG BITS.
 363  
 364  MP_BITS_T *set_long_bits (NODE_T * p, int k, MP_T * z, MOID_T * m, MP_BITS_T bit)
 365  {
 366    int n;
 367    MP_BITS_T *words = stack_mp_bits (p, z, m), mask = 0x1;
 368    k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1);
 369    for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) {
 370      mask = mask << 1;
 371    }
 372    if (bit == 0x1) {
 373      words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) | mask;
 374    } else {
 375      words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) & (~mask);
 376    }
 377    return words;
 378  }
 379  
 380  //! @brief OP SET = (INT, LONG BITS) VOID
 381  
 382  void genie_set_long_bits (NODE_T * p)
 383  {
 384    A68_INT *i;
 385    MP_T *z;
 386    MP_BITS_T *w;
 387    ADDR_T pop_sp = A68_SP;
 388    int bits = get_mp_bits_width (M_LONG_BITS), size = SIZE (M_LONG_BITS);
 389    z = (MP_T *) STACK_OFFSET (-size);
 390    i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT)));
 391    PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT);
 392    w = set_long_bits (p, VALUE (i), z, M_LONG_BITS, 0x1);
 393    (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_BITS);
 394    A68_SP = pop_sp;
 395    DECREMENT_STACK_POINTER (p, SIZE (M_INT));
 396  }
 397  
 398  //! @brief OP SET = (INT, LONG LONG BITS) BOOL
 399  
 400  void genie_set_long_mp_bits (NODE_T * p)
 401  {
 402    A68_INT *i;
 403    MP_T *z;
 404    MP_BITS_T *w;
 405    ADDR_T pop_sp = A68_SP;
 406    int bits = get_mp_bits_width (M_LONG_LONG_BITS), size = SIZE (M_LONG_LONG_BITS);
 407    z = (MP_T *) STACK_OFFSET (-size);
 408    i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT)));
 409    PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT);
 410    w = set_long_bits (p, VALUE (i), z, M_LONG_LONG_BITS, 0x1);
 411    (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_LONG_BITS);
 412    A68_SP = pop_sp;
 413    DECREMENT_STACK_POINTER (p, SIZE (M_INT));
 414  }
 415  
 416  //! @brief OP CLEAR = (INT, LONG BITS) BOOL
 417  
 418  void genie_clear_long_bits (NODE_T * p)
 419  {
 420    A68_INT *i;
 421    MP_T *z;
 422    MP_BITS_T *w;
 423    ADDR_T pop_sp = A68_SP;
 424    int bits = get_mp_bits_width (M_LONG_BITS), size = SIZE (M_LONG_BITS);
 425    z = (MP_T *) STACK_OFFSET (-size);
 426    i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT)));
 427    PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT);
 428    w = set_long_bits (p, VALUE (i), z, M_LONG_BITS, 0x0);
 429    (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_BITS);
 430    A68_SP = pop_sp;
 431    DECREMENT_STACK_POINTER (p, SIZE (M_INT));
 432  }
 433  
 434  //! @brief OP CLEAR = (INT, LONG LONG BITS) BOOL
 435  
 436  void genie_clear_long_mp_bits (NODE_T * p)
 437  {
 438    A68_INT *i;
 439    MP_T *z;
 440    MP_BITS_T *w;
 441    ADDR_T pop_sp = A68_SP;
 442    int bits = get_mp_bits_width (M_LONG_LONG_BITS), size = SIZE (M_LONG_LONG_BITS);
 443    z = (MP_T *) STACK_OFFSET (-size);
 444    i = (A68_INT *) STACK_OFFSET (-(size + SIZE (M_INT)));
 445    PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, M_INT);
 446    w = set_long_bits (p, VALUE (i), z, M_LONG_LONG_BITS, 0x0);
 447    (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (M_INT)), w, M_LONG_LONG_BITS);
 448    A68_SP = pop_sp;
 449    DECREMENT_STACK_POINTER (p, SIZE (M_INT));
 450  }
 451  
 452  //! @brief PROC long bits pack = ([] BOOL) LONG BITS
 453  
 454  void genie_long_bits_pack (NODE_T * p)
 455  {
 456    MOID_T *mode = MOID (p);
 457    A68_REF z;
 458    A68_ARRAY *arr;
 459    A68_TUPLE *tup;
 460    BYTE_T *base;
 461    int size, k, bits, digits;
 462    ADDR_T pop_sp;
 463    POP_REF (p, &z);
 464    CHECK_REF (p, z, M_ROW_BOOL);
 465    GET_DESCRIPTOR (arr, tup, &z);
 466    size = ROW_SIZE (tup);
 467    bits = get_mp_bits_width (mode);
 468    digits = DIGITS (mode);
 469    PRELUDE_ERROR (size < 0 || size > bits, p, ERROR_OUT_OF_BOUNDS, M_ROW_BOOL);
 470  // Convert so that LWB goes to MSB, so ELEM gives same order as [] BOOL.
 471    MP_T *sum = nil_mp (p, digits);
 472    pop_sp = A68_SP;
 473    MP_T *fact = lit_mp (p, 1, 0, digits);
 474    if (ROW_SIZE (tup) > 0) {
 475      base = DEREF (BYTE_T, &ARRAY (arr));
 476      for (k = UPB (tup); k >= LWB (tup); k--) {
 477        int addr = INDEX_1_DIM (arr, tup, k);
 478        A68_BOOL *boo = (A68_BOOL *) & (base[addr]);
 479        CHECK_INIT (p, INITIALISED (boo), M_BOOL);
 480        if (VALUE (boo)) {
 481          (void) add_mp (p, sum, sum, fact, digits);
 482        }
 483        (void) mul_mp_digit (p, fact, fact, (MP_T) 2, digits);
 484      }
 485    }
 486    A68_SP = pop_sp;
 487    MP_STATUS (sum) = (MP_T) INIT_MASK;
 488  }
 489  
 490  //! @brief OP SHL = (LONG BITS, INT) LONG BITS
 491  
 492  void genie_shl_mp (NODE_T * p)
 493  {
 494    MOID_T *mode = LHS_MODE (p);
 495    int i, k, size = SIZE (mode), words = get_mp_bits_words (mode);
 496    MP_T *u;
 497    MP_BITS_T *row_u;
 498    ADDR_T pop_sp;
 499    A68_INT j;
 500  // Pop number of bits.
 501    POP_OBJECT (p, &j, A68_INT);
 502    u = (MP_T *) STACK_OFFSET (-size);
 503    pop_sp = A68_SP;
 504    row_u = stack_mp_bits (p, u, mode);
 505    if (VALUE (&j) >= 0) {
 506      for (i = 0; i < VALUE (&j); i++) {
 507        BOOL_T carry = A68_FALSE;
 508        for (k = words - 1; k >= 0; k--) {
 509          row_u[k] <<= 1;
 510          if (carry) {
 511            row_u[k] |= 0x1;
 512          }
 513          carry = (BOOL_T) ((row_u[k] & MP_BITS_RADIX) != 0);
 514          row_u[k] &= ~((MP_BITS_T) MP_BITS_RADIX);
 515        }
 516      }
 517    } else {
 518      for (i = 0; i < -VALUE (&j); i++) {
 519        BOOL_T carry = A68_FALSE;
 520        for (k = 0; k < words; k++) {
 521          if (carry) {
 522            row_u[k] |= MP_BITS_RADIX;
 523          }
 524          carry = (BOOL_T) ((row_u[k] & 0x1) != 0);
 525          row_u[k] >>= 1;
 526        }
 527      }
 528    }
 529    (void) pack_mp_bits (p, u, row_u, mode);
 530    A68_SP = pop_sp;
 531  }
 532  
 533  //! @brief OP SHR = (LONG BITS, INT) LONG BITS
 534  
 535  void genie_shr_mp (NODE_T * p)
 536  {
 537    A68_INT *j;
 538    POP_OPERAND_ADDRESS (p, j, A68_INT);
 539    VALUE (j) = -VALUE (j);
 540    (void) genie_shl_mp (p);      // Conform RR
 541  }
 542  
 543  //! @brief OP <= = (LONG BITS, LONG BITS) BOOL
 544  
 545  void genie_le_long_bits (NODE_T * p)
 546  {
 547    MOID_T *mode = LHS_MODE (p);
 548    int k, size = SIZE (mode), words = get_mp_bits_words (mode);
 549    ADDR_T pop_sp = A68_SP;
 550    BOOL_T result = A68_TRUE;
 551    MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
 552    MP_BITS_T *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
 553    for (k = 0; (k < words) && result; k++) {
 554      result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_v[k]));
 555    }
 556    A68_SP = pop_sp;
 557    DECREMENT_STACK_POINTER (p, 2 * size);
 558    PUSH_VALUE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL);
 559  }
 560  
 561  //! @brief OP >= = (LONG BITS, LONG BITS) BOOL
 562  
 563  void genie_ge_long_bits (NODE_T * p)
 564  {
 565    MOID_T *mode = LHS_MODE (p);
 566    int k, size = SIZE (mode), words = get_mp_bits_words (mode);
 567    ADDR_T pop_sp = A68_SP;
 568    BOOL_T result = A68_TRUE;
 569    MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
 570    MP_BITS_T *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
 571    for (k = 0; (k < words) && result; k++) {
 572      result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_u[k]));
 573    }
 574    A68_SP = pop_sp;
 575    DECREMENT_STACK_POINTER (p, 2 * size);
 576    PUSH_VALUE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL);
 577  }
 578  
 579  //! @brief OP AND = (LONG BITS, LONG BITS) LONG BITS
 580  
 581  void genie_and_mp (NODE_T * p)
 582  {
 583    MOID_T *mode = LHS_MODE (p);
 584    int k, size = SIZE (mode), words = get_mp_bits_words (mode);
 585    ADDR_T pop_sp = A68_SP;
 586    MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
 587    MP_BITS_T *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
 588    for (k = 0; k < words; k++) {
 589      row_u[k] &= row_v[k];
 590    }
 591    (void) pack_mp_bits (p, u, row_u, mode);
 592    A68_SP = pop_sp;
 593    DECREMENT_STACK_POINTER (p, size);
 594  }
 595  
 596  //! @brief OP OR = (LONG BITS, LONG BITS) LONG BITS
 597  
 598  void genie_or_mp (NODE_T * p)
 599  {
 600    MOID_T *mode = LHS_MODE (p);
 601    int k, size = SIZE (mode), words = get_mp_bits_words (mode);
 602    ADDR_T pop_sp = A68_SP;
 603    MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
 604    MP_BITS_T *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
 605    for (k = 0; k < words; k++) {
 606      row_u[k] |= row_v[k];
 607    }
 608    (void) pack_mp_bits (p, u, row_u, mode);
 609    A68_SP = pop_sp;
 610    DECREMENT_STACK_POINTER (p, size);
 611  }
 612  
 613  //! @brief OP XOR = (LONG BITS, LONG BITS) LONG BITS
 614  
 615  void genie_xor_mp (NODE_T * p)
 616  {
 617    MOID_T *mode = LHS_MODE (p);
 618    int k, size = SIZE (mode), words = get_mp_bits_words (mode);
 619    ADDR_T pop_sp = A68_SP;
 620    MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size);
 621    MP_BITS_T *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode);
 622    for (k = 0; k < words; k++) {
 623      row_u[k] ^= row_v[k];
 624    }
 625    (void) pack_mp_bits (p, u, row_u, mode);
 626    A68_SP = pop_sp;
 627    DECREMENT_STACK_POINTER (p, size);
 628  }
 629  
 630  //! @brief LONG BITS long max bits
 631  
 632  void genie_long_max_bits (NODE_T * p)
 633  {
 634    int digits = DIGITS (M_LONG_BITS);
 635    int width = get_mp_bits_width (M_LONG_BITS);
 636    ADDR_T pop_sp;
 637    MP_T *z = nil_mp (p, digits);
 638    pop_sp = A68_SP;
 639    (void) set_mp (z, (MP_T) 2, 0, digits);
 640    (void) pow_mp_int (p, z, z, width, digits);
 641    (void) minus_one_mp (p, z, z, digits);
 642    A68_SP = pop_sp;
 643  }
 644  
 645  //! @brief LONG LONG BITS long long max bits
 646  
 647  void genie_long_mp_max_bits (NODE_T * p)
 648  {
 649    int digits = DIGITS (M_LONG_LONG_BITS);
 650    int width = get_mp_bits_width (M_LONG_LONG_BITS);
 651    MP_T *z = nil_mp (p, digits);
 652    ADDR_T pop_sp = A68_SP;
 653    (void) set_mp (z, (MP_T) 2, 0, digits);
 654    (void) pow_mp_int (p, z, z, width, digits);
 655    (void) minus_one_mp (p, z, z, digits);
 656    A68_SP = pop_sp;
 657  }
 658  
 659  //! @brief Lengthen LONG BITS to [] BOOL.
 660  
 661  void genie_lengthen_long_bits_to_row_bool (NODE_T * p)
 662  {
 663    MOID_T *m = MOID (SUB (p));
 664    A68_REF z, row;
 665    A68_ARRAY arr;
 666    A68_TUPLE tup;
 667    int size = SIZE (m), k, width = get_mp_bits_width (m), words = get_mp_bits_words (m);
 668    MP_BITS_T *bits;
 669    BYTE_T *base;
 670    MP_T *x;
 671    ADDR_T pop_sp = A68_SP;
 672  // Calculate and convert BITS value.
 673    x = (MP_T *) STACK_OFFSET (-size);
 674    bits = stack_mp_bits (p, x, m);
 675  // Make [] BOOL.
 676    NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, width);
 677    PUT_DESCRIPTOR (arr, tup, &z);
 678    base = ADDRESS (&row) + (width - 1) * SIZE (M_BOOL);
 679    k = width;
 680    while (k > 0) {
 681      MP_BITS_T bit = 0x1;
 682      int j;
 683      for (j = 0; j < MP_BITS_BITS && k >= 0; j++) {
 684        STATUS ((A68_BOOL *) base) = INIT_MASK;
 685        VALUE ((A68_BOOL *) base) = (BOOL_T) ((bits[words - 1] & bit) ? A68_TRUE : A68_FALSE);
 686        base -= SIZE (M_BOOL);
 687        bit <<= 1;
 688        k--;
 689      }
 690      words--;
 691    }
 692    A68_SP = pop_sp;
 693    PUSH_REF (p, z);
 694  }
 695  
 696  #endif