transput-formatting.c
1 //! @file transput-formatting.c
2 //! @author J. Marcel van der Veer
3
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2026 J. Marcel van der Veer [algol68g@algol68genie.nl].
8
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! Formatting routines for transput.
25
26 #include "a68g.h"
27 #include "a68g-genie.h"
28 #include "a68g-prelude.h"
29 #include "a68g-mp.h"
30 #include "a68g-double.h"
31 #include "a68g-conversion.h"
32 #include "a68g-transput.h"
33
34 // Next are formatting routines "whole", "fixed" and "float" for mode
35 // INT, LONG INT and LONG LONG INT, and REAL, LONG REAL and LONG LONG REAL.
36 // They are direct implementations of the routines described in the
37 // Revised Report, although those were only meant as a specification.
38
39
40 //! @brief Generate a string of error chars.
41
42 char *error_chars (char *s, int width)
43 {
44 int k = (width == 0 ? 1 : ABS (width));
45 s[k] = NULL_CHAR;
46 while (--k >= 0) {
47 s[k] = ERROR_CHAR;
48 }
49 return s;
50 }
51
52
53 //! @brief Generate a string of error chars.
54
55 char *error_chars_exception (char *s, char *msg, char *alt, int width)
56 {
57 size_t N = strlen (msg);
58 if (width < N) {
59 if (alt == NO_TEXT) {
60 return error_chars (s, width);
61 } else {
62 return error_chars_exception (s, alt, NO_TEXT, width);
63 }
64 } else {
65 int k = (width < 1 ? 1 : ABS (width));
66 a68g_bufcpy (s, msg, k);
67 s[k] = NULL_CHAR;
68 while (--k >= N) {
69 s[k] = ' '; // ERROR_CHAR;
70 }
71 return s;
72 }
73 }
74
75
76 //! @brief Convert temporary C string to A68 string.
77
78 A68G_REF tmp_to_a68g_string (NODE_T * p, char *temp_string)
79 {
80 // no compaction allowed since temp_string might be up for garbage collecting ...
81 return c_to_a_string (p, temp_string, DEFAULT_WIDTH);
82 }
83
84
85 //! @brief Add c to str, assuming that "str" is large enough.
86
87 char *plusto (char c, char *str)
88 {
89 MOVE (&str[1], &str[0], strlen (str) + 1);
90 str[0] = c;
91 return str;
92 }
93
94
95 //! @brief Add c to str, assuming that "str" is large enough.
96
97 char *string_plusab_char (char *str, char c, int strwid)
98 {
99 char z[2];
100 z[0] = c;
101 z[1] = NULL_CHAR;
102 a68g_bufcat (str, z, strwid);
103 return str;
104 }
105
106
107 //! @brief Add leading spaces to str until length is width.
108
109 char *leading_spaces (char *str, int width)
110 {
111 int j = width - strlen (str);
112 while (--j >= 0) {
113 (void) plusto (BLANK_CHAR, str);
114 }
115 return str;
116 }
117
118
119 //! @brief Convert int to char using a table.
120
121 char digchar (int k)
122 {
123 char *s = "0123456789abcdefghijklmnopqrstuvwxyz";
124 if (k >= 0 && k < strlen (s)) {
125 return s[k];
126 } else {
127 return ERROR_CHAR;
128 }
129 }
130
131
132 //! @brief Formatted string for HEX_NUMBER.
133
134 char *bits_to_string (NODE_T * p)
135 {
136 A68G_INT width, base;
137 POP_OBJECT (p, &base, A68G_INT);
138 POP_OBJECT (p, &width, A68G_INT);
139 DECREMENT_STACK_POINTER (p, SIZE (M_HEX_NUMBER));
140 CHECK_INT_SHORTEN (p, VALUE (&base));
141 CHECK_INT_SHORTEN (p, VALUE (&width));
142 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
143 ADDR_T pop_sp = A68G_SP;
144 int length = ABS (VALUE (&width)), radix = ABS (VALUE (&base));
145 if (radix < 2 || radix > 16) {
146 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
147 exit_genie (p, A68G_RUNTIME_ERROR);
148 }
149 reset_transput_buffer (EDIT_BUFFER);
150 #if (A68G_LEVEL <= 2)
151 (void) mode;
152 (void) length;
153 (void) error_chars (get_transput_buffer (EDIT_BUFFER), VALUE (&width));
154 #else
155 {
156 BOOL_T ret = A68G_TRUE;
157 if (mode == M_BOOL) {
158 UNSIGNED_T z = VALUE ((A68G_BOOL *) (STACK_OFFSET (A68G_UNION_SIZE)));
159 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
160 } else if (mode == M_CHAR) {
161 INT_T z = VALUE ((A68G_CHAR *) (STACK_OFFSET (A68G_UNION_SIZE)));
162 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
163 } else if (mode == M_INT) {
164 INT_T z = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
165 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
166 } else if (mode == M_REAL) {
167 // A trick to copy a REAL into an unt without truncating
168 UNSIGNED_T z;
169 memcpy (&z, (void *) &VALUE ((A68G_REAL *) (STACK_OFFSET (A68G_UNION_SIZE))), 8);
170 ret = convert_radix (p, z, radix, length);
171 } else if (mode == M_BITS) {
172 UNSIGNED_T z = VALUE ((A68G_BITS *) (STACK_OFFSET (A68G_UNION_SIZE)));
173 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
174 } else if (mode == M_LONG_INT) {
175 DOUBLE_NUM_T z = VALUE ((A68G_LONG_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
176 ret = convert_radix_double (p, z, radix, length);
177 } else if (mode == M_LONG_REAL) {
178 DOUBLE_NUM_T z = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
179 ret = convert_radix_double (p, z, radix, length);
180 } else if (mode == M_LONG_BITS) {
181 DOUBLE_NUM_T z = VALUE ((A68G_LONG_BITS *) (STACK_OFFSET (A68G_UNION_SIZE)));
182 ret = convert_radix_double (p, z, radix, length);
183 }
184 if (ret == A68G_FALSE) {
185 errno = EDOM;
186 PRELUDE_ERROR (A68G_TRUE, p, ERROR_OUT_OF_BOUNDS, mode);
187 }
188 }
189 #endif
190 A68G_SP = pop_sp;
191 return get_transput_buffer (EDIT_BUFFER);
192 }
193
194
195 //! @brief Standard string for LONG INT.
196
197 char *sub_whole_mp (NODE_T * p, MP_T * m, int digits, int width)
198 {
199 int len = 0;
200 char *s = stack_string (p, 8 + width);
201 s[0] = NULL_CHAR;
202 ADDR_T pop_sp = A68G_SP;
203 MP_T *n = nil_mp (p, digits);
204 (void) move_mp (n, m, digits);
205 do {
206 if (len < width) {
207 // Sic transit gloria mundi.
208 int n_mod_10 = (MP_INT_T) MP_DIGIT (n, (int) (1 + MP_EXPONENT (n))) % 10;
209 (void) plusto (digchar (n_mod_10), s);
210 }
211 len++;
212 (void) over_mp_digit (p, n, n, (MP_T) 10, digits);
213 } while (MP_DIGIT (n, 1) > 0);
214 if (len > width) {
215 (void) error_chars (s, width);
216 }
217 A68G_SP = pop_sp;
218 return s;
219 }
220
221
222 //! @brief Formatted string for NUMBER.
223
224 char *whole (NODE_T * p)
225 {
226 A68G_INT width;
227 POP_OBJECT (p, &width, A68G_INT);
228 CHECK_INT_SHORTEN (p, VALUE (&width));
229 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
230 ADDR_T pop_sp = A68G_SP;
231 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
232 //
233 if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
234 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
235 PUSH_VALUE (p, VALUE (&width), A68G_INT);
236 PUSH_VALUE (p, 0, A68G_INT);
237 return fixed (p);
238 } else if (mode == M_INT) {
239 INT_T x = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
240 int digits = DIGITS (M_LONG_LONG_INT);
241 PUSH_UNION (p, (void *) M_LONG_LONG_INT);
242 MP_T *z = nil_mp (p, digits);
243 (void) int_to_mp (p, z, x, digits);
244 PUSH_VALUE (p, VALUE (&width), A68G_INT);
245 return whole (p);
246 }
247 #if (A68G_LEVEL >= 3)
248 if (mode == M_LONG_INT) {
249 DOUBLE_NUM_T x = VALUE ((A68G_LONG_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
250 int digits = DIGITS (M_LONG_LONG_INT);
251 PUSH_UNION (p, (void *) M_LONG_LONG_INT);
252 MP_T *z = nil_mp (p, digits);
253 (void) double_int_to_mp (p, z, x, digits);
254 PUSH_VALUE (p, VALUE (&width), A68G_INT);
255 return whole (p);
256 }
257 #endif
258 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
259 int digits = DIGITS (mode);
260 MP_T *n = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
261 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
262 if (MP_EXPONENT (n) >= (MP_T) digits) {
263 int max_length = (mode == M_LONG_INT ? A68G_LONG_INT_WIDTH : A68G_LONG_LONG_INT_WIDTH);
264 int length = (VALUE (&width) == 0 ? max_length : VALUE (&width));
265 char *s = stack_string (p, 1 + length);
266 (void) error_chars (s, length);
267 A68G_SP = pop_sp;
268 return s;
269 }
270 BOOL_T ltz = (BOOL_T) (MP_DIGIT (n, 1) < 0);
271 int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
272 size_t size = (ltz ? 1 : (VALUE (&width) > 0 ? 1 : 0));
273 MP_DIGIT (n, 1) = ABS (MP_DIGIT (n, 1));
274 if (VALUE (&width) == 0) {
275 MP_T *m = nil_mp (p, digits);
276 (void) move_mp (m, n, digits);
277 length = 0;
278 while ((over_mp_digit (p, m, m, (MP_T) 10, digits), length++, MP_DIGIT (m, 1) != 0)) {
279 ;
280 }
281 }
282 size += length;
283 int abs_width = ABS (VALUE (&width));
284 size = 8 + A68G_MAX (size, abs_width);
285 char *s = stack_string (p, size);
286 a68g_bufcpy (s, sub_whole_mp (p, n, digits, length), size);
287 if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
288 (void) error_chars (s, abs_width);
289 } else {
290 if (ltz) {
291 (void) plusto ('-', s);
292 } else if (VALUE (&width) > 0) {
293 (void) plusto ('+', s);
294 }
295 if (VALUE (&width) != 0) {
296 (void) leading_spaces (s, abs_width);
297 }
298 }
299 A68G_SP = pop_sp;
300 return s;
301 }
302 ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
303 return NO_TEXT;
304 }
305
306
307 //! @brief Fetch next digit from LONG.
308
309 char choose_dig_mp (NODE_T * p, MP_T * y, int digits)
310 {
311 // Assuming positive "y".
312 ADDR_T pop_sp = A68G_SP;
313 (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
314 int c = MP_EXPONENT (y) == 0 ? (MP_INT_T) MP_DIGIT (y, 1) : 0;
315 if (c > 9) {
316 c = 9;
317 }
318 MP_T *t = lit_mp (p, c, 0, digits);
319 (void) sub_mp (p, y, y, t, digits);
320 // Reset the stack to prevent overflow, there may be many digits.
321 A68G_SP = pop_sp;
322 return digchar (c);
323 }
324
325
326 //! @brief Standard string for LONG.
327
328 char *sub_fixed_mp (NODE_T * p, MP_T * x, int digits, int width, int after)
329 {
330 ADDR_T pop_sp = A68G_SP;
331 MP_T *y = nil_mp (p, digits);
332 MP_T *s = nil_mp (p, digits);
333 MP_T *t = nil_mp (p, digits);
334 (void) ten_up_mp (p, t, -after, digits);
335 (void) half_mp (p, t, t, digits);
336 (void) add_mp (p, y, x, t, digits);
337 int before = 0;
338 // Not RR - argument reduction.
339 while (MP_EXPONENT (y) > 1) {
340 int k = (int) round (MP_EXPONENT (y) - 1);
341 MP_EXPONENT (y) -= k;
342 before += k * LOG_MP_RADIX;
343 }
344 // Follow RR again.
345 SET_MP_ONE (s, digits);
346 while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) {
347 before++;
348 (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
349 }
350 // Compose the number.
351 if (before + after + (after > 0 ? 1 : 0) > width) {
352 char *str = stack_string (p, width + 1);
353 (void) error_chars (str, width);
354 A68G_SP = pop_sp;
355 return str;
356 }
357 int strwid = 8 + before + after;
358 char *str = stack_string (p, strwid);
359 str[0] = NULL_CHAR;
360 int len = 0;
361 for (int j = 0; j < before; j++) {
362 char ch = (char) (len < A68G_LONG_LONG_REAL_WIDTH ? choose_dig_mp (p, y, digits) : '0');
363 (void) string_plusab_char (str, ch, strwid);
364 len++;
365 }
366 if (after > 0) {
367 (void) string_plusab_char (str, POINT_CHAR, strwid);
368 }
369 for (int j = 0; j < after; j++) {
370 char ch = (char) (len < A68G_LONG_LONG_REAL_WIDTH ? choose_dig_mp (p, y, digits) : '0');
371 (void) string_plusab_char (str, ch, strwid);
372 len++;
373 }
374 if (strlen (str) > width) {
375 (void) error_chars (str, width);
376 }
377 A68G_SP = pop_sp;
378 return str;
379 }
380
381
382 //! @brief Formatted string for NUMBER.
383
384 char *fixed (NODE_T * p)
385 {
386 A68G_INT width, after;
387 POP_OBJECT (p, &after, A68G_INT);
388 POP_OBJECT (p, &width, A68G_INT);
389 CHECK_INT_SHORTEN (p, VALUE (&after));
390 CHECK_INT_SHORTEN (p, VALUE (&width));
391 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
392 ADDR_T pop_sp = A68G_SP;
393 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
394 if (mode == M_INT) {
395 INT_T k = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
396 PUSH_UNION (p, M_REAL);
397 PUSH_VALUE (p, (REAL_T) k, A68G_REAL);
398 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_REAL)));
399 PUSH_VALUE (p, VALUE (&width), A68G_INT);
400 PUSH_VALUE (p, VALUE (&after), A68G_INT);
401 return fixed (p);
402 } else if (mode == M_REAL) {
403 REAL_T x = VALUE ((A68G_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
404 CHECK_REAL (p, x, M_REAL);
405 int digits = DIGITS (M_LONG_LONG_REAL);
406 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
407 MP_T *z = nil_mp (p, digits);
408 #if (A68G_LEVEL >= 3)
409 (void) double_to_mp (p, z, (DOUBLE_T) x, digits);
410 #else
411 (void) real_to_mp (p, z, x, digits);
412 #endif
413 PUSH_VALUE (p, VALUE (&width), A68G_INT);
414 PUSH_VALUE (p, VALUE (&after), A68G_INT);
415 return fixed (p);
416 }
417 #if (A68G_LEVEL >= 3)
418 if (mode == M_LONG_INT) {
419 DOUBLE_NUM_T x = VALUE ((A68G_LONG_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
420 int digits = DIGITS (M_LONG_LONG_REAL);
421 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
422 MP_T *z = nil_mp (p, digits);
423 (void) double_int_to_mp (p, z, x, digits);
424 PUSH_VALUE (p, VALUE (&width), A68G_INT);
425 PUSH_VALUE (p, VALUE (&after), A68G_INT);
426 return fixed (p);
427 } else if (mode == M_LONG_REAL) {
428 DOUBLE_T x = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE))).f;
429 CHECK_DOUBLE_REAL (p, x, M_LONG_REAL);
430 int digits = DIGITS (M_LONG_LONG_REAL);
431 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
432 MP_T *z = nil_mp (p, digits);
433 (void) double_to_mp (p, z, x, digits);
434 PUSH_VALUE (p, VALUE (&width), A68G_INT);
435 PUSH_VALUE (p, VALUE (&after), A68G_INT);
436 return fixed (p);
437 }
438 #endif
439 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
440 if (mode == M_LONG_INT) {
441 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
442 } else {
443 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
444 }
445 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
446 PUSH_VALUE (p, VALUE (&width), A68G_INT);
447 PUSH_VALUE (p, VALUE (&after), A68G_INT);
448 return fixed (p);
449 } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
450 int digits = DIGITS (mode);
451 MP_T *x = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
452 CHECK_LONG_REAL (p, x, mode);
453 if (A68G_PLUS_INF_MP (x)) {
454 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
455 A68G_SP = pop_sp;
456 return error_chars_exception (s, "+infinity", "+inf", VALUE (&width));
457 } else if (A68G_MINUS_INF_MP (x)) {
458 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
459 A68G_SP = pop_sp;
460 return error_chars_exception (s, "-infinity", "-inf", VALUE (&width));
461 } else if (A68G_NAN_MP (x)) {
462 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
463 A68G_SP = pop_sp;
464 return error_chars_exception (s, "nan", NO_TEXT, VALUE (&width));
465 } else {
466 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
467 BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
468 MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
469 int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
470 if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
471 MP_T *z0 = nil_mp (p, digits);
472 MP_T *z1 = nil_mp (p, digits);
473 MP_T *t = nil_mp (p, digits);
474 if (VALUE (&width) == 0) {
475 length = (VALUE (&after) == 0 ? 1 : 0);
476 (void) set_mp (z0, (MP_T) (MP_RADIX / 10), -1, digits);
477 (void) set_mp (z1, (MP_T) 10, 0, digits);
478 (void) pow_mp_int (p, z0, z0, VALUE (&after), digits);
479 (void) pow_mp_int (p, z1, z1, length, digits);
480 while ((div_mp_digit (p, t, z0, (MP_T) 2, digits), add_mp (p, t, x, t, digits), sub_mp (p, t, t, z1, digits), MP_DIGIT (t, 1) > 0)) {
481 length++;
482 (void) mul_mp_digit (p, z1, z1, (MP_T) 10, digits);
483 }
484 length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
485 }
486 char *s = sub_fixed_mp (p, x, digits, length, VALUE (&after));
487 if (strchr (s, ERROR_CHAR) == NO_TEXT) {
488 if (length > strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68G_TRUE) && (MP_EXPONENT (x) < 0 || MP_DIGIT (x, 1) == 0)) {
489 (void) plusto ('0', s);
490 }
491 if (ltz) {
492 (void) plusto ('-', s);
493 } else if (VALUE (&width) > 0) {
494 (void) plusto ('+', s);
495 }
496 if (VALUE (&width) != 0) {
497 (void) leading_spaces (s, ABS (VALUE (&width)));
498 }
499 A68G_SP = pop_sp;
500 return s;
501 } else if (VALUE (&after) > 0) {
502 A68G_SP = pop_sp;
503 MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1));
504 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
505 PUSH_VALUE (p, VALUE (&width), A68G_INT);
506 PUSH_VALUE (p, VALUE (&after) - 1, A68G_INT);
507 return fixed (p);
508 } else {
509 A68G_SP = pop_sp;
510 return error_chars (s, VALUE (&width));
511 }
512 } else {
513 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
514 A68G_SP = pop_sp;
515 return error_chars (s, VALUE (&width));
516 }
517 }
518 }
519 ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
520 return NO_TEXT;
521 }
522
523
524 //! @brief Scale LONG for formatting.
525
526 void standardize_mp (NODE_T * p, MP_T * y, int digits, int before, int after, int *q)
527 {
528 ADDR_T pop_sp = A68G_SP;
529 MP_T *f = nil_mp (p, digits);
530 MP_T *g = nil_mp (p, digits);
531 MP_T *h = nil_mp (p, digits);
532 MP_T *t = nil_mp (p, digits);
533 ten_up_mp (p, g, before, digits);
534 (void) div_mp_digit (p, h, g, (MP_T) 10, digits);
535 // Speed huge exponents.
536 if ((MP_EXPONENT (y) - MP_EXPONENT (g)) > 1) {
537 (*q) += LOG_MP_RADIX * ((int) MP_EXPONENT (y) - (int) MP_EXPONENT (g) - 1);
538 MP_EXPONENT (y) = MP_EXPONENT (g) + 1;
539 }
540 while ((sub_mp (p, t, y, g, digits), MP_DIGIT (t, 1) >= 0)) {
541 (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
542 (*q)++;
543 }
544 if (MP_DIGIT (y, 1) != 0) {
545 // Speed huge exponents.
546 if ((MP_EXPONENT (y) - MP_EXPONENT (h)) < -1) {
547 (*q) -= LOG_MP_RADIX * ((int) MP_EXPONENT (h) - (int) MP_EXPONENT (y) - 1);
548 MP_EXPONENT (y) = MP_EXPONENT (h) - 1;
549 }
550 while ((sub_mp (p, t, y, h, digits), MP_DIGIT (t, 1) < 0)) {
551 (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
552 (*q)--;
553 }
554 }
555 ten_up_mp (p, f, -after, digits);
556 (void) div_mp_digit (p, t, f, (MP_T) 2, digits);
557 (void) add_mp (p, t, y, t, digits);
558 (void) sub_mp (p, t, t, g, digits);
559 if (MP_DIGIT (t, 1) >= 0) {
560 (void) move_mp (y, h, digits);
561 (*q)++;
562 }
563 A68G_SP = pop_sp;
564 }
565
566
567 //! @brief Formatted string for NUMBER.
568
569 char *real (NODE_T * p)
570 {
571 // POP arguments.
572 A68G_INT width, after, expo, frmt;
573 POP_OBJECT (p, &frmt, A68G_INT);
574 POP_OBJECT (p, &expo, A68G_INT);
575 POP_OBJECT (p, &after, A68G_INT);
576 POP_OBJECT (p, &width, A68G_INT);
577 CHECK_INT_SHORTEN (p, VALUE (&frmt));
578 CHECK_INT_SHORTEN (p, VALUE (&expo));
579 CHECK_INT_SHORTEN (p, VALUE (&after));
580 CHECK_INT_SHORTEN (p, VALUE (&width));
581 ADDR_T arg_sp = A68G_SP;
582 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
583 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
584 ADDR_T pop_sp = A68G_SP;
585 //
586 if (mode == M_INT) {
587 INT_T k = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
588 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
589 int digits = DIGITS (M_LONG_LONG_REAL);
590 MP_T *z = nil_mp (p, digits);
591 int_to_mp (p, z, k, digits);
592 PUSH_VALUE (p, VALUE (&width), A68G_INT);
593 PUSH_VALUE (p, VALUE (&after), A68G_INT);
594 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
595 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
596 return real (p);
597 } else if (mode == M_REAL) {
598 REAL_T x = VALUE ((A68G_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
599 CHECK_REAL (p, x, M_REAL);
600 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
601 int digits = DIGITS (M_LONG_LONG_REAL);
602 MP_T *z = nil_mp (p, digits);
603 #if (A68G_LEVEL >= 3)
604 (void) double_to_mp (p, z, (DOUBLE_T) x, digits);
605 #else
606 (void) real_to_mp (p, z, x, digits);
607 #endif
608 PUSH_VALUE (p, VALUE (&width), A68G_INT);
609 PUSH_VALUE (p, VALUE (&after), A68G_INT);
610 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
611 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
612 return real (p);
613 }
614 #if (A68G_LEVEL >= 3)
615 if (mode == M_LONG_INT) {
616 DOUBLE_NUM_T k = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
617 int digits = DIGITS (M_LONG_LONG_REAL);
618 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
619 MP_T *z = nil_mp (p, digits);
620 (void) double_int_to_mp (p, z, k, digits);
621 PUSH_VALUE (p, VALUE (&width), A68G_INT);
622 PUSH_VALUE (p, VALUE (&after), A68G_INT);
623 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
624 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
625 return real (p);
626 } else if (mode == M_LONG_REAL) {
627 DOUBLE_T x = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE))).f;
628 CHECK_DOUBLE_REAL (p, x, M_LONG_REAL);
629 int digits = DIGITS (M_LONG_LONG_REAL);
630 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
631 MP_T *z = nil_mp (p, digits);
632 (void) double_to_mp (p, z, (DOUBLE_T) x, digits);
633 PUSH_VALUE (p, VALUE (&width), A68G_INT);
634 PUSH_VALUE (p, VALUE (&after), A68G_INT);
635 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
636 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
637 return real (p);
638 }
639 #endif
640 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
641 A68G_SP = pop_sp;
642 if (mode == M_LONG_INT) {
643 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
644 } else {
645 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
646 }
647 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
648 PUSH_VALUE (p, VALUE (&width), A68G_INT);
649 PUSH_VALUE (p, VALUE (&after), A68G_INT);
650 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
651 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
652 return real (p);
653 } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
654 int digits = DIGITS (mode);
655 MP_T *x = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
656 CHECK_LONG_REAL (p, x, mode);
657 if (A68G_PLUS_INF_MP (x)) {
658 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
659 A68G_SP = pop_sp;
660 return error_chars_exception (s, "+infinity", "+inf", VALUE (&width));
661 } else if (A68G_MINUS_INF_MP (x)) {
662 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
663 A68G_SP = pop_sp;
664 return error_chars_exception (s, "-infinity", "-inf", VALUE (&width));
665 } else if (A68G_NAN_MP (x)) {
666 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
667 A68G_SP = pop_sp;
668 return error_chars_exception (s, "nan", NO_TEXT, VALUE (&width));
669 } else {
670 CHECK_LONG_REAL (p, x, mode);
671 A68G_SP = arg_sp;
672 MP_T x1 = MP_DIGIT (x, 1); // Save digit for recursion.
673 BOOL_T ltz = (BOOL_T) (x1 < 0);
674 MP_DIGIT (x, 1) = ABS (x1);
675 int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
676 if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
677 int q = 0;
678 MP_T *z = nil_mp (p, digits);
679 (void) move_mp (z, x, digits);
680 standardize_mp (p, z, digits, before, VALUE (&after), &q);
681 if (VALUE (&frmt) > 0) {
682 while (q % VALUE (&frmt) != 0) {
683 (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
684 q--;
685 if (VALUE (&after) > 0) {
686 VALUE (&after)--;
687 }
688 }
689 } else {
690 ADDR_T pop_sp_2 = A68G_SP;
691 MP_T *dif = nil_mp (p, digits);
692 MP_T *lim = nil_mp (p, digits);
693 (void) ten_up_mp (p, lim, -VALUE (&frmt) - 1, digits);
694 (void) sub_mp (p, dif, z, lim, digits);
695 while (MP_DIGIT (dif, 1) < 0) {
696 (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
697 q--;
698 if (VALUE (&after) > 0) {
699 VALUE (&after)--;
700 }
701 (void) sub_mp (p, dif, z, lim, digits);
702 }
703 (void) mul_mp_digit (p, lim, lim, (MP_T) 10, digits);
704 (void) sub_mp (p, dif, z, lim, digits);
705 while (MP_DIGIT (dif, 1) > 0) {
706 (void) div_mp_digit (p, z, z, (MP_T) 10, digits);
707 q++;
708 if (VALUE (&after) > 0) {
709 VALUE (&after)++;
710 }
711 (void) sub_mp (p, dif, z, lim, digits);
712 }
713 A68G_SP = pop_sp_2;
714 }
715 //
716 int strwid = 8 + ABS (VALUE (&width));
717 char *s = stack_string (p, strwid);
718 // Mantissa.
719 PUSH_UNION (p, mode);
720 MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); // Restore sign.
721 size_t N_mp = SIZE (mode);
722 PUSH (p, z, N_mp);
723 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (mode)));
724 PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68G_INT);
725 PUSH_VALUE (p, VALUE (&after), A68G_INT);
726 a68g_bufcpy (s, fixed (p), strwid);
727 // Exponent.
728 PUSH_UNION (p, M_INT);
729 PUSH_VALUE (p, q, A68G_INT);
730 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_INT)));
731 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
732 (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
733 a68g_bufcat (s, whole (p), strwid);
734 // Recursion in case of error chars.
735 if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
736 A68G_SP = arg_sp;
737 // INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
738 PUSH_VALUE (p, VALUE (&width), A68G_INT);
739 PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68G_INT);
740 PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68G_INT);
741 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
742 MP_DIGIT (x, 1) = x1; // Restore original sign.
743 return real (p);
744 } else {
745 A68G_SP = pop_sp;
746 return s;
747 }
748 } else {
749 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
750 A68G_SP = pop_sp;
751 return error_chars (s, VALUE (&width));
752 }
753 }
754 }
755 ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
756 return NO_TEXT;
757 }
758
759
760 //! @brief Formatted string for NUMBER.
761
762 char *hex (NODE_T *p, BYTE_T *q, int size, int mod, MOID_T *mode)
763 {
764 ADDR_T pop_sp = A68G_SP;
765 char *z = "0123456789abcdef";
766 char *s = stack_string (p, SMALL_BUFFER_SIZE);
767 s[0] = NULL_CHAR;
768 int n = 0;
769 if (mod < 0) {
770 a68g_bufcpy (s, moid_to_string (mode, 80, NO_NODE), SMALL_BUFFER_SIZE);
771 n = strlen (s);
772 s[n++] = BLANK_CHAR;
773 }
774 for (int k = 0, m = 0; k < size; k++) {
775 int i = size - k - 1;
776 s[n++] = z[q[i] / 16];
777 s[n++] = z[q[i] % 16];
778 m ++;
779 if (mod != 0) {
780 if (m % ABS (mod) == 0 && k < size - 1) {
781 s[n++] = BLANK_CHAR;
782 }
783 }
784 }
785 s[n] = NULL_CHAR;
786 A68G_SP = pop_sp;
787 return s;
788 }
789
790
791 //! @brief Formatted string for NUMBER.
792
793 char *raw_mp (NODE_T *p, MP_T *z, int digs, int mod, MOID_T *mode)
794 {
795 ADDR_T pop_sp = A68G_SP;
796 UNSIGNED_T size = digs * LOG_MP_RADIX + BUFFER_SIZE;
797 char *s = stack_string (p, size), *fmt, *zfmt;
798 char d[SMALL_BUFFER_SIZE];
799 s[0] = NULL_CHAR;
800 if (mod < 0) {
801 a68g_bufcpy (s, moid_to_string (mode, 80, NO_NODE), size);
802 a68g_bufcat (s, " ", size);
803 }
804 #if (A68G_LEVEL >= 3)
805 fmt = "%lld";
806 zfmt = "%0*lld";
807 #else
808 fmt = "%d";
809 zfmt = "%0*d";
810 #endif
811 snprintf (d, SMALL_BUFFER_SIZE, fmt, (MP_INT_T) MP_DIGIT (z, 1));
812 a68g_bufcat (s, d, size);
813 if (ABS (mod) == 1 && digs > 1) {
814 a68g_bufcat (s, " ", size);
815 }
816 for (int k = 2; k <= digs; k++) {
817 snprintf (d, SMALL_BUFFER_SIZE, zfmt, LOG_MP_RADIX, (MP_INT_T) MP_DIGIT (z, k));
818 a68g_bufcat (s, d, size);
819 if (ABS (mod) == 1) {
820 if (k < digs) {
821 a68g_bufcat (s, " ", size);
822 }
823 }
824 }
825 a68g_bufcat (s, "e", size);
826 snprintf (d, SMALL_BUFFER_SIZE, fmt, (MP_INT_T) MP_EXPONENT (z));
827 a68g_bufcat (s, d, size);
828 A68G_SP = pop_sp;
829 snprintf (d, SMALL_BUFFER_SIZE, " N=%d", digs);
830 a68g_bufcat (s, d, size);
831 if (A68G_NAN_MP (z)) {
832 a68g_bufcat (s, " nan", size);
833 } else if (A68G_PLUS_INF_MP (z)) {
834 a68g_bufcat (s, " +inf", size);
835 } else if (A68G_MINUS_INF_MP (z)) {
836 a68g_bufcat (s, " -inf", size);
837 }
838 return s;
839 }
840
841
842 //! @brief Formatted string for NUMBER.
843
844 char *rawout (NODE_T * p)
845 {
846 A68G_INT mod;
847 POP_OBJECT (p, &mod, A68G_INT);
848 CHECK_INT_SHORTEN (p, VALUE (&mod));
849 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
850 ADDR_T pop_sp = A68G_SP;
851 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
852 //
853 if (mode == M_INT) {
854 INT_T k = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
855 char *s = hex (p, (BYTE_T *) &k, sizeof (k), VALUE (&mod), mode);
856 A68G_SP = pop_sp;
857 return s;
858 }
859 if (mode == M_REAL) {
860 REAL_T z = VALUE ((A68G_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
861 char *s = hex (p, (BYTE_T *) &z, sizeof (z), VALUE (&mod), mode);
862 A68G_SP = pop_sp;
863 return s;
864 }
865 #if (A68G_LEVEL >= 3)
866 if (mode == M_LONG_INT) {
867 DOUBLE_NUM_T k = VALUE ((A68G_LONG_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
868 char *s = hex (p, (BYTE_T *) &(k).u, sizeof (DOUBLE_NUM_T), VALUE (&mod), mode);
869 A68G_SP = pop_sp;
870 return s;
871 }
872 if (mode == M_LONG_REAL) {
873 DOUBLE_NUM_T z = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
874 char *s = hex (p, (BYTE_T *) &(z).f, sizeof (DOUBLE_NUM_T), VALUE (&mod), mode);
875 A68G_SP = pop_sp;
876 return s;
877 }
878 #endif
879 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
880 int digs = DIGITS (mode);
881 MP_T *z = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
882 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
883 char *s = raw_mp (p, z, digs, VALUE (&mod), mode);
884 A68G_SP = pop_sp;
885 return s;
886 }
887 if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
888 int digs = DIGITS (mode);
889 MP_T *z = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
890 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
891 char *s = raw_mp (p, z, digs, VALUE (&mod), mode);
892 A68G_SP = pop_sp;
893 return s;
894 }
895 ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
896 return NO_TEXT;
897 }
© J.M. van der Veer • jmvdveer@algol68genie.nl
