1 /*
2 Copyright (C) 2001-2012, 2014-2020 Free Software Foundation, Inc.
3 Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman
4
5 This file is part of GnuCOBOL.
6
7 The GnuCOBOL runtime library is free software: you can redistribute it
8 and/or modify it under the terms of the GNU Lesser General Public License
9 as published by the Free Software Foundation, either version 3 of the
10 License, or (at your option) any later version.
11
12 GnuCOBOL is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU Lesser General Public License for more details.
16
17 You should have received a copy of the GNU Lesser General Public License
18 along with GnuCOBOL. If not, see <https://www.gnu.org/licenses/>.
19 */
20
21
22 #include <config.h>
23
24 #ifndef _GNU_SOURCE
25 #define _GNU_SOURCE 1
26 #endif
27
28 #include <stdio.h>
29 #include <stdlib.h>
30 #include <stddef.h>
31 #include <stdarg.h>
32 #include <string.h>
33 #include <ctype.h>
34 #include <errno.h>
35
36 #include <math.h>
37 #ifdef HAVE_FINITE_IEEEFP_H
38 #include <ieeefp.h>
39 #endif
40
41 #ifdef WIN32
42 #ifndef isnan
43 #define isnan(x) _isnan(x)
44 #endif
45 #endif
46
47 #if !defined(isinf)
48 #if defined(WIN32)
49 #define isinf(x) ((_fpclass(x) == _FPCLASS_PINF) || (_fpclass(x) == _FPCLASS_NINF))
50 #else
51 #define isinf(x) (!ISFINITE(x))
52 #endif
53 #endif
54
55 /* Force symbol exports, include decimal definitions */
56 #define COB_LIB_EXPIMP
57 #ifdef HAVE_GMP_H
58 #include <gmp.h>
59 #elif defined HAVE_MPIR_H
60 #include <mpir.h>
61 #else
62 #error either HAVE_GMP_H or HAVE_MPIR_H needs to be defined
63 #endif
64 #include "libcob.h"
65 #include "coblocal.h"
66
67 #define DECIMAL_CHECK(d1,d2) \
68 if (unlikely (d1->scale == COB_DECIMAL_NAN || \
69 d2->scale == COB_DECIMAL_NAN)) { \
70 d1->scale = COB_DECIMAL_NAN; \
71 return; \
72 }
73
74 /* Local variables */
75
76 static cob_global *cobglobptr;
77
78 static const unsigned char packed_bytes[] = {
79 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09,
80 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19,
81 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29,
82 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39,
83 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,
84 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59,
85 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69,
86 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79,
87 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89,
88 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99
89 };
90
91 static cob_decimal cob_d1;
92 static cob_decimal cob_d2;
93 static cob_decimal cob_d3;
94 static cob_decimal cob_d_remainder;
95
96 static cob_decimal *cob_decimal_base;
97
98 static mpz_t cob_mexp;
99 static mpz_t cob_mpzt;
100 static mpz_t cob_mpzt2;
101 static mpz_t cob_mpz_ten34m1;
102 static mpz_t cob_mpz_ten16m1;
103 static mpz_t cob_mpze10[COB_MAX_BINARY];
104
105 static mpf_t cob_mpft;
106 static mpf_t cob_mpft_get;
107
108 static unsigned char packed_value[20];
109 static cob_u64_t last_packed_val;
110 static int cob_not_finite = 0;
111
112
113 #ifdef COB_EXPERIMENTAL
114
115 #if GMP_NAIL_BITS != 0
116 #error NAILS not supported
117 #endif
118
119 #define COB_MAX_LL COB_S64_C(9223372036854775807)
120
121 static void
mpz_set_ull(mpz_ptr dest,const cob_u64_t val)122 mpz_set_ull (mpz_ptr dest, const cob_u64_t val)
123 {
124 size_t size;
125
126 size = (val != 0);
127 dest->_mp_d[0] = val & GMP_NUMB_MASK;
128 #if GMP_LIMB_BITS < 64
129 if (val > GMP_NUMB_MAX) {
130 dest->_mp_d[1] = val >> GMP_NUMB_BITS;
131 size = 2;
132 }
133 #endif
134 dest->_mp_size = size;
135 }
136
137 static void
mpz_set_sll(mpz_ptr dest,const cob_s64_t val)138 mpz_set_sll (mpz_ptr dest, const cob_s64_t val)
139 {
140 cob_u64_t vtmp;
141 size_t size;
142
143 vtmp = (cob_u64_t)(val >= 0 ? (cob_u64_t)val : -(cob_u64_t)val);
144 size = (vtmp != 0);
145 dest->_mp_d[0] = vtmp & GMP_NUMB_MASK;
146 #if GMP_LIMB_BITS < 64
147 if (vtmp > GMP_NUMB_MAX) {
148 dest->_mp_d[1] = vtmp >> GMP_NUMB_BITS;
149 size = 2;
150 }
151 #endif
152 dest->_mp_size = (val >= 0) ? size : -size;
153 }
154
155 static cob_u64_t
mpz_get_ull(const mpz_ptr src)156 mpz_get_ull (const mpz_ptr src)
157 {
158 size_t size;
159
160 size = mpz_size (src);
161 if (!size) {
162 return 0;
163 }
164 #if GMP_LIMB_BITS > 32
165 return (cob_u64_t)src->_mp_d[0];
166 #else
167 if (size < 2) {
168 return (cob_u64_t)src->_mp_d[0];
169 }
170 return (cob_u64_t)src->_mp_d[0] |
171 ((cob_u64_t)src->_mp_d[1] << GMP_NUMB_BITS);
172 #endif
173 }
174
175 static cob_s64_t
mpz_get_sll(const mpz_ptr src)176 mpz_get_sll (const mpz_ptr src)
177 {
178 int size;
179 cob_u64_t vtmp;
180
181 size = src->_mp_size;
182 if (!size) {
183 return 0;
184 }
185 vtmp = (cob_u64_t)src->_mp_d[0];
186 #if GMP_LIMB_BITS < 64
187 if (mpz_size (src) > 1) {
188 vtmp |= (cob_u64_t)src->_mp_d[1] << GMP_NUMB_BITS;
189 }
190 #endif
191 if (size > 0) {
192 return (cob_s64_t) vtmp & COB_MAX_LL;
193 }
194 return ~(((cob_s64_t) vtmp - 1LL) & COB_MAX_LL);
195 }
196
197 #endif /* COB_EXPERIMENTAL */
198
199
200 void
cob_gmp_free(void * ptr)201 cob_gmp_free (void * ptr) {
202 /* mpir/gmp free functions */
203 #ifdef HAVE_MP_GET_MEMORY_FUNCTIONS
204 void (*freefunc)(void *, size_t);
205 mp_get_memory_functions (NULL, NULL, &freefunc);
206 freefunc (ptr, strlen((char*) ptr) + 1);
207 #else
208 free (ptr);
209 #endif
210 }
211
212 static COB_INLINE COB_A_INLINE void
num_byte_memcpy(unsigned char * s1,const unsigned char * s2,size_t size)213 num_byte_memcpy (unsigned char *s1, const unsigned char *s2, size_t size)
214 {
215 do {
216 *s1++ = *s2++;
217 } while (--size);
218 }
219
220 static COB_INLINE COB_A_INLINE cob_s64_t
cob_binary_get_sint64(const cob_field * const f)221 cob_binary_get_sint64 (const cob_field * const f)
222 {
223 cob_s64_t n = 0;
224 size_t fsiz = 8U - f->size;
225
226 #ifndef WORDS_BIGENDIAN
227 if (COB_FIELD_BINARY_SWAP (f)) {
228 num_byte_memcpy ((unsigned char *)&n, f->data, f->size);
229 n = COB_BSWAP_64 (n);
230 /* Shift with sign */
231 n >>= (cob_s64_t)8 * fsiz;
232 } else {
233 num_byte_memcpy (((unsigned char *)&n) + fsiz, f->data, f->size);
234 /* Shift with sign */
235 n >>= (cob_s64_t)8 * fsiz;
236 }
237 #else /* WORDS_BIGENDIAN */
238 num_byte_memcpy ((unsigned char *)&n, f->data, f->size);
239 /* Shift with sign */
240 n >>= 8 * fsiz;
241 #endif /* WORDS_BIGENDIAN */
242
243 return n;
244 }
245
246 static COB_INLINE COB_A_INLINE cob_u64_t
cob_binary_get_uint64(const cob_field * const f)247 cob_binary_get_uint64 (const cob_field * const f)
248 {
249 cob_u64_t n = 0;
250 size_t fsiz = 8U - f->size;
251
252 #ifndef WORDS_BIGENDIAN
253 if (COB_FIELD_BINARY_SWAP (f)) {
254 num_byte_memcpy (((unsigned char *)&n) + fsiz, f->data, f->size);
255 n = COB_BSWAP_64 (n);
256 } else {
257 num_byte_memcpy ((unsigned char *)&n, f->data, f->size);
258 }
259 #else /* WORDS_BIGENDIAN */
260 num_byte_memcpy (((unsigned char *)&n) + fsiz, f->data, f->size);
261 #endif /* WORDS_BIGENDIAN */
262
263 return n;
264 }
265
266 static COB_INLINE COB_A_INLINE void
cob_binary_set_uint64(cob_field * f,cob_u64_t n)267 cob_binary_set_uint64 (cob_field *f, cob_u64_t n)
268 {
269 #ifndef WORDS_BIGENDIAN
270 unsigned char *s;
271
272 if (COB_FIELD_BINARY_SWAP (f)) {
273 n = COB_BSWAP_64 (n);
274 s = ((unsigned char *)&n) + 8 - f->size;
275 } else {
276 s = (unsigned char *)&n;
277 }
278 num_byte_memcpy (f->data, s, f->size);
279 #else /* WORDS_BIGENDIAN */
280 num_byte_memcpy (f->data, ((unsigned char *)&n) + 8 - f->size, f->size);
281 #endif /* WORDS_BIGENDIAN */
282 }
283
284 static COB_INLINE COB_A_INLINE void
cob_binary_set_int64(cob_field * f,cob_s64_t n)285 cob_binary_set_int64 (cob_field *f, cob_s64_t n)
286 {
287 #ifndef WORDS_BIGENDIAN
288 unsigned char *s;
289
290 if (COB_FIELD_BINARY_SWAP (f)) {
291 n = COB_BSWAP_64 (n);
292 s = ((unsigned char *)&n) + 8 - f->size;
293 } else {
294 s = (unsigned char *)&n;
295 }
296 num_byte_memcpy (f->data, s, f->size);
297 #else /* WORDS_BIGENDIAN */
298 num_byte_memcpy (f->data, ((unsigned char *)&n) + 8 - f->size, f->size);
299 #endif /* WORDS_BIGENDIAN */
300 }
301
302 /* Decimal number */
303
304 void
cob_decimal_init2(cob_decimal * d,const cob_uli_t initial_num_bits)305 cob_decimal_init2 (cob_decimal *d, const cob_uli_t initial_num_bits)
306 {
307 mpz_init2 (d->value, initial_num_bits);
308 d->scale = 0;
309 }
310
311 void
cob_decimal_init(cob_decimal * d)312 cob_decimal_init (cob_decimal *d)
313 {
314 cob_decimal_init2 (d, COB_MPZ_DEF);
315 }
316
317 void
cob_decimal_clear(cob_decimal * d)318 cob_decimal_clear (cob_decimal *d)
319 {
320 if (d) {
321 mpz_clear (d->value);
322 d->scale = 0;
323 }
324 }
325
326 /** setting a decimal field from an unsigned binary long int */
327 void
cob_decimal_set_ullint(cob_decimal * d,const cob_u64_t n)328 cob_decimal_set_ullint (cob_decimal *d, const cob_u64_t n)
329 {
330 #ifdef COB_LI_IS_LL
331 mpz_set_ui (d->value, (cob_uli_t)n);
332 #else
333 mpz_set_ui (d->value, (cob_uli_t)(n >> 32));
334 mpz_mul_2exp (d->value, d->value, 32);
335 mpz_add_ui (d->value, d->value, (cob_uli_t)(n & 0xFFFFFFFFU));
336 #endif
337 d->scale = 0;
338 }
339
340 /** setting a decimal field from a signed binary long int */
341 void
cob_decimal_set_llint(cob_decimal * d,const cob_s64_t n)342 cob_decimal_set_llint (cob_decimal *d, const cob_s64_t n)
343 {
344 #ifdef COB_LI_IS_LL
345 mpz_set_si (d->value, (cob_sli_t)n);
346 #else
347 cob_u64_t uval;
348 cob_u32_t negative;
349
350 negative = 0;
351 if (n < 0) {
352 negative = 1;
353 uval = (cob_u64_t)-n;
354 } else {
355 uval = (cob_u64_t)n;
356 }
357 mpz_set_ui (d->value, (cob_uli_t)(uval >> 32));
358 mpz_mul_2exp (d->value, d->value, 32);
359 mpz_add_ui (d->value, d->value, (cob_uli_t)(uval & 0xFFFFFFFFU));
360 if (negative) {
361 mpz_neg (d->value, d->value);
362 }
363 #endif
364 d->scale = 0;
365 }
366
367 /* Decimal <-> Decimal */
368
369 static COB_INLINE COB_A_INLINE void
cob_decimal_set(cob_decimal * dst,const cob_decimal * src)370 cob_decimal_set (cob_decimal *dst, const cob_decimal *src)
371 {
372 mpz_set (dst->value, src->value);
373 dst->scale = src->scale;
374 }
375
376 /* Decimal print, note: currently (GC3.1) only called by display/dump
377 code from termio.c (cob_display) via cob_print_ieeedec) */
378 static void
cob_decimal_print(cob_decimal * d,FILE * fp)379 cob_decimal_print (cob_decimal *d, FILE *fp)
380 {
381 int scale, len;
382 char *mza;
383
384 if (unlikely (d->scale == COB_DECIMAL_NAN)) {
385 fprintf (fp, "(Nan)");
386 return;
387 }
388 if (unlikely (d->scale == COB_DECIMAL_INF)) {
389 fprintf (fp, "(Inf)");
390 return;
391 }
392 if (!mpz_sgn (d->value)) {
393 fprintf (fp, "0E0");
394 return;
395 }
396 mpz_set (cob_mpzt2, d->value);
397 scale = d->scale;
398 for ( ; ; ) {
399 if (!mpz_divisible_ui_p (cob_mpzt2, 10UL)) {
400 break;
401 }
402 mpz_tdiv_q_ui (cob_mpzt2, cob_mpzt2, 10UL);
403 scale--;
404 }
405 mza = mpz_get_str (NULL, 10, cob_mpzt2);
406 len = strlen (mza);
407 if (len > 0
408 && scale > 0
409 && scale < len) {
410 fprintf (fp, "%.*s%c%.*s",
411 len-scale, mza, '.',
412 scale, mza + len - scale);
413 } else if (scale == 0) {
414 fprintf (fp, "%s", mza);
415 } else {
416 fprintf (fp, "%sE%d", mza, -scale);
417 }
418 cob_gmp_free (mza);
419 }
420
421 /* d->value *= 10^n, d->scale += n */
422 static void
shift_decimal(cob_decimal * d,const int n)423 shift_decimal (cob_decimal *d, const int n)
424 {
425 if (n == 0) {
426 return;
427 }
428 if (n > 0) {
429 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)n);
430 mpz_mul (d->value, d->value, cob_mexp);
431 } else {
432 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-n);
433 mpz_tdiv_q (d->value, d->value, cob_mexp);
434 }
435 d->scale += n;
436 }
437
438 /* Align decimal */
439 static void
align_decimal(cob_decimal * d1,cob_decimal * d2)440 align_decimal (cob_decimal *d1, cob_decimal *d2)
441 {
442 if (d1->scale < d2->scale) {
443 shift_decimal (d1, d2->scale - d1->scale);
444 } else if (d1->scale > d2->scale) {
445 shift_decimal (d2, d1->scale - d2->scale);
446 }
447 }
448
449 /* IEEE 754 floats */
450
451 static void
cob_decimal_adjust(cob_decimal * d,mpz_t max_value,int min_exp,int max_exp)452 cob_decimal_adjust (cob_decimal *d, mpz_t max_value, int min_exp, int max_exp)
453 {
454 if (mpz_cmpabs (d->value, max_value) > 0) {
455 /* Adjust by 100000000 to get close */
456 while (mpz_cmpabs (d->value, max_value) > 0
457 && mpz_divisible_ui_p (d->value, 100000000UL)) {
458 if (d->scale-8 < min_exp)
459 break;
460 mpz_tdiv_q_ui (d->value, d->value, 100000000UL);
461 d->scale -= 8;
462 }
463 /* Adjust by 1000 to get close */
464 while (mpz_cmpabs (d->value, max_value) > 0
465 && mpz_divisible_ui_p (d->value, 1000UL)) {
466 if (d->scale-3 < min_exp)
467 break;
468 mpz_tdiv_q_ui (d->value, d->value, 1000UL);
469 d->scale -= 3;
470 }
471 }
472 /* Remove trailing ZEROS */
473 while (mpz_divisible_ui_p (d->value, 10UL)
474 || mpz_cmpabs (d->value, max_value) > 0) {
475 if (d->scale < min_exp)
476 break;
477 mpz_tdiv_q_ui (d->value, d->value, 10UL);
478 d->scale--;
479 }
480 if (mpz_cmpabs (d->value, max_value) > 0
481 || d->scale < min_exp
482 || d->scale > max_exp) {
483 cob_set_exception (COB_EC_SIZE_OVERFLOW);
484 return;
485 }
486 }
487
488 static int
cob_decimal_get_ieee64dec(cob_decimal * d,cob_field * f,const int opt)489 cob_decimal_get_ieee64dec (cob_decimal *d, cob_field *f, const int opt)
490 {
491 int sign;
492 cob_u64_t expo;
493 cob_u64_t data;
494
495 sign = mpz_sgn (d->value);
496 if (!sign) {
497 memset (f->data, 0, (size_t)8);
498 return 0;
499 }
500 if (sign < 0) {
501 mpz_neg (d->value, d->value);
502 }
503 cob_decimal_adjust (d, cob_mpz_ten16m1, -369, 398);
504 if (mpz_cmpabs (d->value, cob_mpz_ten16m1) > 0) {
505 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
506 cob_set_exception (COB_EC_SIZE_OVERFLOW);
507 return cobglobptr->cob_exception_code;
508 }
509 for ( ; ; ) {
510 if (d->scale < -369)
511 break;
512 mpz_tdiv_q_ui (d->value, d->value, 10UL);
513 d->scale--;
514 if (mpz_cmpabs (d->value, cob_mpz_ten16m1) < 0) {
515 break;
516 }
517 }
518 }
519 if (d->scale < -369 || d->scale > 398) {
520 cob_set_exception (COB_EC_SIZE_OVERFLOW);
521 return cobglobptr->cob_exception_code;
522 }
523 expo = (cob_u64_t)398 - d->scale;
524
525 data = 0;
526 mpz_export (&data, NULL, -1, (size_t)8, COB_MPZ_ENDIAN, (size_t)0, d->value);
527 /* Move in exponent */
528 if (mpz_sizeinbase (d->value, 2) > 53U) {
529 data &= COB_64_SIGF_2;
530 data |= (expo << 51U) | COB_DEC_EXTEND;
531 } else {
532 data &= COB_64_SIGF_1;
533 data |= (expo << 53U);
534 }
535 if (sign < 0) {
536 data |= COB_DEC_SIGN;
537 }
538 memcpy (f->data, &data, (size_t)8);
539 return 0;
540 }
541
542 static void
cob_decimal_set_ieee64dec(cob_decimal * d,const cob_field * f)543 cob_decimal_set_ieee64dec (cob_decimal *d, const cob_field *f)
544 {
545 cob_u64_t expo;
546 cob_u64_t sign;
547 cob_u64_t data;
548
549 /* bit 0 : sign bit */
550 /* bits 1 - 4 : combination field */
551 /* combination = 15 (all bits set) is inf/nan */
552 /* combination > 11 (bits 1100) is extended exponent */
553 /* Exponent length - 10 bits */
554
555 memcpy (&data, f->data, sizeof(data));
556 sign = data & COB_DEC_SIGN;
557 if (COB_64_IS_SPECIAL (data)) {
558 /* Inf / Nan */
559 mpz_set_ui (d->value, 1UL);
560 d->scale = COB_DECIMAL_NAN;
561 return;
562 }
563 if (COB_64_IS_EXTEND (data)) {
564 expo = (data & COB_64_EXPO_2) >> 51U;
565 data &= COB_64_SIGF_2;
566 data |= COB_64_OR_EXTEND;
567 if (data > COB_U64_C(9999999999999999)) {
568 mpz_set_ui (d->value, 0UL);
569 d->scale = 0;
570 return;
571 }
572 } else {
573 expo = (data & COB_64_EXPO_1) >> 53U;
574 data &= COB_64_SIGF_1;
575 }
576 if (!data) {
577 /* Significand 0 */
578 mpz_set_ui (d->value, 0UL);
579 d->scale = 0;
580 return;
581 }
582 #ifdef COB_LI_IS_LL
583 mpz_set_ui (d->value, data);
584 #else
585 mpz_set_ui (d->value, (cob_uli_t)(data >> 32));
586 mpz_mul_2exp (d->value, d->value, 32);
587 mpz_add_ui (d->value, d->value, (cob_uli_t)(data & 0xFFFFFFFFU));
588 #endif
589
590 d->scale = (int)expo - 398;
591 if (d->scale > 0) {
592 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d->scale);
593 mpz_mul (d->value, d->value, cob_mexp);
594 d->scale = 0;
595 } else if (d->scale < 0) {
596 d->scale = -(d->scale);
597 }
598 if (sign) {
599 mpz_neg (d->value, d->value);
600 }
601 if (d->scale < -369 || d->scale > 398) {
602 cob_set_exception (COB_EC_SIZE_OVERFLOW);
603 return;
604 }
605 }
606
607 static int
cob_decimal_get_ieee128dec(cob_decimal * d,cob_field * f,const int opt)608 cob_decimal_get_ieee128dec (cob_decimal *d, cob_field *f, const int opt)
609 {
610 cob_u64_t expo;
611 cob_u64_t data[2];
612 int sign;
613
614 sign = mpz_sgn (d->value);
615 if (!sign) {
616 memset (f->data, 0, (size_t)16);
617 return 0;
618 }
619 if (sign < 0) {
620 mpz_neg (d->value, d->value);
621 }
622 cob_decimal_adjust (d, cob_mpz_ten34m1, -6111, 6176);
623 if (mpz_cmpabs (d->value, cob_mpz_ten34m1) > 0) {
624 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
625 cob_set_exception (COB_EC_SIZE_OVERFLOW);
626 return cobglobptr->cob_exception_code;
627 }
628 for ( ; ; ) {
629 if (d->scale < -6111)
630 break;
631 mpz_tdiv_q_ui (d->value, d->value, 10UL);
632 d->scale--;
633 if (mpz_cmpabs (d->value, cob_mpz_ten34m1) < 0) {
634 break;
635 }
636 }
637 }
638 if (d->scale < -6111 || d->scale > 6176) {
639 cob_set_exception (COB_EC_SIZE_OVERFLOW);
640 return cobglobptr->cob_exception_code;
641 }
642 expo = (cob_u64_t)6176 - d->scale;
643
644 data[0] = 0;
645 data[1] = 0;
646 mpz_export (data, NULL, -1, (size_t)16, COB_MPZ_ENDIAN, (size_t)0, d->value);
647 /* Move in exponent */
648 COB_128_MSW(data) &= COB_128_SIGF_1;
649 COB_128_MSW(data) |= (expo << 49U);
650 if (sign < 0) {
651 COB_128_MSW(data) |= COB_DEC_SIGN;
652 }
653 memcpy (f->data, data, (size_t)16);
654 return 0;
655 }
656
657 static void
cob_decimal_set_ieee128dec(cob_decimal * d,const cob_field * f)658 cob_decimal_set_ieee128dec (cob_decimal *d, const cob_field *f)
659 {
660 cob_u64_t expo;
661 cob_u64_t sign;
662 cob_u64_t data[2];
663
664 /* bit 0 : sign bit */
665 /* bits 1 - 4 : combination field */
666 /* combination = 15 (all bits set) is inf/nan */
667 /* combination > 11 (bits 1100) is extended exponent */
668 /* Exponent length - 14 bits */
669
670 memcpy (data, f->data, sizeof(data));
671 sign = COB_128_MSW(data) & COB_DEC_SIGN;
672 if (COB_128_IS_SPECIAL (data)) {
673 /* Inf / Nan */
674 mpz_set_ui (d->value, 1UL);
675 d->scale = COB_DECIMAL_NAN;
676 return;
677 }
678 if (COB_128_IS_EXTEND (data)) {
679 expo = (COB_128_MSW(data) & COB_128_EXPO_2) >> 47U;
680 COB_128_MSW(data) &= COB_128_SIGF_2;
681 COB_128_MSW(data) |= COB_128_OR_EXTEND;
682 } else {
683 expo = (COB_128_MSW(data) & COB_128_EXPO_1) >> 49U;
684 COB_128_MSW(data) &= COB_128_SIGF_1;
685 }
686 if (!COB_128_MSW(data) && !COB_128_LSW(data)) {
687 /* Significand 0 */
688 mpz_set_ui (d->value, 0UL);
689 d->scale = 0;
690 return;
691 }
692 #ifdef COB_LI_IS_LL
693 mpz_set_ui (d->value, COB_128_MSW(data));
694 mpz_mul_2exp (d->value, d->value, 64UL);
695 mpz_add_ui (d->value, d->value, COB_128_LSW(data));
696 #else
697 /* RXWRXW - Fixme */
698 mpz_set_ui (d->value, (cob_uli_t)(COB_128_MSW(data) >> 32U));
699 mpz_mul_2exp (d->value, d->value, 32UL);
700 mpz_add_ui (d->value, d->value, (cob_uli_t)(COB_128_MSW(data) & 0xFFFFFFFFU));
701 mpz_mul_2exp (d->value, d->value, 32UL);
702 mpz_add_ui (d->value, d->value, (cob_uli_t)(COB_128_LSW(data) >> 32U));
703 mpz_mul_2exp (d->value, d->value, 32UL);
704 mpz_add_ui (d->value, d->value, (cob_uli_t)(COB_128_LSW(data) & 0xFFFFFFFFU));
705 #endif
706
707 d->scale = (int)expo - 6176;
708 if (d->scale > 0) {
709 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d->scale);
710 mpz_mul (d->value, d->value, cob_mexp);
711 d->scale = 0;
712 } else if (d->scale < 0) {
713 d->scale = -(d->scale);
714 }
715 if (sign) {
716 mpz_neg (d->value, d->value);
717 }
718 cob_decimal_adjust (d, cob_mpz_ten34m1, -6111, 6176);
719 if (mpz_cmpabs (d->value, cob_mpz_ten34m1) > 0) {
720 /* Non-canonical */
721 cob_set_exception (COB_EC_SIZE_OVERFLOW);
722 mpz_set_ui (d->value, 0UL);
723 d->scale = 0;
724 return;
725 }
726 }
727
728 /* Double */
729
730 static void
cob_decimal_set_double(cob_decimal * d,const double v)731 cob_decimal_set_double (cob_decimal *d, const double v)
732 {
733 char *p;
734 char *q;
735 cob_u64_t t1;
736 cob_sli_t scale;
737 cob_sli_t len;
738 int sign;
739 union {
740 double d1;
741 cob_u64_t l1;
742 } ud;
743
744 memset (&t1, ' ', sizeof(t1));
745 ud.d1 = v;
746 if (ud.l1 == 0 || ud.l1 == t1 || !ISFINITE (v)) {
747 mpz_set_ui (d->value, 0UL);
748 d->scale = 0;
749 return;
750 }
751
752 sign = 0;
753 mpf_set_d (cob_mpft, v);
754
755 q = mpf_get_str (NULL, &scale, 10, (size_t)96, cob_mpft);
756 if (!*q) {
757 mpz_set_ui (d->value, 0UL);
758 d->scale = 0;
759 cob_gmp_free(q);
760 return;
761 }
762 p = q;
763 if (*p == '-') {
764 sign = 1;
765 ++p;
766 }
767
768 mpz_set_str (d->value, p, 10);
769
770 len = (cob_sli_t)strlen (p);
771 len -= scale;
772 if (len >= 0) {
773 d->scale = len;
774 } else {
775 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-len);
776 mpz_mul (d->value, d->value, cob_mexp);
777 d->scale = 0;
778 }
779
780 if (sign) {
781 mpz_neg (d->value, d->value);
782 }
783 cob_gmp_free(q);
784 }
785
786 static double
cob_decimal_get_double(cob_decimal * d)787 cob_decimal_get_double (cob_decimal *d)
788 {
789 double v;
790 cob_sli_t n;
791
792 cob_not_finite = 0;
793 v = 0.0;
794 if (unlikely (mpz_size (d->value) == 0)) {
795 return v;
796 }
797
798 mpf_set_z (cob_mpft, d->value);
799
800 n = d->scale;
801 if (n < 0) {
802 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-n);
803 mpf_set_z (cob_mpft_get, cob_mexp);
804 mpf_mul (cob_mpft, cob_mpft, cob_mpft_get);
805 } else if (n > 0) {
806 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)n);
807 mpf_set_z (cob_mpft_get, cob_mexp);
808 mpf_div (cob_mpft, cob_mpft, cob_mpft_get);
809 }
810
811 v = mpf_get_d (cob_mpft);
812 if (!ISFINITE (v)) {
813 cob_not_finite = 1;
814 v = 0.0;
815 }
816 return v;
817 }
818
819 /* PACKED-DECIMAL */
820
821 static int
cob_packed_get_sign(const cob_field * f)822 cob_packed_get_sign (const cob_field *f)
823 {
824 unsigned char *p;
825
826 if (!COB_FIELD_HAVE_SIGN (f) || COB_FIELD_NO_SIGN_NIBBLE (f)) {
827 return 0;
828 }
829 p = f->data + f->size - 1;
830 return ((*p & 0x0FU) == 0x0DU) ? -1 : 1;
831 }
832
833 #if 0 /* RXWRXW - Buggy */
834 static void
835 cob_complement_packed (cob_field *f)
836 {
837 unsigned char *p;
838 int ndigs;
839 int tval;
840 int carry = 0;
841 unsigned int msn;
842
843 ndigs = COB_FIELD_DIGITS(f) - COB_FIELD_SCALE(f);
844 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
845 msn = COB_FIELD_SCALE(f) % 2;
846 } else {
847 msn = 1 - (COB_FIELD_SCALE(f) % 2);
848 }
849
850 p = f->data + (ndigs / 2) - (1 - msn);
851 while (ndigs--) {
852 if (!msn) {
853 tval = *p & 0x0F;
854 } else {
855 tval = (*p & 0xF0) >> 4;
856 }
857 tval += carry;
858 if (tval > 0) {
859 carry = 1;
860 tval= 10 - tval;
861 } else {
862 carry = 0;
863 }
864 if (!msn) {
865 *p = (*p & 0xF0) | tval;
866 msn = 1;
867 } else {
868 *p = (*p & 0x0F) | (tval << 4);
869 msn = 0;
870 p--;
871 }
872 }
873 }
874
875 static int
876 cob_add_packed (cob_field *f, int val, const int opt)
877 {
878 unsigned char *p;
879 int sign;
880 int ndigs;
881 int tval;
882 int carry = 0;
883 unsigned int msn;
884 unsigned int subtr = 0;
885 unsigned int zeroes = 0;
886 unsigned int origdigs;
887 unsigned char savedata[256];
888
889 ndigs = COB_FIELD_DIGITS(f) - COB_FIELD_SCALE(f);
890 if (ndigs <= 0) {
891 return 0;
892 }
893
894 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
895 memcpy (savedata, f->data, f->size);
896 }
897
898 sign = cob_packed_get_sign (f);
899
900 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
901 msn = COB_FIELD_SCALE(f) % 2;
902 } else {
903 msn = 1 - (COB_FIELD_SCALE(f) % 2);
904 }
905
906 /* -x +v = -(x - v), -x -v = -(x + v) */
907 if (sign < 0) {
908 val = -val;
909 }
910 if (val < 0) {
911 val = -val;
912 subtr = 1;
913 }
914 p = f->data + (ndigs / 2) - (1 - msn);
915 origdigs = ndigs;
916 while (ndigs--) {
917 if (val) {
918 carry += (val % 10);
919 val /= 10;
920 }
921 if (!msn) {
922 tval = *p & 0x0F;
923 } else {
924 tval = (*p & 0xF0) >> 4;
925 }
926 if (subtr) {
927 tval -= carry;
928 if (tval < 0) {
929 tval += 10;
930 carry = 1;
931 } else {
932 carry = 0;
933 }
934 } else {
935 tval += carry;
936 if (tval > 9) {
937 tval = (tval + 6) & 0x0F;
938 carry = 1;
939 } else {
940 carry = 0;
941 }
942 }
943 if (tval == 0) {
944 zeroes++;
945 }
946 if (!msn) {
947 *p = (*p & 0xF0) | tval;
948 msn = 1;
949 } else {
950 *p = (*p & 0x0F) | (tval << 4);
951 msn = 0;
952 p--;
953 }
954 }
955 if (sign) {
956 p = f->data + f->size - 1;
957 if (origdigs == zeroes) {
958 *p = (*p & 0xF0) | 0x0C;
959 } else if (subtr && carry) {
960 cob_complement_packed (f);
961 sign = -sign;
962 if (sign < 0) {
963 *p = (*p & 0xF0) | 0x0D;
964 } else {
965 *p = (*p & 0xF0) | 0x0C;
966 }
967 }
968 } else if (subtr && carry) {
969 cob_complement_packed (f);
970 }
971 if (opt && (carry || val)) {
972 /* Overflow */
973 cob_set_exception (COB_EC_SIZE_OVERFLOW);
974 /* If we need to throw an exception */
975 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
976 memcpy (f->data, savedata, f->size);
977 return cobglobptr->cob_exception_code;
978 }
979 }
980 return 0;
981 }
982 #endif
983
984 void
cob_set_packed_zero(cob_field * f)985 cob_set_packed_zero (cob_field *f)
986 {
987 memset (f->data, 0, f->size);
988 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
989 return;
990 }
991 if (!COB_FIELD_HAVE_SIGN (f)) {
992 *(f->data + f->size - 1) = 0x0F;
993 } else {
994 *(f->data + f->size - 1) = 0x0C;
995 }
996 }
997
998 static void
cob_decimal_set_packed(cob_decimal * d,cob_field * f)999 cob_decimal_set_packed (cob_decimal *d, cob_field *f)
1000 {
1001 unsigned char *p;
1002 unsigned char *endp;
1003 int digits;
1004 int sign;
1005 int nibtest;
1006 unsigned int byteval;
1007 unsigned int nonzero;
1008
1009 p = f->data;
1010 digits = COB_FIELD_DIGITS (f);
1011 #if 0 /* RXWRXW - P Fix */
1012 if (digits > (f->size * 2) - 1) {
1013 digits = (f->size * 2) - 1;
1014 }
1015 #endif
1016 sign = cob_packed_get_sign (f);
1017
1018 if (unlikely (COB_FIELD_NO_SIGN_NIBBLE (f))) {
1019 endp = f->data + f->size;
1020 nibtest = 1;
1021 } else {
1022 endp = f->data + f->size - 1;
1023 nibtest = 0;
1024 }
1025
1026 byteval = 0;
1027 if (digits % 2 == nibtest) {
1028 byteval = *p & 0x0FU;
1029 p++;
1030 }
1031 mpz_set_ui (d->value, (cob_uli_t)byteval);
1032 nonzero = !!byteval;
1033
1034 for (; p < endp; p++) {
1035 if (nonzero) {
1036 mpz_mul_ui (d->value, d->value, 100UL);
1037 }
1038 if (*p) {
1039 mpz_add_ui (d->value, d->value,
1040 ((cob_uli_t)(*p >> 4U) * 10) + (*p & 0x0FU));
1041 nonzero = 1;
1042 }
1043 }
1044
1045 if (!nibtest) {
1046 if (nonzero) {
1047 mpz_mul_ui (d->value, d->value, 10UL);
1048 }
1049 mpz_add_ui (d->value, d->value, (cob_uli_t)(*p >> 4U));
1050 }
1051
1052 if (sign < 0) {
1053 mpz_neg (d->value, d->value);
1054 }
1055 d->scale = COB_FIELD_SCALE(f);
1056 }
1057
1058 static int
cob_decimal_get_packed(cob_decimal * d,cob_field * f,const int opt)1059 cob_decimal_get_packed (cob_decimal *d, cob_field *f, const int opt)
1060 {
1061 unsigned char *data;
1062 unsigned char *p;
1063 unsigned char *q;
1064 char *mza;
1065 size_t size;
1066 size_t n;
1067 size_t i;
1068 int diff;
1069 int sign;
1070 int digits;
1071 unsigned int x;
1072
1073 #if 0 /* RXWRXW stack */
1074 char buff[1024];
1075 #endif
1076
1077 /* Build string */
1078 sign = mpz_sgn (d->value);
1079 if (!sign) {
1080 /* Value is 0 */
1081 cob_set_packed_zero (f);
1082 return 0;
1083 }
1084 if (sign < 0) {
1085 mpz_abs (d->value, d->value);
1086 }
1087
1088 #if 0 /* RXWRXW stack */
1089 if (unlikely (mpz_sizeinbase (d->value, 10) > sizeof(buff) - 1)) {
1090 #endif
1091 mza = mpz_get_str (NULL, 10, d->value);
1092 #if 0 /* RXWRXW stack */
1093 } else {
1094 mza = buff;
1095 (void)mpz_get_str (buff, 10, d->value);
1096 }
1097 #endif
1098 size = strlen (mza);
1099
1100 /* Store number */
1101 data = f->data;
1102 digits = COB_FIELD_DIGITS (f);
1103 #if 0 /* RXWRXW - P Fix */
1104 if (digits > (f->size * 2) - 1) {
1105 digits = (f->size * 2) - 1;
1106 }
1107 #endif
1108 q = (unsigned char *)mza;
1109 diff = (int)(digits - size);
1110 if (diff < 0) {
1111 /* Overflow */
1112 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1113
1114 /* If the statement has SIZE ERROR
1115 then throw an exception */
1116 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
1117 #if 0 /* RXWRXW stack */
1118 if (unlikely (mza != buff)) {
1119 #endif
1120 cob_gmp_free(mza);
1121
1122 #if 0 /* RXWRXW stack */
1123 }
1124 #endif
1125 return cobglobptr->cob_exception_code;
1126 }
1127 q += size - digits;
1128 size = digits;
1129 }
1130 memset (data, 0, f->size);
1131 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
1132 p = data + ((digits - 1) / 2) - ((size - 1) / 2);
1133 diff = (int)(size % 2);
1134 } else {
1135 p = data + (digits / 2) - (size / 2);
1136 diff = 1 - (int)(size % 2);
1137 }
1138 for (i = diff, n = 0; i < size + diff; i++, n++) {
1139 x = COB_D2I (q[n]);
1140 if (i % 2 == 0) {
1141 *p = (unsigned char) x << 4;
1142 } else {
1143 *p++ |= x;
1144 }
1145 }
1146
1147 #if 0 /* RXWRXW stack */
1148 if (unlikely (mza != buff)) {
1149 #endif
1150 cob_gmp_free(mza);
1151
1152 #if 0 /* RXWRXW stack */
1153 }
1154 #endif
1155
1156 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
1157 return 0;
1158 }
1159
1160 p = f->data + f->size - 1;
1161 if (!COB_FIELD_HAVE_SIGN (f)) {
1162 *p = (*p & 0xF0U) | 0x0FU;
1163 } else if (sign < 0) {
1164 *p = (*p & 0xF0U) | 0x0DU;
1165 } else {
1166 *p = (*p & 0xF0U) | 0x0CU;
1167 }
1168
1169 return 0;
1170 }
1171
1172 void
cob_set_packed_int(cob_field * f,const int val)1173 cob_set_packed_int (cob_field *f, const int val)
1174 {
1175 unsigned char *p;
1176 size_t sign = 0;
1177 cob_u32_t n;
1178
1179 if (!val) {
1180 cob_set_packed_zero (f);
1181 return;
1182 }
1183 if (val < 0) {
1184 n = (cob_u32_t)-val;
1185 sign = 1;
1186 } else {
1187 n = (cob_u32_t)val;
1188 }
1189 memset (f->data, 0, f->size);
1190 p = f->data + f->size - 1;
1191 if (!COB_FIELD_NO_SIGN_NIBBLE (f)) {
1192 *p = (n % 10) << 4;
1193 if (!COB_FIELD_HAVE_SIGN (f)) {
1194 *p |= 0x0FU;
1195 } else if (sign) {
1196 *p |= 0x0DU;
1197 } else {
1198 *p |= 0x0CU;
1199 }
1200 n /= 10;
1201 p--;
1202 }
1203 for (; n && p >= f->data; n /= 100, p--) {
1204 *p = packed_bytes[n % 100];
1205 }
1206 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
1207 if ((COB_FIELD_DIGITS(f) % 2) == 1) {
1208 *(f->data) &= 0x0FU;
1209 }
1210 return;
1211 }
1212 if ((COB_FIELD_DIGITS(f) % 2) == 0) {
1213 *(f->data) &= 0x0FU;
1214 }
1215 }
1216
1217 /* DISPLAY */
1218
1219 static void
cob_decimal_set_display(cob_decimal * d,cob_field * f)1220 cob_decimal_set_display (cob_decimal *d, cob_field *f)
1221 {
1222 unsigned char *data;
1223 unsigned char *p;
1224 size_t size;
1225 int sign;
1226 cob_uli_t n;
1227
1228 data = COB_FIELD_DATA (f);
1229 size = COB_FIELD_SIZE (f);
1230 if (unlikely (*data == 255)) {
1231 mpz_ui_pow_ui (d->value, 10UL, (cob_uli_t)size);
1232 d->scale = COB_FIELD_SCALE(f);
1233 return;
1234 }
1235 if (unlikely (*data == 0)) {
1236 mpz_ui_pow_ui (d->value, 10UL, (cob_uli_t)size);
1237 mpz_neg (d->value, d->value);
1238 d->scale = COB_FIELD_SCALE(f);
1239 return;
1240 }
1241 sign = COB_GET_SIGN (f);
1242 /* Skip leading zeros (also invalid space/low-value) */
1243 while (size > 1 && (*data & 0x0FU) == 0) {
1244 size--;
1245 data++;
1246 }
1247
1248 /* Set value */
1249 n = 0;
1250
1251 #ifdef COB_LI_IS_LL
1252 if (size < 20) {
1253 #else
1254 if (size < 10) {
1255 #endif
1256 while (size--) {
1257 if (n) {
1258 n *= 10;
1259 }
1260 n += COB_D2I (*data);
1261 data++;
1262 }
1263 mpz_set_ui (d->value, n);
1264 } else {
1265 p = cob_fast_malloc (size + 1U);
1266 for (; n < size; ++n) {
1267 p[n] = (data[n] & 0x0FU) + '0';
1268 }
1269 p[size] = 0;
1270 mpz_set_str (d->value, (char *)p, 10);
1271 cob_free (p);
1272 }
1273
1274 /* Set sign and scale */
1275 if (sign < 0 && mpz_sgn (d->value)) {
1276 mpz_neg (d->value, d->value);
1277 }
1278 d->scale = COB_FIELD_SCALE(f);
1279 COB_PUT_SIGN (f, sign);
1280 }
1281
1282 static int
1283 cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt)
1284 {
1285 unsigned char *data;
1286 char *p;
1287 size_t size;
1288 int diff;
1289 int sign;
1290
1291 data = COB_FIELD_DATA (f);
1292 /* Build string */
1293 sign = mpz_sgn (d->value);
1294 if (!sign) {
1295 /* Value is 0 */
1296 memset (data, '0', COB_FIELD_SIZE (f));
1297 COB_PUT_SIGN (f, sign);
1298 return 0;
1299 }
1300 if (sign < 0) {
1301 mpz_abs (d->value, d->value);
1302 }
1303 p = mpz_get_str (NULL, 10, d->value);
1304 size = strlen (p);
1305
1306 /* Store number */
1307 diff = (int)(COB_FIELD_SIZE (f) - size);
1308 if (unlikely (diff < 0)) {
1309 /* Overflow */
1310 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1311
1312 /* If the statement has ON SIZE ERROR or NOT ON SIZE ERROR,
1313 then throw an exception */
1314 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
1315 cob_gmp_free(p);
1316 return cobglobptr->cob_exception_code;
1317 }
1318
1319 /* Other size, truncate digits */
1320 memcpy (data, p - diff, COB_FIELD_SIZE (f));
1321 } else {
1322 /* No overflow */
1323 memset (data, '0', (size_t)diff);
1324 memcpy (data + diff, p, size);
1325 }
1326
1327 cob_gmp_free(p);
1328 COB_PUT_SIGN (f, sign);
1329
1330 return 0;
1331 }
1332
1333 /* BINARY */
1334
1335 static void
1336 cob_decimal_set_binary (cob_decimal *d, cob_field *f)
1337 {
1338 #ifdef COB_EXPERIMENTAL
1339 #if 1 /* RXWRXW - set_usll */
1340 size_t size;
1341 size_t sizeb;
1342 size_t idx;
1343 int order;
1344 unsigned char buff[COB_MAX_BINARY + 1];
1345
1346 size = f->size;
1347 #ifndef WORDS_BIGENDIAN
1348 if (!COB_FIELD_BINARY_SWAP (f)) {
1349 sizeb = size - 1;
1350 order = -1;
1351 } else {
1352 sizeb = 0;
1353 order = 1;
1354 }
1355 #else
1356 sizeb = 0;
1357 order = 1;
1358 #endif
1359 if (COB_FIELD_HAVE_SIGN (f) && (f->data[sizeb] & 0x80U)) {
1360 for (idx = 0; idx < size; ++idx) {
1361 buff[idx] = ~f->data[idx];
1362 }
1363 mpz_import (d->value, 1, order, size, order, 0, buff);
1364 mpz_com (d->value, d->value);
1365 } else {
1366 mpz_import (d->value, 1, order, size, order, 0, f->data);
1367 }
1368
1369 #else
1370 if (COB_FIELD_HAVE_SIGN (f)) {
1371 mpz_set_sll (d->value, cob_binary_get_sint64 (f));
1372 } else {
1373 mpz_set_ull (d->value, cob_binary_get_uint64 (f));
1374 }
1375 #endif
1376
1377 #elif defined(COB_LI_IS_LL)
1378 if (COB_FIELD_HAVE_SIGN (f)) {
1379 mpz_set_si (d->value, cob_binary_get_sint64 (f));
1380 } else {
1381 mpz_set_ui (d->value, cob_binary_get_uint64 (f));
1382 }
1383 #else
1384 cob_u64_t uval;
1385 cob_s64_t val;
1386 size_t negative;
1387
1388 if (f->size <= 4) {
1389 if (COB_FIELD_HAVE_SIGN (f)) {
1390 mpz_set_si (d->value, (cob_sli_t)cob_binary_get_sint64 (f));
1391 } else {
1392 mpz_set_ui (d->value, (cob_uli_t) cob_binary_get_uint64 (f));
1393 }
1394 } else {
1395 negative = 0;
1396 if (COB_FIELD_HAVE_SIGN (f)) {
1397 val = cob_binary_get_sint64 (f);
1398 if (val < 0) {
1399 negative = 1;
1400 uval = (cob_u64_t)-val;
1401 } else {
1402 uval = (cob_u64_t)val;
1403 }
1404 } else {
1405 uval = cob_binary_get_uint64 (f);
1406 }
1407 mpz_set_ui (d->value, (cob_uli_t)(uval >> 32));
1408 mpz_mul_2exp (d->value, d->value, 32);
1409 mpz_add_ui (d->value, d->value, (cob_uli_t)(uval & 0xFFFFFFFFU));
1410 if (negative) {
1411 mpz_neg (d->value, d->value);
1412 }
1413 }
1414 #endif
1415 d->scale = COB_FIELD_SCALE(f);
1416 }
1417
1418 static int
1419 cob_decimal_get_binary (cob_decimal *d, cob_field *f, const int opt)
1420 {
1421 size_t overflow;
1422 size_t sign;
1423 size_t bitnum;
1424 size_t digits;
1425
1426 #if !defined(COB_EXPERIMENTAL) && !defined(COB_LI_IS_LL)
1427 cob_s64_t llval;
1428 cob_u64_t ullval;
1429 unsigned int lo;
1430 #endif
1431
1432 if (unlikely (mpz_size (d->value) == 0)) {
1433 memset (f->data, 0, f->size);
1434 return 0;
1435 }
1436 overflow = 0;
1437 digits = COB_FIELD_DIGITS(f);
1438 if (COB_FIELD_HAVE_SIGN (f)) {
1439 sign = 1;
1440 } else {
1441 sign = 0;
1442 if (mpz_sgn (d->value) < 0) {
1443 mpz_abs (d->value, d->value);
1444 }
1445 }
1446 bitnum = (f->size * 8) - sign;
1447 if (unlikely (mpz_sizeinbase (d->value, 2) > bitnum)) {
1448 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
1449 goto overflow;
1450 }
1451 overflow = 1;
1452 /* Check if truncation to PIC digits is needed */
1453 if (opt & COB_STORE_TRUNC_ON_OVERFLOW) {
1454 mpz_tdiv_r (d->value, d->value, cob_mpze10[digits]);
1455 } else {
1456 #if 0 /* RXWRXW - Fdiv sign */
1457 mpz_fdiv_r_2exp (d->value, d->value, (f->size * 8) - sign);
1458 #endif
1459 mpz_fdiv_r_2exp (d->value, d->value, (f->size * 8));
1460 }
1461 } else if (opt && COB_FIELD_BINARY_TRUNC (f)) {
1462 if (mpz_cmpabs (d->value, cob_mpze10[digits]) >= 0) {
1463 /* Overflow */
1464 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
1465 goto overflow;
1466 }
1467 overflow = 1;
1468 /* Check if truncation to PIC digits is needed */
1469 if (opt & COB_STORE_TRUNC_ON_OVERFLOW) {
1470 mpz_tdiv_r (d->value, d->value,
1471 cob_mpze10[digits]);
1472 } else {
1473 mpz_fdiv_r_2exp (d->value, d->value, (f->size * 8));
1474 }
1475 }
1476 }
1477 #ifdef COB_LI_IS_LL
1478 if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
1479 cob_binary_set_uint64 (f, mpz_get_ui (d->value));
1480 } else {
1481 cob_binary_set_int64 (f, mpz_get_si (d->value));
1482 }
1483 #elif defined(COB_EXPERIMENTAL)
1484 if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
1485 cob_binary_set_uint64 (f, mpz_get_ull (d->value));
1486 } else {
1487 cob_binary_set_int64 (f, mpz_get_sll (d->value));
1488 }
1489 #else
1490 if (f->size <= 4) {
1491 if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
1492 cob_binary_set_uint64 (f, (cob_u64_t)mpz_get_ui (d->value));
1493 } else {
1494 cob_binary_set_int64 (f, (cob_s64_t)mpz_get_si (d->value));
1495 }
1496 } else {
1497 mpz_fdiv_r_2exp (cob_mpzt, d->value, 32);
1498 mpz_fdiv_q_2exp (d->value, d->value, 32);
1499 lo = mpz_get_ui (cob_mpzt);
1500
1501 if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
1502 ullval = mpz_get_ui (d->value);
1503 ullval = (ullval << 32) | lo;
1504 cob_binary_set_uint64 (f, ullval);
1505 } else {
1506 llval = mpz_get_si (d->value);
1507 llval = (llval << 32) | lo;
1508 cob_binary_set_int64 (f, llval);
1509 }
1510 }
1511 #endif
1512 if (!overflow) {
1513 return 0;
1514 }
1515
1516 overflow:
1517 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1518 return cobglobptr->cob_exception_code;
1519 }
1520
1521 /* General uint -> field */
1522
1523 void
1524 cob_set_field_to_uint (cob_field *field, const cob_u32_t data)
1525 {
1526 cob_decimal dec;
1527
1528 mpz_init2 (dec.value, COB_MPZ_DEF);
1529 mpz_set_ui (dec.value, data);
1530 dec.scale = 0;
1531
1532 cob_decimal_get_field (&dec, field, 0);
1533
1534 mpz_clear (dec.value);
1535 }
1536
1537 /* General field */
1538
1539 void
1540 cob_decimal_set_field (cob_decimal *dec, cob_field *field)
1541 {
1542 union {
1543 double dval;
1544 float fval;
1545 } uval;
1546
1547 switch (COB_FIELD_TYPE (field)) {
1548 case COB_TYPE_NUMERIC_BINARY:
1549 case COB_TYPE_NUMERIC_COMP5:
1550 cob_decimal_set_binary (dec, field);
1551 break;
1552 case COB_TYPE_NUMERIC_PACKED:
1553 cob_decimal_set_packed (dec, field);
1554 break;
1555 case COB_TYPE_NUMERIC_FLOAT:
1556 memcpy ((void *)&uval.fval, field->data, sizeof(float));
1557 cob_decimal_set_double (dec, (double)uval.fval);
1558 break;
1559 case COB_TYPE_NUMERIC_DOUBLE:
1560 memcpy ((void *)&uval.dval, field->data, sizeof(double));
1561 cob_decimal_set_double (dec, uval.dval);
1562 break;
1563 case COB_TYPE_NUMERIC_FP_DEC64:
1564 cob_decimal_set_ieee64dec (dec, field);
1565 break;
1566 case COB_TYPE_NUMERIC_FP_DEC128:
1567 cob_decimal_set_ieee128dec (dec, field);
1568 break;
1569 default:
1570 cob_decimal_set_display (dec, field);
1571 break;
1572 }
1573 }
1574
1575 /* note: currently (GC3.1) only called by display/dump
1576 code from termio.c, with field type
1577 COB_TYPE_NUMERIC_FP_DEC64/COB_TYPE_NUMERIC_FP_DEC128 */
1578 void
1579 cob_print_ieeedec (const cob_field *f, FILE *fp)
1580 {
1581 union {
1582 double dval;
1583 float fval;
1584 } uval;
1585
1586 switch (COB_FIELD_TYPE (f)) {
1587 case COB_TYPE_NUMERIC_FP_DEC64:
1588 cob_decimal_set_ieee64dec (&cob_d3, f);
1589 break;
1590 case COB_TYPE_NUMERIC_FP_DEC128:
1591 cob_decimal_set_ieee128dec (&cob_d3, f);
1592 break;
1593 case COB_TYPE_NUMERIC_FLOAT:
1594 memcpy ((void *)&uval.fval, f->data, sizeof(float));
1595 cob_decimal_set_double (&cob_d3, (double)uval.fval);
1596 break;
1597 case COB_TYPE_NUMERIC_DOUBLE:
1598 memcpy ((void *)&uval.dval, f->data, sizeof(double));
1599 cob_decimal_set_double (&cob_d3, uval.dval);
1600 break;
1601 /* LCOV_EXCL_START */
1602 default:
1603 cob_runtime_error (_("invalid internal call of %s"), "cob_print_ieeedec");
1604 cob_runtime_error (_("Please report this!"));
1605 cob_stop_run (1);
1606 /* LCOV_EXCL_STOP */
1607 }
1608 cob_decimal_print (&cob_d3, fp);
1609 }
1610
1611 void
1612 cob_print_realbin (const cob_field *f, FILE *fp, const int size)
1613 {
1614 union {
1615 cob_u64_t uval;
1616 cob_s64_t val;
1617 } llval;
1618
1619 if (COB_FIELD_HAVE_SIGN (f)) {
1620 llval.val = cob_binary_get_sint64 (f);
1621 fprintf (fp, CB_FMT_PLLD, size, size, llval.val);
1622 return;
1623 }
1624 llval.uval = cob_binary_get_uint64 (f);
1625 fprintf (fp, CB_FMT_PLLU, size, size, llval.uval);
1626 }
1627
1628 static void
1629 cob_decimal_do_round (cob_decimal *d, cob_field *f, const int opt)
1630 {
1631 cob_uli_t adj;
1632 int sign;
1633 int scale;
1634
1635 sign = mpz_sgn (d->value);
1636 /* Returns 0 when value is 0 */
1637 if (!sign) {
1638 return;
1639 }
1640 scale = COB_FIELD_SCALE(f);
1641 if (scale >= d->scale) {
1642 return;
1643 }
1644
1645 switch (opt & ~(COB_STORE_MASK)) {
1646 case COB_STORE_TRUNCATION:
1647 return;
1648 case COB_STORE_PROHIBITED:
1649 cob_set_exception (COB_EC_SIZE_TRUNCATION);
1650 return;
1651 case COB_STORE_AWAY_FROM_ZERO:
1652 adj = d->scale - scale;
1653 mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
1654 mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
1655 if (mpz_sgn (cob_mpzt2)) {
1656 /* Not exact number */
1657 if (sign < 0) {
1658 mpz_sub (d->value, d->value, cob_mpzt);
1659 } else {
1660 mpz_add (d->value, d->value, cob_mpzt);
1661 }
1662 }
1663 return;
1664 case COB_STORE_NEAR_TOWARD_ZERO:
1665 adj = d->scale - scale - 1;
1666 mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
1667 mpz_mul_ui (cob_mpzt, cob_mpzt, 5UL);
1668 mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
1669 shift_decimal (d, scale - d->scale + 1);
1670 if (!mpz_sgn (cob_mpzt2)) {
1671 return;
1672 }
1673 if (sign > 0) {
1674 mpz_add_ui (d->value, d->value, 5UL);
1675 } else {
1676 mpz_sub_ui (d->value, d->value, 5UL);
1677 }
1678 return;
1679 case COB_STORE_TOWARD_GREATER:
1680 adj = d->scale - scale;
1681 mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
1682 mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
1683 if (mpz_sgn (cob_mpzt2)) {
1684 /* Not exact number */
1685 if (sign > 0) {
1686 mpz_add (d->value, d->value, cob_mpzt);
1687 }
1688 }
1689 return;
1690 case COB_STORE_TOWARD_LESSER:
1691 adj = d->scale - scale;
1692 mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
1693 mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
1694 if (mpz_sgn (cob_mpzt2)) {
1695 /* Not exact number */
1696 if (sign < 0) {
1697 mpz_sub (d->value, d->value, cob_mpzt);
1698 }
1699 }
1700 return;
1701 case COB_STORE_NEAR_EVEN:
1702 adj = d->scale - scale - 1;
1703 mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
1704 mpz_mul_ui (cob_mpzt, cob_mpzt, 5UL);
1705 mpz_tdiv_r (cob_mpzt, d->value, cob_mpzt);
1706 shift_decimal (d, scale - d->scale + 1);
1707 if (!mpz_sgn (cob_mpzt)) {
1708 adj = mpz_tdiv_ui (d->value, 100UL);
1709 switch (adj) {
1710 case 5:
1711 case 25:
1712 case 45:
1713 case 65:
1714 case 85:
1715 return;
1716 }
1717 }
1718 if (sign > 0) {
1719 mpz_add_ui (d->value, d->value, 5UL);
1720 } else {
1721 mpz_sub_ui (d->value, d->value, 5UL);
1722 }
1723 return;
1724 case COB_STORE_NEAR_AWAY_FROM_ZERO:
1725 default:
1726 shift_decimal (d, scale - d->scale + 1);
1727 if (sign > 0) {
1728 mpz_add_ui (d->value, d->value, 5UL);
1729 } else {
1730 mpz_sub_ui (d->value, d->value, 5UL);
1731 }
1732 return;
1733 }
1734 }
1735
1736 int
1737 cob_decimal_get_field (cob_decimal *d, cob_field *f, const int opt)
1738 {
1739 cob_field temp;
1740 cob_field_attr attr;
1741 union {
1742 double val;
1743 float fval;
1744 } uval;
1745
1746 if (unlikely (d->scale == COB_DECIMAL_NAN)) {
1747 if (!cobglobptr->cob_exception_code
1748 || !cob_last_exception_is (COB_EC_SIZE_ZERO_DIVIDE)) {
1749 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1750 }
1751 return cobglobptr->cob_exception_code;
1752 }
1753 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
1754 if (unlikely(d->scale == COB_DECIMAL_INF)) {
1755 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1756 return cobglobptr->cob_exception_code;
1757 }
1758 }
1759
1760 /* work copy */
1761 if (d != &cob_d1) {
1762 mpz_set (cob_d1.value, d->value);
1763 cob_d1.scale = d->scale;
1764 d = &cob_d1;
1765 }
1766
1767 /* Rounding */
1768 if ((opt & COB_STORE_ROUND)) {
1769 cob_decimal_do_round (d, f, opt);
1770 }
1771 if (!COB_FIELD_IS_FP(f)) {
1772 /* Append or truncate decimal digits */
1773 shift_decimal (d, COB_FIELD_SCALE(f) - d->scale);
1774 }
1775
1776 /* Store number */
1777 switch (COB_FIELD_TYPE (f)) {
1778 case COB_TYPE_NUMERIC_BINARY:
1779 case COB_TYPE_NUMERIC_COMP5:
1780 return cob_decimal_get_binary (d, f, opt);
1781 case COB_TYPE_NUMERIC_DISPLAY:
1782 return cob_decimal_get_display (d, f, opt);
1783 case COB_TYPE_NUMERIC_PACKED:
1784 return cob_decimal_get_packed (d, f, opt);
1785 case COB_TYPE_NUMERIC_FLOAT:
1786 uval.fval = (float) cob_decimal_get_double (d);
1787 if ((opt & COB_STORE_KEEP_ON_OVERFLOW)
1788 && (isinf (uval.fval) || isnan(uval.fval))) {
1789 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1790 return cobglobptr->cob_exception_code;
1791 }
1792 if ((opt & COB_STORE_KEEP_ON_OVERFLOW)
1793 && cob_not_finite) {
1794 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1795 return cobglobptr->cob_exception_code;
1796 }
1797 memcpy (f->data, &uval.fval, sizeof (float));
1798 return 0;
1799 case COB_TYPE_NUMERIC_DOUBLE:
1800 uval.val = cob_decimal_get_double (d);
1801 if ((opt & COB_STORE_KEEP_ON_OVERFLOW)
1802 && (isinf (uval.val) || isnan(uval.val))) {
1803 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1804 return cobglobptr->cob_exception_code;
1805 }
1806 if ((opt & COB_STORE_KEEP_ON_OVERFLOW)
1807 && cob_not_finite) {
1808 cob_set_exception (COB_EC_SIZE_OVERFLOW);
1809 return cobglobptr->cob_exception_code;
1810 }
1811 memcpy (f->data, &uval.val, sizeof (double));
1812 return 0;
1813 case COB_TYPE_NUMERIC_FP_DEC64:
1814 return cob_decimal_get_ieee64dec (d, f, opt);
1815 case COB_TYPE_NUMERIC_FP_DEC128:
1816 return cob_decimal_get_ieee128dec (d, f, opt);
1817 default:
1818 break;
1819 }
1820 COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, COB_FIELD_DIGITS(f),
1821 COB_FIELD_SCALE(f), COB_FLAG_HAVE_SIGN, NULL);
1822 temp.size = COB_FIELD_DIGITS(f);
1823 temp.data = cob_malloc (COB_FIELD_DIGITS(f));
1824 temp.attr = &attr;
1825 if (cob_decimal_get_display (d, &temp, opt) == 0) {
1826 cob_move (&temp, f);
1827 cob_free (temp.data);
1828 return 0;
1829 }
1830 cob_free (temp.data);
1831 return cobglobptr->cob_exception_code;
1832 }
1833
1834 /* Decimal arithmetic */
1835
1836 void
1837 cob_decimal_add (cob_decimal *d1, cob_decimal *d2)
1838 {
1839 DECIMAL_CHECK (d1, d2);
1840 align_decimal (d1, d2);
1841 mpz_add (d1->value, d1->value, d2->value);
1842 }
1843
1844 void
1845 cob_decimal_sub (cob_decimal *d1, cob_decimal *d2)
1846 {
1847 DECIMAL_CHECK (d1, d2);
1848 align_decimal (d1, d2);
1849 mpz_sub (d1->value, d1->value, d2->value);
1850 }
1851
1852 void
1853 cob_decimal_mul (cob_decimal *d1, cob_decimal *d2)
1854 {
1855 DECIMAL_CHECK (d1, d2);
1856 d1->scale += d2->scale;
1857 mpz_mul (d1->value, d1->value, d2->value);
1858 }
1859
1860 void
1861 cob_decimal_div (cob_decimal *d1, cob_decimal *d2)
1862 {
1863 DECIMAL_CHECK (d1, d2);
1864
1865 /* Check for division by zero */
1866 if (unlikely (mpz_sgn (d2->value) == 0)) {
1867 d1->scale = COB_DECIMAL_NAN;
1868 /* FIXME: we currently don't handle the fatal exception correct
1869 fatal->abort. We only should set it when it *doesn't* happen
1870 within a arithmetic statement with SIZE error phrase and must
1871 execute the appropriate USE statement, if any before the abort
1872 */
1873 cob_set_exception (COB_EC_SIZE_ZERO_DIVIDE);
1874 return;
1875 }
1876 if (unlikely (mpz_sgn (d1->value) == 0)) {
1877 d1->scale = 0;
1878 return;
1879 }
1880 d1->scale -= d2->scale;
1881 shift_decimal (d1, COB_MAX_DIGITS + ((d1->scale < 0) ? -d1->scale : 0));
1882 mpz_tdiv_q (d1->value, d1->value, d2->value);
1883 }
1884
1885 int
1886 cob_decimal_cmp (cob_decimal *d1, cob_decimal *d2)
1887 {
1888 align_decimal (d1, d2);
1889 return mpz_cmp (d1->value, d2->value);
1890 }
1891
1892 /*
1893 * Shift 'd1' to have same scale as 'd2'
1894 */
1895 void
1896 cob_decimal_align (cob_decimal *d1, const int scale)
1897 {
1898 if (d1->scale > scale) {
1899 shift_decimal (d1, scale - d1->scale);
1900 } else if (d1->scale < scale) {
1901 shift_decimal (d1, d1->scale - scale);
1902 }
1903 return;
1904 }
1905
1906 /* Convenience functions */
1907
1908 void
1909 cob_add (cob_field *f1, cob_field *f2, const int opt)
1910 {
1911 cob_decimal_set_field (&cob_d1, f1);
1912 cob_decimal_set_field (&cob_d2, f2);
1913 cob_decimal_add (&cob_d1, &cob_d2);
1914 (void)cob_decimal_get_field (&cob_d1, f1, opt);
1915 }
1916
1917 void
1918 cob_sub (cob_field *f1, cob_field *f2, const int opt)
1919 {
1920 cob_decimal_set_field (&cob_d1, f1);
1921 cob_decimal_set_field (&cob_d2, f2);
1922 cob_decimal_sub (&cob_d1, &cob_d2);
1923 (void)cob_decimal_get_field (&cob_d1, f1, opt);
1924 }
1925
1926 void
1927 cob_mul (cob_field *f1, cob_field *f2, const int opt)
1928 {
1929 cob_decimal_set_field (&cob_d1, f1);
1930 cob_decimal_set_field (&cob_d2, f2);
1931 cob_decimal_mul (&cob_d1, &cob_d2);
1932 (void)cob_decimal_get_field (&cob_d1, f1, opt);
1933 }
1934
1935 void
1936 cob_div (cob_field *f1, cob_field *f2, const int opt)
1937 {
1938 cob_decimal_set_field (&cob_d1, f1);
1939 cob_decimal_set_field (&cob_d2, f2);
1940 cob_decimal_div (&cob_d1, &cob_d2);
1941 (void)cob_decimal_get_field (&cob_d1, f1, opt);
1942 }
1943
1944 void
1945 cob_div_quotient (cob_field *dividend, cob_field *divisor,
1946 cob_field *quotient, const int opt)
1947 {
1948 /* Note that cob_div_quotient and cob_div_remainder must remain */
1949 /* separate because of COBOL rules. The quotient must be fully */
1950 /* evaluated before the remainder item is evaluated */
1951 /* e.g. DIVIDE A BY B GIVING Z REMAINDER FLD (Z). */
1952
1953 cob_decimal_set_field (&cob_d1, dividend);
1954 cob_decimal_set_field (&cob_d2, divisor);
1955 cob_decimal_set (&cob_d_remainder, &cob_d1);
1956
1957 /* Compute quotient */
1958 cob_decimal_div (&cob_d1, &cob_d2);
1959 /* Check divide by zero - Exception is set in cob_decimal_div */
1960 if (cob_d1.scale == COB_DECIMAL_NAN) {
1961 /* Forces an early return from cob_div_remainder */
1962 cob_d_remainder.scale = COB_DECIMAL_NAN;
1963 return;
1964 }
1965
1966 /* Set quotient */
1967 cob_decimal_set (&cob_d3, &cob_d1);
1968 (void)cob_decimal_get_field (&cob_d1, quotient, opt);
1969
1970 /* Truncate digits from the quotient */
1971 shift_decimal (&cob_d3, COB_FIELD_SCALE(quotient) - cob_d3.scale);
1972
1973 /* Compute remainder */
1974 cob_decimal_mul (&cob_d3, &cob_d2);
1975 cob_decimal_sub (&cob_d_remainder, &cob_d3);
1976 }
1977
1978 void
1979 cob_div_remainder (cob_field *fld_remainder, const int opt)
1980 {
1981 (void)cob_decimal_get_field (&cob_d_remainder, fld_remainder, opt);
1982 }
1983
1984 void
1985 cob_decimal_setget_fld (cob_field *src, cob_field *dst, const int opt)
1986 {
1987 cob_decimal_set_field (&cob_d1, src);
1988 (void)cob_decimal_get_field (&cob_d1, dst, opt);
1989 }
1990
1991 #if 0 /* RXWRXW - Buggy */
1992
1993 /* Optimized arithmetic for DISPLAY */
1994
1995 static int
1996 display_add_int (unsigned char *data, const size_t size, int n, const int opt)
1997 {
1998 unsigned char *sp;
1999 size_t carry = 0;
2000 int i;
2001 int is;
2002
2003 sp = data + size;
2004 while (n > 0) {
2005 i = n % 10;
2006 n /= 10;
2007
2008 /* Check for overflow */
2009 if (unlikely (--sp < data)) {
2010 return opt;
2011 }
2012
2013 /* Perform addition */
2014 is = (*sp & 0x0F) + i + carry;
2015 if (is > 9) {
2016 carry = 1;
2017 *sp = '0' + ((is + 6) & 0x0F);
2018 } else {
2019 carry = 0;
2020 *sp = '0' + is;
2021 }
2022 }
2023 if (carry == 0) {
2024 return 0;
2025 }
2026
2027 /* Carry up */
2028 while (--sp >= data) {
2029 if ((*sp += 1) <= (unsigned char)'9') {
2030 return 0;
2031 }
2032 *sp = '0';
2033 }
2034 return opt;
2035 }
2036
2037 static int
2038 display_sub_int (unsigned char *data, const size_t size, int n, const int opt)
2039 {
2040 unsigned char *sp;
2041 size_t carry = 0;
2042 int i;
2043
2044 COB_UNUSED (opt);
2045
2046 sp = data + size;
2047 while (n > 0) {
2048 i = n % 10;
2049 n /= 10;
2050
2051 /* Check for overflow */
2052 if (unlikely (--sp < data)) {
2053 return 1;
2054 }
2055
2056 #if 0 /* RXWRXW - Garbage check */
2057 /* Correct garbage */
2058 *sp = (unsigned char)('0' + (*sp & 0x0F));
2059 #endif
2060 /* Perform subtraction */
2061 if ((*sp -= i + carry) < '0') {
2062 carry = 1;
2063 *sp += 10;
2064 } else {
2065 carry = 0;
2066 }
2067 }
2068 if (carry == 0) {
2069 return 0;
2070 }
2071
2072 /* Carry up */
2073 while (--sp >= data) {
2074 #if 0 /* RXWRXW - Garbage check */
2075 /* Correct garbage */
2076 *sp = (unsigned char)('0' + (*sp & 0x0F));
2077 #endif
2078 if ((*sp -= 1) >= (unsigned char)'0') {
2079 return 0;
2080 }
2081 *sp = '9';
2082 }
2083 return 1;
2084 }
2085
2086 static int
2087 cob_display_add_int (cob_field *f, int n, const int opt)
2088 {
2089 unsigned char *data;
2090 size_t osize;
2091 size_t size;
2092 size_t i;
2093 int scale;
2094 int sign;
2095 unsigned char tfield[256];
2096
2097 data = COB_FIELD_DATA (f);
2098 size = COB_FIELD_SIZE (f);
2099 osize = size;
2100 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
2101 memcpy (tfield, data, size);
2102 }
2103 scale = COB_FIELD_SCALE (f);
2104 sign = COB_GET_SIGN (f);
2105 /* -x +v = -(x - v), -x -v = -(x + v) */
2106 if (sign < 0) {
2107 n = -n;
2108 }
2109
2110 if (unlikely (scale < 0)) {
2111 /* PIC 9(n)P(m) */
2112 if (-scale < 10) {
2113 /* Fix optimizer bug */
2114 while (scale) {
2115 ++scale;
2116 n /= 10;
2117 }
2118 } else {
2119 n = 0;
2120 }
2121 scale = 0;
2122 if (n == 0) {
2123 return 0;
2124 }
2125 } else {
2126 /* PIC 9(n)V9(m) */
2127 size -= scale;
2128 if (!size) {
2129 COB_PUT_SIGN (f, sign);
2130 cob_set_exception (COB_EC_SIZE_OVERFLOW);
2131 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
2132 return cobglobptr->cob_exception_code;
2133 }
2134 return 0;
2135 }
2136 }
2137
2138 if (n > 0) {
2139 /* Add n to the field */
2140 if (display_add_int (data, size, n, opt) != 0) {
2141 /* Overflow */
2142 COB_PUT_SIGN (f, sign);
2143 cob_set_exception (COB_EC_SIZE_OVERFLOW);
2144 /* If we need to restore */
2145 if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
2146 memcpy (data, tfield, osize);
2147 return cobglobptr->cob_exception_code;
2148 }
2149 }
2150 } else if (n < 0) {
2151 /* Subtract n from the field */
2152 if (display_sub_int (data, size, -n, opt) != 0) {
2153 for (i = 0; i < size; ++i) {
2154 data[i] = COB_I2D (9 - COB_D2I (data[i]));
2155 }
2156 if (scale) {
2157 for (i = size; i < size + scale; ++i) {
2158 if (COB_D2I (data[i]) > 0) {
2159 data[i] = COB_I2D (10 - COB_D2I (data[i]));
2160 }
2161 }
2162 } else {
2163 (void)display_add_int (data, size, 1, 0);
2164 }
2165 sign = -sign;
2166 }
2167 }
2168
2169 COB_PUT_SIGN (f, sign);
2170 return 0;
2171 }
2172 #endif /* Buggy */
2173
2174 int
2175 cob_add_int (cob_field *f, const int n, const int opt)
2176 {
2177 int scale;
2178 int val;
2179
2180 if (unlikely (n == 0)) {
2181 return 0;
2182 }
2183 #if 0 /* RXWRXW - Buggy */
2184 if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_PACKED) {
2185 return cob_add_packed (f, n, opt);
2186 } else if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_DISPLAY) {
2187 return cob_display_add_int (f, n, opt);
2188 }
2189 #endif
2190
2191 /* Not optimized */
2192 cob_decimal_set_field (&cob_d1, f);
2193
2194 if (COB_FIELD_TYPE (f) >= COB_TYPE_NUMERIC_FLOAT
2195 && COB_FIELD_TYPE (f) <= COB_TYPE_NUMERIC_FP_BIN128) {
2196 mpz_set_si (cob_d2.value, (cob_sli_t) n);
2197 cob_d2.scale = 0;
2198 cob_decimal_add (&cob_d1, &cob_d2);
2199 return cob_decimal_get_field (&cob_d1, f, opt);
2200 }
2201 else {
2202 scale = COB_FIELD_SCALE (f);
2203 val = n;
2204 if (unlikely (scale < 0)) {
2205 /* PIC 9(n)P(m) */
2206 if (-scale < 10) {
2207 while (scale++) {
2208 val /= 10;
2209 }
2210 } else {
2211 val = 0;
2212 }
2213 scale = 0;
2214 if (!val) {
2215 return 0;
2216 }
2217 }
2218 mpz_set_si (cob_d2.value, (cob_sli_t)val);
2219 cob_d2.scale = 0;
2220 if (scale > 0) {
2221 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)scale);
2222 mpz_mul (cob_d2.value, cob_d2.value, cob_mexp);
2223 cob_d2.scale = cob_d1.scale;
2224 }
2225 mpz_add (cob_d1.value, cob_d1.value, cob_d2.value);
2226 return cob_decimal_get_field (&cob_d1, f, opt);
2227 }
2228 }
2229
2230 int
2231 cob_sub_int (cob_field *f, const int n, const int opt)
2232 {
2233 return cob_add_int (f, -n, opt);
2234 }
2235
2236 int
2237 cob_cmp_int (cob_field *f1, const int n)
2238 {
2239 cob_decimal_set_field (&cob_d1, f1);
2240 mpz_set_si (cob_d2.value, (cob_sli_t)n);
2241 cob_d2.scale = 0;
2242 return cob_decimal_cmp (&cob_d1, &cob_d2);
2243 }
2244
2245 int
2246 cob_cmp_uint (cob_field *f1, const unsigned int n)
2247 {
2248 cob_decimal_set_field (&cob_d1, f1);
2249 mpz_set_ui (cob_d2.value, (cob_uli_t)n);
2250 cob_d2.scale = 0;
2251 return cob_decimal_cmp (&cob_d1, &cob_d2);
2252 }
2253
2254 int
2255 cob_cmp_llint (cob_field *f1, const cob_s64_t n)
2256 {
2257 #ifdef COB_LI_IS_LL
2258 mpz_set_si (cob_d2.value, (cob_sli_t)n);
2259 #else
2260 cob_u64_t uval;
2261 cob_u32_t negative;
2262
2263 negative = 0;
2264 if (n < 0) {
2265 negative = 1;
2266 uval = (cob_u64_t)-n;
2267 } else {
2268 uval = (cob_u64_t)n;
2269 }
2270 mpz_set_ui (cob_d2.value, (cob_uli_t)(uval >> 32));
2271 mpz_mul_2exp (cob_d2.value, cob_d2.value, 32);
2272 mpz_add_ui (cob_d2.value, cob_d2.value, (cob_uli_t)(uval & 0xFFFFFFFFU));
2273 if (negative) {
2274 mpz_neg (cob_d2.value, cob_d2.value);
2275 }
2276 #endif
2277
2278 cob_d2.scale = 0;
2279 cob_decimal_set_field (&cob_d1, f1);
2280 return cob_decimal_cmp (&cob_d1, &cob_d2);
2281 }
2282
2283 #ifdef COB_FLOAT_DELTA
2284 #define TOLERANCE (double) COB_FLOAT_DELTA
2285 #else
2286 #define TOLERANCE (double) 0.0000001
2287 #endif
2288 #define FLOAT_EQ(x,y,t) (fabs(((x-y)/x)) < t)
2289
2290 int
2291 cob_cmp_float (cob_field *f1, cob_field *f2)
2292 {
2293 double d1,d2;
2294 float flt;
2295 if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT) {
2296 memcpy(&flt,f1->data,sizeof(float));
2297 d1 = flt;
2298 } else if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE) {
2299 memcpy(&d1,f1->data,sizeof(double));
2300 } else {
2301 cob_decimal_set_field (&cob_d1, f1);
2302 d1 = cob_decimal_get_double(&cob_d1);
2303 }
2304 if(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT) {
2305 memcpy(&flt,f2->data,sizeof(float));
2306 d2 = flt;
2307 } else if(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) {
2308 memcpy(&d2,f2->data,sizeof(double));
2309 } else {
2310 cob_decimal_set_field (&cob_d1, f2);
2311 d2 = cob_decimal_get_double(&cob_d1);
2312 }
2313 if(d1 == d2)
2314 return 0;
2315 if(d1 != 0.0
2316 && FLOAT_EQ(d1,d2,TOLERANCE))
2317 return 0;
2318 if(d1 < d2)
2319 return -1;
2320 return 1;
2321 }
2322
2323 int
2324 cob_numeric_cmp (cob_field *f1, cob_field *f2)
2325 {
2326 if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT
2327 || COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE
2328 || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT
2329 || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) {
2330 return cob_cmp_float (f1, f2);
2331 }
2332 cob_decimal_set_field (&cob_d1, f1);
2333 cob_decimal_set_field (&cob_d2, f2);
2334 return cob_decimal_cmp (&cob_d1, &cob_d2);
2335 }
2336
2337 int
2338 cob_cmp_packed (cob_field *f, const cob_s64_t val)
2339 {
2340 unsigned char *p;
2341 cob_u64_t n;
2342 size_t size;
2343 size_t inc;
2344 int sign;
2345 unsigned char val1[20];
2346
2347 sign = cob_packed_get_sign (f);
2348 /* Field positive, value negative */
2349 if (sign >= 0 && val < 0) {
2350 return 1;
2351 }
2352 /* Field negative, value positive */
2353 if (sign < 0 && val >= 0) {
2354 return -1;
2355 }
2356 /* Both positive or both negative */
2357 if (val < 0) {
2358 n = (cob_u64_t)-val;
2359 } else {
2360 n = (cob_u64_t)val;
2361 }
2362 inc = 0;
2363 p = f->data;
2364 for (size = 0; size < 20; size++) {
2365 if (size < 20 - f->size) {
2366 val1[size] = 0;
2367 } else {
2368 val1[size] = p[inc++];
2369 }
2370 }
2371 if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
2372 if ((COB_FIELD_DIGITS(f) % 2) == 1) {
2373 val1[20 - f->size] &= 0x0F;
2374 }
2375 } else {
2376 val1[19] &= 0xF0;
2377 if ((COB_FIELD_DIGITS(f) % 2) == 0) {
2378 val1[20 - f->size] &= 0x0F;
2379 }
2380 }
2381 if (n != last_packed_val) {
2382 last_packed_val = n;
2383 memset (packed_value, 0, sizeof(packed_value));
2384 if (n) {
2385 p = &packed_value[19];
2386 if (!COB_FIELD_NO_SIGN_NIBBLE (f)) {
2387 *p = (n % 10) << 4;
2388 p--;
2389 n /= 10;
2390 }
2391 for (; n;) {
2392 size = n % 100;
2393 *p = (unsigned char)((size % 10) | ((size / 10) << 4));
2394 n /= 100;
2395 p--;
2396 }
2397 }
2398 }
2399 for (size = 0; size < 20; size++) {
2400 if (val1[size] != packed_value[size]) {
2401 if (sign < 0) {
2402 return packed_value[size] - val1[size];
2403 } else {
2404 return val1[size] - packed_value[size];
2405 }
2406 }
2407 }
2408 return 0;
2409 }
2410
2411 /* Numeric Display compares */
2412
2413 #ifdef COB_EBCDIC_MACHINE
2414 static unsigned int
2415 cob_get_long_ascii_sign (const unsigned char *p, cob_s64_t *val)
2416 {
2417 switch (*p) {
2418 case 'p':
2419 return 1;
2420 case 'q':
2421 *val += 1;
2422 return 1;
2423 case 'r':
2424 *val += 2;
2425 return 1;
2426 case 's':
2427 *val += 3;
2428 return 1;
2429 case 't':
2430 *val += 4;
2431 return 1;
2432 case 'u':
2433 *val += 5;
2434 return 1;
2435 case 'v':
2436 *val += 6;
2437 return 1;
2438 case 'w':
2439 *val += 7;
2440 return 1;
2441 case 'x':
2442 *val += 8;
2443 return 1;
2444 case 'y':
2445 *val += 9;
2446 return 1;
2447 }
2448 return 0;
2449 }
2450 #endif
2451
2452 static unsigned int
2453 cob_get_long_ebcdic_sign (const unsigned char *p, cob_s64_t *val)
2454 {
2455 switch (*p) {
2456 case '{':
2457 return 0;
2458 case 'A':
2459 *val += 1;
2460 return 0;
2461 case 'B':
2462 *val += 2;
2463 return 0;
2464 case 'C':
2465 *val += 3;
2466 return 0;
2467 case 'D':
2468 *val += 4;
2469 return 0;
2470 case 'E':
2471 *val += 5;
2472 return 0;
2473 case 'F':
2474 *val += 6;
2475 return 0;
2476 case 'G':
2477 *val += 7;
2478 return 0;
2479 case 'H':
2480 *val += 8;
2481 return 0;
2482 case 'I':
2483 *val += 9;
2484 return 0;
2485 case '}':
2486 return 1;
2487 case 'J':
2488 *val += 1;
2489 return 1;
2490 case 'K':
2491 *val += 2;
2492 return 1;
2493 case 'L':
2494 *val += 3;
2495 return 1;
2496 case 'M':
2497 *val += 4;
2498 return 1;
2499 case 'N':
2500 *val += 5;
2501 return 1;
2502 case 'O':
2503 *val += 6;
2504 return 1;
2505 case 'P':
2506 *val += 7;
2507 return 1;
2508 case 'Q':
2509 *val += 8;
2510 return 1;
2511 case 'R':
2512 *val += 9;
2513 return 1;
2514 }
2515 return 0;
2516 }
2517
2518 int
2519 cob_cmp_numdisp (const unsigned char *data, const size_t size,
2520 const cob_s64_t n, const cob_u32_t has_sign)
2521 {
2522 const unsigned char *p;
2523 cob_s64_t val = 0;
2524 size_t inc;
2525
2526 p = data;
2527 if (!has_sign) {
2528 if (unlikely (n < 0)) {
2529 return 1;
2530 }
2531 for (inc = 0; inc < size; inc++, p++) {
2532 val = (val * 10) + COB_D2I (*p);
2533 }
2534 return (val < n) ? -1 : (val > n);
2535 }
2536 for (inc = 0; inc < size - 1; inc++, p++) {
2537 val = (val * 10) + COB_D2I (*p);
2538 }
2539 val *= 10;
2540 if (*p >= (unsigned char)'0' && *p <= (unsigned char)'9') {
2541 val += COB_D2I (*p);
2542 } else {
2543 if (unlikely (COB_MODULE_PTR->ebcdic_sign)) {
2544 if (cob_get_long_ebcdic_sign (p, &val)) {
2545 val = -val;
2546 }
2547 } else {
2548 #ifdef COB_EBCDIC_MACHINE
2549 if (cob_get_long_ascii_sign (p, &val)) {
2550 val = -val;
2551 }
2552 #else
2553 if (*p >= (unsigned char)'p' && *p <= (unsigned char)'y') {
2554 val += (*p - (unsigned char)'p');
2555 val = -val;
2556 }
2557 #endif
2558 }
2559 }
2560 return (val < n) ? -1 : (val > n);
2561 }
2562
2563 void
2564 cob_decimal_alloc (const cob_u32_t params, ...)
2565 {
2566 cob_decimal **dec;
2567 cob_u32_t i;
2568 va_list args;
2569
2570 va_start (args, params);
2571 for (i = 0; i < params; ++i) {
2572 dec = va_arg (args, cob_decimal **);
2573 *dec = cob_decimal_base + i;
2574 }
2575 va_end (args);
2576 }
2577
2578 void
2579 cob_decimal_push (const cob_u32_t params, ...)
2580 {
2581 cob_decimal **dec;
2582 cob_u32_t i;
2583 va_list args;
2584
2585 va_start (args, params);
2586 for (i = 0; i < params; ++i) {
2587 dec = va_arg (args, cob_decimal **);
2588 *dec = cob_malloc (sizeof(cob_decimal));
2589 cob_decimal_init (*dec);
2590 }
2591 va_end (args);
2592 }
2593
2594 void
2595 cob_decimal_pop (const cob_u32_t params, ...)
2596 {
2597 cob_decimal *dec;
2598 cob_u32_t i;
2599 va_list args;
2600
2601 va_start (args, params);
2602 for (i = 0; i < params; ++i) {
2603 dec = va_arg (args, cob_decimal *);
2604 mpz_clear (dec->value);
2605 cob_free (dec);
2606 }
2607 va_end (args);
2608 }
2609
2610 /* Init/Exit routines */
2611
2612 void
2613 cob_exit_numeric (void)
2614 {
2615 cob_decimal *d1;
2616 size_t i;
2617
2618 if (cob_decimal_base) {
2619 d1 = cob_decimal_base;
2620 for (i = 0; i < COB_MAX_DEC_STRUCT; d1++, i++) {
2621 mpz_clear (d1->value);
2622 }
2623 cob_free (cob_decimal_base);
2624 }
2625
2626 mpz_clear (cob_d_remainder.value);
2627
2628 mpz_clear (cob_d3.value);
2629 mpz_clear (cob_d2.value);
2630 mpz_clear (cob_d1.value);
2631
2632 mpz_clear (cob_mexp);
2633 mpz_clear (cob_mpzt2);
2634 mpz_clear (cob_mpzt);
2635
2636 mpz_clear (cob_mpz_ten34m1);
2637 mpz_clear (cob_mpz_ten16m1);
2638 for (i = 0; i < COB_MAX_BINARY; i++) {
2639 mpz_clear (cob_mpze10[i]);
2640 }
2641
2642 mpf_clear (cob_mpft_get);
2643 mpf_clear (cob_mpft);
2644 }
2645
2646 void
2647 cob_init_numeric (cob_global *lptr)
2648 {
2649 cob_decimal *d1;
2650 cob_u32_t i;
2651
2652 cobglobptr = lptr;
2653
2654 memset (packed_value, 0, sizeof(packed_value));
2655 last_packed_val = 0;
2656
2657 mpf_init2 (cob_mpft, COB_MPF_PREC);
2658 mpf_init2 (cob_mpft_get, COB_MPF_PREC);
2659
2660 for (i = 0; i < COB_MAX_BINARY; i++) {
2661 mpz_init2 (cob_mpze10[i], 128UL);
2662 mpz_ui_pow_ui (cob_mpze10[i], 10UL, (cob_uli_t)i);
2663 }
2664 mpz_init_set (cob_mpz_ten16m1, cob_mpze10[16]);
2665 mpz_sub_ui (cob_mpz_ten16m1, cob_mpz_ten16m1, 1UL);
2666 mpz_init_set (cob_mpz_ten34m1, cob_mpze10[34]);
2667 mpz_sub_ui (cob_mpz_ten34m1, cob_mpz_ten34m1, 1UL);
2668
2669 mpz_init2 (cob_mpzt, COB_MPZ_DEF);
2670 mpz_init2 (cob_mpzt2, COB_MPZ_DEF);
2671 mpz_init2 (cob_mexp, COB_MPZ_DEF);
2672
2673 cob_decimal_init (&cob_d1);
2674 cob_decimal_init (&cob_d2);
2675 cob_decimal_init (&cob_d3);
2676 cob_decimal_init (&cob_d_remainder);
2677
2678 cob_decimal_base = cob_malloc (COB_MAX_DEC_STRUCT * sizeof(cob_decimal));
2679 d1 = cob_decimal_base;
2680 for (i = 0; i < COB_MAX_DEC_STRUCT; d1++, i++) {
2681 cob_decimal_init (d1);
2682 }
2683 }
2684