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