mp-bits.c
You can download the current version of Algol 68 Genie and its documentation here.
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 .
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 .
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
jmvdveer@xs4all.nl