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-2024 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 unt 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 unt 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 A68_INT k;
137 POP_OBJECT (p, &k, A68_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), A68_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 A68_REAL x;
161 POP_OBJECT (p, &x, A68_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), A68_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 = A68_SP;
185 MP_T *z = (MP_T *) STACK_OFFSET (-size);
186 (void) entier_mp (p, z, z, digs);
187 A68_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 = A68_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 A68_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 A68_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 A68_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 A68_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 A68_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 (A68_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 int 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 int 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 int 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)), A68_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 A68_CMP_LONG(n, OP)\
605 void n (NODE_T * p) {\
606 MOID_T *mode = LHS_MODE (p);\
607 A68_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), A68_BOOL);\
614 }
615
616 A68_CMP_LONG (genie_eq_mp, eq_mp);
617 A68_CMP_LONG (genie_ne_mp, ne_mp);
618 A68_CMP_LONG (genie_lt_mp, lt_mp);
619 A68_CMP_LONG (genie_gt_mp, gt_mp);
620 A68_CMP_LONG (genie_le_mp, le_mp);
621 A68_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 A68_INT k;
630 POP_OBJECT (p, &k, A68_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 = A68_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 (A68_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 A68_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))])), A68_BOOL);
668 } else {
669 PUSH_VALUE (p, A68_FALSE, A68_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 A68_INT k;
729 POP_OBJECT (p, &k, A68_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 = A68_SP;
767 MP_T *z = (MP_T *) STACK_OFFSET (-size);
768 (void) round_mp (p, z, z, digs);
769 A68_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 = A68_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 A68_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 A68_REAL a, b;
896 POP_OBJECT (p, &b, A68_REAL);
897 POP_OBJECT (p, &a, A68_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_VALUE (p, mp_to_real (p, a, digs), A68_REAL);
915 PUSH_VALUE (p, mp_to_real (p, b, digs), A68_REAL);
916 }
917
918 //! @brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX
919
920 void genie_lengthen_mp_complex_to_long_mp_complex (NODE_T * p)
921 {
922 int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
923 int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL);
924 ADDR_T pop_sp = A68_SP;
925 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
926 MP_T *b = (MP_T *) STACK_OFFSET (-size);
927 MP_T *c = len_mp (p, a, digs, gdigs);
928 MP_T *d = len_mp (p, b, digs, gdigs);
929 (void) move_mp (a, c, gdigs);
930 (void) move_mp (&a[LEN_MP (gdigs)], d, gdigs);
931 A68_SP = pop_sp;
932 INCREMENT_STACK_POINTER (p, 2 * (size_g - size));
933 }
934
935 //! @brief OP SHORTEN = (LONG LONG COMPLEX) LONG COMPLEX
936
937 void genie_shorten_long_mp_complex_to_mp_complex (NODE_T * p)
938 {
939 int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
940 int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL);
941 ADDR_T pop_sp = A68_SP;
942 MP_T *b = (MP_T *) STACK_OFFSET (-size_g);
943 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size_g);
944 (void) shorten_mp (p, a, digs, a, gdigs);
945 (void) shorten_mp (p, &a[LEN_MP (digs)], digs, b, gdigs);
946 A68_SP = pop_sp;
947 MP_STATUS (a) = (MP_T) INIT_MASK;
948 MP_STATUS (&a[LEN_MP (digs)]) = (MP_T) INIT_MASK;
949 DECREMENT_STACK_POINTER (p, 2 * (size_g - size));
950 }
951
952 //! @brief OP RE = (LONG COMPLEX) LONG REAL
953
954 void genie_re_mp_complex (NODE_T * p)
955 {
956 int size = SIZE (SUB_MOID (p));
957 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
958 MP_STATUS (a) = (MP_T) INIT_MASK;
959 DECREMENT_STACK_POINTER (p, size);
960 }
961
962 //! @brief OP IM = (LONG COMPLEX) LONG REAL
963
964 void genie_im_mp_complex (NODE_T * p)
965 {
966 MOID_T *mode = SUB_MOID (p);
967 int digs = DIGITS (mode), size = SIZE (mode);
968 MP_T *b = (MP_T *) STACK_OFFSET (-size);
969 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
970 (void) move_mp (a, b, digs);
971 MP_STATUS (a) = (MP_T) INIT_MASK;
972 DECREMENT_STACK_POINTER (p, size);
973 }
974
975 //! @brief OP - = (LONG COMPLEX) LONG COMPLEX
976
977 void genie_minus_mp_complex (NODE_T * p)
978 {
979 int size = SIZE_COMPL (SUB_MOID (p));
980 MP_T *b = (MP_T *) STACK_OFFSET (-size);
981 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
982 MP_DIGIT (a, 1) = -MP_DIGIT (a, 1);
983 MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
984 MP_STATUS (a) = (MP_T) INIT_MASK;
985 MP_STATUS (b) = (MP_T) INIT_MASK;
986 }
987
988 //! @brief OP CONJ = (LONG COMPLEX) LONG COMPLEX
989
990 void genie_conj_mp_complex (NODE_T * p)
991 {
992 int size = SIZE_COMPL (SUB_MOID (p));
993 MP_T *b = (MP_T *) STACK_OFFSET (-size);
994 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
995 MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
996 MP_STATUS (a) = (MP_T) INIT_MASK;
997 MP_STATUS (b) = (MP_T) INIT_MASK;
998 }
999
1000 //! @brief OP ABS = (LONG COMPLEX) LONG REAL
1001
1002 void genie_abs_mp_complex (NODE_T * p)
1003 {
1004 MOID_T *mode = SUB_MOID (p);
1005 int digs = DIGITS (mode), size = SIZE (mode);
1006 ADDR_T pop_sp = A68_SP;
1007 MP_T *b = (MP_T *) STACK_OFFSET (-size);
1008 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
1009 MP_T *z = nil_mp (p, digs);
1010 errno = 0;
1011 (void) hypot_mp (p, z, a, b, digs);
1012 A68_SP = pop_sp;
1013 DECREMENT_STACK_POINTER (p, size);
1014 (void) move_mp (a, z, digs);
1015 MP_STATUS (a) = (MP_T) INIT_MASK;
1016 MATH_RTE (p, errno != 0, mode, NO_TEXT);
1017 }
1018
1019 //! @brief OP ARG = (LONG COMPLEX) LONG REAL
1020
1021 void genie_arg_mp_complex (NODE_T * p)
1022 {
1023 MOID_T *mode = SUB_MOID (p);
1024 int digs = DIGITS (mode), size = SIZE (mode);
1025 ADDR_T pop_sp = A68_SP;
1026 MP_T *b = (MP_T *) STACK_OFFSET (-size);
1027 MP_T *a = (MP_T *) STACK_OFFSET (-2 * size);
1028 MP_T *z = nil_mp (p, digs);
1029 errno = 0;
1030 (void) atan2_mp (p, z, a, b, digs);
1031 A68_SP = pop_sp;
1032 DECREMENT_STACK_POINTER (p, size);
1033 (void) move_mp (a, z, digs);
1034 MP_STATUS (a) = (MP_T) INIT_MASK;
1035 MATH_RTE (p, errno != 0, mode, NO_TEXT);
1036 }
1037
1038 //! @brief OP + = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1039
1040 void genie_add_mp_complex (NODE_T * p)
1041 {
1042 MOID_T *mode = SUB_MOID (p);
1043 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1044 ADDR_T pop_sp = A68_SP;
1045 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1046 MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1047 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1048 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1049 (void) add_mp (p, b, b, d, digs);
1050 (void) add_mp (p, a, a, c, digs);
1051 MP_STATUS (a) = (MP_T) INIT_MASK;
1052 MP_STATUS (b) = (MP_T) INIT_MASK;
1053 A68_SP = pop_sp;
1054 DECREMENT_STACK_POINTER (p, 2 * size);
1055 }
1056
1057 //! @brief OP - = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1058
1059 void genie_sub_mp_complex (NODE_T * p)
1060 {
1061 MOID_T *mode = SUB_MOID (p);
1062 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1063 ADDR_T pop_sp = A68_SP;
1064 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1065 MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1066 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1067 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1068 (void) sub_mp (p, b, b, d, digs);
1069 (void) sub_mp (p, a, a, c, digs);
1070 MP_STATUS (a) = (MP_T) INIT_MASK;
1071 MP_STATUS (b) = (MP_T) INIT_MASK;
1072 A68_SP = pop_sp;
1073 DECREMENT_STACK_POINTER (p, 2 * size);
1074 }
1075
1076 //! @brief OP * = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1077
1078 void genie_mul_mp_complex (NODE_T * p)
1079 {
1080 MOID_T *mode = SUB_MOID (p);
1081 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1082 ADDR_T pop_sp = A68_SP;
1083 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1084 MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1085 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1086 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1087 (void) cmul_mp (p, a, b, c, d, digs);
1088 MP_STATUS (a) = (MP_T) INIT_MASK;
1089 MP_STATUS (b) = (MP_T) INIT_MASK;
1090 A68_SP = pop_sp;
1091 DECREMENT_STACK_POINTER (p, 2 * size);
1092 }
1093
1094 //! @brief OP / = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1095
1096 void genie_div_mp_complex (NODE_T * p)
1097 {
1098 MOID_T *mode = SUB_MOID (p);
1099 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1100 ADDR_T pop_sp = A68_SP;
1101 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1102 MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1103 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1104 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1105 PRELUDE_ERROR (cdiv_mp (p, a, b, c, d, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
1106 MP_STATUS (a) = (MP_T) INIT_MASK;
1107 MP_STATUS (b) = (MP_T) INIT_MASK;
1108 A68_SP = pop_sp;
1109 DECREMENT_STACK_POINTER (p, 2 * size);
1110 }
1111
1112 //! @brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX
1113
1114 void genie_pow_mp_complex_int (NODE_T * p)
1115 {
1116 MOID_T *mode = SUB_MOID (p);
1117 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1118 A68_INT j;
1119 POP_OBJECT (p, &j, A68_INT);
1120 ADDR_T pop_sp = A68_SP;
1121 MP_T *im_x = (MP_T *) STACK_OFFSET (-size);
1122 MP_T *re_x = (MP_T *) STACK_OFFSET (-2 * size);
1123 MP_T *re_z = lit_mp (p, 1, 0, digs);
1124 MP_T *im_z = nil_mp (p, digs);
1125 MP_T *re_y = nil_mp (p, digs);
1126 MP_T *im_y = nil_mp (p, digs);
1127 (void) move_mp (re_y, re_x, digs);
1128 (void) move_mp (im_y, im_x, digs);
1129 MP_T *rea = nil_mp (p, digs);
1130 MP_T *acc = nil_mp (p, digs);
1131 int expo = 1;
1132 BOOL_T negative = (BOOL_T) (VALUE (&j) < 0);
1133 if (negative) {
1134 VALUE (&j) = -VALUE (&j);
1135 }
1136 while ((int) expo <= (int) (VALUE (&j))) {
1137 if (expo & VALUE (&j)) {
1138 (void) mul_mp (p, acc, im_z, im_y, digs);
1139 (void) mul_mp (p, rea, re_z, re_y, digs);
1140 (void) sub_mp (p, rea, rea, acc, digs);
1141 (void) mul_mp (p, acc, im_z, re_y, digs);
1142 (void) mul_mp (p, im_z, re_z, im_y, digs);
1143 (void) add_mp (p, im_z, im_z, acc, digs);
1144 (void) move_mp (re_z, rea, digs);
1145 }
1146 (void) mul_mp (p, acc, im_y, im_y, digs);
1147 (void) mul_mp (p, rea, re_y, re_y, digs);
1148 (void) sub_mp (p, rea, rea, acc, digs);
1149 (void) mul_mp (p, acc, im_y, re_y, digs);
1150 (void) mul_mp (p, im_y, re_y, im_y, digs);
1151 (void) add_mp (p, im_y, im_y, acc, digs);
1152 (void) move_mp (re_y, rea, digs);
1153 expo <<= 1;
1154 }
1155 A68_SP = pop_sp;
1156 if (negative) {
1157 SET_MP_ONE (re_x, digs);
1158 SET_MP_ZERO (im_x, digs);
1159 INCREMENT_STACK_POINTER (p, 2 * size);
1160 genie_div_mp_complex (p);
1161 } else {
1162 (void) move_mp (re_x, re_z, digs);
1163 (void) move_mp (im_x, im_z, digs);
1164 }
1165 MP_STATUS (re_x) = (MP_T) INIT_MASK;
1166 MP_STATUS (im_x) = (MP_T) INIT_MASK;
1167 }
1168
1169 //! @brief OP = = (LONG COMPLEX, LONG COMPLEX) BOOL
1170
1171 void genie_eq_mp_complex (NODE_T * p)
1172 {
1173 int digs = DIGITS_COMPL (LHS_MODE (p)), size = SIZE_COMPL (LHS_MODE (p));
1174 ADDR_T pop_sp = A68_SP;
1175 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1176 MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1177 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1178 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1179 (void) sub_mp (p, b, b, d, digs);
1180 (void) sub_mp (p, a, a, c, digs);
1181 A68_SP = pop_sp;
1182 DECREMENT_STACK_POINTER (p, 4 * size);
1183 PUSH_VALUE (p, (BOOL_T) (MP_DIGIT (a, 1) == 0 && MP_DIGIT (b, 1) == 0), A68_BOOL);
1184 }
1185
1186 //! @brief OP /= = (LONG COMPLEX, LONG COMPLEX) BOOL
1187
1188 void genie_ne_mp_complex (NODE_T * p)
1189 {
1190 int digs = DIGITS_COMPL (LHS_MODE (p)), size = SIZE_COMPL (LHS_MODE (p));
1191 ADDR_T pop_sp = A68_SP;
1192 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1193 MP_T *c = (MP_T *) STACK_OFFSET (-2 * size);
1194 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1195 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1196 (void) sub_mp (p, b, b, d, digs);
1197 (void) sub_mp (p, a, a, c, digs);
1198 A68_SP = pop_sp;
1199 DECREMENT_STACK_POINTER (p, 4 * size);
1200 PUSH_VALUE (p, (BOOL_T) (MP_DIGIT (a, 1) != 0 || MP_DIGIT (b, 1) != 0), A68_BOOL);
1201 }
1202
1203 //! @brief OP +:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1204
1205 void genie_plusab_mp_complex (NODE_T * p)
1206 {
1207 MOID_T *mode = LHS_MODE (p);
1208 genie_f_and_becomes (p, mode, genie_add_mp_complex);
1209 }
1210
1211 //! @brief OP -:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1212
1213 void genie_minusab_mp_complex (NODE_T * p)
1214 {
1215 MOID_T *mode = LHS_MODE (p);
1216 genie_f_and_becomes (p, mode, genie_sub_mp_complex);
1217 }
1218
1219 //! @brief OP *:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1220
1221 void genie_timesab_mp_complex (NODE_T * p)
1222 {
1223 MOID_T *mode = LHS_MODE (p);
1224 genie_f_and_becomes (p, mode, genie_mul_mp_complex);
1225 }
1226
1227 //! @brief OP /:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1228
1229 void genie_divab_mp_complex (NODE_T * p)
1230 {
1231 MOID_T *mode = LHS_MODE (p);
1232 genie_f_and_becomes (p, mode, genie_div_mp_complex);
1233 }
1234
1235 //! @brief PROC LONG REAL next long random
1236
1237 void genie_long_next_random (NODE_T * p)
1238 {
1239 // This is 'real width' precision only.
1240 genie_next_random (p);
1241 genie_lengthen_real_to_mp (p);
1242 if (MOID (p) == M_LONG_LONG_REAL) {
1243 genie_lengthen_mp_to_long_mp (p);
1244 }
1245 }
1246
1247 //! @brief PROC (LONG REAL) LONG REAL long csc
1248
1249 void genie_csc_mp (NODE_T * p)
1250 {
1251 C_L_FUNCTION (p, csc_mp);
1252 }
1253
1254 //! @brief PROC (LONG REAL) LONG REAL long acsc
1255
1256 void genie_acsc_mp (NODE_T * p)
1257 {
1258 C_L_FUNCTION (p, acsc_mp);
1259 }
1260
1261 //! @brief PROC (LONG REAL) LONG REAL long sec
1262
1263 void genie_sec_mp (NODE_T * p)
1264 {
1265 C_L_FUNCTION (p, sec_mp);
1266 }
1267
1268 //! @brief PROC (LONG REAL) LONG REAL long asec
1269
1270 void genie_asec_mp (NODE_T * p)
1271 {
1272 C_L_FUNCTION (p, asec_mp);
1273 }
1274
1275 //! @brief PROC (LONG REAL) LONG REAL long cot
1276
1277 void genie_cot_mp (NODE_T * p)
1278 {
1279 C_L_FUNCTION (p, cot_mp);
1280 }
1281
1282 //! @brief PROC (LONG REAL) LONG REAL long acot
1283
1284 void genie_acot_mp (NODE_T * p)
1285 {
1286 C_L_FUNCTION (p, acot_mp);
1287 }
1288
1289 //! @brief PROC (LONG REAL) LONG REAL long sindg
1290
1291 void genie_sindg_mp (NODE_T * p)
1292 {
1293 C_L_FUNCTION (p, sindg_mp);
1294 }
1295
1296 //! @brief PROC (LONG REAL) LONG REAL long cosdg
1297
1298 void genie_cosdg_mp (NODE_T * p)
1299 {
1300 C_L_FUNCTION (p, cosdg_mp);
1301 }
1302
1303 //! @brief PROC (LONG REAL) LONG REAL long tandg
1304
1305 void genie_tandg_mp (NODE_T * p)
1306 {
1307 C_L_FUNCTION (p, tandg_mp);
1308 }
1309
1310 //! @brief PROC (LONG REAL) LONG REAL long secdg
1311
1312 void genie_secdg_mp (NODE_T * p)
1313 {
1314 C_L_FUNCTION (p, secdg_mp);
1315 }
1316
1317 //! @brief PROC (LONG REAL) LONG REAL long asecdg
1318
1319 void genie_asecdg_mp (NODE_T * p)
1320 {
1321 C_L_FUNCTION (p, asecdg_mp);
1322 }
1323
1324 //! @brief PROC (LONG REAL) LONG REAL long cscdg
1325
1326 void genie_cscdg_mp (NODE_T * p)
1327 {
1328 C_L_FUNCTION (p, cscdg_mp);
1329 }
1330
1331 //! @brief PROC (LONG REAL) LONG REAL long acscdg
1332
1333 void genie_acscdg_mp (NODE_T * p)
1334 {
1335 C_L_FUNCTION (p, acscdg_mp);
1336 }
1337
1338 //! @brief PROC (LONG REAL) LONG REAL long cotdg
1339
1340 void genie_cotdg_mp (NODE_T * p)
1341 {
1342 C_L_FUNCTION (p, cotdg_mp);
1343 }
1344
1345 //! @brief PROC (LONG REAL) LONG REAL long asindg
1346
1347 void genie_asindg_mp (NODE_T * p)
1348 {
1349 C_L_FUNCTION (p, asindg_mp);
1350 }
1351
1352 //! @brief PROC (LONG REAL) LONG REAL long acosdg
1353
1354 void genie_acosdg_mp (NODE_T * p)
1355 {
1356 C_L_FUNCTION (p, acosdg_mp);
1357 }
1358
1359 //! @brief PROC (LONG REAL) LONG REAL long atandg
1360
1361 void genie_atandg_mp (NODE_T * p)
1362 {
1363 C_L_FUNCTION (p, atandg_mp);
1364 }
1365
1366 //! @brief PROC (LONG REAL) LONG REAL long acotdg
1367
1368 void genie_acotdg_mp (NODE_T * p)
1369 {
1370 C_L_FUNCTION (p, acotdg_mp);
1371 }
1372
1373 //! @brief PROC (LONG REAL, LONG REAL) LONG REAL long arctan2
1374
1375 void genie_atan2dg_mp (NODE_T * p)
1376 {
1377 int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
1378 MP_T *y = (MP_T *) STACK_OFFSET (-size);
1379 MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);
1380 PRELUDE_ERROR (atan2dg_mp (p, x, y, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
1381 A68_SP -= size;
1382 MP_STATUS (x) = (MP_T) INIT_MASK;
1383 }
1384
1385 //! @brief PROC (LONG REAL) LONG REAL long
1386
1387 void genie_sinpi_mp (NODE_T * p)
1388 {
1389 C_L_FUNCTION (p, sinpi_mp);
1390 }
1391
1392 //! @brief PROC (LONG REAL) LONG REAL long
1393
1394 void genie_cospi_mp (NODE_T * p)
1395 {
1396 C_L_FUNCTION (p, cospi_mp);
1397 }
1398
1399 //! @brief PROC (LONG REAL) LONG REAL long
1400
1401 void genie_cotpi_mp (NODE_T * p)
1402 {
1403 C_L_FUNCTION (p, cotpi_mp);
1404 }
1405
1406 //! @brief PROC (LONG REAL) LONG REAL long
1407
1408 void genie_tanpi_mp (NODE_T * p)
1409 {
1410 C_L_FUNCTION (p, tanpi_mp);
1411 }
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
