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