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-2026 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 //! @brief OP CEIL = (LONG REAL) LONG INT
191
192 void genie_ceil_mp (NODE_T * p)
193 {
194 int digs = DIGITS (LHS_MODE (p)), size = SIZE (LHS_MODE (p));
195 ADDR_T pop_sp = A68G_SP;
196 MP_T *z = (MP_T *) STACK_OFFSET (-size);
197 (void) ceil_mp (p, z, z, digs);
198 A68G_SP = pop_sp;
199 }
200
201 //! @brief OP TRUNC = (LONG REAL) LONG INT
202
203 void genie_trunc_mp (NODE_T * p)
204 {
205 int digs = DIGITS (LHS_MODE (p)), size = SIZE (LHS_MODE (p));
206 ADDR_T pop_sp = A68G_SP;
207 MP_T *z = (MP_T *) STACK_OFFSET (-size);
208 (void) trunc_mp (p, z, z, digs);
209 A68G_SP = pop_sp;
210 }
211
212 //! @brief OP FRAC = (LONG REAL) LONG INT
213
214 void genie_frac_mp (NODE_T * p)
215 {
216 int digs = DIGITS (LHS_MODE (p)), size = SIZE (LHS_MODE (p));
217 ADDR_T pop_sp = A68G_SP;
218 MP_T *z = (MP_T *) STACK_OFFSET (-size);
219 (void) frac_mp (p, z, z, digs);
220 A68G_SP = pop_sp;
221 }
222
223 #define C_L_FUNCTION(p, f)\
224 int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));\
225 ADDR_T pop_sp = A68G_SP;\
226 MP_T *x = (MP_T *) STACK_OFFSET (-size);\
227 errno = 0;\
228 PRELUDE_ERROR (f (p, x, x, digs) == NaN_MP || errno != 0, p, ERROR_INVALID_ARGUMENT, MOID (p));\
229 MP_STATUS (x) = (MP_T) INIT_MASK;\
230 A68G_SP = pop_sp;
231
232 //! @brief PROC (LONG REAL) LONG REAL long sqrt
233
234 void genie_sqrt_mp (NODE_T * p)
235 {
236 C_L_FUNCTION (p, sqrt_mp);
237 }
238
239 //! @brief PROC (LONG REAL) LONG REAL long curt
240
241 void genie_curt_mp (NODE_T * p)
242 {
243 C_L_FUNCTION (p, curt_mp);
244 }
245
246 //! @brief PROC (LONG REAL) LONG REAL long exp
247
248 void genie_exp_mp (NODE_T * p)
249 {
250 C_L_FUNCTION (p, exp_mp);
251 }
252
253 //! @brief PROC (LONG REAL) LONG REAL long erf
254
255 void genie_erf_mp (NODE_T * p)
256 {
257 C_L_FUNCTION (p, erf_mp);
258 }
259
260 //! @brief PROC (LONG REAL) LONG REAL long inverf
261
262 void genie_inverf_mp (NODE_T * p)
263 {
264 C_L_FUNCTION (p, inverf_mp);
265 }
266
267 //! @brief PROC (LONG REAL) LONG REAL long erfc
268
269 void genie_erfc_mp (NODE_T * p)
270 {
271 C_L_FUNCTION (p, erfc_mp);
272 }
273
274 //! @brief PROC (LONG REAL) LONG REAL long inverfc
275
276 void genie_inverfc_mp (NODE_T * p)
277 {
278 C_L_FUNCTION (p, inverfc_mp);
279 }
280
281 //! @brief PROC (LONG REAL) LONG REAL long gamma
282
283 void genie_gamma_mp (NODE_T * p)
284 {
285 C_L_FUNCTION (p, gamma_mp);
286 }
287
288 //! @brief PROC (LONG REAL) LONG REAL long ln gamma
289
290 void genie_lngamma_mp (NODE_T * p)
291 {
292 C_L_FUNCTION (p, lngamma_mp);
293 }
294
295 //! @brief PROC (LONG REAL) LONG REAL long beta
296
297 void genie_beta_mp (NODE_T * p)
298 {
299 int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
300 MP_T *b = (MP_T *) STACK_OFFSET (-size);
301 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
302 PRELUDE_ERROR (beta_mp (p, a, a, b, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
303 A68G_SP -= size;
304 MP_STATUS (a) = (MP_T) INIT_MASK;
305 }
306
307 //! @brief PROC (LONG REAL) LONG REAL long ln beta
308
309 void genie_lnbeta_mp (NODE_T * p)
310 {
311 int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
312 MP_T *b = (MP_T *) STACK_OFFSET (-size);
313 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
314 PRELUDE_ERROR (lnbeta_mp (p, a, a, b, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
315 A68G_SP -= size;
316 MP_STATUS (a) = (MP_T) INIT_MASK;
317 }
318
319 //! @brief PROC (LONG REAL) LONG REAL long beta
320
321 void genie_beta_inc_mp (NODE_T * p)
322 {
323 int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
324 MP_T *x = (MP_T *) STACK_OFFSET (-size);
325 MP_T *t = (MP_T *) STACK_OFFSET (- (2 * size));
326 MP_T *s = (MP_T *) STACK_OFFSET (-3 * size);
327 PRELUDE_ERROR (beta_inc_mp (p, s, s, t, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
328 A68G_SP -= 2 * size;
329 MP_STATUS (s) = (MP_T) INIT_MASK;
330 }
331
332 //! @brief PROC (LONG REAL) LONG REAL long ln
333
334 void genie_ln_mp (NODE_T * p)
335 {
336 C_L_FUNCTION (p, ln_mp);
337 }
338
339 //! @brief PROC (LONG REAL) LONG REAL long log
340
341 void genie_log_mp (NODE_T * p)
342 {
343 C_L_FUNCTION (p, log_mp);
344 }
345
346 //! @brief PROC (LONG REAL) LONG REAL long sinh
347
348 void genie_sinh_mp (NODE_T * p)
349 {
350 C_L_FUNCTION (p, sinh_mp);
351 }
352
353 //! @brief PROC (LONG REAL) LONG REAL long cosh
354
355 void genie_cosh_mp (NODE_T * p)
356 {
357 C_L_FUNCTION (p, cosh_mp);
358 }
359
360 //! @brief PROC (LONG REAL) LONG REAL long tanh
361
362 void genie_tanh_mp (NODE_T * p)
363 {
364 C_L_FUNCTION (p, tanh_mp);
365 }
366
367 //! @brief PROC (LONG REAL) LONG REAL long arcsinh
368
369 void genie_asinh_mp (NODE_T * p)
370 {
371 C_L_FUNCTION (p, asinh_mp);
372 }
373
374 //! @brief PROC (LONG REAL) LONG REAL long arccosh
375
376 void genie_acosh_mp (NODE_T * p)
377 {
378 C_L_FUNCTION (p, acosh_mp);
379 }
380
381 //! @brief PROC (LONG REAL) LONG REAL long arctanh
382
383 void genie_atanh_mp (NODE_T * p)
384 {
385 C_L_FUNCTION (p, atanh_mp);
386 }
387
388 //! @brief PROC (LONG REAL) LONG REAL long sin
389
390 void genie_sin_mp (NODE_T * p)
391 {
392 C_L_FUNCTION (p, sin_mp);
393 }
394
395 //! @brief PROC (LONG REAL) LONG REAL long cas
396
397 void genie_cas_mp (NODE_T * p)
398 {
399 C_L_FUNCTION (p, cas_mp);
400 }
401
402 //! @brief PROC (LONG REAL) LONG REAL long cos
403
404 void genie_cos_mp (NODE_T * p)
405 {
406 C_L_FUNCTION (p, cos_mp);
407 }
408
409 //! @brief PROC (LONG REAL) LONG REAL long tan
410
411 void genie_tan_mp (NODE_T * p)
412 {
413 C_L_FUNCTION (p, tan_mp);
414 }
415
416 //! @brief PROC (LONG REAL) LONG REAL long arcsin
417
418 void genie_asin_mp (NODE_T * p)
419 {
420 C_L_FUNCTION (p, asin_mp);
421 }
422
423 //! @brief PROC (LONG REAL) LONG REAL long arccos
424
425 void genie_acos_mp (NODE_T * p)
426 {
427 C_L_FUNCTION (p, acos_mp);
428 }
429
430 //! @brief PROC (LONG REAL) LONG REAL long arctan
431
432 void genie_atan_mp (NODE_T * p)
433 {
434 C_L_FUNCTION (p, atan_mp);
435 }
436
437 //! @brief PROC (LONG REAL, LONG REAL) LONG REAL long arctan2
438
439 void genie_atan2_mp (NODE_T * p)
440 {
441 int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
442 MP_T *y = (MP_T *) STACK_OFFSET (-size);
443 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
444 PRELUDE_ERROR (atan2_mp (p, x, y, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
445 A68G_SP -= size;
446 MP_STATUS (x) = (MP_T) INIT_MASK;
447 }
448
449 // Arithmetic operations.
450
451 //! @brief OP LENG = (LONG MODE) LONG LONG MODE
452
453 void genie_lengthen_mp_to_long_mp (NODE_T * p)
454 {
455 DECREMENT_STACK_POINTER (p, (int) size_mp ());
456 MP_T *z = (MP_T *) STACK_ADDRESS (A68G_SP);
457 z = len_mp (p, z, mp_digits (), long_mp_digits ());
458 MP_STATUS (z) = (MP_T) INIT_MASK;
459 }
460
461 //! @brief OP SHORTEN = (LONG LONG MODE) LONG MODE
462
463 void genie_shorten_long_mp_to_mp (NODE_T * p)
464 {
465 MOID_T *m = SUB_MOID (p);
466 DECREMENT_STACK_POINTER (p, (int) size_long_mp ());
467 MP_T *z = empty_mp (p, mp_digits ());
468 if (m == M_LONG_INT) {
469 PRELUDE_ERROR (MP_EXPONENT (z) > LONG_MP_DIGITS - 1, p, ERROR_OUT_OF_BOUNDS, m);
470 }
471 (void) shorten_mp (p, z, mp_digits (), z, long_mp_digits ());
472 MP_STATUS (z) = (MP_T) INIT_MASK;
473 }
474
475 //! @brief OP - = (LONG MODE) LONG MODE
476
477 void genie_minus_mp (NODE_T * p)
478 {
479 size_t size = SIZE (LHS_MODE (p));
480 MP_T *z = (MP_T *) STACK_OFFSET (-size);
481 MP_STATUS (z) = (MP_T) INIT_MASK;
482 MP_DIGIT (z, 1) = -MP_DIGIT (z, 1);
483 }
484
485 //! @brief OP ABS = (LONG MODE) LONG MODE
486
487 void genie_abs_mp (NODE_T * p)
488 {
489 size_t size = SIZE (LHS_MODE (p));
490 MP_T *z = (MP_T *) STACK_OFFSET (-size);
491 MP_STATUS (z) = (MP_T) INIT_MASK;
492 MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
493 }
494
495 //! @brief OP SIGN = (LONG MODE) INT
496
497 void genie_sign_mp (NODE_T * p)
498 {
499 size_t size = SIZE (LHS_MODE (p));
500 MP_T *z = (MP_T *) STACK_OFFSET (-size);
501 DECREMENT_STACK_POINTER (p, size);
502 PUSH_VALUE (p, SIGN (MP_DIGIT (z, 1)), A68G_INT);
503 }
504
505 //! @brief OP + = (LONG MODE, LONG MODE) LONG MODE
506
507 void genie_add_mp (NODE_T * p)
508 {
509 MOID_T *mode = RHS_MODE (p);
510 int digs = DIGITS (mode), size = SIZE (mode);
511 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
512 MP_T *y = (MP_T *) STACK_OFFSET (-size);
513 (void) add_mp (p, x, x, y, digs);
514 MP_STATUS (x) = (MP_T) INIT_MASK;
515 DECREMENT_STACK_POINTER (p, size);
516 }
517
518 //! @brief OP - = (LONG MODE, LONG MODE) LONG MODE
519
520 void genie_sub_mp (NODE_T * p)
521 {
522 MOID_T *mode = RHS_MODE (p);
523 int digs = DIGITS (mode), size = SIZE (mode);
524 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
525 MP_T *y = (MP_T *) STACK_OFFSET (-size);
526 (void) sub_mp (p, x, x, y, digs);
527 MP_STATUS (x) = (MP_T) INIT_MASK;
528 DECREMENT_STACK_POINTER (p, size);
529 }
530
531 //! @brief OP * = (LONG MODE, LONG MODE) LONG MODE
532
533 void genie_mul_mp (NODE_T * p)
534 {
535 MOID_T *mode = RHS_MODE (p);
536 int digs = DIGITS (mode), size = SIZE (mode);
537 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
538 MP_T *y = (MP_T *) STACK_OFFSET (-size);
539 (void) mul_mp (p, x, x, y, digs);
540 MP_STATUS (x) = (MP_T) INIT_MASK;
541 DECREMENT_STACK_POINTER (p, size);
542 }
543
544 //! @brief OP / = (LONG MODE, LONG MODE) LONG MODE
545
546 void genie_div_mp (NODE_T * p)
547 {
548 MOID_T *mode = RHS_MODE (p);
549 int digs = DIGITS (mode), size = SIZE (mode);
550 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
551 MP_T *y = (MP_T *) STACK_OFFSET (-size);
552 PRELUDE_ERROR (div_mp (p, x, x, y, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
553 MP_STATUS (x) = (MP_T) INIT_MASK;
554 DECREMENT_STACK_POINTER (p, size);
555 }
556
557 //! @brief OP % = (LONG MODE, LONG MODE) LONG MODE
558
559 void genie_over_mp (NODE_T * p)
560 {
561 MOID_T *mode = RHS_MODE (p);
562 int digs = DIGITS (mode), size = SIZE (mode);
563 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
564 MP_T *y = (MP_T *) STACK_OFFSET (-size);
565 PRELUDE_ERROR (over_mp (p, x, x, y, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
566 MP_STATUS (x) = (MP_T) INIT_MASK;
567 DECREMENT_STACK_POINTER (p, size);
568 }
569
570 //! @brief OP %* = (LONG MODE, LONG MODE) LONG MODE
571
572 void genie_mod_mp (NODE_T * p)
573 {
574 MOID_T *mode = RHS_MODE (p);
575 int digs = DIGITS (mode), size = SIZE (mode);
576 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
577 MP_T *y = (MP_T *) STACK_OFFSET (-size);
578 PRELUDE_ERROR (mod_mp (p, x, x, y, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
579 if (MP_DIGIT (x, 1) < 0) {
580 MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1));
581 (void) add_mp (p, x, x, y, digs);
582 }
583 MP_STATUS (x) = (MP_T) INIT_MASK;
584 DECREMENT_STACK_POINTER (p, size);
585 }
586
587 //! @brief OP +:= = (REF LONG MODE, LONG MODE) REF LONG MODE
588
589 void genie_plusab_mp (NODE_T * p)
590 {
591 MOID_T *mode = LHS_MODE (p);
592 genie_f_and_becomes (p, mode, genie_add_mp);
593 }
594
595 //! @brief OP -:= = (REF LONG MODE, LONG MODE) REF LONG MODE
596
597 void genie_minusab_mp (NODE_T * p)
598 {
599 MOID_T *mode = LHS_MODE (p);
600 genie_f_and_becomes (p, mode, genie_sub_mp);
601 }
602
603 //! @brief OP *:= = (REF LONG MODE, LONG MODE) REF LONG MODE
604
605 void genie_timesab_mp (NODE_T * p)
606 {
607 MOID_T *mode = LHS_MODE (p);
608 genie_f_and_becomes (p, mode, genie_mul_mp);
609 }
610
611 //! @brief OP /:= = (REF LONG MODE, LONG MODE) REF LONG MODE
612
613 void genie_divab_mp (NODE_T * p)
614 {
615 MOID_T *mode = LHS_MODE (p);
616 genie_f_and_becomes (p, mode, genie_div_mp);
617 }
618
619 //! @brief OP %:= = (REF LONG MODE, LONG MODE) REF LONG MODE
620
621 void genie_overab_mp (NODE_T * p)
622 {
623 MOID_T *mode = LHS_MODE (p);
624 genie_f_and_becomes (p, mode, genie_over_mp);
625 }
626
627 //! @brief OP %*:= = (REF LONG MODE, LONG MODE) REF LONG MODE
628
629 void genie_modab_mp (NODE_T * p)
630 {
631 MOID_T *mode = LHS_MODE (p);
632 genie_f_and_becomes (p, mode, genie_mod_mp);
633 }
634
635 // OP (LONG MODE, LONG MODE) BOOL.
636
637 #define A68G_CMP_LONG(n, OP)\
638 void n (NODE_T * p) {\
639 MOID_T *mode = LHS_MODE (p);\
640 A68G_BOOL z;\
641 int digs = DIGITS (mode), size = SIZE (mode);\
642 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));\
643 MP_T *y = (MP_T *) STACK_OFFSET (-size);\
644 OP (p, &z, x, y, digs);\
645 DECREMENT_STACK_POINTER (p, 2 * size);\
646 PUSH_VALUE (p, VALUE (&z), A68G_BOOL);\
647 }
648
649 A68G_CMP_LONG (genie_eq_mp, eq_mp);
650 A68G_CMP_LONG (genie_ne_mp, ne_mp);
651 A68G_CMP_LONG (genie_lt_mp, lt_mp);
652 A68G_CMP_LONG (genie_gt_mp, gt_mp);
653 A68G_CMP_LONG (genie_le_mp, le_mp);
654 A68G_CMP_LONG (genie_ge_mp, ge_mp);
655
656 //! @brief OP ** = (LONG MODE, INT) LONG MODE
657
658 void genie_pow_mp_int (NODE_T * p)
659 {
660 MOID_T *mode = LHS_MODE (p);
661 int digs = DIGITS (mode), size = SIZE (mode);
662 A68G_INT k;
663 POP_OBJECT (p, &k, A68G_INT);
664 MP_T *x = (MP_T *) STACK_OFFSET (-size);
665 (void) pow_mp_int (p, x, x, VALUE (&k), digs);
666 MP_STATUS (x) = (MP_T) INIT_MASK;
667 }
668
669 //! @brief OP ** = (LONG MODE, LONG MODE) LONG MODE
670
671 void genie_pow_mp (NODE_T * p)
672 {
673 MOID_T *mode = LHS_MODE (p);
674 int digs = DIGITS (mode), size = SIZE (mode);
675 ADDR_T pop_sp = A68G_SP;
676 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
677 MP_T *y = (MP_T *) STACK_OFFSET (-size);
678 if (IS_ZERO_MP (x)) {
679 if (MP_DIGIT (y, 1) < (MP_T) 0) {
680 PRELUDE_ERROR (A68G_TRUE, p, ERROR_INVALID_ARGUMENT, MOID (p));
681 } else if (IS_ZERO_MP (y)) {
682 SET_MP_ONE (x, digs);
683 }
684 } else {
685 (void) pow_mp (p, x, x, y, digs);
686 }
687 A68G_SP = pop_sp - size;
688 MP_STATUS (x) = (MP_T) INIT_MASK;
689 }
690
691 //! @brief OP ODD = (LONG INT) BOOL
692
693 void genie_odd_mp (NODE_T * p)
694 {
695 MOID_T *mode = LHS_MODE (p);
696 int digs = DIGITS (mode), size = SIZE (mode);
697 MP_T *z = (MP_T *) STACK_OFFSET (-size);
698 DECREMENT_STACK_POINTER (p, size);
699 if (MP_EXPONENT (z) <= (MP_T) (digs - 1)) {
700 PUSH_VALUE (p, (BOOL_T) ! EVEN ((MP_INT_T) (z[(int) (2 + MP_EXPONENT (z))])), A68G_BOOL);
701 } else {
702 PUSH_VALUE (p, A68G_FALSE, A68G_BOOL);
703 }
704 }
705
706 //! @brief Test whether z is a valid LONG INT.
707
708 void test_mp_int_range (NODE_T * p, MP_T * z, MOID_T * m)
709 {
710 PRELUDE_ERROR (!check_mp_int (z, m), p, ERROR_OUT_OF_BOUNDS, m);
711 }
712
713 //! @brief OP + = (LONG INT, LONG INT) LONG INT
714
715 void genie_add_mp_int (NODE_T * p)
716 {
717 MOID_T *m = RHS_MODE (p);
718 int digs = DIGITS (m), size = SIZE (m);
719 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
720 MP_T *y = (MP_T *) STACK_OFFSET (-size);
721 (void) add_mp (p, x, x, y, digs);
722 test_mp_int_range (p, x, m);
723 MP_STATUS (x) = (MP_T) INIT_MASK;
724 DECREMENT_STACK_POINTER (p, size);
725 }
726
727 //! @brief OP - = (LONG INT, LONG INT) LONG INT
728
729 void genie_sub_mp_int (NODE_T * p)
730 {
731 MOID_T *m = RHS_MODE (p);
732 int digs = DIGITS (m), size = SIZE (m);
733 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
734 MP_T *y = (MP_T *) STACK_OFFSET (-size);
735 (void) sub_mp (p, x, x, y, digs);
736 test_mp_int_range (p, x, m);
737 MP_STATUS (x) = (MP_T) INIT_MASK;
738 DECREMENT_STACK_POINTER (p, size);
739 }
740
741 //! @brief OP * = (LONG INT, LONG INT) LONG INT
742
743 void genie_mul_mp_int (NODE_T * p)
744 {
745 MOID_T *m = RHS_MODE (p);
746 int digs = DIGITS (m), size = SIZE (m);
747 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
748 MP_T *y = (MP_T *) STACK_OFFSET (-size);
749 (void) mul_mp (p, x, x, y, digs);
750 test_mp_int_range (p, x, m);
751 MP_STATUS (x) = (MP_T) INIT_MASK;
752 DECREMENT_STACK_POINTER (p, size);
753 }
754
755 //! @brief OP ** = (LONG MODE, INT) LONG INT
756
757 void genie_pow_mp_int_int (NODE_T * p)
758 {
759 MOID_T *m = LHS_MODE (p);
760 int digs = DIGITS (m), size = SIZE (m);
761 A68G_INT k;
762 POP_OBJECT (p, &k, A68G_INT);
763 MP_T *x = (MP_T *) STACK_OFFSET (-size);
764 (void) pow_mp_int (p, x, x, VALUE (&k), digs);
765 test_mp_int_range (p, x, m);
766 MP_STATUS (x) = (MP_T) INIT_MASK;
767 }
768
769 //! @brief OP +:= = (REF LONG INT, LONG INT) REF LONG INT
770
771 void genie_plusab_mp_int (NODE_T * p)
772 {
773 MOID_T *mode = LHS_MODE (p);
774 genie_f_and_becomes (p, mode, genie_add_mp_int);
775 }
776
777 //! @brief OP -:= = (REF LONG INT, LONG INT) REF LONG INT
778
779 void genie_minusab_mp_int (NODE_T * p)
780 {
781 MOID_T *mode = LHS_MODE (p);
782 genie_f_and_becomes (p, mode, genie_sub_mp_int);
783 }
784
785 //! @brief OP *:= = (REF LONG INT, LONG INT) REF LONG INT
786
787 void genie_timesab_mp_int (NODE_T * p)
788 {
789 MOID_T *mode = LHS_MODE (p);
790 genie_f_and_becomes (p, mode, genie_mul_mp_int);
791 }
792
793 //! @brief OP ROUND = (LONG REAL) LONG INT
794
795 void genie_round_mp (NODE_T * p)
796 {
797 MOID_T *mode = LHS_MODE (p);
798 int digs = DIGITS (mode), size = SIZE (mode);
799 ADDR_T pop_sp = A68G_SP;
800 MP_T *z = (MP_T *) STACK_OFFSET (-size);
801 (void) round_mp (p, z, z, digs);
802 A68G_SP = pop_sp;
803 }
804
805 #define C_CL_FUNCTION(p, f)\
806 MOID_T *mode = MOID (p);\
807 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);\
808 ADDR_T pop_sp = A68G_SP;\
809 MP_T *im = (MP_T *) STACK_OFFSET (-size);\
810 MP_T *re = (MP_T *) STACK_OFFSET (- (2 * size));\
811 errno = 0;\
812 (void) f(p, re, im, digs);\
813 A68G_SP = pop_sp;\
814 MP_STATUS (re) = (MP_T) INIT_MASK;\
815 MP_STATUS (im) = (MP_T) INIT_MASK;\
816 MATH_RTE (p, errno != 0, mode, NO_TEXT);\
817
818 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csqrt
819
820 void genie_sqrt_mp_complex (NODE_T * p)
821 {
822 C_CL_FUNCTION (p, csqrt_mp);
823 }
824
825 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long cexp
826
827 void genie_exp_mp_complex (NODE_T * p)
828 {
829 C_CL_FUNCTION (p, cexp_mp);
830 }
831
832 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long cln
833
834 void genie_ln_mp_complex (NODE_T * p)
835 {
836 C_CL_FUNCTION (p, cln_mp);
837 }
838
839 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csin
840
841 void genie_sin_mp_complex (NODE_T * p)
842 {
843 C_CL_FUNCTION (p, csin_mp);
844 }
845
846 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ccos
847
848 void genie_cos_mp_complex (NODE_T * p)
849 {
850 C_CL_FUNCTION (p, ccos_mp);
851 }
852
853 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ctan
854
855 void genie_tan_mp_complex (NODE_T * p)
856 {
857 C_CL_FUNCTION (p, ctan_mp);
858 }
859
860 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long arcsin
861
862 void genie_asin_mp_complex (NODE_T * p)
863 {
864 C_CL_FUNCTION (p, casin_mp);
865 }
866
867 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carccos
868
869 void genie_acos_mp_complex (NODE_T * p)
870 {
871 C_CL_FUNCTION (p, cacos_mp);
872 }
873
874 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long catan
875
876 void genie_atan_mp_complex (NODE_T * p)
877 {
878 C_CL_FUNCTION (p, catan_mp);
879 }
880
881 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long csinh
882
883 void genie_sinh_mp_complex (NODE_T * p)
884 {
885 C_CL_FUNCTION (p, csinh_mp);
886 }
887
888 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ccosh
889
890 void genie_cosh_mp_complex (NODE_T * p)
891 {
892 C_CL_FUNCTION (p, ccosh_mp);
893 }
894
895 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long ctanh
896
897 void genie_tanh_mp_complex (NODE_T * p)
898 {
899 C_CL_FUNCTION (p, ctanh_mp);
900 }
901
902 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carcsinh
903
904 void genie_asinh_mp_complex (NODE_T * p)
905 {
906 C_CL_FUNCTION (p, casinh_mp);
907 }
908
909 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carccosh
910
911 void genie_acosh_mp_complex (NODE_T * p)
912 {
913 C_CL_FUNCTION (p, cacosh_mp);
914 }
915
916 //! @brief PROC (LONG COMPLEX) LONG COMPLEX long carctanh
917
918 void genie_atanh_mp_complex (NODE_T * p)
919 {
920 C_CL_FUNCTION (p, catanh_mp);
921 }
922
923 //! @brief OP LENG = (COMPLEX) LONG COMPLEX
924
925 void genie_lengthen_complex_to_mp_complex (NODE_T * p)
926 {
927 int digs = DIGITS (M_LONG_REAL);
928 A68G_REAL a, b;
929 POP_OBJECT (p, &b, A68G_REAL);
930 POP_OBJECT (p, &a, A68G_REAL);
931 MP_T *z = nil_mp (p, digs);
932 (void) real_to_mp (p, z, VALUE (&a), digs);
933 MP_STATUS (z) = (MP_T) INIT_MASK;
934 z = nil_mp (p, digs);
935 (void) real_to_mp (p, z, VALUE (&b), digs);
936 MP_STATUS (z) = (MP_T) INIT_MASK;
937 }
938
939 //! @brief OP SHORTEN = (LONG COMPLEX) COMPLEX
940
941 void genie_shorten_mp_complex_to_complex (NODE_T * p)
942 {
943 int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
944 MP_T *b = (MP_T *) STACK_OFFSET (-size);
945 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
946 DECREMENT_STACK_POINTER (p, 2 * size);
947 PUSH_COMPLEX_VALUE (p, mp_to_real (p, a, digs), mp_to_real (p, b, digs));
948 }
949
950 //! @brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX
951
952 void genie_lengthen_mp_complex_to_long_mp_complex (NODE_T * p)
953 {
954 int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
955 int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL);
956 ADDR_T pop_sp = A68G_SP;
957 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
958 MP_T *b = (MP_T *) STACK_OFFSET (-size);
959 MP_T *c = len_mp (p, a, digs, gdigs);
960 MP_T *d = len_mp (p, b, digs, gdigs);
961 (void) move_mp (a, c, gdigs);
962 (void) move_mp (&a[LEN_MP (gdigs)], d, gdigs);
963 A68G_SP = pop_sp;
964 INCREMENT_STACK_POINTER (p, 2 * (size_g - size));
965 }
966
967 //! @brief OP SHORTEN = (LONG LONG COMPLEX) LONG COMPLEX
968
969 void genie_shorten_long_mp_complex_to_mp_complex (NODE_T * p)
970 {
971 int digs = DIGITS (M_LONG_REAL), size = SIZE (M_LONG_REAL);
972 int gdigs = DIGITS (M_LONG_LONG_REAL), size_g = SIZE (M_LONG_LONG_REAL);
973 ADDR_T pop_sp = A68G_SP;
974 MP_T *b = (MP_T *) STACK_OFFSET (-size_g);
975 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size_g));
976 (void) shorten_mp (p, a, digs, a, gdigs);
977 (void) shorten_mp (p, &a[LEN_MP (digs)], digs, b, gdigs);
978 A68G_SP = pop_sp;
979 MP_STATUS (a) = (MP_T) INIT_MASK;
980 MP_STATUS (&a[LEN_MP (digs)]) = (MP_T) INIT_MASK;
981 DECREMENT_STACK_POINTER (p, 2 * (size_g - size));
982 }
983
984 //! @brief OP RE = (LONG COMPLEX) LONG REAL
985
986 void genie_re_mp_complex (NODE_T * p)
987 {
988 size_t size = SIZE (SUB_MOID (p));
989 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
990 MP_STATUS (a) = (MP_T) INIT_MASK;
991 DECREMENT_STACK_POINTER (p, size);
992 }
993
994 //! @brief OP IM = (LONG COMPLEX) LONG REAL
995
996 void genie_im_mp_complex (NODE_T * p)
997 {
998 MOID_T *mode = SUB_MOID (p);
999 int digs = DIGITS (mode), size = SIZE (mode);
1000 MP_T *b = (MP_T *) STACK_OFFSET (-size);
1001 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
1002 (void) move_mp (a, b, digs);
1003 MP_STATUS (a) = (MP_T) INIT_MASK;
1004 DECREMENT_STACK_POINTER (p, size);
1005 }
1006
1007 //! @brief OP - = (LONG COMPLEX) LONG COMPLEX
1008
1009 void genie_minus_mp_complex (NODE_T * p)
1010 {
1011 size_t size = SIZE_COMPL (SUB_MOID (p));
1012 MP_T *b = (MP_T *) STACK_OFFSET (-size);
1013 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
1014 MP_DIGIT (a, 1) = -MP_DIGIT (a, 1);
1015 MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
1016 MP_STATUS (a) = (MP_T) INIT_MASK;
1017 MP_STATUS (b) = (MP_T) INIT_MASK;
1018 }
1019
1020 //! @brief OP CONJ = (LONG COMPLEX) LONG COMPLEX
1021
1022 void genie_conj_mp_complex (NODE_T * p)
1023 {
1024 size_t size = SIZE_COMPL (SUB_MOID (p));
1025 MP_T *b = (MP_T *) STACK_OFFSET (-size);
1026 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
1027 MP_DIGIT (b, 1) = -MP_DIGIT (b, 1);
1028 MP_STATUS (a) = (MP_T) INIT_MASK;
1029 MP_STATUS (b) = (MP_T) INIT_MASK;
1030 }
1031
1032 //! @brief OP ABS = (LONG COMPLEX) LONG REAL
1033
1034 void genie_abs_mp_complex (NODE_T * p)
1035 {
1036 MOID_T *mode = SUB_MOID (p);
1037 int digs = DIGITS (mode), size = SIZE (mode);
1038 ADDR_T pop_sp = A68G_SP;
1039 MP_T *b = (MP_T *) STACK_OFFSET (-size);
1040 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
1041 MP_T *z = nil_mp (p, digs);
1042 errno = 0;
1043 (void) hypot_mp (p, z, a, b, digs);
1044 A68G_SP = pop_sp;
1045 DECREMENT_STACK_POINTER (p, size);
1046 (void) move_mp (a, z, digs);
1047 MP_STATUS (a) = (MP_T) INIT_MASK;
1048 MATH_RTE (p, errno != 0, mode, NO_TEXT);
1049 }
1050
1051 //! @brief OP ARG = (LONG COMPLEX) LONG REAL
1052
1053 void genie_arg_mp_complex (NODE_T * p)
1054 {
1055 MOID_T *mode = SUB_MOID (p);
1056 int digs = DIGITS (mode), size = SIZE (mode);
1057 ADDR_T pop_sp = A68G_SP;
1058 MP_T *b = (MP_T *) STACK_OFFSET (-size);
1059 MP_T *a = (MP_T *) STACK_OFFSET (- (2 * size));
1060 MP_T *z = nil_mp (p, digs);
1061 errno = 0;
1062 (void) atan2_mp (p, z, a, b, digs);
1063 A68G_SP = pop_sp;
1064 DECREMENT_STACK_POINTER (p, size);
1065 (void) move_mp (a, z, digs);
1066 MP_STATUS (a) = (MP_T) INIT_MASK;
1067 MATH_RTE (p, errno != 0, mode, NO_TEXT);
1068 }
1069
1070 //! @brief OP + = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1071
1072 void genie_add_mp_complex (NODE_T * p)
1073 {
1074 MOID_T *mode = SUB_MOID (p);
1075 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1076 ADDR_T pop_sp = A68G_SP;
1077 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1078 MP_T *c = (MP_T *) STACK_OFFSET (- (2 * size));
1079 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1080 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1081 (void) add_mp (p, b, b, d, digs);
1082 (void) add_mp (p, a, a, c, digs);
1083 MP_STATUS (a) = (MP_T) INIT_MASK;
1084 MP_STATUS (b) = (MP_T) INIT_MASK;
1085 A68G_SP = pop_sp;
1086 DECREMENT_STACK_POINTER (p, 2 * size);
1087 }
1088
1089 //! @brief OP - = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1090
1091 void genie_sub_mp_complex (NODE_T * p)
1092 {
1093 MOID_T *mode = SUB_MOID (p);
1094 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1095 ADDR_T pop_sp = A68G_SP;
1096 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1097 MP_T *c = (MP_T *) STACK_OFFSET (- (2 * size));
1098 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1099 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1100 (void) sub_mp (p, b, b, d, digs);
1101 (void) sub_mp (p, a, a, c, digs);
1102 MP_STATUS (a) = (MP_T) INIT_MASK;
1103 MP_STATUS (b) = (MP_T) INIT_MASK;
1104 A68G_SP = pop_sp;
1105 DECREMENT_STACK_POINTER (p, 2 * size);
1106 }
1107
1108 //! @brief OP * = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1109
1110 void genie_mul_mp_complex (NODE_T * p)
1111 {
1112 MOID_T *mode = SUB_MOID (p);
1113 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1114 ADDR_T pop_sp = A68G_SP;
1115 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1116 MP_T *c = (MP_T *) STACK_OFFSET (- (2 * size));
1117 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1118 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1119 (void) cmul_mp (p, a, b, c, d, digs);
1120 MP_STATUS (a) = (MP_T) INIT_MASK;
1121 MP_STATUS (b) = (MP_T) INIT_MASK;
1122 A68G_SP = pop_sp;
1123 DECREMENT_STACK_POINTER (p, 2 * size);
1124 }
1125
1126 //! @brief OP / = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX
1127
1128 void genie_div_mp_complex (NODE_T * p)
1129 {
1130 MOID_T *mode = SUB_MOID (p);
1131 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1132 ADDR_T pop_sp = A68G_SP;
1133 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1134 MP_T *c = (MP_T *) STACK_OFFSET (- (2 * size));
1135 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1136 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1137 PRELUDE_ERROR (cdiv_mp (p, a, b, c, d, digs) == NaN_MP, p, ERROR_DIVISION_BY_ZERO, mode);
1138 MP_STATUS (a) = (MP_T) INIT_MASK;
1139 MP_STATUS (b) = (MP_T) INIT_MASK;
1140 A68G_SP = pop_sp;
1141 DECREMENT_STACK_POINTER (p, 2 * size);
1142 }
1143
1144 //! @brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX
1145
1146 void genie_pow_mp_complex_int (NODE_T * p)
1147 {
1148 MOID_T *mode = SUB_MOID (p);
1149 int digs = DIGITS_COMPL (mode), size = SIZE_COMPL (mode);
1150 A68G_INT j;
1151 POP_OBJECT (p, &j, A68G_INT);
1152 ADDR_T pop_sp = A68G_SP;
1153 MP_T *im_x = (MP_T *) STACK_OFFSET (-size);
1154 MP_T *re_x = (MP_T *) STACK_OFFSET (- (2 * size));
1155 MP_T *re_z = lit_mp (p, 1, 0, digs);
1156 MP_T *im_z = nil_mp (p, digs);
1157 MP_T *re_y = nil_mp (p, digs);
1158 MP_T *im_y = nil_mp (p, digs);
1159 (void) move_mp (re_y, re_x, digs);
1160 (void) move_mp (im_y, im_x, digs);
1161 MP_T *rea = nil_mp (p, digs);
1162 MP_T *acc = nil_mp (p, digs);
1163 int expo = 1;
1164 BOOL_T negative = (BOOL_T) (VALUE (&j) < 0);
1165 if (negative) {
1166 VALUE (&j) = -VALUE (&j);
1167 }
1168 while ((int) expo <= (int) (VALUE (&j))) {
1169 if (expo & VALUE (&j)) {
1170 (void) mul_mp (p, acc, im_z, im_y, digs);
1171 (void) mul_mp (p, rea, re_z, re_y, digs);
1172 (void) sub_mp (p, rea, rea, acc, digs);
1173 (void) mul_mp (p, acc, im_z, re_y, digs);
1174 (void) mul_mp (p, im_z, re_z, im_y, digs);
1175 (void) add_mp (p, im_z, im_z, acc, digs);
1176 (void) move_mp (re_z, rea, digs);
1177 }
1178 (void) mul_mp (p, acc, im_y, im_y, digs);
1179 (void) mul_mp (p, rea, re_y, re_y, digs);
1180 (void) sub_mp (p, rea, rea, acc, digs);
1181 (void) mul_mp (p, acc, im_y, re_y, digs);
1182 (void) mul_mp (p, im_y, re_y, im_y, digs);
1183 (void) add_mp (p, im_y, im_y, acc, digs);
1184 (void) move_mp (re_y, rea, digs);
1185 expo <<= 1;
1186 }
1187 A68G_SP = pop_sp;
1188 if (negative) {
1189 SET_MP_ONE (re_x, digs);
1190 SET_MP_ZERO (im_x, digs);
1191 INCREMENT_STACK_POINTER (p, 2 * size);
1192 genie_div_mp_complex (p);
1193 } else {
1194 (void) move_mp (re_x, re_z, digs);
1195 (void) move_mp (im_x, im_z, digs);
1196 }
1197 MP_STATUS (re_x) = (MP_T) INIT_MASK;
1198 MP_STATUS (im_x) = (MP_T) INIT_MASK;
1199 }
1200
1201 //! @brief OP = = (LONG COMPLEX, LONG COMPLEX) BOOL
1202
1203 void genie_eq_mp_complex (NODE_T * p)
1204 {
1205 int digs = DIGITS_COMPL (LHS_MODE (p)), size = SIZE_COMPL (LHS_MODE (p));
1206 ADDR_T pop_sp = A68G_SP;
1207 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1208 MP_T *c = (MP_T *) STACK_OFFSET (- (2 * size));
1209 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1210 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1211 (void) sub_mp (p, b, b, d, digs);
1212 (void) sub_mp (p, a, a, c, digs);
1213 A68G_SP = pop_sp;
1214 DECREMENT_STACK_POINTER (p, 4 * size);
1215 PUSH_VALUE (p, (BOOL_T) (MP_DIGIT (a, 1) == 0 && MP_DIGIT (b, 1) == 0), A68G_BOOL);
1216 }
1217
1218 //! @brief OP /= = (LONG COMPLEX, LONG COMPLEX) BOOL
1219
1220 void genie_ne_mp_complex (NODE_T * p)
1221 {
1222 int digs = DIGITS_COMPL (LHS_MODE (p)), size = SIZE_COMPL (LHS_MODE (p));
1223 ADDR_T pop_sp = A68G_SP;
1224 MP_T *d = (MP_T *) STACK_OFFSET (-size);
1225 MP_T *c = (MP_T *) STACK_OFFSET (- (2 * size));
1226 MP_T *b = (MP_T *) STACK_OFFSET (-3 * size);
1227 MP_T *a = (MP_T *) STACK_OFFSET (-4 * size);
1228 (void) sub_mp (p, b, b, d, digs);
1229 (void) sub_mp (p, a, a, c, digs);
1230 A68G_SP = pop_sp;
1231 DECREMENT_STACK_POINTER (p, 4 * size);
1232 PUSH_VALUE (p, (BOOL_T) (MP_DIGIT (a, 1) != 0 || MP_DIGIT (b, 1) != 0), A68G_BOOL);
1233 }
1234
1235 //! @brief OP +:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1236
1237 void genie_plusab_mp_complex (NODE_T * p)
1238 {
1239 MOID_T *mode = LHS_MODE (p);
1240 genie_f_and_becomes (p, mode, genie_add_mp_complex);
1241 }
1242
1243 //! @brief OP -:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1244
1245 void genie_minusab_mp_complex (NODE_T * p)
1246 {
1247 MOID_T *mode = LHS_MODE (p);
1248 genie_f_and_becomes (p, mode, genie_sub_mp_complex);
1249 }
1250
1251 //! @brief OP *:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1252
1253 void genie_timesab_mp_complex (NODE_T * p)
1254 {
1255 MOID_T *mode = LHS_MODE (p);
1256 genie_f_and_becomes (p, mode, genie_mul_mp_complex);
1257 }
1258
1259 //! @brief OP /:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX
1260
1261 void genie_divab_mp_complex (NODE_T * p)
1262 {
1263 MOID_T *mode = LHS_MODE (p);
1264 genie_f_and_becomes (p, mode, genie_div_mp_complex);
1265 }
1266
1267 //! @brief PROC LONG REAL next long random
1268
1269 void genie_long_next_random (NODE_T * p)
1270 {
1271 // This is 'real width' precision only.
1272 genie_next_random (p);
1273 genie_lengthen_real_to_mp (p);
1274 if (MOID (p) == M_LONG_LONG_REAL) {
1275 genie_lengthen_mp_to_long_mp (p);
1276 }
1277 }
1278
1279 //! @brief PROC (LONG REAL) LONG REAL long csc
1280
1281 void genie_csc_mp (NODE_T * p)
1282 {
1283 C_L_FUNCTION (p, csc_mp);
1284 }
1285
1286 //! @brief PROC (LONG REAL) LONG REAL long acsc
1287
1288 void genie_acsc_mp (NODE_T * p)
1289 {
1290 C_L_FUNCTION (p, acsc_mp);
1291 }
1292
1293 //! @brief PROC (LONG REAL) LONG REAL long sec
1294
1295 void genie_sec_mp (NODE_T * p)
1296 {
1297 C_L_FUNCTION (p, sec_mp);
1298 }
1299
1300 //! @brief PROC (LONG REAL) LONG REAL long asec
1301
1302 void genie_asec_mp (NODE_T * p)
1303 {
1304 C_L_FUNCTION (p, asec_mp);
1305 }
1306
1307 //! @brief PROC (LONG REAL) LONG REAL long cot
1308
1309 void genie_cot_mp (NODE_T * p)
1310 {
1311 C_L_FUNCTION (p, cot_mp);
1312 }
1313
1314 //! @brief PROC (LONG REAL) LONG REAL long acot
1315
1316 void genie_acot_mp (NODE_T * p)
1317 {
1318 C_L_FUNCTION (p, acot_mp);
1319 }
1320
1321 //! @brief PROC (LONG REAL) LONG REAL long sindg
1322
1323 void genie_sindg_mp (NODE_T * p)
1324 {
1325 C_L_FUNCTION (p, sindg_mp);
1326 }
1327
1328 //! @brief PROC (LONG REAL) LONG REAL long cosdg
1329
1330 void genie_cosdg_mp (NODE_T * p)
1331 {
1332 C_L_FUNCTION (p, cosdg_mp);
1333 }
1334
1335 //! @brief PROC (LONG REAL) LONG REAL long tandg
1336
1337 void genie_tandg_mp (NODE_T * p)
1338 {
1339 C_L_FUNCTION (p, tandg_mp);
1340 }
1341
1342 //! @brief PROC (LONG REAL) LONG REAL long secdg
1343
1344 void genie_secdg_mp (NODE_T * p)
1345 {
1346 C_L_FUNCTION (p, secdg_mp);
1347 }
1348
1349 //! @brief PROC (LONG REAL) LONG REAL long asecdg
1350
1351 void genie_asecdg_mp (NODE_T * p)
1352 {
1353 C_L_FUNCTION (p, asecdg_mp);
1354 }
1355
1356 //! @brief PROC (LONG REAL) LONG REAL long cscdg
1357
1358 void genie_cscdg_mp (NODE_T * p)
1359 {
1360 C_L_FUNCTION (p, cscdg_mp);
1361 }
1362
1363 //! @brief PROC (LONG REAL) LONG REAL long acscdg
1364
1365 void genie_acscdg_mp (NODE_T * p)
1366 {
1367 C_L_FUNCTION (p, acscdg_mp);
1368 }
1369
1370 //! @brief PROC (LONG REAL) LONG REAL long cotdg
1371
1372 void genie_cotdg_mp (NODE_T * p)
1373 {
1374 C_L_FUNCTION (p, cotdg_mp);
1375 }
1376
1377 //! @brief PROC (LONG REAL) LONG REAL long asindg
1378
1379 void genie_asindg_mp (NODE_T * p)
1380 {
1381 C_L_FUNCTION (p, asindg_mp);
1382 }
1383
1384 //! @brief PROC (LONG REAL) LONG REAL long acosdg
1385
1386 void genie_acosdg_mp (NODE_T * p)
1387 {
1388 C_L_FUNCTION (p, acosdg_mp);
1389 }
1390
1391 //! @brief PROC (LONG REAL) LONG REAL long atandg
1392
1393 void genie_atandg_mp (NODE_T * p)
1394 {
1395 C_L_FUNCTION (p, atandg_mp);
1396 }
1397
1398 //! @brief PROC (LONG REAL) LONG REAL long acotdg
1399
1400 void genie_acotdg_mp (NODE_T * p)
1401 {
1402 C_L_FUNCTION (p, acotdg_mp);
1403 }
1404
1405 //! @brief PROC (LONG REAL, LONG REAL) LONG REAL long arctan2
1406
1407 void genie_atan2dg_mp (NODE_T * p)
1408 {
1409 int digs = DIGITS (MOID (p)), size = SIZE (MOID (p));
1410 MP_T *y = (MP_T *) STACK_OFFSET (-size);
1411 MP_T *x = (MP_T *) STACK_OFFSET (- (2 * size));
1412 PRELUDE_ERROR (atan2dg_mp (p, x, y, x, digs) == NaN_MP, p, ERROR_INVALID_ARGUMENT, MOID (p));
1413 A68G_SP -= size;
1414 MP_STATUS (x) = (MP_T) INIT_MASK;
1415 }
1416
1417 //! @brief PROC (LONG REAL) LONG REAL long
1418
1419 void genie_sinpi_mp (NODE_T * p)
1420 {
1421 C_L_FUNCTION (p, sinpi_mp);
1422 }
1423
1424 //! @brief PROC (LONG REAL) LONG REAL long
1425
1426 void genie_cospi_mp (NODE_T * p)
1427 {
1428 C_L_FUNCTION (p, cospi_mp);
1429 }
1430
1431 //! @brief PROC (LONG REAL) LONG REAL long
1432
1433 void genie_cotpi_mp (NODE_T * p)
1434 {
1435 C_L_FUNCTION (p, cotpi_mp);
1436 }
1437
1438 //! @brief PROC (LONG REAL) LONG REAL long
1439
1440 void genie_tanpi_mp (NODE_T * p)
1441 {
1442 C_L_FUNCTION (p, tanpi_mp);
1443 }
|
© 2002-2026 J.M. van der Veer (jmvdveer@xs4all.nl)
|
