numeric.c File Reference

#include "config.h"
#include <stdio.h>
#include <stdlib.h>
#include <stddef.h>
#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#include <errno.h>
#include <math.h>
#include "libcob.h"
#include "coblocal.h"

Include dependency graph for numeric.c:

Go to the source code of this file.

Macros
#define	_GNU_SOURCE   1
#define	COB_LIB_EXPIMP
#define	DECIMAL_CHECK(d1, d2)
#define	TOLERANCE   (double) 0.0000001
#define	FLOAT_EQ(x, y, t)   (fabs(((x-y)/x)) < t)

Functions
void	cob_gmp_free (void *ptr)
static COB_INLINE COB_A_INLINE void	num_byte_memcpy (unsigned char *s1, const unsigned char *s2, size_t size)
static COB_INLINE COB_A_INLINE cob_s64_t	cob_binary_get_sint64 (const cob_field *const f)
static COB_INLINE COB_A_INLINE cob_u64_t	cob_binary_get_uint64 (const cob_field *const f)
static COB_INLINE COB_A_INLINE void	cob_binary_set_uint64 (cob_field *f, cob_u64_t n)
static COB_INLINE COB_A_INLINE void	cob_binary_set_int64 (cob_field *f, cob_s64_t n)
void	cob_decimal_init (cob_decimal *d)
void	cob_decimal_set_llint (cob_decimal *d, const cob_s64_t n)
static COB_INLINE COB_A_INLINE void	cob_decimal_set (cob_decimal *dst, const cob_decimal *src)
static void	cob_decimal_print (cob_decimal *d, FILE *fp)
static void	shift_decimal (cob_decimal *d, const int n)
static void	align_decimal (cob_decimal *d1, cob_decimal *d2)
static int	cob_decimal_get_ieee64dec (cob_decimal *d, cob_field *f, const int opt)
static void	cob_decimal_set_ieee64dec (cob_decimal *d, const cob_field *f)
static int	cob_decimal_get_ieee128dec (cob_decimal *d, cob_field *f, const int opt)
static void	cob_decimal_set_ieee128dec (cob_decimal *d, const cob_field *f)
static void	cob_decimal_set_double (cob_decimal *d, const double v)
static double	cob_decimal_get_double (cob_decimal *d)
static int	cob_packed_get_sign (const cob_field *f)
void	cob_set_packed_zero (cob_field *f)
static void	cob_decimal_set_packed (cob_decimal *d, cob_field *f)
static int	cob_decimal_get_packed (cob_decimal *d, cob_field *f, const int opt)
void	cob_set_packed_int (cob_field *f, const int val)
static void	cob_decimal_set_display (cob_decimal *d, cob_field *f)
static int	cob_decimal_get_display (cob_decimal *d, cob_field *f, const int opt)
static void	cob_decimal_set_binary (cob_decimal *d, cob_field *f)
static int	cob_decimal_get_binary (cob_decimal *d, cob_field *f, const int opt)
void	cob_decimal_set_field (cob_decimal *d, cob_field *f)
void	cob_print_ieeedec (const cob_field *f, FILE *fp)
void	cob_print_realbin (const cob_field *f, FILE *fp, const int size)
static void	cob_decimal_do_round (cob_decimal *d, cob_field *f, const int opt)
int	cob_decimal_get_field (cob_decimal *d, cob_field *f, const int opt)
void	cob_decimal_add (cob_decimal *d1, cob_decimal *d2)
void	cob_decimal_sub (cob_decimal *d1, cob_decimal *d2)
void	cob_decimal_mul (cob_decimal *d1, cob_decimal *d2)
void	cob_decimal_div (cob_decimal *d1, cob_decimal *d2)
int	cob_decimal_cmp (cob_decimal *d1, cob_decimal *d2)
void	cob_add (cob_field *f1, cob_field *f2, const int opt)
void	cob_sub (cob_field *f1, cob_field *f2, const int opt)
void	cob_mul (cob_field *f1, cob_field *f2, const int opt)
void	cob_div (cob_field *f1, cob_field *f2, const int opt)
void	cob_div_quotient (cob_field *dividend, cob_field *divisor, cob_field *quotient, const int opt)
void	cob_div_remainder (cob_field *fld_remainder, const int opt)
void	cob_decimal_setget_fld (cob_field *src, cob_field *dst, const int opt)
int	cob_add_int (cob_field *f, const int n, const int opt)
int	cob_sub_int (cob_field *f, const int n, const int opt)
int	cob_cmp_int (cob_field *f1, const int n)
int	cob_cmp_uint (cob_field *f1, const unsigned int n)
int	cob_cmp_llint (cob_field *f1, const cob_s64_t n)
int	cob_cmp_float (cob_field *f1, cob_field *f2)
int	cob_numeric_cmp (cob_field *f1, cob_field *f2)
int	cob_cmp_packed (cob_field *f, const cob_s64_t val)
static unsigned int	cob_get_long_ebcdic_sign (const unsigned char *p, cob_s64_t *val)
int	cob_cmp_numdisp (const unsigned char *data, const size_t size, const cob_s64_t n, const cob_u32_t has_sign)
void	cob_decimal_alloc (const cob_u32_t params,...)
void	cob_decimal_push (const cob_u32_t params,...)
void	cob_decimal_pop (const cob_u32_t params,...)
void	cob_exit_numeric (void)
void	cob_init_numeric (cob_global *lptr)

Variables
static cob_global *	cobglobptr
static const unsigned char	packed_bytes []
static cob_decimal	cob_d1
static cob_decimal	cob_d2
static cob_decimal	cob_d3
static cob_decimal	cob_d_remainder
static cob_decimal *	cob_decimal_base
static mpz_t	cob_mexp
static mpz_t	cob_mpzt
static mpz_t	cob_mpzt2
static mpz_t	cob_mpz_ten34m1
static mpz_t	cob_mpz_ten16m1
static mpz_t	cob_mpze10 [COB_MAX_BINARY]
static mpf_t	cob_mpft
static mpf_t	cob_mpft_get
static unsigned char	packed_value [20]
static cob_u64_t	last_packed_val

Macro Definition Documentation

#define _GNU_SOURCE   1

Definition at line 25 of file numeric.c.

#define COB_LIB_EXPIMP

Definition at line 42 of file numeric.c.

#define DECIMAL_CHECK	(		d1,
			d2
	)

Value:

if (unlikely(d1->scale == COB_DECIMAL_NAN || \
        d2->scale == COB_DECIMAL_NAN)) { \
		d1->scale = COB_DECIMAL_NAN; \
        return; \
    }

Definition at line 47 of file numeric.c.

Referenced by cob_decimal_add(), cob_decimal_div(), cob_decimal_mul(), and cob_decimal_sub().

#define FLOAT_EQ	(		x,
			y,
			t
	)		(fabs(((x-y)/x)) < t)

Definition at line 2312 of file numeric.c.

Referenced by cob_cmp_float().

#define TOLERANCE   (double) 0.0000001

Definition at line 2310 of file numeric.c.

Referenced by cob_cmp_float().

Function Documentation

static void align_decimal ( cob_decimal *  d1, cob_decimal *  d2  )

static

Definition at line 411 of file numeric.c.

References cob_decimal::scale, and shift_decimal().

Referenced by cob_decimal_add(), cob_decimal_cmp(), and cob_decimal_sub().

{
    if (d1->scale < d2->scale) {
        shift_decimal (d1, d2->scale - d1->scale);
    } else if (d1->scale > d2->scale) {
        shift_decimal (d2, d1->scale - d2->scale);
    }
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_add	(	cob_field *	f1,
		cob_field *	f2,
		const int	opt
	)

Definition at line 1931 of file numeric.c.

References cob_decimal_add(), cob_decimal_get_field(), and cob_decimal_set_field().

Referenced by get__reserved__lists_().

{
    cob_decimal_set_field (&cob_d1, f1);
    cob_decimal_set_field (&cob_d2, f2);
    cob_decimal_add (&cob_d1, &cob_d2);
    (void)cob_decimal_get_field (&cob_d1, f1, opt);
}

Here is the call graph for this function:

Here is the caller graph for this function:

int cob_add_int	(	cob_field *	f,
		const int	n,
		const int	opt
	)

Definition at line 2195 of file numeric.c.

References cob_decimal_get_field(), cob_decimal_set_field(), COB_FIELD_SCALE, COB_FIELD_TYPE, cob_mexp, cob_sli_t, COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_FP_BIN128, COB_TYPE_NUMERIC_PACKED, cob_uli_t, cob_decimal::scale, unlikely, and cob_decimal::value.

Referenced by cob_inspect_characters(), cob_linage_write_opt(), cob_sub_int(), cob_unstring_tallying(), cobxref_(), GCic_(), inspect_common(), LISTING_(), and relative_read_next().

{
    int scale;
    int val;

    if (unlikely(n == 0)) {
        return 0;
    }
#if 0   /* RXWRXW - Buggy */
    if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_PACKED) {
        return cob_add_packed (f, n, opt);
    } else if (COB_FIELD_TYPE (f) == COB_TYPE_NUMERIC_DISPLAY) {
        return cob_display_add_int (f, n, opt);
    }
#endif

    /* Not optimized */
    cob_decimal_set_field (&cob_d1, f);

    if (COB_FIELD_TYPE (f) >= COB_TYPE_NUMERIC_FLOAT
    &&  COB_FIELD_TYPE (f) <= COB_TYPE_NUMERIC_FP_BIN128) {
        mpz_set_si (cob_d2.value, (cob_sli_t) n);
        cob_d2.scale = 0;
        mpz_add (cob_d1.value, cob_d1.value, cob_d2.value);
        return cob_decimal_get_field (&cob_d1, f, opt);
    }
    else {
        scale = COB_FIELD_SCALE (f);
        val = n;
        if (unlikely(scale < 0)) {
            /* PIC 9(n)P(m) */
            if (-scale < 10) {
                while (scale++) {
                    val /= 10;
                }
            } else {
                val = 0;
            }
            scale = 0;
            if (!val) {
                return 0;
            }
        }
        mpz_set_si (cob_d2.value, (cob_sli_t)val);
        cob_d2.scale = 0;
        if (scale > 0) {
            mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)scale);
            mpz_mul (cob_d2.value, cob_d2.value, cob_mexp);
            cob_d2.scale = cob_d1.scale;
        }
        mpz_add (cob_d1.value, cob_d1.value, cob_d2.value);
        return cob_decimal_get_field (&cob_d1, f, opt);
    }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static COB_INLINE COB_A_INLINE cob_s64_t cob_binary_get_sint64 ( const cob_field *const  f )

static

Definition at line 237 of file numeric.c.

References COB_BSWAP_64, COB_FIELD_BINARY_SWAP, cob_s64_t, cob_field::data, num_byte_memcpy(), and cob_field::size.

Referenced by cob_decimal_set_binary(), and cob_print_realbin().

{
    cob_s64_t   n = 0;
    size_t      fsiz = 8U - f->size;

#ifndef WORDS_BIGENDIAN
    if (COB_FIELD_BINARY_SWAP (f)) {
        num_byte_memcpy ((unsigned char *)&n, f->data, f->size);
        n = COB_BSWAP_64 (n);
        /* Shift with sign */
        n >>= 8 * fsiz;
    } else {
        num_byte_memcpy (((unsigned char *)&n) + fsiz, f->data, f->size);
        /* Shift with sign */
        n >>= 8 * fsiz;
    }
#else   /* WORDS_BIGENDIAN */
    num_byte_memcpy ((unsigned char *)&n, f->data, f->size);
    /* Shift with sign */
    n >>= 8 * fsiz;
#endif  /* WORDS_BIGENDIAN */

    return n;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static COB_INLINE COB_A_INLINE cob_u64_t cob_binary_get_uint64 ( const cob_field *const  f )

static

Definition at line 263 of file numeric.c.

References COB_BSWAP_64, COB_FIELD_BINARY_SWAP, cob_u64_t, cob_field::data, num_byte_memcpy(), and cob_field::size.

Referenced by cob_decimal_set_binary(), and cob_print_realbin().

{
    cob_u64_t       n = 0;
    size_t          fsiz = 8U - f->size;

#ifndef WORDS_BIGENDIAN
    if (COB_FIELD_BINARY_SWAP (f)) {
        num_byte_memcpy (((unsigned char *)&n) + fsiz, f->data, f->size);
        n = COB_BSWAP_64 (n);
    } else {
        num_byte_memcpy ((unsigned char *)&n, f->data, f->size);
    }
#else   /* WORDS_BIGENDIAN */
    num_byte_memcpy (((unsigned char *)&n) + fsiz, f->data, f->size);
#endif  /* WORDS_BIGENDIAN */

    return n;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static COB_INLINE COB_A_INLINE void cob_binary_set_int64 ( cob_field *  f, cob_s64_t  n  )

static

Definition at line 301 of file numeric.c.

References COB_BSWAP_64, COB_FIELD_BINARY_SWAP, cob_field::data, num_byte_memcpy(), and cob_field::size.

Referenced by cob_decimal_get_binary().

{
#ifndef WORDS_BIGENDIAN
    unsigned char   *s;

    if (COB_FIELD_BINARY_SWAP (f)) {
        n = COB_BSWAP_64 (n);
        s = ((unsigned char *)&n) + 8 - f->size;
    } else {
        s = (unsigned char *)&n;
    }
    num_byte_memcpy (f->data, s, f->size);
#else   /* WORDS_BIGENDIAN */
    num_byte_memcpy (f->data, ((unsigned char *)&n) + 8 - f->size, f->size);
#endif  /* WORDS_BIGENDIAN */
}

Here is the call graph for this function:

Here is the caller graph for this function:

static COB_INLINE COB_A_INLINE void cob_binary_set_uint64 ( cob_field *  f, cob_u64_t  n  )

static

Definition at line 283 of file numeric.c.

References COB_BSWAP_64, COB_FIELD_BINARY_SWAP, cob_field::data, num_byte_memcpy(), and cob_field::size.

Referenced by cob_decimal_get_binary().

{
#ifndef WORDS_BIGENDIAN
    unsigned char   *s;

    if (COB_FIELD_BINARY_SWAP (f)) {
        n = COB_BSWAP_64 (n);
        s = ((unsigned char *)&n) + 8 - f->size;
    } else {
        s = (unsigned char *)&n;
    }
    num_byte_memcpy (f->data, s, f->size);
#else   /* WORDS_BIGENDIAN */
    num_byte_memcpy (f->data, ((unsigned char *)&n) + 8 - f->size, f->size);
#endif  /* WORDS_BIGENDIAN */
}

Here is the call graph for this function:

Here is the caller graph for this function:

int cob_cmp_float	(	cob_field *	f1,
		cob_field *	f2
	)

Definition at line 2315 of file numeric.c.

References cob_decimal_get_double(), cob_decimal_set_field(), COB_FIELD_TYPE, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_FLOAT, d1, d2, cob_field::data, FLOAT_EQ, and TOLERANCE.

Referenced by cob_numeric_cmp().

{
    double  d1,d2;
    float   flt;
    if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT) {
        memcpy(&flt,f1->data,sizeof(float));
        d1 = flt;
    } else if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE) {
        memcpy(&d1,f1->data,sizeof(double));
    } else {
        cob_decimal_set_field (&cob_d1, f1);
        d1 = cob_decimal_get_double(&cob_d1);
    }
    if(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT) {
        memcpy(&flt,f2->data,sizeof(float));
        d2 = flt;
    } else if(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) {
        memcpy(&d2,f2->data,sizeof(double));
    } else {
        cob_decimal_set_field (&cob_d1, f2);
        d2 = cob_decimal_get_double(&cob_d1);
    }
    if(d1 == d2)
        return 0;
    if(d1 != 0.0
    && FLOAT_EQ(d1,d2,TOLERANCE))
        return 0;
    if(d1 < d2)
        return -1;
    return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

int cob_cmp_int	(	cob_field *	f1,
		const int	n
	)

Definition at line 2257 of file numeric.c.

References cob_decimal_cmp(), cob_decimal_set_field(), cob_sli_t, cob_decimal::scale, and cob_decimal::value.

Referenced by cob_cmp().

{
    cob_decimal_set_field (&cob_d1, f1);
    mpz_set_si (cob_d2.value, (cob_sli_t)n);
    cob_d2.scale = 0;
    return cob_decimal_cmp (&cob_d1, &cob_d2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

int cob_cmp_llint	(	cob_field *	f1,
		const cob_s64_t	n
	)

Definition at line 2275 of file numeric.c.

References cob_decimal_cmp(), cob_decimal_set_field(), COB_FIELD_HAVE_SIGN, cob_sli_t, cob_u32_t, cob_u64_t, cob_uli_t, cob_decimal::scale, and cob_decimal::value.

{
#ifdef  COB_LI_IS_LL
    if (COB_FIELD_HAVE_SIGN(f1)) {
        mpz_set_si (cob_d2.value, (cob_sli_t)n);
    } else {
        mpz_set_ui (cob_d2.value, (cob_uli_t)n);
    }
#else
    cob_u64_t   uval;
    cob_u32_t   negative;

    negative = 0;
    if (n < 0) {
        negative = 1;
        uval = (cob_u64_t)-n;
    } else {
        uval = (cob_u64_t)n;
    }
    mpz_set_ui (cob_d2.value, (cob_uli_t)(uval >> 32));
    mpz_mul_2exp (cob_d2.value, cob_d2.value, 32);
    mpz_add_ui (cob_d2.value, cob_d2.value, (cob_uli_t)(uval & 0xFFFFFFFFU));
    if (negative) {
        mpz_neg (cob_d2.value, cob_d2.value);
    }
#endif

    cob_d2.scale = 0;
    cob_decimal_set_field (&cob_d1, f1);
    return cob_decimal_cmp (&cob_d1, &cob_d2);
}

Here is the call graph for this function:

int cob_cmp_numdisp	(	const unsigned char *	data,
		const size_t	size,
		const cob_s64_t	n,
		const cob_u32_t	has_sign
	)

Definition at line 2543 of file numeric.c.

References COB_D2I, cob_get_long_ebcdic_sign(), COB_MODULE_PTR, cob_s64_t, and unlikely.

{
    const unsigned char *p;
    cob_s64_t       val = 0;
    size_t          inc;

    p = data;
    if (!has_sign) {
        if (unlikely(n < 0)) {
            return 1;
        }
        for (inc = 0; inc < size; inc++, p++) {
            val = (val * 10) + COB_D2I (*p);
        }
        return (val < n) ? -1 : (val > n);
    }
    for (inc = 0; inc < size - 1; inc++, p++) {
        val = (val * 10) + COB_D2I (*p);
    }
    val *= 10;
    if (*p >= (unsigned char)'0' && *p <= (unsigned char)'9') {
        val += COB_D2I (*p);
    } else {
        if (unlikely(COB_MODULE_PTR->ebcdic_sign)) {
            if (cob_get_long_ebcdic_sign (p, &val)) {
                val = -val;
            }
        } else {
#ifdef  COB_EBCDIC_MACHINE
            if (cob_get_long_ascii_sign (p, &val)) {
                val = -val;
            }
#else
            if (*p >= (unsigned char)'p' && *p <= (unsigned char)'y') {
                val += (*p - (unsigned char)'p');
                val = -val;
            }
#endif
        }
    }
    return (val < n) ? -1 : (val > n);
}

Here is the call graph for this function:

int cob_cmp_packed	(	cob_field *	f,
		const cob_s64_t	val
	)

Definition at line 2362 of file numeric.c.

References COB_FIELD_DIGITS, COB_FIELD_NO_SIGN_NIBBLE, cob_packed_get_sign(), cob_u64_t, cob_field::data, last_packed_val, packed_value, sign, and cob_field::size.

{
    unsigned char       *p;
    cob_u64_t       n;
    size_t          size;
    size_t          inc;
    int         sign;
    unsigned char       val1[20];

    sign = cob_packed_get_sign (f);
    /* Field positive, value negative */
    if (sign >= 0 && val < 0) {
        return 1;
    }
    /* Field negative, value positive */
    if (sign < 0 && val >= 0) {
        return -1;
    }
    /* Both positive or both negative */
    if (val < 0) {
        n = (cob_u64_t)-val;
    } else {
        n = (cob_u64_t)val;
    }
    inc = 0;
    p = f->data;
    for (size = 0; size < 20; size++) {
        if (size < 20 - f->size) {
            val1[size] = 0;
        } else {
            val1[size] = p[inc++];
        }
    }
    if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
        if ((COB_FIELD_DIGITS(f) % 2) == 1) {
            val1[20 - f->size] &= 0x0F;
        }
    } else {
        val1[19] &= 0xF0;
        if ((COB_FIELD_DIGITS(f) % 2) == 0) {
            val1[20 - f->size] &= 0x0F;
        }
    }
    if (n != last_packed_val) {
        last_packed_val = n;
        memset (packed_value, 0, sizeof(packed_value));
        if (n) {
            p = &packed_value[19];
            if (!COB_FIELD_NO_SIGN_NIBBLE (f)) {
                *p =  (n % 10) << 4;
                p--;
                n /= 10;
            }
            for (; n;) {
                size = n % 100;
                *p = (unsigned char)((size % 10) | ((size / 10) << 4));
                n /= 100;
                p--;
            }
        }
    }
    for (size = 0; size < 20; size++) {
        if (val1[size] != packed_value[size]) {
            if (sign < 0) {
                return packed_value[size] - val1[size];
            } else {
                return val1[size] - packed_value[size];
            }
        }
    }
    return 0;
}

Here is the call graph for this function:

int cob_cmp_uint	(	cob_field *	f1,
		const unsigned int	n
	)

Definition at line 2266 of file numeric.c.

References cob_decimal_cmp(), cob_decimal_set_field(), cob_uli_t, cob_decimal::scale, and cob_decimal::value.

{
    cob_decimal_set_field (&cob_d1, f1);
    mpz_set_ui (cob_d2.value, (cob_uli_t)n);
    cob_d2.scale = 0;
    return cob_decimal_cmp (&cob_d1, &cob_d2);
}

Here is the call graph for this function:

void cob_decimal_add	(	cob_decimal *	d1,
		cob_decimal *	d2
	)

Definition at line 1875 of file numeric.c.

References align_decimal(), DECIMAL_CHECK, and cob_decimal::value.

Referenced by calc_mean_of_args(), calc_variance_of_args(), cob_add(), cob_intr_annuity(), cob_intr_binop(), cob_intr_combined_datetime(), cob_intr_mean(), cob_intr_median(), cob_intr_midrange(), cob_intr_present_value(), cob_intr_sum(), cobxref_(), and seconds_from_formatted_time().

{
    DECIMAL_CHECK (d1, d2);
    align_decimal (d1, d2);
    mpz_add (d1->value, d1->value, d2->value);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_decimal_alloc	(	const cob_u32_t	params,
			...
	)

Definition at line 2588 of file numeric.c.

References cob_u32_t, and params.

{
    cob_decimal **dec;
    cob_u32_t   i;
    va_list     args;

    va_start (args, params);
    for (i = 0; i < params; ++i) {
        dec = va_arg (args, cob_decimal **);
        *dec = cob_decimal_base + i;
    }
    va_end (args);
}

int cob_decimal_cmp	(	cob_decimal *	d1,
		cob_decimal *	d2
	)

Definition at line 1922 of file numeric.c.

References align_decimal(), and cob_decimal::value.

Referenced by cob_cmp_int(), cob_cmp_llint(), cob_cmp_uint(), cob_intr_acos(), cob_intr_asin(), cob_numeric_cmp(), and valid_decimal_time().

{
    align_decimal (d1, d2);
    return mpz_cmp (d1->value, d2->value);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_decimal_div	(	cob_decimal *	d1,
		cob_decimal *	d2
	)

Definition at line 1899 of file numeric.c.

References COB_DECIMAL_NAN, COB_EC_SIZE_ZERO_DIVIDE, COB_MAX_DIGITS, cob_set_exception(), DECIMAL_CHECK, cob_decimal::scale, shift_decimal(), unlikely, and cob_decimal::value.

Referenced by calc_mean_of_args(), calc_variance_of_args(), cob_decimal_pow(), cob_div(), cob_div_quotient(), cob_intr_annuity(), cob_intr_binop(), cob_intr_combined_datetime(), cob_intr_mean(), cob_intr_median(), cob_intr_midrange(), cob_intr_present_value(), and cob_mod_or_rem().

{
    DECIMAL_CHECK (d1, d2);

    /* Check for division by zero */
    if (unlikely(mpz_sgn (d2->value) == 0)) {
        d1->scale = COB_DECIMAL_NAN;
        cob_set_exception (COB_EC_SIZE_ZERO_DIVIDE);
        return;
    }
    if (unlikely(mpz_sgn (d1->value) == 0)) {
        d1->scale = 0;
        return;
    }
    d1->scale -= d2->scale;
    shift_decimal (d1, COB_MAX_DIGITS + ((d1->scale < 0) ? -d1->scale : 0));
#if 0   /* RXWRXW - cdiv */
    mpz_cdiv_q (d1->value, d1->value, d2->value);
#endif
    mpz_tdiv_q (d1->value, d1->value, d2->value);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cob_decimal_do_round ( cob_decimal *  d, cob_field *  f, const int  opt  )

static

Definition at line 1693 of file numeric.c.

References COB_EC_SIZE_TRUNCATION, COB_FIELD_SCALE, cob_mpzt, cob_mpzt2, cob_set_exception(), COB_STORE_AWAY_FROM_ZERO, COB_STORE_MASK, COB_STORE_NEAR_AWAY_FROM_ZERO, COB_STORE_NEAR_EVEN, COB_STORE_NEAR_TOWARD_ZERO, COB_STORE_PROHIBITED, COB_STORE_TOWARD_GREATER, COB_STORE_TOWARD_LESSER, COB_STORE_TRUNCATION, cob_uli_t, cob_decimal::scale, shift_decimal(), sign, and cob_decimal::value.

Referenced by cob_decimal_get_field().

{
    cob_uli_t   adj;
    int     sign;
    int     scale;

    sign = mpz_sgn (d->value);
    /* Returns 0 when value is 0 */
    if (!sign) {
        return;
    }
    scale = COB_FIELD_SCALE(f);
    if (scale >= d->scale) {
        return;
    }

    switch (opt & ~(COB_STORE_MASK)) {
    case COB_STORE_TRUNCATION:
        return;
    case COB_STORE_PROHIBITED:
        cob_set_exception (COB_EC_SIZE_TRUNCATION);
        return;
    case COB_STORE_AWAY_FROM_ZERO:
        adj = d->scale - scale;
        mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
        mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
        if (mpz_sgn (cob_mpzt2)) {
            /* Not exact number */
            if (sign < 0) {
                mpz_sub (d->value, d->value, cob_mpzt);
            } else {
                mpz_add (d->value, d->value, cob_mpzt);
            }
        }
        return;
    case COB_STORE_NEAR_TOWARD_ZERO:
        adj = d->scale - scale - 1;
        mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
        mpz_mul_ui (cob_mpzt, cob_mpzt, 5UL);
        mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
        shift_decimal (d, scale - d->scale + 1);
        if (!mpz_sgn (cob_mpzt2)) {
            return;
        }
        if (sign > 0) {
            mpz_add_ui (d->value, d->value, 5UL);
        } else {
            mpz_sub_ui (d->value, d->value, 5UL);
        }
        return;
    case COB_STORE_TOWARD_GREATER:
        adj = d->scale - scale;
        mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
        mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
        if (mpz_sgn (cob_mpzt2)) {
            /* Not exact number */
            if (sign > 0) {
                mpz_add (d->value, d->value, cob_mpzt);
            }
        }
        return;
    case COB_STORE_TOWARD_LESSER:
        adj = d->scale - scale;
        mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
        mpz_tdiv_r (cob_mpzt2, d->value, cob_mpzt);
        if (mpz_sgn (cob_mpzt2)) {
            /* Not exact number */
            if (sign < 0) {
                mpz_sub (d->value, d->value, cob_mpzt);
            }
        }
        return;
    case COB_STORE_NEAR_EVEN:
        adj = d->scale - scale - 1;
        mpz_ui_pow_ui (cob_mpzt, 10UL, adj);
        mpz_mul_ui (cob_mpzt, cob_mpzt, 5UL);
        mpz_tdiv_r (cob_mpzt, d->value, cob_mpzt);
        shift_decimal (d, scale - d->scale + 1);
        if (!mpz_sgn (cob_mpzt)) {
            adj = mpz_tdiv_ui (d->value, 100UL);
            switch (adj) {
            case 5:
            case 25:
            case 45:
            case 65:
            case 85:
                return;
            }
        }
        if (sign > 0) {
            mpz_add_ui (d->value, d->value, 5UL);
        } else {
            mpz_sub_ui (d->value, d->value, 5UL);
        }
        return;
    case COB_STORE_NEAR_AWAY_FROM_ZERO:
    default:
        shift_decimal (d, scale - d->scale + 1);
        if (sign > 0) {
            mpz_add_ui (d->value, d->value, 5UL);
        } else {
            mpz_sub_ui (d->value, d->value, 5UL);
        }
        return;
    }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cob_decimal_get_binary ( cob_decimal *  d, cob_field *  f, const int  opt  )

static

Definition at line 1507 of file numeric.c.

References cob_binary_set_int64(), cob_binary_set_uint64(), COB_EC_SIZE_OVERFLOW, __cob_global::cob_exception_code, COB_FIELD_BINARY_TRUNC, COB_FIELD_DIGITS, COB_FIELD_HAVE_SIGN, cob_mpze10, cob_mpzt, cob_s64_t, cob_set_exception(), COB_STORE_TRUNC_ON_OVERFLOW, cob_u64_t, cob_field::data, overflow, sign, cob_field::size, unlikely, and cob_decimal::value.

Referenced by cob_decimal_get_field().

{
    size_t          overflow;
    size_t          sign;
    size_t          bitnum;
    size_t          digits;

#if !defined(COB_EXPERIMENTAL) && !defined(COB_LI_IS_LL)
    cob_s64_t       llval;
    cob_u64_t       ullval;
    unsigned int        lo;
#endif

    if (unlikely(mpz_size (d->value) == 0)) {
        memset (f->data, 0, f->size);
        return 0;
    }
    overflow = 0;
    digits = COB_FIELD_DIGITS(f);
    if (COB_FIELD_HAVE_SIGN (f)) {
        sign = 1;
    } else {
        sign = 0;
        if (mpz_sgn (d->value) < 0) {
            mpz_abs (d->value, d->value);
        }
    }
    bitnum = (f->size * 8) - sign;
    if (unlikely(mpz_sizeinbase (d->value, 2) > bitnum)) {
        if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
            goto overflow;
        }
        overflow = 1;
        /* Check if truncation to PIC digits is needed */
        if (opt & COB_STORE_TRUNC_ON_OVERFLOW) {
            mpz_tdiv_r (d->value, d->value, cob_mpze10[digits]);
        } else {
#if 0   /* RXWRXW - Fdiv sign */
            mpz_fdiv_r_2exp (d->value, d->value, (f->size * 8) - sign);
#endif
            mpz_fdiv_r_2exp (d->value, d->value, (f->size * 8));
        }
    } else if (opt && COB_FIELD_BINARY_TRUNC (f)) {
        if (mpz_cmpabs (d->value, cob_mpze10[digits]) >= 0) {
            /* Overflow */
            if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
                goto overflow;
            }
            overflow = 1;
            /* Check if truncation to PIC digits is needed */
            if (opt & COB_STORE_TRUNC_ON_OVERFLOW) {
                mpz_tdiv_r (d->value, d->value,
                        cob_mpze10[digits]);
            } else {
                mpz_fdiv_r_2exp (d->value, d->value, (f->size * 8));
            }
        }
    }
#ifdef  COB_LI_IS_LL
    if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
        cob_binary_set_uint64 (f, mpz_get_ui (d->value));
    } else {
        cob_binary_set_int64 (f, mpz_get_si (d->value));
    }
#elif   defined(COB_EXPERIMENTAL)
    if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
        cob_binary_set_uint64 (f, mpz_get_ull (d->value));
    } else {
        cob_binary_set_int64 (f, mpz_get_sll (d->value));
    }
#else
    if (f->size <= 4) {
        if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
            cob_binary_set_uint64 (f, (cob_u64_t)mpz_get_ui (d->value));
        } else {
            cob_binary_set_int64 (f, (cob_s64_t)mpz_get_si (d->value));
        }
    } else {
        mpz_fdiv_r_2exp (cob_mpzt, d->value, 32);
        mpz_fdiv_q_2exp (d->value, d->value, 32);
        lo = mpz_get_ui (cob_mpzt);

        if (!sign || (overflow && !(opt & COB_STORE_TRUNC_ON_OVERFLOW))) {
            ullval = mpz_get_ui (d->value);
            ullval = (ullval << 32) | lo;
            cob_binary_set_uint64 (f, ullval);
        } else {
            llval = mpz_get_si (d->value);
            llval = (llval << 32) | lo;
            cob_binary_set_int64 (f, llval);
        }
    }
#endif
    if (!overflow) {
        return 0;
    }

overflow:
    cob_set_exception (COB_EC_SIZE_OVERFLOW);
    return cobglobptr->cob_exception_code;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cob_decimal_get_display ( cob_decimal *  d, cob_field *  f, const int  opt  )

static

Definition at line 1371 of file numeric.c.

References COB_EC_SIZE_OVERFLOW, __cob_global::cob_exception_code, COB_FIELD_DATA, COB_FIELD_SIZE, cob_gmp_free(), COB_PUT_SIGN, cob_set_exception(), NULL, sign, unlikely, and cob_decimal::value.

Referenced by cob_decimal_get_field().

{
    unsigned char   *data;
    char        *p;
    size_t      size;
    int     diff;
    int     sign;

    data = COB_FIELD_DATA (f);
    /* Build string */
    sign = mpz_sgn (d->value);
    if (!sign) {
        /* Value is 0 */
        memset (data, '0', COB_FIELD_SIZE (f));
        COB_PUT_SIGN (f, sign);
        return 0;
    }
    if (sign < 0) {
        mpz_abs (d->value, d->value);
    }
    p = mpz_get_str (NULL, 10, d->value);
    size = strlen (p);

    /* Store number */
    diff = (int)(COB_FIELD_SIZE (f) - size);
    if (unlikely(diff < 0)) {
        /* Overflow */
        cob_set_exception (COB_EC_SIZE_OVERFLOW);

        /* If the statement has ON SIZE ERROR or NOT ON SIZE ERROR,
           then throw an exception */
        if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
            cob_gmp_free(p);
            return cobglobptr->cob_exception_code;
        }

        /* Othersize, truncate digits */
        memcpy (data, p - diff, COB_FIELD_SIZE (f));
    } else {
        /* No overflow */
        memset (data, '0', (size_t)diff);
        memcpy (data + diff, p, size);
    }

    cob_gmp_free(p);
    COB_PUT_SIGN (f, sign);

    return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static double cob_decimal_get_double ( cob_decimal *  d )

static

Definition at line 877 of file numeric.c.

References cob_mexp, cob_mpft, cob_mpft_get, cob_sli_t, cob_uli_t, cob_decimal::scale, unlikely, and cob_decimal::value.

Referenced by cob_cmp_float(), and cob_decimal_get_field().

{
    double      v;
    cob_sli_t   n;

    v = 0.0;
    if (unlikely(mpz_size (d->value) == 0)) {
        return v;
    }

    mpf_set_z (cob_mpft, d->value);

    n = d->scale;
    if (n < 0) {
        mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-n);
        mpf_set_z (cob_mpft_get, cob_mexp);
        mpf_mul (cob_mpft, cob_mpft, cob_mpft_get);
    } else if (n > 0) {
        mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)n);
        mpf_set_z (cob_mpft_get, cob_mexp);
        mpf_div (cob_mpft, cob_mpft, cob_mpft_get);
    }

    v = mpf_get_d (cob_mpft);
    if (!finite (v)) {
        v = 0.0;
    }
    return v;
}

Here is the caller graph for this function:

int cob_decimal_get_field	(	cob_decimal *	d,
		cob_field *	f,
		const int	opt
	)

Definition at line 1801 of file numeric.c.

References cob_field::attr, COB_ATTR_INIT, cob_d1, cob_decimal_do_round(), cob_decimal_get_binary(), cob_decimal_get_display(), cob_decimal_get_double(), cob_decimal_get_ieee128dec(), cob_decimal_get_ieee64dec(), cob_decimal_get_packed(), COB_DECIMAL_NAN, COB_EC_SIZE_OVERFLOW, __cob_global::cob_exception_code, COB_FIELD_DIGITS, COB_FIELD_IS_FP, COB_FIELD_SCALE, COB_FIELD_TYPE, COB_FLAG_HAVE_SIGN, cob_free(), cob_malloc(), cob_move(), cob_set_exception(), COB_STORE_ROUND, COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_FP_DEC128, COB_TYPE_NUMERIC_FP_DEC64, COB_TYPE_NUMERIC_PACKED, cob_field::data, NULL, cob_decimal::scale, shift_decimal(), cob_field::size, unlikely, and cob_decimal::value.

Referenced by cob_add(), cob_add_int(), cob_decimal_move_temp(), cob_decimal_setget_fld(), cob_div(), cob_div_quotient(), cob_div_remainder(), cob_intr_abs(), cob_intr_acos(), cob_intr_annuity(), cob_intr_asin(), cob_intr_atan(), cob_intr_binop(), cob_intr_combined_datetime(), cob_intr_cos(), cob_intr_e(), cob_intr_exp(), cob_intr_exp10(), cob_intr_factorial(), cob_intr_fraction_part(), cob_intr_highest_algebraic(), cob_intr_integer(), cob_intr_integer_part(), cob_intr_log(), cob_intr_log10(), cob_intr_lowest_algebraic(), cob_intr_mean(), cob_intr_median(), cob_intr_midrange(), cob_intr_numval_f(), cob_intr_pi(), cob_intr_present_value(), cob_intr_range(), cob_intr_seconds_from_formatted_time(), cob_intr_sin(), cob_intr_sqrt(), cob_intr_standard_deviation(), cob_intr_sum(), cob_intr_tan(), cob_intr_variance(), cob_mod_or_rem(), cob_mul(), cob_sub(), cobxref_(), LISTING_(), and numval().

{
    cob_field       temp;
    cob_field_attr      attr;
    union {
        double          val;
        float           fval;
    } uval;

    if (unlikely(d->scale == COB_DECIMAL_NAN)) {
        cob_set_exception (COB_EC_SIZE_OVERFLOW);
        return cobglobptr->cob_exception_code;
    }

    /* work copy */
    if (d != &cob_d1) {
        mpz_set (cob_d1.value, d->value);
        cob_d1.scale = d->scale;
        d = &cob_d1;
    }

#if 0   /* RXWRXW - Round FP */
    if (!COB_FIELD_IS_FP(f)) {
#endif
        /* Rounding */
        if ((opt & COB_STORE_ROUND)) {
            cob_decimal_do_round (d, f, opt);
        }
        /* Append or truncate decimal digits */
        shift_decimal (d, COB_FIELD_SCALE(f) - d->scale);
#if 0   /* RXWRXW - Round FP */
    }
#endif

    /* Store number */
    switch (COB_FIELD_TYPE (f)) {
    case COB_TYPE_NUMERIC_BINARY:
        return cob_decimal_get_binary (d, f, opt);
    case COB_TYPE_NUMERIC_DISPLAY:
        return cob_decimal_get_display (d, f, opt);
    case COB_TYPE_NUMERIC_PACKED:
        return cob_decimal_get_packed (d, f, opt);
    case COB_TYPE_NUMERIC_FLOAT:
        uval.fval = (float) cob_decimal_get_double (d);
        memcpy (f->data, &uval.fval, sizeof (float));
        return 0;
    case COB_TYPE_NUMERIC_DOUBLE:
        uval.val = cob_decimal_get_double (d);
        memcpy (f->data, &uval.val, sizeof (double));
        return 0;
    case COB_TYPE_NUMERIC_FP_DEC64:
        return cob_decimal_get_ieee64dec (d, f, opt);
    case COB_TYPE_NUMERIC_FP_DEC128:
        return cob_decimal_get_ieee128dec (d, f, opt);
    default:
        break;
    }
    COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, COB_FIELD_DIGITS(f),
            COB_FIELD_SCALE(f), COB_FLAG_HAVE_SIGN, NULL);
    temp.size = COB_FIELD_DIGITS(f);
    temp.data = cob_malloc (COB_FIELD_DIGITS(f));
    temp.attr = &attr;
    if (cob_decimal_get_display (d, &temp, opt) == 0) {
        cob_move (&temp, f);
        cob_free (temp.data);
        return 0;
    }
    cob_free (temp.data);
    return cobglobptr->cob_exception_code;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cob_decimal_get_ieee128dec ( cob_decimal *  d, cob_field *  f, const int  opt  )

static

Definition at line 612 of file numeric.c.

References COB_128_MSW, COB_128_OR_EXTEND, COB_128_SIGF_1, COB_128_SIGF_2, COB_DEC_EXTEND, COB_DEC_SIGN, COB_EC_SIZE_OVERFLOW, __cob_global::cob_exception_code, COB_MPZ_ENDIAN, cob_mpz_ten34m1, cob_mpze10, cob_set_exception(), COB_STORE_KEEP_ON_OVERFLOW, cob_u64_t, cob_field::data, NULL, cob_decimal::scale, sign, and cob_decimal::value.

Referenced by cob_decimal_get_field().

{
    cob_u64_t   expo;
    cob_u64_t   data[2];
    int     sign;

    sign = mpz_sgn (d->value);
    if (!sign) {
        memset (f->data, 0, (size_t)16);
        return 0;
    }
    if (sign < 0) {
        mpz_neg (d->value, d->value);
    }
    for ( ; ; d->scale--) {
        if (!mpz_divisible_ui_p (d->value, 10UL)) {
            break;
        }
        mpz_tdiv_q_ui (d->value, d->value, 10UL);
    }
    if (mpz_cmpabs (d->value, cob_mpz_ten34m1) >= 0) {
        if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
            cob_set_exception (COB_EC_SIZE_OVERFLOW);
            return cobglobptr->cob_exception_code;
        }
#if 0   /* RXWRXW - FP Trunc */
        if (d->scale > 0 ) {
            for ( ; d->scale; ) {
#endif
        for ( ; ; ) {
            mpz_tdiv_q_ui (d->value, d->value, 10UL);
            d->scale--;
            if (mpz_cmpabs (d->value, cob_mpz_ten34m1) < 0) {
                break;
            }
        }
#if 0   /* RXWRXW - FP Trunc */
        } else {
            mpz_tdiv_r (d->value, d->value, cob_mpze10[34]);
        }
#endif
    }
    if (d->scale < -6176 || d->scale > 6111) {
        cob_set_exception (COB_EC_SIZE_OVERFLOW);
        return cobglobptr->cob_exception_code;
    }
    expo = 6176 - d->scale;
#if 0   /* Clamp */
    expo = cob_clamp_decimal (d, 6176U, 6111U, 113U);
#endif

    data[0] = 0;
    data[1] = 0;
    mpz_export (data, NULL, -1, (size_t)16, COB_MPZ_ENDIAN,
            (size_t)0, d->value);
    /* Move in exponent */
#if 0   /* IEEE canonical */
    if (mpz_sizeinbase (d->value, 2) > 113U) {
        COB_128_MSW(data) &= COB_128_SIGF_2;
        COB_128_MSW(data) |= (expo << 47U) |
                     COB_DEC_EXTEND | COB_128_OR_EXTEND;
    } else {
#endif
        COB_128_MSW(data) &= COB_128_SIGF_1;
        COB_128_MSW(data) |= (expo << 49U);
#if 0   /* IEEE canonical */
    }
#endif
    if (sign < 0) {
        COB_128_MSW(data) |= COB_DEC_SIGN;
    }
    memcpy (f->data, data, (size_t)16);
    return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cob_decimal_get_ieee64dec ( cob_decimal *  d, cob_field *  f, const int  opt  )

static

Definition at line 481 of file numeric.c.

References COB_64_OR_EXTEND, COB_64_SIGF_1, COB_64_SIGF_2, COB_DEC_EXTEND, COB_DEC_SIGN, COB_EC_SIZE_OVERFLOW, __cob_global::cob_exception_code, COB_MPZ_ENDIAN, cob_mpz_ten16m1, cob_mpze10, cob_set_exception(), COB_STORE_KEEP_ON_OVERFLOW, cob_u64_t, cob_field::data, NULL, cob_decimal::scale, sign, and cob_decimal::value.

Referenced by cob_decimal_get_field().

{
    int     sign;
    cob_u64_t   expo;
    cob_u64_t   data;

    sign = mpz_sgn (d->value);
    if (!sign) {
        memset (f->data, 0, (size_t)8);
        return 0;
    }
    if (sign < 0) {
        mpz_neg (d->value, d->value);
    }
    for ( ; ; d->scale--) {
        if (!mpz_divisible_ui_p (d->value, 10UL)) {
            break;
        }
        mpz_tdiv_q_ui (d->value, d->value, 10UL);
    }
    if (mpz_cmpabs (d->value, cob_mpz_ten16m1) >= 0) {
        if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
            cob_set_exception (COB_EC_SIZE_OVERFLOW);
            return cobglobptr->cob_exception_code;
        }
#if 0   /* RXWRXW - FP Trunc */
        if (d->scale > 0 ) {
            for ( ; d->scale; ) {
#endif
        for ( ; ; ) {
            mpz_tdiv_q_ui (d->value, d->value, 10UL);
            d->scale--;
            if (mpz_cmpabs (d->value, cob_mpz_ten16m1) < 0) {
                break;
            }
        }
#if 0   /* RXWRXW - FP Trunc */
        } else {
            mpz_tdiv_r (d->value, d->value, cob_mpze10[16]);
        }
#endif
    }
    if (d->scale < -398 || d->scale > 369) {
        cob_set_exception (COB_EC_SIZE_OVERFLOW);
        return cobglobptr->cob_exception_code;
    }
    expo = 398 - d->scale;
#if 0   /* Clamp */
    expo = cob_clamp_decimal (d, 398U, 369U, 53U);
#endif

    data = 0;
    mpz_export (&data, NULL, -1, (size_t)8, COB_MPZ_ENDIAN,
            (size_t)0, d->value);
    /* Move in exponent */
    if (mpz_sizeinbase (d->value, 2) > 51U) {
        data &= COB_64_SIGF_2;
        data |= (expo << 51U) | COB_DEC_EXTEND | COB_64_OR_EXTEND;
    } else {
        data &= COB_64_SIGF_1;
        data |= (expo << 53U);
    }
    if (sign < 0) {
        data |= COB_DEC_SIGN;
    }
    memcpy (f->data, &data, (size_t)8);
    return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cob_decimal_get_packed ( cob_decimal *  d, cob_field *  f, const int  opt  )

static

Definition at line 1147 of file numeric.c.

References COB_D2I, COB_EC_SIZE_OVERFLOW, __cob_global::cob_exception_code, COB_FIELD_DIGITS, COB_FIELD_HAVE_SIGN, COB_FIELD_NO_SIGN_NIBBLE, cob_gmp_free(), cob_set_exception(), cob_set_packed_zero(), cob_field::data, NULL, sign, cob_field::size, unlikely, and cob_decimal::value.

Referenced by cob_decimal_get_field().

{
    unsigned char   *data;
    unsigned char   *p;
    unsigned char   *q;
    char        *mza;
    size_t      size;
    size_t      n;
    size_t      i;
    int     diff;
    int     sign;
    int     digits;
    unsigned int    x;

#if 0   /* RXWRXW stack */
    char        buff[1024];
#endif

    /* Build string */
    sign = mpz_sgn (d->value);
    if (!sign) {
        /* Value is 0 */
        cob_set_packed_zero (f);
        return 0;
    }
    if (sign < 0) {
        mpz_abs (d->value, d->value);
    }

#if 0   /* RXWRXW stack */
    if (unlikely(mpz_sizeinbase (d->value, 10) > sizeof(buff) - 1)) {
#endif
        mza = mpz_get_str (NULL, 10, d->value);
#if 0   /* RXWRXW stack */
    } else {
        mza = buff;
        (void)mpz_get_str (buff, 10, d->value);
    }
#endif
    size = strlen (mza);

    /* Store number */
    data = f->data;
    digits = COB_FIELD_DIGITS (f);
#if 0   /* RXWRXW - P Fix */
    if (digits > (f->size * 2) - 1) {
        digits = (f->size * 2) - 1;
    }
#endif
    q = (unsigned char *)mza;
    diff = (int)(digits - size);
    if (diff < 0) {
        /* Overflow */
        cob_set_exception (COB_EC_SIZE_OVERFLOW);

        /* If the statement has SIZE ERROR
           then throw an exception */
        if (opt & COB_STORE_KEEP_ON_OVERFLOW) {
#if 0   /* RXWRXW stack */
            if (unlikely(mza != buff)) {
#endif
                cob_gmp_free(mza);

#if 0   /* RXWRXW stack */
            }
#endif
            return cobglobptr->cob_exception_code;
        }
        q += size - digits;
        size = digits;
    }
    memset (data, 0, f->size);
    if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
        p = data + ((digits - 1) / 2) - ((size - 1) / 2);
        diff = (int)(size % 2);
    } else {
        p = data + (digits / 2) - (size / 2);
        diff = 1 - (int)(size % 2);
    }
    for (i = diff, n = 0; i < size + diff; i++, n++) {
        x = COB_D2I (q[n]);
        if (i % 2 == 0) {
            *p = x << 4;
        } else {
            *p++ |= x;
        }
    }

#if 0   /* RXWRXW stack */
    if (unlikely(mza != buff)) {
#endif
        cob_gmp_free(mza);

#if 0   /* RXWRXW stack */
    }
#endif

    if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
        return 0;
    }

    p = f->data + f->size - 1;
    if (!COB_FIELD_HAVE_SIGN (f)) {
        *p = (*p & 0xF0U) | 0x0FU;
    } else if (sign < 0) {
        *p = (*p & 0xF0U) | 0x0DU;
    } else {
        *p = (*p & 0xF0U) | 0x0CU;
    }

    return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_decimal_init

(

cob_decimal *

d

)

Definition at line 321 of file numeric.c.

References COB_MPZ_DEF, cob_decimal::scale, and cob_decimal::value.

Referenced by cob_decimal_push(), and cob_init_numeric().

{
    mpz_init2 (d->value, COB_MPZ_DEF);
    d->scale = 0;
}

Here is the caller graph for this function:

void cob_decimal_mul	(	cob_decimal *	d1,
		cob_decimal *	d2
	)

Definition at line 1891 of file numeric.c.

References DECIMAL_CHECK, cob_decimal::scale, and cob_decimal::value.

Referenced by calc_variance_of_args(), cob_div_quotient(), cob_intr_binop(), cob_mod_or_rem(), cob_mul(), and cobxref_().

{
    DECIMAL_CHECK (d1, d2);
    d1->scale += d2->scale;
    mpz_mul (d1->value, d1->value, d2->value);
}

Here is the caller graph for this function:

void cob_decimal_pop	(	const cob_u32_t	params,
			...
	)

Definition at line 2619 of file numeric.c.

References cob_free(), cob_u32_t, params, and cob_decimal::value.

{
    cob_decimal *dec;
    cob_u32_t   i;
    va_list     args;

    va_start (args, params);
    for (i = 0; i < params; ++i) {
        dec = va_arg (args, cob_decimal *);
        mpz_clear (dec->value);
        cob_free (dec);
    }
    va_end (args);
}

Here is the call graph for this function:

static void cob_decimal_print ( cob_decimal *  d, FILE *  fp  )

static

Definition at line 364 of file numeric.c.

References COB_DECIMAL_INF, COB_DECIMAL_NAN, cob_mpzt2, cob_decimal::scale, unlikely, and cob_decimal::value.

Referenced by cob_print_ieeedec().

{
    int scale;

    if (unlikely(d->scale == COB_DECIMAL_NAN)) {
        fprintf (fp, "(Nan)");
        return;
    }
    if (unlikely(d->scale == COB_DECIMAL_INF)) {
        fprintf (fp, "(Inf)");
        return;
    }
    if (!mpz_sgn (d->value)) {
        fprintf (fp, "0E0");
        return;
    }
    mpz_set (cob_mpzt2, d->value);
    scale = d->scale;
    for ( ; ; ) {
        if (!mpz_divisible_ui_p (cob_mpzt2, 10UL)) {
            break;
        }
        mpz_tdiv_q_ui (cob_mpzt2, cob_mpzt2, 10UL);
        scale--;
    }
    gmp_fprintf (fp, "%ZdE%d", cob_mpzt2, -scale);
}

Here is the caller graph for this function:

void cob_decimal_push	(	const cob_u32_t	params,
			...
	)

Definition at line 2603 of file numeric.c.

References cob_decimal_init(), cob_malloc(), cob_u32_t, and params.

{
    cob_decimal **dec;
    cob_u32_t   i;
    va_list     args;

    va_start (args, params);
    for (i = 0; i < params; ++i) {
        dec = va_arg (args, cob_decimal **);
        *dec = cob_malloc (sizeof(cob_decimal));
        cob_decimal_init (*dec);
    }
    va_end (args);
}

Here is the call graph for this function:

static COB_INLINE COB_A_INLINE void cob_decimal_set ( cob_decimal *  dst, const cob_decimal *  src  )

static

Definition at line 356 of file numeric.c.

References cob_decimal::scale, and cob_decimal::value.

Referenced by cob_div_quotient().

{
    mpz_set (dst->value, src->value);
    dst->scale = src->scale;
}

Here is the caller graph for this function:

static void cob_decimal_set_binary ( cob_decimal *  d, cob_field *  f  )

static

Definition at line 1424 of file numeric.c.

References cob_binary_get_sint64(), cob_binary_get_uint64(), COB_FIELD_BINARY_SWAP, COB_FIELD_HAVE_SIGN, COB_FIELD_SCALE, COB_MAX_BINARY, cob_s64_t, cob_sli_t, cob_u64_t, cob_uli_t, cob_field::data, cob_decimal::scale, cob_field::size, and cob_decimal::value.

Referenced by cob_decimal_set_field().

{
#ifdef  COB_EXPERIMENTAL
#if 1   /* RXWRXW - set_usll */
    size_t      size;
    size_t      sizeb;
    size_t      idx;
    int     order;
    unsigned char   buff[COB_MAX_BINARY + 1];

    size = f->size;
#ifndef WORDS_BIGENDIAN
    if (!COB_FIELD_BINARY_SWAP (f)) {
        sizeb = size - 1;
        order = -1;
    } else {
        sizeb = 0;
        order = 1;
    }
#else
    sizeb = 0;
    order = 1;
#endif
    if (COB_FIELD_HAVE_SIGN (f) && (f->data[sizeb] & 0x80U)) {
        for (idx = 0; idx < size; ++idx) {
            buff[idx] = ~f->data[idx];
        }
        mpz_import (d->value, 1, order, size, order, 0, buff);
        mpz_com (d->value, d->value);
    } else {
        mpz_import (d->value, 1, order, size, order, 0, f->data);
    }

#else
    if (COB_FIELD_HAVE_SIGN (f)) {
        mpz_set_sll (d->value, cob_binary_get_sint64 (f));
    } else {
        mpz_set_ull (d->value, cob_binary_get_uint64 (f));
    }
#endif

#elif   defined(COB_LI_IS_LL)
    if (COB_FIELD_HAVE_SIGN (f)) {
        mpz_set_si (d->value, cob_binary_get_sint64 (f));
    } else {
        mpz_set_ui (d->value, cob_binary_get_uint64 (f));
    }
#else
    cob_u64_t       uval;
    cob_s64_t       val;
    size_t          negative;

    if (f->size <= 4) {
        if (COB_FIELD_HAVE_SIGN (f)) {
            mpz_set_si (d->value, (cob_sli_t)cob_binary_get_sint64 (f));
        } else {
            mpz_set_ui (d->value, (cob_uli_t) cob_binary_get_uint64 (f));
        }
    } else {
        negative = 0;
        if (COB_FIELD_HAVE_SIGN (f)) {
            val = cob_binary_get_sint64 (f);
            if (val < 0) {
                negative = 1;
                uval = (cob_u64_t)-val;
            } else {
                uval = (cob_u64_t)val;
            }
        } else {
            uval = cob_binary_get_uint64 (f);
        }
        mpz_set_ui (d->value, (cob_uli_t)(uval >> 32));
        mpz_mul_2exp (d->value, d->value, 32);
        mpz_add_ui (d->value, d->value, (cob_uli_t)(uval & 0xFFFFFFFFU));
        if (negative) {
            mpz_neg (d->value, d->value);
        }
    }
#endif
    d->scale = COB_FIELD_SCALE(f);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cob_decimal_set_display ( cob_decimal *  d, cob_field *  f  )

static

Definition at line 1308 of file numeric.c.

References COB_D2I, cob_fast_malloc(), COB_FIELD_DATA, COB_FIELD_SCALE, COB_FIELD_SIZE, cob_free(), COB_GET_SIGN, COB_PUT_SIGN, cob_uli_t, cob_decimal::scale, sign, unlikely, and cob_decimal::value.

Referenced by cob_decimal_set_field().

{
    unsigned char   *data;
    unsigned char   *p;
    size_t      size;
    int     sign;
    cob_uli_t   n;

    data = COB_FIELD_DATA (f);
    size = COB_FIELD_SIZE (f);
    if (unlikely(*data == 255)) {
        mpz_ui_pow_ui (d->value, 10UL, (cob_uli_t)size);
        d->scale = COB_FIELD_SCALE(f);
        return;
    }
    if (unlikely(*data == 0)) {
        mpz_ui_pow_ui (d->value, 10UL, (cob_uli_t)size);
        mpz_neg (d->value, d->value);
        d->scale = COB_FIELD_SCALE(f);
        return;
    }
    sign = COB_GET_SIGN (f);
    /* Skip leading zeros (also invalid space/low-value) */
    while (size > 1 && (*data & 0x0FU) == 0) {
        size--;
        data++;
    }

    /* Set value */
    n = 0;

#ifdef  COB_LI_IS_LL
    if (size < 20) {
#else
    if (size < 10) {
#endif
        while (size--) {
            if (n) {
                n *= 10;
            }
            n += COB_D2I (*data);
            data++;
        }
        mpz_set_ui (d->value, n);
    } else {
        p = cob_fast_malloc (size + 1U);
        for (; n < size; ++n) {
            p[n] = (data[n] & 0x0FU) + '0';
        }
        p[size] = 0;
        mpz_set_str (d->value, (char *)p, 10);
        cob_free (p);
    }

    /* Set sign and scale */
    if (sign < 0 && mpz_sgn (d->value)) {
        mpz_neg (d->value, d->value);
    }
    d->scale = COB_FIELD_SCALE(f);
    COB_PUT_SIGN (f, sign);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cob_decimal_set_double ( cob_decimal *  d, const double  v  )

static

Definition at line 821 of file numeric.c.

References cob_gmp_free(), cob_mexp, cob_mpft, cob_sli_t, cob_u64_t, cob_uli_t, d1, NULL, cob_decimal::scale, sign, and cob_decimal::value.

Referenced by cob_decimal_set_field(), and cob_print_ieeedec().

{
    char            *p;
    char            *q;
    cob_u64_t       t1;
    cob_sli_t       scale;
    cob_sli_t       len;
    int         sign;
    union {
        double      d1;
        cob_u64_t   l1;
    } ud;

    memset (&t1, ' ', sizeof(t1));
    ud.d1 = v;
    if (ud.l1 == 0 || ud.l1 == t1 || !finite (v)) {
        mpz_set_ui (d->value, 0UL);
        d->scale = 0;
        return;
    }

    sign = 0;
    mpf_set_d (cob_mpft, v);

    q = mpf_get_str (NULL, &scale, 10, (size_t)96, cob_mpft);
    if (!*q) {
        mpz_set_ui (d->value, 0UL);
        d->scale = 0;
        cob_gmp_free(q);
        return;
    }
    p = q;
    if (*p == '-') {
        sign = 1;
        ++p;
    }

    mpz_set_str (d->value, p, 10);

    len = (cob_sli_t)strlen (p);
    len -= scale;
    if (len >= 0) {
        d->scale = len;
    } else {
        mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-len);
        mpz_mul (d->value, d->value, cob_mexp);
        d->scale = 0;
    }

    if (sign) {
        mpz_neg (d->value, d->value);
    }
    cob_gmp_free(q);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_decimal_set_field	(	cob_decimal *	d,
		cob_field *	f
	)

Definition at line 1612 of file numeric.c.

References cob_decimal_set_binary(), cob_decimal_set_display(), cob_decimal_set_double(), cob_decimal_set_ieee128dec(), cob_decimal_set_ieee64dec(), cob_decimal_set_packed(), COB_FIELD_TYPE, COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_FP_DEC128, COB_TYPE_NUMERIC_FP_DEC64, COB_TYPE_NUMERIC_PACKED, and cob_field::data.

Referenced by calc_mean_of_args(), calc_variance_of_args(), cob_add(), cob_add_int(), cob_cmp_float(), cob_cmp_int(), cob_cmp_llint(), cob_cmp_uint(), cob_decimal_move_temp(), cob_decimal_setget_fld(), cob_div(), cob_div_quotient(), cob_intr_abs(), cob_intr_acos(), cob_intr_annuity(), cob_intr_asin(), cob_intr_atan(), cob_intr_binop(), cob_intr_combined_datetime(), cob_intr_cos(), cob_intr_exp(), cob_intr_exp10(), cob_intr_fraction_part(), cob_intr_integer(), cob_intr_integer_part(), cob_intr_log(), cob_intr_log10(), cob_intr_mean(), cob_intr_median(), cob_intr_midrange(), cob_intr_present_value(), cob_intr_range(), cob_intr_sign(), cob_intr_sin(), cob_intr_sqrt(), cob_intr_sum(), cob_intr_tan(), cob_mod_or_rem(), cob_mul(), cob_numeric_cmp(), cob_sub(), cobxref_(), get_fractional_seconds(), and LISTING_().

{
    union {
        double  dval;
        float   fval;
    } uval;

    switch (COB_FIELD_TYPE (f)) {
    case COB_TYPE_NUMERIC_BINARY:
        cob_decimal_set_binary (d, f);
        break;
    case COB_TYPE_NUMERIC_PACKED:
        cob_decimal_set_packed (d, f);
        break;
    case COB_TYPE_NUMERIC_FLOAT:
        memcpy ((void *)&uval.fval, f->data, sizeof(float));
        cob_decimal_set_double (d, (double)uval.fval);
        break;
    case COB_TYPE_NUMERIC_DOUBLE:
        memcpy ((void *)&uval.dval, f->data, sizeof(double));
        cob_decimal_set_double (d, uval.dval);
        break;
    case COB_TYPE_NUMERIC_FP_DEC64:
        cob_decimal_set_ieee64dec (d, f);
        break;
    case COB_TYPE_NUMERIC_FP_DEC128:
        cob_decimal_set_ieee128dec (d, f);
        break;
    default:
        cob_decimal_set_display (d, f);
        break;
    }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void cob_decimal_set_ieee128dec ( cob_decimal *  d, const cob_field *  f  )

static

Definition at line 688 of file numeric.c.

References COB_128_EXPO_1, COB_128_EXPO_2, COB_128_IS_EXTEND, COB_128_IS_SPECIAL, COB_128_LSW, COB_128_MSW, COB_128_OR_EXTEND, COB_128_SIGF_1, COB_128_SIGF_2, COB_DEC_SIGN, COB_DECIMAL_NAN, cob_mexp, cob_mpz_ten34m1, cob_u64_t, cob_uli_t, cob_field::data, cob_decimal::scale, sign, and cob_decimal::value.

Referenced by cob_decimal_set_field(), and cob_print_ieeedec().

{
    cob_u64_t   expo;
    cob_u64_t   sign;
    cob_u64_t   data[2];

    /* bit 0 : sign bit */
    /* bits 1 - 4 : combination field */
    /* combination = 15 (all bits set) is inf/nan */
    /* combination > 11 (bits 1100) is extended exponent */
    /* Exponent length - 14 bits */

    memcpy (data, f->data, sizeof(data));
    sign = COB_128_MSW(data) & COB_DEC_SIGN;
    if (COB_128_IS_SPECIAL (data)) {
        /* Inf / Nan */
        mpz_set_ui (d->value, 1UL);
        d->scale = COB_DECIMAL_NAN;
        return;
    }
    if (COB_128_IS_EXTEND (data)) {
        expo = (COB_128_MSW(data) & COB_128_EXPO_2) >> 47U;
        COB_128_MSW(data) &= COB_128_SIGF_2;
        COB_128_MSW(data) |= COB_128_OR_EXTEND;
#if 0   /* RXWRXW - IEEE cap at 34 digits */
        /* Non-canonical */
        mpz_set_ui (d->value, 0);
        d->scale = 0;
        return;
#endif
    } else {
        expo = (COB_128_MSW(data) & COB_128_EXPO_1) >> 49U;
        COB_128_MSW(data) &= COB_128_SIGF_1;
    }
    if (!COB_128_MSW(data) && !COB_128_LSW(data)) {
        /* Significand 0 */
        mpz_set_ui (d->value, 0UL);
        d->scale = 0;
        return;
    }
#ifdef  COB_LI_IS_LL
    mpz_set_ui (d->value, COB_128_MSW(data));
    mpz_mul_2exp (d->value, d->value, 64UL);
    mpz_add_ui (d->value, d->value, COB_128_LSW(data));
#else
    /* RXWRXW - Fixme */
    mpz_set_ui (d->value, (cob_uli_t)(COB_128_MSW(data) >> 32U));
    mpz_mul_2exp (d->value, d->value, 32UL);
    mpz_add_ui (d->value, d->value, (cob_uli_t)(COB_128_MSW(data) & 0xFFFFFFFFU));
    mpz_mul_2exp (d->value, d->value, 32UL);
    mpz_add_ui (d->value, d->value, (cob_uli_t)(COB_128_LSW(data) >> 32U));
    mpz_mul_2exp (d->value, d->value, 32UL);
    mpz_add_ui (d->value, d->value, (cob_uli_t)(COB_128_LSW(data) & 0xFFFFFFFFU));
#endif

    if (mpz_cmpabs (d->value, cob_mpz_ten34m1) >= 0) {
        /* Non-canonical */
        mpz_set_ui (d->value, 0UL);
        d->scale = 0;
        return;
    }
    d->scale = (int)expo - 6176;
    if (d->scale > 0) {
        mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d->scale);
        mpz_mul (d->value, d->value, cob_mexp);
        d->scale = 0;
    } else if (d->scale < 0) {
        d->scale = -(d->scale);
    }
    if (sign) {
        mpz_neg (d->value, d->value);
    }
}

Here is the caller graph for this function:

static void cob_decimal_set_ieee64dec ( cob_decimal *  d, const cob_field *  f  )

static

Definition at line 551 of file numeric.c.

References COB_64_EXPO_1, COB_64_EXPO_2, COB_64_IS_EXTEND, COB_64_IS_SPECIAL, COB_64_OR_EXTEND, COB_64_SIGF_1, COB_64_SIGF_2, COB_DEC_SIGN, COB_DECIMAL_NAN, cob_mexp, COB_U64_C, cob_u64_t, cob_uli_t, cob_field::data, cob_decimal::scale, sign, and cob_decimal::value.

Referenced by cob_decimal_set_field(), and cob_print_ieeedec().

{
    cob_u64_t   expo;
    cob_u64_t   sign;
    cob_u64_t   data;

    /* bit 0 : sign bit */
    /* bits 1 - 4 : combination field */
    /* combination = 15 (all bits set) is inf/nan */
    /* combination > 11 (bits 1100) is extended exponent */
    /* Exponent length - 10 bits */

    memcpy (&data, f->data, sizeof(data));
    sign = data & COB_DEC_SIGN;
    if (COB_64_IS_SPECIAL (data)) {
        /* Inf / Nan */
        mpz_set_ui (d->value, 1UL);
        d->scale = COB_DECIMAL_NAN;
        return;
    }
    if (COB_64_IS_EXTEND (data)) {
        expo = (data & COB_64_EXPO_2) >> 51U;
        data &= COB_64_SIGF_2;
        data |= COB_64_OR_EXTEND;
        if (data > COB_U64_C(9999999999999999)) {
            mpz_set_ui (d->value, 0UL);
            d->scale = 0;
            return;
        }
    } else {
        expo = (data & COB_64_EXPO_1) >> 53U;
        data &= COB_64_SIGF_1;
    }
    if (!data) {
        /* Significand 0 */
        mpz_set_ui (d->value, 0UL);
        d->scale = 0;
        return;
    }
#ifdef  COB_LI_IS_LL
    mpz_set_ui (d->value, data);
#else
    mpz_set_ui (d->value, (cob_uli_t)(data >> 32));
    mpz_mul_2exp (d->value, d->value, 32);
    mpz_add_ui (d->value, d->value, (cob_uli_t)(data & 0xFFFFFFFFU));
#endif

    d->scale = (int)expo - 398;
    if (d->scale > 0) {
        mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d->scale);
        mpz_mul (d->value, d->value, cob_mexp);
        d->scale = 0;
    } else if (d->scale < 0) {
        d->scale = -(d->scale);
    }
    if (sign) {
        mpz_neg (d->value, d->value);
    }
}

Here is the caller graph for this function:

void cob_decimal_set_llint	(	cob_decimal *	d,
		const cob_s64_t	n
	)

Definition at line 328 of file numeric.c.

References cob_sli_t, cob_u32_t, cob_u64_t, cob_uli_t, cob_decimal::scale, and cob_decimal::value.

{
#ifdef  COB_LI_IS_LL
    mpz_set_si (d->value, (cob_sli_t)n);
#else
    cob_u64_t   uval;
    cob_u32_t   negative;

    negative = 0;
    if (n < 0) {
        negative = 1;
        uval = (cob_u64_t)-n;
    } else {
        uval = (cob_u64_t)n;
    }
    mpz_set_ui (d->value, (cob_uli_t)(uval >> 32));
    mpz_mul_2exp (d->value, d->value, 32);
    mpz_add_ui (d->value, d->value, (cob_uli_t)(uval & 0xFFFFFFFFU));
    if (negative) {
        mpz_neg (d->value, d->value);
    }
#endif
    d->scale = 0;
}

static void cob_decimal_set_packed ( cob_decimal *  d, cob_field *  f  )

static

Definition at line 1087 of file numeric.c.

References COB_FIELD_DIGITS, COB_FIELD_NO_SIGN_NIBBLE, COB_FIELD_SCALE, cob_packed_get_sign(), cob_uli_t, cob_field::data, cob_decimal::scale, sign, cob_field::size, unlikely, and cob_decimal::value.

Referenced by cob_decimal_set_field().

{
    unsigned char   *p;
    unsigned char   *endp;
    int     digits;
    int     sign;
    int     nibtest;
    unsigned int    byteval;
    unsigned int    nonzero;

    p = f->data;
    digits = COB_FIELD_DIGITS (f);
#if 0   /* RXWRXW - P Fix */
    if (digits > (f->size * 2) - 1) {
        digits = (f->size * 2) - 1;
    }
#endif
    sign = cob_packed_get_sign (f);

    if (unlikely(COB_FIELD_NO_SIGN_NIBBLE (f))) {
        endp = f->data + f->size;
        nibtest = 1;
    } else {
        endp = f->data + f->size - 1;
        nibtest = 0;
    }

    byteval = 0;
    if (digits % 2 == nibtest) {
        byteval = *p & 0x0FU;
        p++;
    }
    mpz_set_ui (d->value, (cob_uli_t)byteval);
    nonzero = !!byteval;

    for (; p < endp; p++) {
        if (nonzero) {
            mpz_mul_ui (d->value, d->value, 100UL);
        }
        if (*p) {
            mpz_add_ui (d->value, d->value,
                    (cob_uli_t)((*p >> 4U) * 10U) + (*p & 0x0FU));
            nonzero = 1;
        }
    }

    if (!nibtest) {
        if (nonzero) {
            mpz_mul_ui (d->value, d->value, 10UL);
        }
        mpz_add_ui (d->value, d->value, (cob_uli_t)(*p >> 4U));
    }

    if (sign < 0) {
        mpz_neg (d->value, d->value);
    }
    d->scale = COB_FIELD_SCALE(f);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_decimal_setget_fld	(	cob_field *	src,
		cob_field *	dst,
		const int	opt
	)

Definition at line 2007 of file numeric.c.

References cob_decimal_get_field(), and cob_decimal_set_field().

Referenced by cob_move().

{
    cob_decimal_set_field (&cob_d1, src);
    (void)cob_decimal_get_field (&cob_d1, dst, opt);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_decimal_sub	(	cob_decimal *	d1,
		cob_decimal *	d2
	)

Definition at line 1883 of file numeric.c.

References align_decimal(), DECIMAL_CHECK, and cob_decimal::value.

Referenced by calc_variance_of_args(), cob_div_quotient(), cob_intr_annuity(), cob_intr_binop(), cob_intr_range(), cob_mod_or_rem(), cob_sub(), cobxref_(), get_fractional_seconds(), and LISTING_().

{
    DECIMAL_CHECK (d1, d2);
    align_decimal (d1, d2);
    mpz_sub (d1->value, d1->value, d2->value);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_div	(	cob_field *	f1,
		cob_field *	f2,
		const int	opt
	)

Definition at line 1958 of file numeric.c.

References cob_decimal_div(), cob_decimal_get_field(), and cob_decimal_set_field().

{
    cob_decimal_set_field (&cob_d1, f1);
    cob_decimal_set_field (&cob_d2, f2);
    cob_decimal_div (&cob_d1, &cob_d2);
    (void)cob_decimal_get_field (&cob_d1, f1, opt);
}

Here is the call graph for this function:

void cob_div_quotient	(	cob_field *	dividend,
		cob_field *	divisor,
		cob_field *	quotient,
		const int	opt
	)

Definition at line 1967 of file numeric.c.

References cob_decimal_div(), cob_decimal_get_field(), cob_decimal_mul(), COB_DECIMAL_NAN, cob_decimal_set(), cob_decimal_set_field(), cob_decimal_sub(), COB_FIELD_SCALE, cob_decimal::scale, and shift_decimal().

{
    /* Note that cob_div_quotient and cob_div_remainder must remain */
    /* separate because of COBOL rules. The quotient must be fully */
    /* evaluated before the remainder item is evaluated */
    /* eg. DIVIDE A BY B GIVING Z REMAINDER FLD (Z). */

    cob_decimal_set_field (&cob_d1, dividend);
    cob_decimal_set_field (&cob_d2, divisor);
    cob_decimal_set (&cob_d_remainder, &cob_d1);

    /* Compute quotient */
    cob_decimal_div (&cob_d1, &cob_d2);
    /* Check divide by zero - Exception is set in cob_decimal_div */
    if (cob_d1.scale == COB_DECIMAL_NAN) {
        /* Forces an early return from cob_div_remainder */
        cob_d_remainder.scale = COB_DECIMAL_NAN;
        return;
    }

    /* Set quotient */
    cob_decimal_set (&cob_d3, &cob_d1);
    (void)cob_decimal_get_field (&cob_d1, quotient, opt);

    /* Truncate digits from the quotient */
    shift_decimal (&cob_d3, COB_FIELD_SCALE(quotient) - cob_d3.scale);

    /* Compute remainder */
    cob_decimal_mul (&cob_d3, &cob_d2);
    cob_decimal_sub (&cob_d_remainder, &cob_d3);
}

Here is the call graph for this function:

void cob_div_remainder	(	cob_field *	fld_remainder,
		const int	opt
	)

Definition at line 2001 of file numeric.c.

References cob_decimal_get_field().

{
    (void)cob_decimal_get_field (&cob_d_remainder, fld_remainder, opt);
}

Here is the call graph for this function:

void cob_exit_numeric

(

void

)

Definition at line 2637 of file numeric.c.

References cob_decimal_base, cob_free(), COB_MAX_BINARY, COB_MAX_DEC_STRUCT, cob_mexp, cob_mpft, cob_mpft_get, cob_mpz_ten16m1, cob_mpz_ten34m1, cob_mpze10, cob_mpzt, cob_mpzt2, d1, and cob_decimal::value.

Referenced by cob_terminate_routines().

{
    cob_decimal *d1;
    size_t      i;

    if (cob_decimal_base) {
        d1 = cob_decimal_base;
        for (i = 0; i < COB_MAX_DEC_STRUCT; d1++, i++) {
            mpz_clear (d1->value);
        }
        cob_free (cob_decimal_base);
    }

    mpz_clear (cob_d_remainder.value);

    mpz_clear (cob_d3.value);
    mpz_clear (cob_d2.value);
    mpz_clear (cob_d1.value);

    mpz_clear (cob_mexp);
    mpz_clear (cob_mpzt2);
    mpz_clear (cob_mpzt);

    mpz_clear (cob_mpz_ten34m1);
    mpz_clear (cob_mpz_ten16m1);
    for (i = 0; i < COB_MAX_BINARY; i++) {
        mpz_clear (cob_mpze10[i]);
    }

    mpf_clear (cob_mpft_get);
    mpf_clear (cob_mpft);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static unsigned int cob_get_long_ebcdic_sign ( const unsigned char *  p, cob_s64_t *  val  )

static

Definition at line 2477 of file numeric.c.

Referenced by cob_cmp_numdisp().

{
    switch (*p) {
    case '{':
        return 0;
    case 'A':
        *val += 1;
        return 0;
    case 'B':
        *val += 2;
        return 0;
    case 'C':
        *val += 3;
        return 0;
    case 'D':
        *val += 4;
        return 0;
    case 'E':
        *val += 5;
        return 0;
    case 'F':
        *val += 6;
        return 0;
    case 'G':
        *val += 7;
        return 0;
    case 'H':
        *val += 8;
        return 0;
    case 'I':
        *val += 9;
        return 0;
    case '}':
        return 1;
    case 'J':
        *val += 1;
        return 1;
    case 'K':
        *val += 2;
        return 1;
    case 'L':
        *val += 3;
        return 1;
    case 'M':
        *val += 4;
        return 1;
    case 'N':
        *val += 5;
        return 1;
    case 'O':
        *val += 6;
        return 1;
    case 'P':
        *val += 7;
        return 1;
    case 'Q':
        *val += 8;
        return 1;
    case 'R':
        *val += 9;
        return 1;
    }
    return 0;
}

Here is the caller graph for this function:

void cob_gmp_free

(

void *

ptr

)

Definition at line 217 of file numeric.c.

References NULL.

Referenced by cob_decimal_get_display(), cob_decimal_get_packed(), cob_decimal_set_double(), and cob_decimal_set_mpf().

                          {
/* mpir/gmp free functions */
#ifdef HAVE_MP_GET_MEMORY_FUNCTIONS
    void (*freefunc)(void *, size_t);
    mp_get_memory_functions (NULL, NULL, &freefunc);
    freefunc (ptr, strlen((char*) ptr) + 1);
#else
    free (ptr);
#endif
}

Here is the caller graph for this function:

void cob_init_numeric

(

cob_global *

lptr

)

Definition at line 2671 of file numeric.c.

References cob_decimal_base, cob_decimal_init(), cob_malloc(), COB_MAX_BINARY, COB_MAX_DEC_STRUCT, cob_mexp, COB_MPF_PREC, cob_mpft, cob_mpft_get, COB_MPZ_DEF, cob_mpz_ten16m1, cob_mpz_ten34m1, cob_mpze10, cob_mpzt, cob_mpzt2, cob_u32_t, cob_uli_t, d1, last_packed_val, and packed_value.

Referenced by cob_init().

{
    cob_decimal *d1;
    cob_u32_t   i;

    cobglobptr = lptr;

    memset (packed_value, 0, sizeof(packed_value));
    last_packed_val = 0;

    mpf_init2 (cob_mpft, COB_MPF_PREC);
    mpf_init2 (cob_mpft_get, COB_MPF_PREC);

    for (i = 0; i < COB_MAX_BINARY; i++) {
        mpz_init2 (cob_mpze10[i], 128UL);
        mpz_ui_pow_ui (cob_mpze10[i], 10UL, (cob_uli_t)i);
    }
    mpz_init_set (cob_mpz_ten16m1, cob_mpze10[16]);
    mpz_sub_ui (cob_mpz_ten16m1, cob_mpz_ten16m1, 1UL);
    mpz_init_set (cob_mpz_ten34m1, cob_mpze10[34]);
    mpz_sub_ui (cob_mpz_ten34m1, cob_mpz_ten34m1, 1UL);

    mpz_init2 (cob_mpzt, COB_MPZ_DEF);
    mpz_init2 (cob_mpzt2, COB_MPZ_DEF);
    mpz_init2 (cob_mexp, COB_MPZ_DEF);

    cob_decimal_init (&cob_d1);
    cob_decimal_init (&cob_d2);
    cob_decimal_init (&cob_d3);
    cob_decimal_init (&cob_d_remainder);

    cob_decimal_base = cob_malloc (COB_MAX_DEC_STRUCT * sizeof(cob_decimal));
    d1 = cob_decimal_base;
    for (i = 0; i < COB_MAX_DEC_STRUCT; d1++, i++) {
        cob_decimal_init (d1);
    }
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_mul	(	cob_field *	f1,
		cob_field *	f2,
		const int	opt
	)

Definition at line 1949 of file numeric.c.

References cob_decimal_get_field(), cob_decimal_mul(), and cob_decimal_set_field().

{
    cob_decimal_set_field (&cob_d1, f1);
    cob_decimal_set_field (&cob_d2, f2);
    cob_decimal_mul (&cob_d1, &cob_d2);
    (void)cob_decimal_get_field (&cob_d1, f1, opt);
}

Here is the call graph for this function:

int cob_numeric_cmp	(	cob_field *	f1,
		cob_field *	f2
	)

Definition at line 2348 of file numeric.c.

References cob_cmp_float(), cob_decimal_cmp(), cob_decimal_set_field(), COB_FIELD_TYPE, COB_TYPE_NUMERIC_DOUBLE, and COB_TYPE_NUMERIC_FLOAT.

Referenced by cob_cmp(), cob_file_sort_compare(), and sort_compare().

{
    if(COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_FLOAT
    || COB_FIELD_TYPE (f1) == COB_TYPE_NUMERIC_DOUBLE
    || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_FLOAT
    || COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_DOUBLE) {
        return cob_cmp_float(f1,f2);
    }
    cob_decimal_set_field (&cob_d1, f1);
    cob_decimal_set_field (&cob_d2, f2);
    return cob_decimal_cmp (&cob_d1, &cob_d2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cob_packed_get_sign ( const cob_field *  f )

static

Definition at line 910 of file numeric.c.

References COB_FIELD_HAVE_SIGN, COB_FIELD_NO_SIGN_NIBBLE, cob_field::data, and cob_field::size.

Referenced by cob_cmp_packed(), and cob_decimal_set_packed().

{
    unsigned char *p;

    if (!COB_FIELD_HAVE_SIGN (f) || COB_FIELD_NO_SIGN_NIBBLE (f)) {
        return 0;
    }
    p = f->data + f->size - 1;
    return ((*p & 0x0FU) == 0x0DU) ? -1 : 1;
}

Here is the caller graph for this function:

void cob_print_ieeedec	(	const cob_field *	f,
		FILE *	fp
	)

Definition at line 1647 of file numeric.c.

References cob_decimal_print(), cob_decimal_set_double(), cob_decimal_set_ieee128dec(), cob_decimal_set_ieee64dec(), COB_FIELD_TYPE, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_FP_DEC128, COB_TYPE_NUMERIC_FP_DEC64, and cob_field::data.

Referenced by display_common().

{
    union {
        double  dval;
        float   fval;
    } uval;

    switch (COB_FIELD_TYPE (f)) {
    case COB_TYPE_NUMERIC_FP_DEC64:
        cob_decimal_set_ieee64dec (&cob_d3, f);
        break;
    case COB_TYPE_NUMERIC_FP_DEC128:
        cob_decimal_set_ieee128dec (&cob_d3, f);
        break;
    case COB_TYPE_NUMERIC_FLOAT:
        memcpy ((void *)&uval.fval, f->data, sizeof(float));
        cob_decimal_set_double (&cob_d3, (double)uval.fval);
        break;
    case COB_TYPE_NUMERIC_DOUBLE:
        memcpy ((void *)&uval.dval, f->data, sizeof(double));
        cob_decimal_set_double (&cob_d3, uval.dval);
        break;
    default:
        return;
    }
    cob_decimal_print (&cob_d3, fp);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_print_realbin	(	const cob_field *	f,
		FILE *	fp,
		const int	size
	)

Definition at line 1676 of file numeric.c.

References CB_FMT_PLLD, CB_FMT_PLLU, cob_binary_get_sint64(), cob_binary_get_uint64(), COB_FIELD_HAVE_SIGN, cob_s64_t, and cob_u64_t.

Referenced by display_common().

{
    union {
        cob_u64_t   uval;
        cob_s64_t   val;
    } llval;

    if (COB_FIELD_HAVE_SIGN (f)) {
        llval.val = cob_binary_get_sint64 (f);
        fprintf (fp, CB_FMT_PLLD, size, size, llval.val);
        return;
    }
    llval.uval = cob_binary_get_uint64 (f);
    fprintf (fp, CB_FMT_PLLU, size, size, llval.uval);
}

Here is the call graph for this function:

Here is the caller graph for this function:

void cob_set_packed_int	(	cob_field *	f,
		const int	val
	)

Definition at line 1261 of file numeric.c.

References COB_FIELD_DIGITS, COB_FIELD_HAVE_SIGN, COB_FIELD_NO_SIGN_NIBBLE, cob_set_packed_zero(), cob_u32_t, cob_field::data, packed_bytes, and cob_field::size.

{
    unsigned char   *p;
    size_t      sign = 0;
    cob_u32_t   n;

    if (!val) {
        cob_set_packed_zero (f);
        return;
    }
    if (val < 0) {
        n = (cob_u32_t)-val;
        sign = 1;
    } else {
        n = (cob_u32_t)val;
    }
    memset (f->data, 0, f->size);
    p = f->data + f->size - 1;
    if (!COB_FIELD_NO_SIGN_NIBBLE (f)) {
        *p = (n % 10) << 4;
        if (!COB_FIELD_HAVE_SIGN (f)) {
            *p |= 0x0FU;
        } else if (sign) {
            *p |= 0x0DU;
        } else {
            *p |= 0x0CU;
        }
        n /= 10;
        p--;
    }
    for (; n && p >= f->data; n /= 100, p--) {
        *p = packed_bytes[n % 100];
    }
    if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
        if ((COB_FIELD_DIGITS(f) % 2) == 1) {
            *(f->data) &= 0x0FU;
        }
        return;
    }
    if ((COB_FIELD_DIGITS(f) % 2) == 0) {
        *(f->data) &= 0x0FU;
    }
}

Here is the call graph for this function:

void cob_set_packed_zero

(

cob_field *

f

)

Definition at line 1073 of file numeric.c.

References COB_FIELD_HAVE_SIGN, COB_FIELD_NO_SIGN_NIBBLE, cob_field::data, and cob_field::size.

Referenced by cob_decimal_get_packed(), and cob_set_packed_int().

{
    memset (f->data, 0, f->size);
    if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
        return;
    }
    if (!COB_FIELD_HAVE_SIGN (f)) {
        *(f->data + f->size - 1) = 0x0F;
    } else {
        *(f->data + f->size - 1) = 0x0C;
    }
}

Here is the caller graph for this function:

void cob_sub	(	cob_field *	f1,
		cob_field *	f2,
		const int	opt
	)

Definition at line 1940 of file numeric.c.

References cob_decimal_get_field(), cob_decimal_set_field(), and cob_decimal_sub().

{
    cob_decimal_set_field (&cob_d1, f1);
    cob_decimal_set_field (&cob_d2, f2);
    cob_decimal_sub (&cob_d1, &cob_d2);
    (void)cob_decimal_get_field (&cob_d1, f1, opt);
}

Here is the call graph for this function:

int cob_sub_int	(	cob_field *	f,
		const int	n,
		const int	opt
	)

Definition at line 2251 of file numeric.c.

References cob_add_int().

{
    return cob_add_int (f, -n, opt);
}

Here is the call graph for this function:

static COB_INLINE COB_A_INLINE void num_byte_memcpy ( unsigned char *  s1, const unsigned char *  s2, size_t  size  )

static

Definition at line 229 of file numeric.c.

Referenced by cob_binary_get_sint64(), cob_binary_get_uint64(), cob_binary_set_int64(), and cob_binary_set_uint64().

{
    do {
        *s1++ = *s2++;
    } while (--size);
}

Here is the caller graph for this function:

static void shift_decimal ( cob_decimal *  d, const int  n  )

static

Definition at line 394 of file numeric.c.

References cob_mexp, cob_uli_t, cob_decimal::scale, and cob_decimal::value.

Referenced by align_decimal(), cob_decimal_div(), cob_decimal_do_round(), cob_decimal_get_field(), and cob_div_quotient().

{
    if (n == 0) {
        return;
    }
    if (n > 0) {
        mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)n);
        mpz_mul (d->value, d->value, cob_mexp);
    } else {
        mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-n);
        mpz_tdiv_q (d->value, d->value, cob_mexp);
    }
    d->scale += n;
}

Here is the caller graph for this function:

Variable Documentation

cob_decimal cob_d1

static

Definition at line 108 of file numeric.c.

Referenced by cob_decimal_get_field().

cob_decimal cob_d2

static

Definition at line 109 of file numeric.c.

cob_decimal cob_d3

static

Definition at line 110 of file numeric.c.

cob_decimal cob_d_remainder

static

Definition at line 111 of file numeric.c.

cob_decimal* cob_decimal_base

static

Definition at line 113 of file numeric.c.

Referenced by cob_exit_numeric(), and cob_init_numeric().

mpz_t cob_mexp

static

Definition at line 115 of file numeric.c.

Referenced by cob_add_int(), cob_decimal_get_double(), cob_decimal_set_double(), cob_decimal_set_ieee128dec(), cob_decimal_set_ieee64dec(), cob_exit_numeric(), cob_init_numeric(), and shift_decimal().

mpf_t cob_mpft

static

Definition at line 122 of file numeric.c.

Referenced by cob_decimal_get_double(), cob_decimal_set_double(), cob_exit_numeric(), and cob_init_numeric().

mpf_t cob_mpft_get

static

Definition at line 123 of file numeric.c.

Referenced by cob_decimal_get_double(), cob_exit_numeric(), and cob_init_numeric().

mpz_t cob_mpz_ten16m1

static

Definition at line 119 of file numeric.c.

Referenced by cob_decimal_get_ieee64dec(), cob_exit_numeric(), and cob_init_numeric().

mpz_t cob_mpz_ten34m1

static

Definition at line 118 of file numeric.c.

Referenced by cob_decimal_get_ieee128dec(), cob_decimal_set_ieee128dec(), cob_exit_numeric(), and cob_init_numeric().

mpz_t cob_mpze10[COB_MAX_BINARY]

static

Definition at line 120 of file numeric.c.

Referenced by cob_decimal_get_binary(), cob_decimal_get_ieee128dec(), cob_decimal_get_ieee64dec(), cob_exit_numeric(), and cob_init_numeric().

mpz_t cob_mpzt

static

Definition at line 116 of file numeric.c.

Referenced by cob_decimal_do_round(), cob_decimal_get_binary(), cob_exit_numeric(), and cob_init_numeric().

mpz_t cob_mpzt2

static

Definition at line 117 of file numeric.c.

Referenced by cob_decimal_do_round(), cob_decimal_print(), cob_exit_numeric(), and cob_init_numeric().

cob_global* cobglobptr

static

Definition at line 56 of file numeric.c.

cob_u64_t last_packed_val

static

Definition at line 126 of file numeric.c.

Referenced by cob_cmp_packed(), and cob_init_numeric().

const unsigned char packed_bytes[]

static

Initial value:

= {
    0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09,
    0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19,
    0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29,
    0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39,
    0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49,
    0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59,
    0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69,
    0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79,
    0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89,
    0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99
}

Definition at line 58 of file numeric.c.

Referenced by cob_set_packed_int().

unsigned char packed_value[20]

static

Definition at line 125 of file numeric.c.

Referenced by cob_cmp_packed(), and cob_init_numeric().