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