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