single.c
You can download the current version of Algol 68 Genie and its documentation here.
1 //! @file single.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 .
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 .
21
22 //! @section Synopsis
23 //!
24 //! INT, REAL, COMPLEX and BITS routines.
25
26 #include "a68g.h"
27 #include "a68g-genie.h"
28 #include "a68g-prelude.h"
29 #include "a68g-double.h"
30 #include "a68g-numbers.h"
31 #include "a68g-stddef.h"
32
33 // INT operations.
34
35 // OP - = (INT) INT.
36
37 A68_MONAD (genie_minus_int, A68_INT, -);
38
39 // OP ABS = (INT) INT
40
41 void genie_abs_int (NODE_T * p)
42 {
43 A68_INT *j;
44 POP_OPERAND_ADDRESS (p, j, A68_INT);
45 VALUE (j) = ABS (VALUE (j));
46 }
47
48 // OP SIGN = (INT) INT
49
50 void genie_sign_int (NODE_T * p)
51 {
52 A68_INT *j;
53 POP_OPERAND_ADDRESS (p, j, A68_INT);
54 VALUE (j) = SIGN (VALUE (j));
55 }
56
57 // OP ODD = (INT) BOOL
58
59 void genie_odd_int (NODE_T * p)
60 {
61 A68_INT j;
62 POP_OBJECT (p, &j, A68_INT);
63 PUSH_VALUE (p, (BOOL_T) ((VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)) % 2 == 1), A68_BOOL);
64 }
65
66 // OP + = (INT, INT) INT
67
68 void genie_add_int (NODE_T * p)
69 {
70 A68_INT *i, *j;
71 POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
72 errno = 0;
73 VALUE (i) = a68_add_int (VALUE (i), VALUE (j));
74 MATH_RTE (p, errno != 0, M_INT, "M overflow");
75 }
76
77 // OP - = (INT, INT) INT
78
79 void genie_sub_int (NODE_T * p)
80 {
81 A68_INT *i, *j;
82 POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
83 errno = 0;
84 VALUE (i) = a68_sub_int (VALUE (i), VALUE (j));
85 MATH_RTE (p, errno != 0, M_INT, "M overflow");
86 }
87
88 // OP * = (INT, INT) INT
89
90 void genie_mul_int (NODE_T * p)
91 {
92 A68_INT *i, *j;
93 POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
94 errno = 0;
95 VALUE (i) = a68_mul_int (VALUE (i), VALUE (j));
96 MATH_RTE (p, errno != 0, M_INT, "M overflow");
97 }
98
99 // OP OVER = (INT, INT) INT
100
101 void genie_over_int (NODE_T * p)
102 {
103 A68_INT *i, *j;
104 POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
105 errno = 0;
106 VALUE (i) = a68_over_int (VALUE (i), VALUE (j));
107 MATH_RTE (p, errno != 0, M_INT, ERROR_DIVISION_BY_ZERO);
108 }
109
110 // OP MOD = (INT, INT) INT
111
112 void genie_mod_int (NODE_T * p)
113 {
114 A68_INT *i, *j;
115 POP_OPERAND_ADDRESSES (p, i, j, A68_INT);
116 errno = 0;
117 VALUE (i) = a68_mod_int (VALUE (i), VALUE (j));
118 MATH_RTE (p, errno != 0, M_INT, ERROR_DIVISION_BY_ZERO);
119 }
120
121 // OP / = (INT, INT) REAL
122
123 void genie_div_int (NODE_T * p)
124 {
125 A68_INT i, j;
126 POP_OBJECT (p, &j, A68_INT);
127 POP_OBJECT (p, &i, A68_INT);
128 errno = 0;
129 PUSH_VALUE (p, a68_div_int (VALUE (&i), VALUE (&j)), A68_REAL);
130 MATH_RTE (p, errno != 0, M_INT, "M division by zero");
131 }
132
133 // OP ** = (INT, INT) INT
134
135 void genie_pow_int (NODE_T * p)
136 {
137 A68_INT i, j;
138 POP_OBJECT (p, &j, A68_INT);
139 PRELUDE_ERROR (VALUE (&j) < 0, p, ERROR_EXPONENT_INVALID, M_INT);
140 POP_OBJECT (p, &i, A68_INT);
141 errno = 0;
142 PUSH_VALUE (p, a68_m_up_n (VALUE (&i), VALUE (&j)), A68_INT);
143 MATH_RTE (p, errno != 0, M_INT, "M overflow");
144 }
145
146 // OP (INT, INT) BOOL.
147
148 #define A68_CMP_INT(n, OP)\
149 void n (NODE_T * p) {\
150 A68_INT i, j;\
151 POP_OBJECT (p, &j, A68_INT);\
152 POP_OBJECT (p, &i, A68_INT);\
153 PUSH_VALUE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\
154 }
155
156 A68_CMP_INT (genie_eq_int, ==);
157 A68_CMP_INT (genie_ne_int, !=);
158 A68_CMP_INT (genie_lt_int, <);
159 A68_CMP_INT (genie_gt_int, >);
160 A68_CMP_INT (genie_le_int, <=);
161 A68_CMP_INT (genie_ge_int, >=);
162
163 // OP +:= = (REF INT, INT) REF INT
164
165 void genie_plusab_int (NODE_T * p)
166 {
167 genie_f_and_becomes (p, M_REF_INT, genie_add_int);
168 }
169
170 // OP -:= = (REF INT, INT) REF INT
171
172 void genie_minusab_int (NODE_T * p)
173 {
174 genie_f_and_becomes (p, M_REF_INT, genie_sub_int);
175 }
176
177 // OP *:= = (REF INT, INT) REF INT
178
179 void genie_timesab_int (NODE_T * p)
180 {
181 genie_f_and_becomes (p, M_REF_INT, genie_mul_int);
182 }
183
184 // OP %:= = (REF INT, INT) REF INT
185
186 void genie_overab_int (NODE_T * p)
187 {
188 genie_f_and_becomes (p, M_REF_INT, genie_over_int);
189 }
190
191 // OP %*:= = (REF INT, INT) REF INT
192
193 void genie_modab_int (NODE_T * p)
194 {
195 genie_f_and_becomes (p, M_REF_INT, genie_mod_int);
196 }
197
198 // REAL operations.
199
200 // OP - = (REAL) REAL.
201
202 A68_MONAD (genie_minus_real, A68_REAL, -);
203
204 // OP ABS = (REAL) REAL
205
206 void genie_abs_real (NODE_T * p)
207 {
208 A68_REAL *x;
209 POP_OPERAND_ADDRESS (p, x, A68_REAL);
210 VALUE (x) = ABS (VALUE (x));
211 }
212
213 // OP ROUND = (REAL) INT
214
215 void genie_round_real (NODE_T * p)
216 {
217 A68_REAL x;
218 POP_OBJECT (p, &x, A68_REAL);
219 PRELUDE_ERROR (VALUE (&x) < -(REAL_T) A68_MAX_INT || VALUE (&x) > (REAL_T) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, M_INT);
220 PUSH_VALUE (p, a68_round (VALUE (&x)), A68_INT);
221 }
222
223 // OP ENTIER = (REAL) INT
224
225 void genie_entier_real (NODE_T * p)
226 {
227 A68_REAL x;
228 POP_OBJECT (p, &x, A68_REAL);
229 PRELUDE_ERROR (VALUE (&x) < -(REAL_T) A68_MAX_INT || VALUE (&x) > (REAL_T) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, M_INT);
230 PUSH_VALUE (p, (INT_T) floor (VALUE (&x)), A68_INT);
231 }
232
233 // OP SIGN = (REAL) INT
234
235 void genie_sign_real (NODE_T * p)
236 {
237 A68_REAL x;
238 POP_OBJECT (p, &x, A68_REAL);
239 PUSH_VALUE (p, SIGN (VALUE (&x)), A68_INT);
240 }
241
242 // OP + = (REAL, REAL) REAL
243
244 void genie_add_real (NODE_T * p)
245 {
246 A68_REAL *x, *y;
247 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
248 VALUE (x) += VALUE (y);
249 CHECK_REAL (p, VALUE (x));
250 }
251
252 // OP - = (REAL, REAL) REAL
253
254 void genie_sub_real (NODE_T * p)
255 {
256 A68_REAL *x, *y;
257 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
258 VALUE (x) -= VALUE (y);
259 CHECK_REAL (p, VALUE (x));
260 }
261
262 // OP * = (REAL, REAL) REAL
263
264 void genie_mul_real (NODE_T * p)
265 {
266 A68_REAL *x, *y;
267 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
268 VALUE (x) *= VALUE (y);
269 CHECK_REAL (p, VALUE (x));
270 }
271
272 // OP / = (REAL, REAL) REAL
273
274 void genie_div_real (NODE_T * p)
275 {
276 A68_REAL *x, *y;
277 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
278 PRELUDE_ERROR (VALUE (y) == 0.0, p, ERROR_DIVISION_BY_ZERO, M_REAL);
279 VALUE (x) /= VALUE (y);
280 }
281
282 // OP ** = (REAL, INT) REAL
283
284 void genie_pow_real_int (NODE_T * p)
285 {
286 A68_INT j;
287 A68_REAL x;
288 REAL_T z;
289 POP_OBJECT (p, &j, A68_INT);
290 POP_OBJECT (p, &x, A68_REAL);
291 z = a68_x_up_n (VALUE (&x), VALUE (&j));
292 CHECK_REAL (p, z);
293 PUSH_VALUE (p, z, A68_REAL);
294 }
295
296 // OP ** = (REAL, REAL) REAL
297
298 void genie_pow_real (NODE_T * p)
299 {
300 A68_REAL x, y;
301 REAL_T z = 0;
302 POP_OBJECT (p, &y, A68_REAL);
303 POP_OBJECT (p, &x, A68_REAL);
304 errno = 0;
305 z = a68_x_up_y (VALUE (&x), VALUE (&y));
306 MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);
307 PUSH_VALUE (p, z, A68_REAL);
308 }
309
310 // OP (REAL, REAL) BOOL.
311
312 #define A68_CMP_REAL(n, OP)\
313 void n (NODE_T * p) {\
314 A68_REAL i, j;\
315 POP_OBJECT (p, &j, A68_REAL);\
316 POP_OBJECT (p, &i, A68_REAL);\
317 PUSH_VALUE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\
318 }
319
320 A68_CMP_REAL (genie_eq_real, ==);
321 A68_CMP_REAL (genie_ne_real, !=);
322 A68_CMP_REAL (genie_lt_real, <);
323 A68_CMP_REAL (genie_gt_real, >);
324 A68_CMP_REAL (genie_le_real, <=);
325 A68_CMP_REAL (genie_ge_real, >=);
326
327 // OP +:= = (REF REAL, REAL) REF REAL
328
329 void genie_plusab_real (NODE_T * p)
330 {
331 genie_f_and_becomes (p, M_REF_REAL, genie_add_real);
332 }
333
334 // OP -:= = (REF REAL, REAL) REF REAL
335
336 void genie_minusab_real (NODE_T * p)
337 {
338 genie_f_and_becomes (p, M_REF_REAL, genie_sub_real);
339 }
340
341 // OP *:= = (REF REAL, REAL) REF REAL
342
343 void genie_timesab_real (NODE_T * p)
344 {
345 genie_f_and_becomes (p, M_REF_REAL, genie_mul_real);
346 }
347
348 // OP /:= = (REF REAL, REAL) REF REAL
349
350 void genie_divab_real (NODE_T * p)
351 {
352 genie_f_and_becomes (p, M_REF_REAL, genie_div_real);
353 }
354
355 // @brief PROC (INT) VOID first random
356
357 void genie_first_random (NODE_T * p)
358 {
359 A68_INT i;
360 POP_OBJECT (p, &i, A68_INT);
361 init_rng ((unt) VALUE (&i));
362 }
363
364 // @brief PROC REAL next random
365
366 void genie_next_random (NODE_T * p)
367 {
368 PUSH_VALUE (p, a68_unif_rand (), A68_REAL);
369 }
370
371 // @brief PROC REAL rnd
372
373 void genie_next_rnd (NODE_T * p)
374 {
375 PUSH_VALUE (p, 2 * a68_unif_rand () - 1, A68_REAL);
376 }
377
378 // BITS operations.
379
380 // BITS max bits
381
382 void genie_max_bits (NODE_T * p)
383 {
384 PUSH_VALUE (p, A68_MAX_BITS, A68_BITS);
385 }
386
387 // OP NOT = (BITS) BITS.
388 A68_MONAD (genie_not_bits, A68_BITS, ~);
389
390 // OP AND = (BITS, BITS) BITS
391
392 void genie_and_bits (NODE_T * p)
393 {
394 A68_BITS *i, *j;
395 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
396 VALUE (i) = VALUE (i) & VALUE (j);
397 }
398
399 // OP OR = (BITS, BITS) BITS
400
401 void genie_or_bits (NODE_T * p)
402 {
403 A68_BITS *i, *j;
404 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
405 VALUE (i) = VALUE (i) | VALUE (j);
406 }
407
408 // OP XOR = (BITS, BITS) BITS
409
410 void genie_xor_bits (NODE_T * p)
411 {
412 A68_BITS *i, *j;
413 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
414 VALUE (i) = VALUE (i) ^ VALUE (j);
415 }
416
417 // OP + = (BITS, BITS) BITS
418
419 void genie_add_bits (NODE_T * p)
420 {
421 A68_BITS *i, *j;
422 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
423 CHECK_BITS_ADDITION (p, VALUE (i), VALUE (j));
424 VALUE (i) = VALUE (i) + VALUE (j);
425 }
426
427 // OP - = (BITS, BITS) BITS
428
429 void genie_sub_bits (NODE_T * p)
430 {
431 A68_BITS *i, *j;
432 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
433 CHECK_BITS_SUBTRACTION (p, VALUE (i), VALUE (j));
434 VALUE (i) = VALUE (i) - VALUE (j);
435 }
436
437 // OP * = (BITS, BITS) BITS
438
439 void genie_times_bits (NODE_T * p)
440 {
441 A68_BITS *i, *j;
442 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
443 CHECK_BITS_MULTIPLICATION (p, VALUE (i), VALUE (j));
444 VALUE (i) = VALUE (i) * VALUE (j);
445 }
446
447 // OP OVER = (BITS, BITS) BITS
448
449 void genie_over_bits (NODE_T * p)
450 {
451 A68_BITS *i, *j;
452 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
453 PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, M_BITS);
454 VALUE (i) = VALUE (i) / VALUE (j);
455 }
456
457 // OP MOD = (BITS, BITS) BITS
458
459 void genie_mod_bits (NODE_T * p)
460 {
461 A68_BITS *i, *j;
462 POP_OPERAND_ADDRESSES (p, i, j, A68_BITS);
463 PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, M_BITS);
464 VALUE (i) = VALUE (i) % VALUE (j);
465 }
466
467 // OP = = (BITS, BITS) BOOL.
468
469 #define A68_CMP_BITS(n, OP)\
470 void n (NODE_T * p) {\
471 A68_BITS i, j;\
472 POP_OBJECT (p, &j, A68_BITS);\
473 POP_OBJECT (p, &i, A68_BITS);\
474 PUSH_VALUE (p, (BOOL_T) ((UNSIGNED_T) VALUE (&i) OP (UNSIGNED_T) VALUE (&j)), A68_BOOL);\
475 }
476
477 A68_CMP_BITS (genie_eq_bits, ==);
478 A68_CMP_BITS (genie_ne_bits, !=);
479
480 // OP <= = (BITS, BITS) BOOL
481
482 void genie_le_bits (NODE_T * p)
483 {
484 A68_BITS i, j;
485 POP_OBJECT (p, &j, A68_BITS);
486 POP_OBJECT (p, &i, A68_BITS);
487 PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL);
488 }
489
490 // OP >= = (BITS, BITS) BOOL
491
492 void genie_ge_bits (NODE_T * p)
493 {
494 A68_BITS i, j;
495 POP_OBJECT (p, &j, A68_BITS);
496 POP_OBJECT (p, &i, A68_BITS);
497 PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL);
498 }
499
500 #if (A68_LEVEL >= 3)
501
502 // OP < = (BITS, BITS) BOOL
503
504 void genie_lt_bits (NODE_T * p)
505 {
506 A68_BITS i, j;
507 POP_OBJECT (p, &j, A68_BITS);
508 POP_OBJECT (p, &i, A68_BITS);
509 if (VALUE (&i) == VALUE (&j)) {
510 PUSH_VALUE (p, A68_FALSE, A68_BOOL);
511 } else {
512 PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL);
513 }
514 }
515
516 // OP >= = (BITS, BITS) BOOL
517
518 void genie_gt_bits (NODE_T * p)
519 {
520 A68_BITS i, j;
521 POP_OBJECT (p, &j, A68_BITS);
522 POP_OBJECT (p, &i, A68_BITS);
523 if (VALUE (&i) == VALUE (&j)) {
524 PUSH_VALUE (p, A68_FALSE, A68_BOOL);
525 } else {
526 PUSH_VALUE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL);
527 }
528 }
529
530 #endif
531
532 // OP SHL = (BITS, INT) BITS
533
534 void genie_shl_bits (NODE_T * p)
535 {
536 A68_BITS i;
537 A68_INT j;
538 POP_OBJECT (p, &j, A68_INT);
539 POP_OBJECT (p, &i, A68_BITS);
540 if (VALUE (&j) >= 0) {
541 int k;
542 UNSIGNED_T z = VALUE (&i);
543 for (k = 0; k < VALUE (&j); k++) {
544 PRELUDE_ERROR (!MODULAR_MATH (p) && (z & D_SIGN), p, ERROR_MATH, M_BITS);
545 z = z << 1;
546 }
547 PUSH_VALUE (p, z, A68_BITS);
548 } else {
549 PUSH_VALUE (p, VALUE (&i) >> -VALUE (&j), A68_BITS);
550 }
551 }
552
553 // OP SHR = (BITS, INT) BITS
554
555 void genie_shr_bits (NODE_T * p)
556 {
557 A68_INT *j;
558 POP_OPERAND_ADDRESS (p, j, A68_INT);
559 VALUE (j) = -VALUE (j);
560 genie_shl_bits (p); // Conform RR
561 }
562
563 // OP ROL = (BITS, INT) BITS
564
565 void genie_rol_bits (NODE_T * p)
566 {
567 A68_BITS i;
568 A68_INT j;
569 int k, n;
570 UNSIGNED_T w;
571 POP_OBJECT (p, &j, A68_INT);
572 POP_OBJECT (p, &i, A68_BITS);
573 CHECK_INT_SHORTEN (p, VALUE (&j));
574 w = VALUE (&i);
575 n = VALUE (&j);
576 if (n >= 0) {
577 for (k = 0; k < n; k++) {
578 UNSIGNED_T carry = (w & D_SIGN ? 0x1 : 0x0);
579 w = (w << 1) | carry;
580 }
581 } else {
582 n = -n;
583 for (k = 0; k < n; k++) {
584 UNSIGNED_T carry = (w & 0x1 ? D_SIGN : 0x0);
585 w = (w >> 1) | carry;
586 }
587 }
588 PUSH_VALUE (p, w, A68_BITS);
589 }
590
591 // OP ROR = (BITS, INT) BITS
592
593 void genie_ror_bits (NODE_T * p)
594 {
595 A68_INT *j;
596 POP_OPERAND_ADDRESS (p, j, A68_INT);
597 VALUE (j) = -VALUE (j);
598 genie_rol_bits (p);
599 }
600
601 // OP ELEM = (INT, BITS) BOOL
602
603 void genie_elem_bits (NODE_T * p)
604 {
605 A68_BITS j;
606 A68_INT i;
607 int n;
608 UNSIGNED_T mask = 0x1;
609 POP_OBJECT (p, &j, A68_BITS);
610 POP_OBJECT (p, &i, A68_INT);
611 PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
612 for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
613 mask = mask << 1;
614 }
615 PUSH_VALUE (p, (BOOL_T) ((VALUE (&j) & mask) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
616 }
617
618 // OP SET = (INT, BITS) BITS
619
620 void genie_set_bits (NODE_T * p)
621 {
622 A68_BITS j;
623 A68_INT i;
624 int n;
625 UNSIGNED_T mask = 0x1;
626 POP_OBJECT (p, &j, A68_BITS);
627 POP_OBJECT (p, &i, A68_INT);
628 PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
629 for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
630 mask = mask << 1;
631 }
632 PUSH_VALUE (p, VALUE (&j) | mask, A68_BITS);
633 }
634
635 // OP CLEAR = (INT, BITS) BITS
636
637 void genie_clear_bits (NODE_T * p)
638 {
639 A68_BITS j;
640 A68_INT i;
641 int n;
642 UNSIGNED_T mask = 0x1;
643 POP_OBJECT (p, &j, A68_BITS);
644 POP_OBJECT (p, &i, A68_INT);
645 PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_INT);
646 for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) {
647 mask = mask << 1;
648 }
649 PUSH_VALUE (p, VALUE (&j) & ~mask, A68_BITS);
650 }
651
652 // OP ABS = (BITS) INT
653
654 void genie_abs_bits (NODE_T * p)
655 {
656 A68_BITS i;
657 POP_OBJECT (p, &i, A68_BITS);
658 PUSH_VALUE (p, (INT_T) (VALUE (&i)), A68_INT);
659 }
660
661 // OP BIN = (INT) BITS
662
663 void genie_bin_int (NODE_T * p)
664 {
665 A68_INT i;
666 POP_OBJECT (p, &i, A68_INT);
667 if (!MODULAR_MATH (p) && VALUE (&i) < 0) {
668 // RR does not convert negative numbers.
669 errno = EDOM;
670 diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, M_BITS);
671 exit_genie (p, A68_RUNTIME_ERROR);
672 }
673 PUSH_VALUE (p, (UNSIGNED_T) (VALUE (&i)), A68_BITS);
674 }
675
676 // @brief PROC ([] BOOL) BITS bits pack
677
678 void genie_bits_pack (NODE_T * p)
679 {
680 A68_REF z;
681 A68_BITS b;
682 A68_ARRAY *arr;
683 A68_TUPLE *tup;
684 BYTE_T *base;
685 int size, k;
686 UNSIGNED_T bit;
687 POP_REF (p, &z);
688 CHECK_REF (p, z, M_ROW_BOOL);
689 GET_DESCRIPTOR (arr, tup, &z);
690 size = ROW_SIZE (tup);
691 PRELUDE_ERROR (size < 0 || size > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, M_ROW_BOOL);
692 VALUE (&b) = 0x0;
693 if (ROW_SIZE (tup) > 0) {
694 base = DEREF (BYTE_T, &ARRAY (arr));
695 bit = 0x1;
696 for (k = UPB (tup); k >= LWB (tup); k--) {
697 int addr = INDEX_1_DIM (arr, tup, k);
698 A68_BOOL *boo = (A68_BOOL *) & (base[addr]);
699 CHECK_INIT (p, INITIALISED (boo), M_BOOL);
700 if (VALUE (boo)) {
701 VALUE (&b) |= bit;
702 }
703 bit <<= 1;
704 }
705 }
706 STATUS (&b) = INIT_MASK;
707 PUSH_OBJECT (p, b, A68_BITS);
708 }
709
710 // @brief PROC (REAL) REAL sqrt
711
712 void genie_sqrt_real (NODE_T * p)
713 {
714 C_FUNCTION (p, sqrt);
715 }
716
717 // @brief PROC (REAL) REAL curt
718
719 void genie_curt_real (NODE_T * p)
720 {
721 C_FUNCTION (p, cbrt);
722 }
723
724 // @brief PROC (REAL) REAL exp
725
726 void genie_exp_real (NODE_T * p)
727 {
728 A68_REAL *x;
729 POP_OPERAND_ADDRESS (p, x, A68_REAL);
730 if (VALUE (x) > LOG_DBL_MAX) {
731 errno = EDOM;
732 } else if (VALUE (x) < LOG_DBL_MIN) {
733 errno = EDOM;
734 } else {
735 errno = 0;
736 VALUE (x) = exp (VALUE (x));
737 }
738 MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);
739 }
740
741 // @brief PROC (REAL) REAL ln
742
743 void genie_ln_real (NODE_T * p)
744 {
745 C_FUNCTION (p, a68_ln);
746 }
747
748 // @brief PROC (REAL) REAL ln1p
749
750 void genie_ln1p_real (NODE_T * p)
751 {
752 C_FUNCTION (p, a68_ln1p);
753 }
754
755 // @brief PROC (REAL) REAL log
756
757 void genie_log_real (NODE_T * p)
758 {
759 C_FUNCTION (p, log10);
760 }
761
762 // @brief PROC (REAL) REAL sin
763
764 void genie_sin_real (NODE_T * p)
765 {
766 C_FUNCTION (p, sin);
767 }
768
769 // @brief PROC (REAL) REAL arcsin
770
771 void genie_asin_real (NODE_T * p)
772 {
773 C_FUNCTION (p, asin);
774 }
775
776 // @brief PROC (REAL) REAL cos
777
778 void genie_cos_real (NODE_T * p)
779 {
780 C_FUNCTION (p, cos);
781 }
782
783 // @brief PROC (REAL) REAL arccos
784
785 void genie_acos_real (NODE_T * p)
786 {
787 C_FUNCTION (p, acos);
788 }
789
790 // @brief PROC (REAL) REAL tan
791
792 void genie_tan_real (NODE_T * p)
793 {
794 C_FUNCTION (p, tan);
795 }
796
797 // @brief PROC (REAL) REAL csc
798
799 void genie_csc_real (NODE_T * p)
800 {
801 C_FUNCTION (p, a68_csc);
802 }
803
804 // @brief PROC (REAL) REAL acsc
805
806 void genie_acsc_real (NODE_T * p)
807 {
808 C_FUNCTION (p, a68_acsc);
809 }
810
811 // @brief PROC (REAL) REAL sec
812
813 void genie_sec_real (NODE_T * p)
814 {
815 C_FUNCTION (p, a68_sec);
816 }
817
818 // @brief PROC (REAL) REAL asec
819
820 void genie_asec_real (NODE_T * p)
821 {
822 C_FUNCTION (p, a68_asec);
823 }
824
825 // @brief PROC (REAL) REAL cot
826
827 void genie_cot_real (NODE_T * p)
828 {
829 C_FUNCTION (p, a68_cot);
830 }
831
832 // @brief PROC (REAL) REAL acot
833
834 void genie_acot_real (NODE_T * p)
835 {
836 C_FUNCTION (p, a68_acot);
837 }
838
839 // @brief PROC (REAL) REAL arctan
840
841 void genie_atan_real (NODE_T * p)
842 {
843 C_FUNCTION (p, atan);
844 }
845
846 // @brief PROC (REAL, REAL) REAL arctan2
847
848 void genie_atan2_real (NODE_T * p)
849 {
850 A68_REAL *x, *y;
851 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
852 errno = 0;
853 PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL);
854 VALUE (x) = a68_atan2 (VALUE (y), VALUE (x));
855 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
856 }
857
858 // @brief PROC (REAL) REAL sindg
859
860 void genie_sindg_real (NODE_T * p)
861 {
862 C_FUNCTION (p, a68_sindg);
863 }
864
865 // @brief PROC (REAL) REAL arcsindg
866
867 void genie_asindg_real (NODE_T * p)
868 {
869 C_FUNCTION (p, a68_asindg);
870 }
871
872 // @brief PROC (REAL) REAL cosdg
873
874 void genie_cosdg_real (NODE_T * p)
875 {
876 C_FUNCTION (p, a68_cosdg);
877 }
878
879 // @brief PROC (REAL) REAL arccosdg
880
881 void genie_acosdg_real (NODE_T * p)
882 {
883 C_FUNCTION (p, a68_acosdg);
884 }
885
886 // @brief PROC (REAL) REAL tandg
887
888 void genie_tandg_real (NODE_T * p)
889 {
890 C_FUNCTION (p, a68_tandg);
891 }
892
893 // @brief PROC (REAL) REAL arctandg
894
895 void genie_atandg_real (NODE_T * p)
896 {
897 C_FUNCTION (p, a68_atandg);
898 }
899
900 // @brief PROC (REAL) REAL cotdg
901
902 void genie_cotdg_real (NODE_T * p)
903 {
904 C_FUNCTION (p, a68_cotdg);
905 }
906
907 // @brief PROC (REAL) REAL acotdg
908
909 void genie_acotdg_real (NODE_T * p)
910 {
911 C_FUNCTION (p, a68_acotdg);
912 }
913
914 // @brief PROC (REAL, REAL) REAL arctan2dg
915
916 void genie_atan2dg_real (NODE_T * p)
917 {
918 A68_REAL *x, *y;
919 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
920 errno = 0;
921 PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, M_LONG_REAL);
922 VALUE (x) = CONST_180_OVER_PI * a68_atan2 (VALUE (y), VALUE (x));
923 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
924 }
925
926 // @brief PROC (REAL) REAL sinpi
927
928 void genie_sinpi_real (NODE_T * p)
929 {
930 C_FUNCTION (p, a68_sinpi);
931 }
932
933 // @brief PROC (REAL) REAL cospi
934
935 void genie_cospi_real (NODE_T * p)
936 {
937 C_FUNCTION (p, a68_cospi);
938 }
939
940 // @brief PROC (REAL) REAL tanpi
941
942 void genie_tanpi_real (NODE_T * p)
943 {
944 C_FUNCTION (p, a68_tanpi);
945 }
946
947 // @brief PROC (REAL) REAL cotpi
948
949 void genie_cotpi_real (NODE_T * p)
950 {
951 C_FUNCTION (p, a68_cotpi);
952 }
953
954 // @brief PROC (REAL) REAL sinh
955
956 void genie_sinh_real (NODE_T * p)
957 {
958 C_FUNCTION (p, sinh);
959 }
960
961 // @brief PROC (REAL) REAL cosh
962
963 void genie_cosh_real (NODE_T * p)
964 {
965 C_FUNCTION (p, cosh);
966 }
967
968 // @brief PROC (REAL) REAL tanh
969
970 void genie_tanh_real (NODE_T * p)
971 {
972 C_FUNCTION (p, tanh);
973 }
974
975 // @brief PROC (REAL) REAL asinh
976
977 void genie_asinh_real (NODE_T * p)
978 {
979 C_FUNCTION (p, a68_asinh);
980 }
981
982 // @brief PROC (REAL) REAL acosh
983
984 void genie_acosh_real (NODE_T * p)
985 {
986 C_FUNCTION (p, a68_acosh);
987 }
988
989 // @brief PROC (REAL) REAL atanh
990
991 void genie_atanh_real (NODE_T * p)
992 {
993 C_FUNCTION (p, a68_atanh);
994 }
995
996 // @brief PROC (REAL) REAL erf
997
998 void genie_erf_real (NODE_T * p)
999 {
1000 C_FUNCTION (p, erf);
1001 }
1002
1003 // @brief PROC (REAL) REAL inverf
1004
1005 void genie_inverf_real (NODE_T * p)
1006 {
1007 C_FUNCTION (p, a68_inverf);
1008 }
1009
1010 // @brief PROC (REAL) REAL erfc
1011
1012 void genie_erfc_real (NODE_T * p)
1013 {
1014 C_FUNCTION (p, erfc);
1015 }
1016
1017 // @brief PROC (REAL) REAL inverfc
1018
1019 void genie_inverfc_real (NODE_T * p)
1020 {
1021 C_FUNCTION (p, a68_inverfc);
1022 }
1023
1024 // @brief PROC (REAL) REAL gamma
1025
1026 void genie_gamma_real (NODE_T * p)
1027 {
1028 C_FUNCTION (p, tgamma);
1029 }
1030
1031 // @brief PROC (REAL) REAL ln gamma
1032
1033 void genie_ln_gamma_real (NODE_T * p)
1034 {
1035 C_FUNCTION (p, lgamma);
1036 }
1037
1038 // @brief PROC (REAL, REAL) REAL beta
1039
1040 void genie_beta_real (NODE_T * p)
1041 {
1042 A68_REAL *x, *y;
1043 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
1044 errno = 0;
1045 VALUE (x) = a68_beta (VALUE (x), VALUE (y));
1046 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1047 }
1048
1049 // @brief PROC (REAL, REAL) REAL ln beta
1050
1051 void genie_ln_beta_real (NODE_T * p)
1052 {
1053 A68_REAL *x, *y;
1054 POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);
1055 errno = 0;
1056 VALUE (x) = a68_ln_beta (VALUE (x), VALUE (y));
1057 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1058 }
1059
1060 // @brief PROC (REAL, REAL, REAL) REAL cf beta inc
1061
1062 void genie_beta_inc_cf_real (NODE_T * p)
1063 {
1064 A68_REAL *s, *t, *x;
1065 POP_3_OPERAND_ADDRESSES (p, s, t, x, A68_REAL);
1066 errno = 0;
1067 VALUE (s) = a68_beta_inc (VALUE (s), VALUE (t), VALUE (x));
1068 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1069 }
1070
1071 // @brief PROC (REAL, REAL, REAL) REAL lj e 12 6
1072
1073 void genie_lj_e_12_6 (NODE_T * p)
1074 {
1075 A68_REAL *e, *s, *r;
1076 REAL_T u, u2, u6;
1077 POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL);
1078 PRELUDE_ERROR (VALUE (r) == 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1079 u = (VALUE (s) / VALUE (r));
1080 u2 = u * u;
1081 u6 = u2 * u2 * u2;
1082 VALUE (e) = 4.0 * VALUE (e) * u6 * (u6 - 1.0);
1083 }
1084
1085 // @brief PROC (REAL, REAL, REAL) REAL lj f 12 6
1086
1087 void genie_lj_f_12_6 (NODE_T * p)
1088 {
1089 A68_REAL *e, *s, *r;
1090 REAL_T u, u2, u6;
1091 POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL);
1092 PRELUDE_ERROR (VALUE (r) == 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
1093 u = (VALUE (s) / VALUE (r));
1094 u2 = u * u;
1095 u6 = u2 * u2 * u2;
1096 VALUE (e) = 24.0 * VALUE (e) * u * u6 * (1.0 - 2.0 * u6);
1097 }
1098
1099 // This file also contains Algol68G's standard environ for complex numbers.
1100 // Some of the LONG operations are generic for LONG and LONG LONG.
1101 //
1102 // Some routines are based on
1103 // GNU Scientific Library
1104 // Abramowitz and Stegun.
1105
1106 // OP +* = (REAL, REAL) COMPLEX
1107
1108 void genie_i_complex (NODE_T * p)
1109 {
1110 // This function must exist so the code generator recognises it!
1111 (void) p;
1112 }
1113
1114 // OP +* = (INT, INT) COMPLEX
1115
1116 void genie_i_int_complex (NODE_T * p)
1117 {
1118 A68_INT re, im;
1119 POP_OBJECT (p, &im, A68_INT);
1120 POP_OBJECT (p, &re, A68_INT);
1121 PUSH_VALUE (p, (REAL_T) VALUE (&re), A68_REAL);
1122 PUSH_VALUE (p, (REAL_T) VALUE (&im), A68_REAL);
1123 }
1124
1125 // OP RE = (COMPLEX) REAL
1126
1127 void genie_re_complex (NODE_T * p)
1128 {
1129 DECREMENT_STACK_POINTER (p, SIZE (M_REAL));
1130 }
1131
1132 // OP IM = (COMPLEX) REAL
1133
1134 void genie_im_complex (NODE_T * p)
1135 {
1136 A68_REAL im;
1137 POP_OBJECT (p, &im, A68_REAL);
1138 *(A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL))) = im;
1139 }
1140
1141 // OP - = (COMPLEX) COMPLEX
1142
1143 void genie_minus_complex (NODE_T * p)
1144 {
1145 A68_REAL *re_x, *im_x;
1146 im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL)));
1147 re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL)));
1148 VALUE (im_x) = -VALUE (im_x);
1149 VALUE (re_x) = -VALUE (re_x);
1150 (void) p;
1151 }
1152
1153 // ABS = (COMPLEX) REAL
1154
1155 void genie_abs_complex (NODE_T * p)
1156 {
1157 A68_REAL re_x, im_x;
1158 POP_COMPLEX (p, &re_x, &im_x);
1159 PUSH_VALUE (p, a68_hypot (VALUE (&re_x), VALUE (&im_x)), A68_REAL);
1160 }
1161
1162 // OP ARG = (COMPLEX) REAL
1163
1164 void genie_arg_complex (NODE_T * p)
1165 {
1166 A68_REAL re_x, im_x;
1167 POP_COMPLEX (p, &re_x, &im_x);
1168 PRELUDE_ERROR (VALUE (&re_x) == 0.0 && VALUE (&im_x) == 0.0, p, ERROR_INVALID_ARGUMENT, M_COMPLEX);
1169 PUSH_VALUE (p, atan2 (VALUE (&im_x), VALUE (&re_x)), A68_REAL);
1170 }
1171
1172 // OP CONJ = (COMPLEX) COMPLEX
1173
1174 void genie_conj_complex (NODE_T * p)
1175 {
1176 A68_REAL *im;
1177 POP_OPERAND_ADDRESS (p, im, A68_REAL);
1178 VALUE (im) = -VALUE (im);
1179 }
1180
1181 // OP + = (COMPLEX, COMPLEX) COMPLEX
1182
1183 void genie_add_complex (NODE_T * p)
1184 {
1185 A68_REAL *re_x, *im_x, re_y, im_y;
1186 POP_COMPLEX (p, &re_y, &im_y);
1187 im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL)));
1188 re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL)));
1189 VALUE (im_x) += VALUE (&im_y);
1190 VALUE (re_x) += VALUE (&re_y);
1191 CHECK_COMPLEX (p, VALUE (re_x), VALUE (im_x));
1192 }
1193
1194 // OP - = (COMPLEX, COMPLEX) COMPLEX
1195
1196 void genie_sub_complex (NODE_T * p)
1197 {
1198 A68_REAL *re_x, *im_x, re_y, im_y;
1199 POP_COMPLEX (p, &re_y, &im_y);
1200 im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (M_REAL)));
1201 re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (M_REAL)));
1202 VALUE (im_x) -= VALUE (&im_y);
1203 VALUE (re_x) -= VALUE (&re_y);
1204 CHECK_COMPLEX (p, VALUE (re_x), VALUE (im_x));
1205 }
1206
1207 // OP * = (COMPLEX, COMPLEX) COMPLEX
1208
1209 void genie_mul_complex (NODE_T * p)
1210 {
1211 A68_REAL re_x, im_x, re_y, im_y;
1212 REAL_T re, im;
1213 POP_COMPLEX (p, &re_y, &im_y);
1214 POP_COMPLEX (p, &re_x, &im_x);
1215 re = VALUE (&re_x) * VALUE (&re_y) - VALUE (&im_x) * VALUE (&im_y);
1216 im = VALUE (&im_x) * VALUE (&re_y) + VALUE (&re_x) * VALUE (&im_y);
1217 CHECK_COMPLEX (p, re, im);
1218 PUSH_COMPLEX (p, re, im);
1219 }
1220
1221 // OP / = (COMPLEX, COMPLEX) COMPLEX
1222
1223 void genie_div_complex (NODE_T * p)
1224 {
1225 A68_REAL re_x, im_x, re_y, im_y;
1226 REAL_T re = 0.0, im = 0.0;
1227 POP_COMPLEX (p, &re_y, &im_y);
1228 POP_COMPLEX (p, &re_x, &im_x);
1229 #if !defined (HAVE_IEEE_754)
1230 PRELUDE_ERROR (VALUE (&re_y) == 0.0 && VALUE (&im_y) == 0.0, p, ERROR_DIVISION_BY_ZERO, M_COMPLEX);
1231 #endif
1232 if (ABS (VALUE (&re_y)) >= ABS (VALUE (&im_y))) {
1233 REAL_T r = VALUE (&im_y) / VALUE (&re_y), den = VALUE (&re_y) + r * VALUE (&im_y);
1234 re = (VALUE (&re_x) + r * VALUE (&im_x)) / den;
1235 im = (VALUE (&im_x) - r * VALUE (&re_x)) / den;
1236 } else {
1237 REAL_T r = VALUE (&re_y) / VALUE (&im_y), den = VALUE (&im_y) + r * VALUE (&re_y);
1238 re = (VALUE (&re_x) * r + VALUE (&im_x)) / den;
1239 im = (VALUE (&im_x) * r - VALUE (&re_x)) / den;
1240 }
1241 CHECK_COMPLEX (p, re, im);
1242 PUSH_COMPLEX (p, re, im);
1243 }
1244
1245 // OP ** = (COMPLEX, INT) COMPLEX
1246
1247 void genie_pow_complex_int (NODE_T * p)
1248 {
1249 A68_REAL re_x, im_x;
1250 REAL_T re_y, im_y, re_z, im_z, rea;
1251 A68_INT j;
1252 INT_T expo;
1253 BOOL_T negative;
1254 POP_OBJECT (p, &j, A68_INT);
1255 POP_COMPLEX (p, &re_x, &im_x);
1256 re_z = 1.0;
1257 im_z = 0.0;
1258 re_y = VALUE (&re_x);
1259 im_y = VALUE (&im_x);
1260 expo = 1;
1261 negative = (BOOL_T) (VALUE (&j) < 0);
1262 if (negative) {
1263 VALUE (&j) = -VALUE (&j);
1264 }
1265 while ((UNSIGNED_T) expo <= (UNSIGNED_T) (VALUE (&j))) {
1266 if (expo & VALUE (&j)) {
1267 rea = re_z * re_y - im_z * im_y;
1268 im_z = re_z * im_y + im_z * re_y;
1269 re_z = rea;
1270 }
1271 rea = re_y * re_y - im_y * im_y;
1272 im_y = im_y * re_y + re_y * im_y;
1273 re_y = rea;
1274 expo <<= 1;
1275 }
1276 CHECK_COMPLEX (p, re_z, im_z);
1277 if (negative) {
1278 PUSH_VALUE (p, 1.0, A68_REAL);
1279 PUSH_VALUE (p, 0.0, A68_REAL);
1280 PUSH_VALUE (p, re_z, A68_REAL);
1281 PUSH_VALUE (p, im_z, A68_REAL);
1282 genie_div_complex (p);
1283 } else {
1284 PUSH_VALUE (p, re_z, A68_REAL);
1285 PUSH_VALUE (p, im_z, A68_REAL);
1286 }
1287 }
1288
1289 // OP = = (COMPLEX, COMPLEX) BOOL
1290
1291 void genie_eq_complex (NODE_T * p)
1292 {
1293 A68_REAL re_x, im_x, re_y, im_y;
1294 POP_COMPLEX (p, &re_y, &im_y);
1295 POP_COMPLEX (p, &re_x, &im_x);
1296 PUSH_VALUE (p, (BOOL_T) ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL);
1297 }
1298
1299 // OP /= = (COMPLEX, COMPLEX) BOOL
1300
1301 void genie_ne_complex (NODE_T * p)
1302 {
1303 A68_REAL re_x, im_x, re_y, im_y;
1304 POP_COMPLEX (p, &re_y, &im_y);
1305 POP_COMPLEX (p, &re_x, &im_x);
1306 PUSH_VALUE (p, (BOOL_T) ! ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL);
1307 }
1308
1309 // OP +:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1310
1311 void genie_plusab_complex (NODE_T * p)
1312 {
1313 genie_f_and_becomes (p, M_REF_COMPLEX, genie_add_complex);
1314 }
1315
1316 // OP -:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1317
1318 void genie_minusab_complex (NODE_T * p)
1319 {
1320 genie_f_and_becomes (p, M_REF_COMPLEX, genie_sub_complex);
1321 }
1322
1323 // OP *:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1324
1325 void genie_timesab_complex (NODE_T * p)
1326 {
1327 genie_f_and_becomes (p, M_REF_COMPLEX, genie_mul_complex);
1328 }
1329
1330 // OP /:= = (REF COMPLEX, COMPLEX) REF COMPLEX
1331
1332 void genie_divab_complex (NODE_T * p)
1333 {
1334 genie_f_and_becomes (p, M_REF_COMPLEX, genie_div_complex);
1335 }
1336
1337 #define C_C_FUNCTION(p, f)\
1338 A68_REAL re, im;\
1339 COMPLEX_T z;\
1340 POP_OBJECT (p, &im, A68_REAL);\
1341 POP_OBJECT (p, &re, A68_REAL);\
1342 errno = 0;\
1343 z = VALUE (&re) + VALUE (&im) * _Complex_I;\
1344 z = f (z);\
1345 PUSH_VALUE (p, (REAL_T) creal (z), A68_REAL);\
1346 PUSH_VALUE (p, (REAL_T) cimag (z), A68_REAL);\
1347 MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);
1348
1349 // @brief PROC (COMPLEX) COMPLEX csqrt
1350
1351 void genie_sqrt_complex (NODE_T * p)
1352 {
1353 C_C_FUNCTION (p, csqrt);
1354 }
1355
1356 // @brief PROC (COMPLEX) COMPLEX cexp
1357
1358 void genie_exp_complex (NODE_T * p)
1359 {
1360 C_C_FUNCTION (p, cexp);
1361 }
1362
1363 // @brief PROC (COMPLEX) COMPLEX cln
1364
1365 void genie_ln_complex (NODE_T * p)
1366 {
1367 C_C_FUNCTION (p, clog);
1368 }
1369
1370 // @brief PROC (COMPLEX) COMPLEX csin
1371
1372 void genie_sin_complex (NODE_T * p)
1373 {
1374 C_C_FUNCTION (p, csin);
1375 }
1376
1377 // @brief PROC (COMPLEX) COMPLEX ccos
1378
1379 void genie_cos_complex (NODE_T * p)
1380 {
1381 C_C_FUNCTION (p, ccos);
1382 }
1383
1384 // @brief PROC (COMPLEX) COMPLEX ctan
1385
1386 void genie_tan_complex (NODE_T * p)
1387 {
1388 C_C_FUNCTION (p, ctan);
1389 }
1390
1391 // @brief PROC carcsin= (COMPLEX) COMPLEX
1392
1393 void genie_asin_complex (NODE_T * p)
1394 {
1395 C_C_FUNCTION (p, casin);
1396 }
1397
1398 // @brief PROC (COMPLEX) COMPLEX carccos
1399
1400 void genie_acos_complex (NODE_T * p)
1401 {
1402 C_C_FUNCTION (p, cacos);
1403 }
1404
1405 // @brief PROC (COMPLEX) COMPLEX carctan
1406
1407 void genie_atan_complex (NODE_T * p)
1408 {
1409 C_C_FUNCTION (p, catan);
1410 }
1411
1412 // @brief PROC (COMPLEX) COMPLEX csinh
1413
1414 void genie_sinh_complex (NODE_T * p)
1415 {
1416 C_C_FUNCTION (p, csinh);
1417 }
1418
1419 // @brief PROC (COMPLEX) COMPLEX ccosh
1420
1421 void genie_cosh_complex (NODE_T * p)
1422 {
1423 C_C_FUNCTION (p, ccosh);
1424 }
1425
1426 // @brief PROC (COMPLEX) COMPLEX ctanh
1427
1428 void genie_tanh_complex (NODE_T * p)
1429 {
1430 C_C_FUNCTION (p, ctanh);
1431 }
1432
1433 // @brief PROC (COMPLEX) COMPLEX carcsinh
1434
1435 void genie_asinh_complex (NODE_T * p)
1436 {
1437 C_C_FUNCTION (p, casinh);
1438 }
1439
1440 // @brief PROC (COMPLEX) COMPLEX carccosh
1441
1442 void genie_acosh_complex (NODE_T * p)
1443 {
1444 C_C_FUNCTION (p, cacosh);
1445 }
1446
1447 // @brief PROC (COMPLEX) COMPLEX carctanh
1448
1449 void genie_atanh_complex (NODE_T * p)
1450 {
1451 C_C_FUNCTION (p, catanh);
1452 }
1453
1454 #define C_C_INLINE(z, x, f)\
1455 COMPLEX_T u = RE (x) + IM (x) * _Complex_I;\
1456 COMPLEX_T v = f (u);\
1457 STATUS_RE (z) = INIT_MASK;\
1458 STATUS_IM (z) = INIT_MASK;\
1459 RE (z) = creal (v);\
1460 IM (z) = cimag (v);\
1461
1462 //! @brief PROC (COMPLEX) COMPLEX csqrt
1463
1464 void a68_sqrt_complex (A68_REAL * z, A68_REAL * x)
1465 {
1466 C_C_INLINE (z, x, csqrt);
1467 }
1468
1469 //! @brief PROC (COMPLEX) COMPLEX cexp
1470
1471 void a68_exp_complex (A68_REAL * z, A68_REAL * x)
1472 {
1473 C_C_INLINE (z, x, cexp);
1474 }
1475
1476 //! @brief PROC (COMPLEX) COMPLEX cln
1477
1478 void a68_ln_complex (A68_REAL * z, A68_REAL * x)
1479 {
1480 C_C_INLINE (z, x, clog);
1481 }
1482
1483 //! @brief PROC (COMPLEX) COMPLEX csin
1484
1485 void a68_sin_complex (A68_REAL * z, A68_REAL * x)
1486 {
1487 C_C_INLINE (z, x, csin);
1488 }
1489
1490 //! @brief PROC (COMPLEX) COMPLEX ccos
1491
1492 void a68_cos_complex (A68_REAL * z, A68_REAL * x)
1493 {
1494 C_C_INLINE (z, x, ccos);
1495 }
1496
1497 //! @brief PROC (COMPLEX) COMPLEX ctan
1498
1499 void a68_tan_complex (A68_REAL * z, A68_REAL * x)
1500 {
1501 C_C_INLINE (z, x, ctan);
1502 }
1503
1504 //! @brief PROC (COMPLEX) COMPLEX casin
1505
1506 void a68_asin_complex (A68_REAL * z, A68_REAL * x)
1507 {
1508 C_C_INLINE (z, x, casin);
1509 }
1510
1511 //! @brief PROC (COMPLEX) COMPLEX cacos
1512
1513 void a68_acos_complex (A68_REAL * z, A68_REAL * x)
1514 {
1515 C_C_INLINE (z, x, cacos);
1516 }
1517
1518 //! @brief PROC (COMPLEX) COMPLEX catan
1519
1520 void a68_atan_complex (A68_REAL * z, A68_REAL * x)
1521 {
1522 C_C_INLINE (z, x, catan);
1523 }
1524
1525 //! @brief PROC (COMPLEX) COMPLEX csinh
1526
1527 void a68_sinh_complex (A68_REAL * z, A68_REAL * x)
1528 {
1529 C_C_INLINE (z, x, csinh);
1530 }
1531
1532 //! @brief PROC (COMPLEX) COMPLEX ccosh
1533
1534 void a68_cosh_complex (A68_REAL * z, A68_REAL * x)
1535 {
1536 C_C_INLINE (z, x, ccosh);
1537 }
1538
1539 //! @brief PROC (COMPLEX) COMPLEX ctanh
1540
1541 void a68_tanh_complex (A68_REAL * z, A68_REAL * x)
1542 {
1543 C_C_INLINE (z, x, ctanh);
1544 }
1545
1546 //! @brief PROC (COMPLEX) COMPLEX casinh
1547
1548 void a68_asinh_complex (A68_REAL * z, A68_REAL * x)
1549 {
1550 C_C_INLINE (z, x, casinh);
1551 }
1552
1553 //! @brief PROC (COMPLEX) COMPLEX cacosh
1554
1555 void a68_acosh_complex (A68_REAL * z, A68_REAL * x)
1556 {
1557 C_C_INLINE (z, x, cacosh);
1558 }
1559
1560 //! @brief PROC (COMPLEX) COMPLEX catanh
1561
1562 void a68_atanh_complex (A68_REAL * z, A68_REAL * x)
1563 {
1564 C_C_INLINE (z, x, catanh);
1565 }
1566
1567 //! @brief PROC (INT, INT) REAL choose
1568
1569 void genie_fact_real (NODE_T * p)
1570 {
1571 A68_INT n;
1572 POP_OBJECT (p, &n, A68_INT);
1573 errno = 0;
1574 PUSH_VALUE (p, a68_fact (VALUE (&n)), A68_REAL);
1575 MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1576 }
1577
1578 //! @brief PROC (INT, INT) REAL ln fact
1579
1580 void genie_ln_fact_real (NODE_T * p)
1581 {
1582 A68_INT n;
1583 POP_OBJECT (p, &n, A68_INT);
1584 errno = 0;
1585 PUSH_VALUE (p, a68_ln_fact (VALUE (&n)), A68_REAL);
1586 MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1587 }
1588
1589 void genie_choose_real (NODE_T * p)
1590 {
1591 A68_INT n, m;
1592 POP_OBJECT (p, &m, A68_INT);
1593 POP_OBJECT (p, &n, A68_INT);
1594 errno = 0;
1595 PUSH_VALUE (p, a68_choose (VALUE (&n), VALUE (&m)), A68_REAL);
1596 MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1597 }
1598
1599 //! @brief PROC (INT, INT) REAL ln choose
1600
1601 void genie_ln_choose_real (NODE_T * p)
1602 {
1603 A68_INT n, m;
1604 POP_OBJECT (p, &m, A68_INT);
1605 POP_OBJECT (p, &n, A68_INT);
1606 errno = 0;
1607 PUSH_VALUE (p, a68_ln_choose (VALUE (&n), VALUE (&m)), A68_REAL);
1608 MATH_RTE (p, errno != 0, M_INT, NO_TEXT);
1609 }
1610
1611 // OP / = (COMPLEX, COMPLEX) COMPLEX
1612
1613 void a68_div_complex (A68_REAL * z, A68_REAL * x, A68_REAL * y)
1614 {
1615 STATUS_RE (z) = INIT_MASK;
1616 STATUS_IM (z) = INIT_MASK;
1617 if (RE (y) == 0 && IM (y) == 0) {
1618 RE (z) = 0.0;
1619 IM (z) = 0.0;
1620 errno = EDOM;
1621 } else if (fabs (RE (y)) >= fabs (IM (y))) {
1622 REAL_T r = IM (y) / RE (y), den = RE (y) + r * IM (y);
1623 RE (z) = (RE (x) + r * IM (x)) / den;
1624 IM (z) = (IM (x) - r * RE (x)) / den;
1625 } else {
1626 REAL_T r = RE (y) / IM (y), den = IM (y) + r * RE (y);
1627 RE (z) = (RE (x) * r + IM (x)) / den;
1628 IM (z) = (IM (x) * r - RE (x)) / den;
1629 }
1630 }
jmvdveer@xs4all.nl