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