/*
 * Copyright (C) 2001, 2000, 1999,  Rildo Pragana, Jim Noeth, 
 *               Andrew Cameron, David Essex.
 * Copyright (C) 1993, 1991  Rildo Pragana.
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 2.1,
 * or (at your option) any later version.
 * 
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; see the file COPYING.LIB.  If
 * not, write to the Free Software Foundation, Inc., 59 Temple Place,
 * Suite 330, Boston, MA 02111-1307 USA
 */

/* 
 * 
 *   COBOL Compiler Run Time Library -- Math Module
 * 
 */

#include "htcoblib.h"

#include <math.h>

/* undef DEBUG_RTS */
/* define DEBUG_RTS 1 */
/* define DEBUG_MOVE_RTS 1 */

#if defined DEBUG_RTS
/* #define DEBUG_RTN(fmt, p1, p2, p3, p4, p5, p6)
 {fprintf(stderr, fmt, p1, p2, p3, p4, p5, p6);} */
#else
/* #define DEBUG_RTN(fmt, p1, p2, p3, p4, p5, p6) */
#endif

/* global data */
static double exp10[] = {1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10, 1e11, 1e12, 1e13,
    1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20, 1e21, 1e22, 1e23, 1e24, 1e25,
    1e26, 1e27, 1e28, 1e29, 1e30, 1e31, 1e32, 1e33, 1e34, 1e35, 1e36, 1e37,
    1e38, 1e39, 1e40, 1e41, 1e42, 1e43, 1e44, 1e45, 1e46, 1e47, 1e48, 1e49,
    1e50};

struct fld_desc _generic_4binary = {4, DTYPE_BININT, 0, 0, 0, 0, 0, 0, 0, 0, "S\19\x09"};

struct fld_desc _generic_8float = {8, DTYPE_FLOAT, 15, 0, 0, 0, 0, 0, 0, 0, "S\19\x0fV\19\x0f"};

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          fp_runtime_error                              |
 |                                                                        |
 \*------------------------------------------------------------------------*/

#if 0

static void
fp_runtime_error(struct fld_desc *f)
{
    char *pic;
    fprintf(stderr, "math runtime error: *** invalid contents of numeric field ***\n");
    pic = tcob_picExpand(f);
    fprintf(stderr, "field len: %ld, type: %c, decimals: %d, pic: %s\n",
            f->len, f->type, f->decimals, pic);
    free(pic);
    /*      getchar();*/
}
#endif

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          dump_double                                   |
 |                                                                        |
 \*------------------------------------------------------------------------*/

#if 0

static void
dump_double(char *msg, unsigned char *ptr)
{
    int i;
    printf(msg);
    for (i = 7; i >= 0; i--)
        printf("%02.2x", ptr[i]);
    getchar();
}
#endif

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_sign_to_char                             |
 |  input: digit (-9..-1,0,1..9, or 0x80 for -0)                          |
 |  return: character  +0...+9:"{ABCDEFGHI"  -0...-9:"}JKLMNOPQR"         |
 |                                                                        |
 \*------------------------------------------------------------------------*/

char
tcob_sign_to_char(int digit)
{
    if (!digit)
        return '{';

    if (digit == 0x80)
        return '}';

    if (digit > 0)
        return 'A' + (char) (digit - 1);

    digit = -digit;

    return 'J' + (char) (digit - 1);
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_char_to_sign                             |
 |  input and return are reverse those of tcob_sign_to_char               |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_char_to_sign(char ch)
{
    if (ch == '{')
        return 0;

    if (ch == '}')
        return 0x80;

    if (ch < 'J')
        return (int) (ch - 'A' + 1);

    return (-(int) (ch - 'J' + 1));
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_extract_sign                             |
 |  return: sign (0 is +, 1 is -)                                         |
 |  modified: s[f->len-1] (if type is not PACKED and is signed)           |
 |                                                                        |
 \*------------------------------------------------------------------------*/

char
tcob_extract_sign(struct fld_desc *f, char *s)
{
    char *tmp;
    int digit;

    if (tcob_picElemVal(f->pic, 0) != 'S')
        return 0;

    if (f->type == DTYPE_PACKED)
    {
        digit = s[f->len / 2] & 0x0F;
        return (((digit == 0x0D) || (digit == 0x0B)) ? 1 : 0);
    }

    tmp = (f->leading_sign) ? s : s + f->len - 1;
    digit = tcob_char_to_sign(*tmp);

    if (digit == 0x80)
        *tmp = '0';
    else
        if (digit < 0)
        *tmp = '0' - digit;
    else
    {
        *tmp = '0' + digit;
        return 0;
    }

    return 1;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_put_sign                                 |
 |  modified: possibly s[f->len/2] or s[f->len-1]                         |
 |                                                                        |
 \*------------------------------------------------------------------------*/

void
tcob_put_sign(struct fld_desc *f, char *s, char sign)
{
    char *tmp;
    int digit;

    if (f->type == DTYPE_PACKED)
    {
        if (tcob_picElemVal(f->pic, 0) == 'S')
            digit = (sign) ? 0x0D : 0x0C;
        else
            digit = 0x0F;

        s[f->len / 2] = (s[f->len / 2] & 0xF0) | digit;
        return;
    }
    if (tcob_picElemVal(f->pic, 0) != 'S')
        return;

    tmp = (f->leading_sign) ? s : s + f->len - 1;
    digit = *tmp - '0';
    /*      fprintf(stderr, "tcob_put_sign: t=%c,d=%d,s=%d\n",*tmp,digit,sign); */
    if (sign)
        digit = -digit;

    *tmp = tcob_sign_to_char((sign && digit == 0) ? 0x80 : digit);
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_adjust_length                            |
 |                                                                        |
 \*------------------------------------------------------------------------*/

struct fld_desc *
tcob_adjust_length(struct fld_desc *dep_desc, char *dep_val, int min, int max,
        struct fld_desc *var_desc, struct fld_desc *item, struct fld_desc *copy)
{
    int itocc;
    tcob_move(dep_desc, dep_val, &_generic_4binary, (char *) & itocc);
    if (itocc < min || itocc > max)
    {
        /* should generate exception, for now just a warning */
        fprintf(stderr, "*** Warning: table size out of bounds ");
        fprintf(stderr, "(requested = %d, min = %d, max = %d)\n", itocc, min,
                max);
        itocc = max;
    }

    memmove(copy, var_desc, sizeof (struct fld_desc));
    copy->len -= (max - itocc) * item->len;
    return copy;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_get_index & al.                          |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_get_index(struct fld_desc *f, char *s)
{
    int index;

    tcob_move(f, s, &_generic_4binary, (char *) & index);
    return index;
}

int
tcob_cnv_ll2i(long long idx)
{
    /* If a run-time truncation check should occur, it should be here */
    return (int) idx;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_fldtod                                   |
 |  Convert from a string to a double based on the fld_desc               |
 |  modified: *fp                                                         |
 |                                                                        |
 \*------------------------------------------------------------------------*/

void
tcob_fldtod(struct fld_desc *f, char *s, double *fp)
{
    unsigned int i;
    unsigned char sign = 0;
    unsigned char fpdig;
    int scale;
    double fpp = 0.;

#ifdef DEBUG_MOVE_RTS
    fprintf(stderr, "debug: tcob_fldtod 1: f: type=%c, len=%ld, dec=%d, s=%s\n",
            f->type,
            f->len,
            f->decimals,
            s);
#endif

    switch (f->type)
    {
        case DTYPE_BININT:
            switch (f->len)
            {
                case 1:
                    fpp = (double) *((char *) s);
                    break;
                case 2:
                    fpp = (double) *((short int *) s);
                    break;
                case 4:
                    fpp = (double) *((int *) s);
                    break;
                case 8:
                    fpp = (double) *((long long *) s);
                    break;
            }
            /*                fprintf(stderr, "debug: tcob_fldtod 3: f->len=%d, fpp=%f, s=%d\n",
             f->len,
             fpp,
             *((int *)s)); */
            break;
        case DTYPE_PACKED:
            for (i = 0;; i++)
            {
                fpdig = ((i & 1) ? s[i / 2] : s[i / 2] >> 4) & 0x0F;
                if (fpdig > 9)
                    break;
                fpp *= 10.;
                fpp += (double) fpdig;
            }
            sign = ((fpdig == 0x0D) || (fpdig == 0x0B)) ? 1 : 0;
            break;
        case DTYPE_FLOAT:
            switch (f->len)
            {
                case 4:
                    fpp = (double) *((float *) s);
                    /*                             fprintf(stderr, "debug: tcob_fldtod 3a: fpp=%f, s=%f\n",
                     fpp, *((float *)s)); */
                    break;
                case 8:
                    fpp = (double) *((double *) s);
                    /*                              fprintf(stderr, "debug: tcob_fldtod 3b: fpp=%f, s=%f\n",
                     fpp, *((double *)s)); */
                    break;
            }
            break;
        default:
            if (f->separate_sign)
            {
                f->len--;
                if (f->leading_sign)
                {
                    sign = (s[0] == '-') ? 1 : 0;
                    s++;
                }
                else
                    sign = (s[f->len] == '-') ? 1 : 0;
            }
            else
                sign = tcob_extract_sign(f, s);
            for (i = 0; i < f->len; i++)
            {
                fpdig = (s[i] == ' ') ? 0 : s[i] - '0';
                fpp *= 10.;
                fpp += (double) fpdig;
            }
            if (f->separate_sign)
            {
                f->len++;
                if (f->leading_sign)
                    s--;
            }
            else
                tcob_put_sign(f, s, sign);
            break;
    }

    /* scale the number with it's (fld_desc *)->decimals */
    /* No decimal scaling required for floating types */
    if (f->type != DTYPE_FLOAT)
    {
        scale = f->decimals;
        if (scale == 0 && f->pscale < 0)
            scale = f->pscale;
        /*            fprintf(stderr, "debug: tcob_fldtod 8a: scale=%d\n",  scale); */
        if (scale > 0 && scale <= 50)
            fpp /= exp10[scale];
        else if (scale > 50) /* because our table don't have everything */
            fpp /= pow(10., (double) scale);
        else if (scale < 0) /* because our table don't have everything */
            fpp /= pow(10., (double) scale);
        if (sign)
            fpp = -fpp;
        /*dump_double( "\fRes:",&fpp );*/

    }

    *fp = fpp;

#ifdef DEBUG_MOVE_RTS
    fprintf(stderr, "debug: tcob_fldtod 9: f: type=%c, len=%d, dec=%d; fpp=%g\n",
            f->type, (int) f->len, f->decimals, fpp);
#endif
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_push_double                              |
 |                                                                        |
 \*------------------------------------------------------------------------*/

void
tcob_push_double(struct fld_desc *f, char *s, double d)
{
    tcob_fldtod(f, s, &d);
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          do_rounding                                   |
 |                                                                        |
 \*------------------------------------------------------------------------*/

static void
do_rounding(struct fld_desc *f, double *d1)
{
    double fp = *d1;
    double rounding_incr = .5;

    /*      fp *= exp10[f->decimals]; */
    if (fp < 0)
    {
        rounding_incr = -rounding_incr;
    }
    if (f->pscale < 0)
        rounding_incr *= exp10[-(f->pscale)];
    else
        rounding_incr /= exp10[f->decimals];
    /*       fprintf(stderr, "debug: do_rounding 1: d1=%f, dec=%d, ri=%f\n",
     fp, f->decimals, rounding_incr); */
    fp += rounding_incr;
    /*       fprintf(stderr, "debug: do_rounding 2: d1=%f\n", fp); */
    *d1 = fp;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_assign_double                            |
 |  opts: bit 0 = ROUNDED                                                 |
 |        bit 1 = ON SIZE ERROR                                           |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_assign_double(struct fld_desc *f, char *s1, int opts, double d1)
{
    int rc = 0;
    int rc1 = 0;
    double tempd = d1; /* do not change d1, as it only exists on the stack */

#ifdef DEBUG_MOVE_RTS
    fprintf(stderr, "debug: tcob_assign_double 1: d1=%f\n", d1);
#endif
    if (f->type == DTYPE_EDITED)
        f->decimals = tcob_picEditedCompDecimals(f);

    /*  <--- WE MUST ROUND EVER, AS WE ARE DOING
     FLOATING POINT OPERATIONS. tHE REAL FIX
     IS TO CHANGE MATH IN THE COMPILER.
     PLEASE, DO NOT REMOVE "do_rounding". */
    if (opts & 1)
        do_rounding(f, &tempd);

    // Always checks on size error, even the user program do not test that...
    // if (opts & 2)
    rc = tcob_check_size_overflow(f, tempd);

#ifdef DEBUG_MOVE_RTS
    fprintf(stderr, "debug: tcob_assign_double 2: d1=%f, s1=%s, rc=%d\n", d1, s1, rc);
#endif

    // TODO: Always move????
    //if (rc == 0)
    rc1 = tcob_dtofld(f, s1, 0, tempd); /* no rounding, already done */
    /*         tcob_move( &_generic_8float, (char *)&tempd, f, s1 ); */

#ifdef DEBUG_MOVE_RTS
    fprintf(stderr, "debug: tcob_assign_double 3: d1=%f, s1=%s, rc=%d\n", d1, s1, rc);

    if (rc != 0)
        fprintf(stderr, "debug: size error on field of type %c\n", f->type);
#endif

    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_dtofld                                   |
 |  Convert from a double to a string based on the fld_desc,              |
 |  rounding if indicated by round                                        |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_dtofld(struct fld_desc *f, char *s1, int round, double d1)
{
    int ndec;
    unsigned int i, len, nd;
    unsigned int sign, rc = 0;
    //unsigned int lenDest;
    //double remainder; walter
    double fpa;
    char form[10];
    char saida[128];

    memset(&saida[0], 0, 128);
    memset(&form[0], 0, 10);
    form[0] = '%';
    form[1] = '0';

#ifdef DEBUG_RTS
    fprintf(stderr, "debug: tcob_dtofld 0: d1=%f, rc=%d\n", d1, rc);
#endif

    switch (f->type)
    {
        case DTYPE_BININT:
            d1 *= exp10[f->decimals];

#ifdef DEBUG_RTS
            fprintf(stderr, "debug: tcob_dtofld 2a: d1=%f, rc=%d\n", d1, rc);
#endif

            if (round != 0)
                d1 += (d1 > 0.) ? .5 : -.5;

#ifdef DEBUG_RTS
            fprintf(stderr, "debug: tcob_dtofld 2b: d1=%f, rc=%d\n", d1, rc);
#endif

            switch (f->len)
            {
                case 1:
                    *((char *) s1) = (int) d1;
                    /*                          fprintf(stderr, "debug: tcob_dtofld 2-1: d1=%f, s1=%d\n",
                     d1, *((char *)s1)); */
                    break;
                case 2:
                    *((short int *) s1) = (int) d1;
                    /*                          fprintf(stderr, "debug: tcob_dtofld 2-2: d1=%f, s1=%d\n",
                     d1, *((short int *)s1)); */
                    break;
                case 4:
                    *((int *) s1) = (int) d1;
                    /*                          fprintf(stderr, "debug: tcob_dtofld 2-4: d1=%f, s1=%d, fi=%d\n",
                     d1, *((int *)s1), fi); */
                    break;
                case 8:
                    *((long long *) s1) = (long long) d1;
                    /*                          fprintf(stderr, "debug: tcob_dtofld 2-8: d1=%f, s1=%d\n",
                     d1, *((long long *)s1)); */
                    break;
            }
            return rc;
        case DTYPE_PACKED:
            len = f->len;
            break;
        case DTYPE_FLOAT:
            switch (f->len)
            {
                case 4:
                    *((float *) s1) = (float) d1;
                    /*                      fprintf(stderr, "debug: tcob_dtofld 3: d1=%f, s1=%f\n",
                     d1, *((float *)s1)); */
                    break;
                case 8:
                    *((double *) s1) = d1;
                    /*                     fprintf(stderr, "debug: tcob_dtofld 4: d1=%f, s1=%f\n",
                     d1, *((double *)s1)); */
                    break;
                default:
                    rc = 1;
                    break;
            }
            /*                fprintf(stderr, "debug: tcob_dtofld 5: d1=%f, rc=%d\n",
             d1, rc); */
            return rc;
        case DTYPE_EDITED:
            len = tcob_picEditedCompLength(f);
            break;
        default:
            len = f->len;

#ifdef DEBUG_RTS
            fprintf(stderr, "debug: tcob_dtofld default: LEN=%d d1=%f\n", len, d1);
#endif

            break;
    }
    /*dump_double("\fAssign: ",&d1);*/
    fpa = d1;
    if (f->type == DTYPE_EDITED)
        ndec = tcob_picEditedCompDecimals(f);
    else
        ndec = (int) f->decimals;

#ifdef DEBUG_RTS
    fprintf(stderr, "debug: tcob_dtofld 6: fpa=%f,dec=%d,len=%d\n", fpa, ndec, (int) f->len);
#endif

    if (fpa < 0.)
    {
        sign = 1;
        fpa = -fpa;
    }
    else
        sign = 0;

    nd = len + ndec;
    if (ndec > 0)
        nd += (f->separate_sign ? 0 : 1);
    if (ndec) // walter
        sprintf(&form[2], "%i.%if", nd, ndec);
    else
        sprintf(&form[2], "%i.1f", (nd + 2));

#ifdef DEBUG_RTS
    fprintf(stderr, "debug: tcob_dtofld 6a: len=%d, ndec=%d, exp10[len-ndec]=%f, fpa=%f\n",
            len, ndec, exp10[len - ndec], fpa);
#endif

#if 0
    /* Do not remove this code */
    if (fpa > exp10[len - ndec])
    {
        fp_runtime_error(f);
        rc = 1;
        return rc;
    }
#endif

    fpa *= exp10[ndec];
    //        remainder = fpa - (unsigned long) fpa;
    //        if (f->pscale < 0) {
    //                fpa /= exp10[abs(f->pscale)];
    //                remainder /= exp10[abs(f->pscale)];
    //        }

    /* the following line is to fix a truncation error caused by rounding
     * in converting from long to double to long (i.e. 4.5 to 4.49999...).
     */
    /*      fprintf(stderr, "debug: tcob_dtofld 6: fpa=%f, round=%d\n", fpa,round); */
    //        if (remainder >= 0.999999) // walter tinha 0.9999999
    //				fpa += 0.000001; // tinha 0.0000001
    /*      if ( (round != 0) || ((unsigned long)(fpa * 10) % 10 > 8) )
     fpa += (fpa > 0.) ? .5 : -.5; */
    /*                fprintf(stderr, "debug: tcob_dtofld 7: fpa=%f\n", fpa); */
    /*      if (fpa>pow(2.,32.)) {
     printf("\fFP overflow!"); getchar();
     return;
     }
     */

    if (f->type != DTYPE_PACKED)
    {
        //unsigned int mini; walter
        //unsigned long fint; walter
        char *s;
        if (f->type == DTYPE_EDITED)
            s = (char *) malloc(len);
        else
            s = s1;

        /* if separate sign, tack on and hide */
        if (f->separate_sign)
        {
            char cSign = (sign) ? '-' : '+';
            if (f->leading_sign)
            {
                s[0] = cSign;
                s++;
            }
            else
                s[len - 1] = cSign;
            len--;
        }

        memset(s, '0', len); // TODO: What???? See the IF above...

        // put on "s" just the rightmost picture size characters

#ifdef DEBUG_RTS
        fprintf(stderr, "debug: tcob_dtofld: ANTES: len=%d, dec=%d\n", f->len, f->decimals);
        fprintf(stderr, "debug: tcob_dtofld: ANTES: value=[%f], saida=[%s], s=[%s]\n", fpa, saida, s);
#endif

        char *ss;
        ss = (char *) malloc(f->len + 2); // size plus 2... sign and terminator
        memset(ss,0,f->len+2);

        // put value on "saida"
        sprintf(&saida[0], &form[0], fpa); //walter

        // saida has something like 2400099.00 for 24000,99 and PIC 9(4)V9(2)
        i = 0;
        while (saida[i] && saida[i] != '.')
        {
            ss[i] = saida[i];
            i++;
        }

        // we must transfer from ss to s, limited to the size of the picture (on the sample, 6)

        // if value less or equal than picture size, just copy it to output
        // otherwise, limits the copy to size defined by the picture
        if (strlen(ss) <= f->len)
            strcpy(s, ss);
        else
        {
            i = strlen(ss) - f->len;
            memcpy(s, &ss[i], f->len);
        }

#ifdef DEBUG_RTS
        fprintf(stderr, "debug: tcob_dtofld: DEPOIS: len=%d, dec=%d\n", f->len, f->decimals);
        fprintf(stderr, "debug: tcob_dtofld: DEPOIS: value=[%f], saida=[%s], s=[%s], ss=[%s]\n", fpa, saida, s, ss);
#endif

        // for numeric edited, move value and clean up
        if (f->type == DTYPE_EDITED)
        {
            struct fld_desc fcopy;
            unsigned int picLen = tcob_picReqLen(4);
            memcpy(&fcopy, f, sizeof (struct fld_desc));
            fcopy.pic = (char *) malloc(picLen);
            tcob_picCreate(fcopy.pic, picLen, 'S', 1, '9', len - ndec, NULL);
            if (ndec > 0)
                tcob_picAppend(fcopy.pic, picLen, 'V', 1, '9', ndec, NULL);
            fcopy.type = DTYPE_DISPLAY;
            fcopy.len = len;
            fcopy.decimals = ndec;
            tcob_put_sign(&fcopy, s, sign);
            tcob_move(&fcopy, s, f, s1);
            free(fcopy.pic);
            free(s);
        }

        /* tack on the sign */
        if (!(f->separate_sign))
            tcob_put_sign(f, s1, sign);
    }

    // fprintf(stderr, "\nString: %20.20s\n", s);
    // getchar();

    if (f->type == DTYPE_PACKED)
    {
        unsigned long long fpahold = (unsigned long long) fpa;
        unsigned char cDigit, cSign;

        memset(s1, 0, (len / 2) + 1); /* Initialize s1 array */

        if ((len & 1) == 0) /* Make sure length is odd */
            len++;

        /* convert scaled number in fpa to our result */
        for (i = len; (i > 0) && (fpahold != 0); i--)
        {
            cDigit = fpahold % 10;
            if ((i % 2) == 1)
                cDigit <<= 4;
            fpahold /= 10;
            s1[(i - 1) / 2] |= cDigit;
        }

        /* attach the sign */
        if (tcob_picElemVal(f->pic, 0) == 'S')
            cSign = (sign) ? 0x0D : 0x0C;
        else
            cSign = 0x0F;
        s1[len / 2] |= cSign;
    }

    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_add_double                               |
 |                          tcob_subtract_double                          |
 |                          tcob_multiply_double                          |
 |                          tcob_divide_double                            |
 |                          tcob_pow_double                               |
 |                                                                        |
 \*------------------------------------------------------------------------*/

void
tcob_add_double(double *d2, double d1)
{
    *d2 += d1;
}

void
tcob_subtract_double(double *d2, double d1)
{
    *d2 -= d1;
}

void
tcob_multiply_double(double *d2, double d1)
{
    *d2 *= d1;

    // due to a bug on gcc...
    if (*d2 == 0)
        *d2 = 0;
}

void
tcob_divide_double(double *d2, double d1)
{
#if 0
    /* check for divide by zero */
    if (d1 == 0)
    {
        fprintf(stderr, "*** RUNTIME ERROR: divide by zero\n");
        exit(1);
    }
#endif
    if (d1 == 0)
        *d2 = 0;
    else
        *d2 /= d1;
}

void
tcob_pow_double(double *d2, double d1)
{
    *d2 = pow(*d2, d1);
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_add                                      |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_add(struct fld_desc *f1, char *s1, struct fld_desc *f2, char *s2, int round)
{
    int rc = 0;
    double fp1, fp2;

    tcob_fldtod(f1, s1, &fp1);
    tcob_fldtod(f2, s2, &fp2);
    fp1 += fp2;
    rc = tcob_check_size_overflow(f2, fp1);
    if (rc == 0)
        tcob_dtofld(f2, s2, round, fp1);
    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_subtract                                 |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_subtract(struct fld_desc *f1, char *s1, struct fld_desc *f2, char *s2, int round)
{
    int rc = 0;
    double fp1, fp2;

    tcob_fldtod(f1, s1, &fp1);
    tcob_fldtod(f2, s2, &fp2);
    fp2 -= fp1;
    rc = tcob_check_size_overflow(f2, fp2);
    if (rc == 0)
        tcob_dtofld(f2, s2, round, fp2);
    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_multiply                                 |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_multiply(struct fld_desc *f1, char *s1, struct fld_desc *f2, char *s2, struct fld_desc *f3, char *s3, int round)
{
    int rc = 0;
    double fp1, fp2, fp3;

    tcob_fldtod(f1, s1, &fp1);
    tcob_fldtod(f2, s2, &fp2);
    fp3 = fp1 * fp2;
    rc = tcob_check_size_overflow(f3, fp3);
    if (rc == 0)
        tcob_dtofld(f3, s3, round, fp3);
    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_divide                                   |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_divide(struct fld_desc *f1, char *s1, struct fld_desc *f2, char *s2,
        struct fld_desc *f3, char *s3, int round)
{
    int rc = 0;
    double fp1, fp2, fp3;

    tcob_fldtod(f1, s1, &fp1);
    tcob_fldtod(f2, s2, &fp2);
    if (fp2 == 0)
        rc = 1;
    else
    {
        fp3 = fp1 / fp2;
        rc = tcob_check_size_overflow(f3, fp3);
        if (rc == 0)
            tcob_dtofld(f3, s3, round, fp3);
    }

    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_divide1                                  |
 |  Divide with remainder option                                          |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_divide1(struct fld_desc *f1, char *s1, struct fld_desc *f2, char *s2,
        struct fld_desc *f3, char *s3, struct fld_desc *f4, char *s4, int round)
{
    int rc = 0;
    double fp1, fp2, fp3, fp4, tfp3;

    tcob_fldtod(f1, s1, &fp1);
    tcob_fldtod(f2, s2, &fp2);
    /*      fprintf(stderr, "debug mcmath 1: fp1=%05.5f fp2=%05.5f\n", fp1, fp2); */
    if (fp2 == 0)
    { /* divide by zero error */
        rc = 1;
        return rc;
    }

    /*
     * Calculate GIVING
     */
    fp3 = fp1 / fp2;
    /*      fprintf(stderr, "debug mcmath 2: fp3=%05.5f\n", fp3); */
    rc = tcob_check_size_overflow(f3, fp3);
    if (rc != 0)
        return rc;

    tcob_dtofld(f3, s3, round, fp3);

    /*
     *  Calculate REMAINDER.
     */

    tcob_fldtod(f3, s3, &tfp3);

    fp4 = (fp1 - (tfp3 * fp2));
    /*      fprintf(stderr, "debug mcmath 3: fp4=%05.5f, tfp3=%05.5f\n", fp4, tfp3); */
    rc = tcob_check_size_overflow(f4, fp4);
    if (rc != 0)
    {
        /*              fprintf(stderr, "debug mcmath 4: check_size_overflow : "
         "a overflow has occured on fp4=%05.5f\n",
         fp4); */
        return rc;
    }

    /*      fprintf(stderr, "debug mcmath 4: fp1=%05.5f, fp2=%05.5f, fp3=%05.5f, tfp3=%05.5f, fp4=%05.5f, fp4=%05.5f\n", fp1, fp2, fp3, tfp3, fp4, fp4); */
    tcob_dtofld(f4, s4, 0, fp4);

    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_check_size_overflow                      |
 |  Check if size will fit in destination field.  0 if yes, 1 if false.   |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_check_size_overflow(struct fld_desc *f, double d)
{
    unsigned int rc, len;

    if (f->type == DTYPE_EDITED)
        len = tcob_picEditedCompLength(f);
    else
        len = tcob_picCompLength(f) + tc_abs((char) f->pscale);

#ifdef DEBUG_RTS
    fprintf(stderr, "debug: tcob_check_size_overflow 1: piclen=%d, f->len=%d, f->decimals=%d\n",
            len, (int) f->len, f->decimals);
#endif
    if (len < f->decimals)
    {
        rc = 1;
    }
    else if (((d < 0.0) ? -d : d) >= exp10[len - f->decimals])
    {
        rc = 1;
    }
    else
    {
        rc = 0;
    }

#ifdef DEBUG_RTS
    fprintf(stderr, "debug: tcob_check_size_overflow 2: d=%g, rc=%d\n",
            d, rc);
#endif
    return rc;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_check_numeric                            |
 |  test if all data in variable conforms to its class (type)             |
 |  0 if true, 1 if false.                                                |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_check_numeric(struct fld_desc *f, char *s)
{
    unsigned int i, dig = 0;
    char c;

    if ((f->type == DTYPE_BININT) || (f->type == DTYPE_PACKED) || (f->type
            == DTYPE_FLOAT))
        return 0; /* these types are assumed to always be valid */
    for (i = 0; i < f->len; i++)
    {
        c = s[i];
        /* must have at least one digit */
        if (!dig && (c >= '0') && (c <= '9'))
            dig++;
        if (i == 0 && ((c == ' ') || (c == '+') || (c == '-')))
            continue;
        /* look for a number followed by several spaces (is this valid?) */
        if (c == ' ')
        {
            for (; i < f->len; i++)
            {
                if (s[i] != ' ')
                    return 1;
            }
            break;
        }
        /*
         Omit: NULL picture (bug in refmod's)
         No picture in group items
         */
        if ((f->pic != NULL) && (f->type != DTYPE_GROUP))
        {
            /* take care of signed numbers (non separate sign) */
            if ((i == f->len - 1) && (tcob_picElemVal(f->pic, 0) == 'S'))
            {
                if (strchr("}ABCDEFGHI{JKLMNOPQR", c) != NULL)
                {
                    dig++;
                    break;
                }
            }
        }
        if ((c > '9') || (c < '0'))
            return 1;
    }
    if (!dig)
        return 1;
    return 0;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_check_alphabetic                         |
 |  Is the string alphabetic?  0 if yes, 1 if no.                         |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_check_alphabetic(struct fld_desc *f, char *s)
{
    unsigned int i;
    char c;

    for (i = 0; i < f->len; i++)
    {
        c = s[i];
        if (!((c == ' ') || ((c >= 'a') && (c <= 'z')) || ((c >= 'A') && (c
                <= 'Z'))))
            return 1;
    }
    return 0;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_check_upper                              |
 |  Is the string in upper case?  0 if yes, 1 if no.                      |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_check_upper(struct fld_desc *f, char *s)
{
    unsigned int i;
    char c;

    for (i = 0; i < f->len; i++)
    {
        c = s[i];
        if (!((c == ' ') || ((c >= 'A') && (c <= 'Z'))))
            return 1;
    }
    return 0;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_check_lower                              |
 |  Is the string in lower case?  0 if yes, 1 if no.                      |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_check_lower(struct fld_desc *f, char *s)
{
    unsigned int i;
    char c;

    for (i = 0; i < f->len; i++)
    {
        c = s[i];
        if (!((c == ' ') || ((c >= 'a') && (c <= 'z'))))
            return 1;
    }
    return 0;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_check_condition                          |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_check_condition(struct fld_desc *f1, char *s1, ...)
{
    struct fld_desc *f2, *f3;
    char *s2, *s3;
    int ret = 1; /* assume wrong */
    va_list args;
    double fp1, fp2, fp3;

    va_start(args, s1);
    f2 = va_arg(args, struct fld_desc *);
    while (f2)
    {
        s2 = va_arg(args, char *);
        f3 = va_arg(args, struct fld_desc *);
        s3 = va_arg(args, char *);

        if (f1->type == DTYPE_DISPLAY || f1->type == DTYPE_BININT)
        {
            tcob_fldtod(f1, s1, &fp1);
            tcob_fldtod(f2, s2, &fp2);
            tcob_fldtod(f3, s3, &fp3);
            if ((fp1 >= fp2 && fp1 <= fp3))
            {
                ret = 0;
                break;
            }
        }
        else
        {
            if (tcob_compare(f1, s1, f2, s2) > -1 && tcob_compare(f1, s1, f3,
                    s3) < 1)
            {
                ret = 0;
                break;
            }
        }
        f2 = va_arg(args, struct fld_desc *);
    }
    va_end(args);
    return ret;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_compare_doubles                          |
 |  retorna 1 se d1>d2; 0 se d1==d2; -1 se d1<d2                          |
 |  return  1 if d1>d2; 0 if d1==d2; -1 if d1<d2                          |
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_compare_doubles(double d1, double d2)
{
    if (d1 > d2)
        return 1;
    if (d2 > d1)
        return -1;
    return 0;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          compare_all                                   |
 |  retorna 1 se s1>d2; 0 se s1==s2; -1 se s1<s2                          |
 |  return  1 if s1>s2; 0 if s1==s2; -1 if s1<s2                          |
 |  s1 and s2 must be compared unsigned otherwise High-value compares     |
 |            less than Low-value.                                        |
 |                                                                        |
 \*------------------------------------------------------------------------*/

static int
compare_all(struct fld_desc *f1, char *s1, struct fld_desc *f2, char *s2)
{
    unsigned int i, j, k, maxi;
    unsigned char *us1 = (unsigned char *) s1, *us2 = (unsigned char *) s2;

    maxi = (f1->len < f2->len) ? f1->len : f2->len; /* min (f1->len, f2->len) */
    j = 0;
    k = 0;
    for (i = 0; i < maxi; i++)
    {
        if (us1[j] == us2[k])
            continue;
        if (us1[j] > us2[k])
            return 1;
        if (us1[j] < us2[k])
            return -1;
        j++;
        k++;
        if (f1->all && j >= f1->len)
            j = 0;
        if (f2->all && k >= f2->len)
            k = 0;
    }

    if (f1->len > f2->len)
        while (j < f1->len)
        {
            if (us1[j++] != us2[k++])
                return 1;
            if (k >= f2->len)
                k = 0;
        }
    else
        while (k < f2->len)
        {
            if (us2[k++] != us1[j++])
                return -1;
            if (j >= f1->len)
                j = 0;
        }
    return 0;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_compare                                  |
 |  retorna 1 se s1>s2; 0 se s1==s2; -1 se s1<s2                          |
 |  return  1 if s1>s2; 0 if s1==s2; -1 if s1<s2                          |
 |  s1 and s2 must be declared unsigned otherwise High-value compares     |
 |            less than Low-value.
 |                                                                        |
 \*------------------------------------------------------------------------*/

int
tcob_compare(struct fld_desc *f1, char *s1, struct fld_desc *f2, char *s2)
{
    unsigned int i, maxi;
    double fp1, fp2;
    char c1, c2;
    unsigned char *us1 = (unsigned char *) s1, *us2 = (unsigned char *) s2;

    if ((f1->type == DTYPE_ALPHANUMERIC || f1->type == DTYPE_GROUP)
            && (f2->type == DTYPE_ALPHANUMERIC || f2->type == DTYPE_GROUP))
    { /* compare strings */
        if (f1->all || f2->all)
            return (compare_all(f1, s1, f2, s2));
        maxi = (f1->len < f2->len) ? f1->len : f2->len; /* min (f1->len, f2->len) */
        for (i = 0; i < maxi; i++)
        {
            if (us1[i] == us2[i])
                continue;
            if (us1[i] > us2[i])
                return 1;
            if (us1[i] < us2[i])
                return -1;
        }
        if (f1->len > f2->len)
            for (; i < f1->len; i++)
            {
                if (us1[i] != ' ')
                    return 1;
            }
        else
            for (; i < f2->len; i++)
            {
                if (us2[i] != ' ')
                    return -1;
            }
    }
    else if ((f1->type != DTYPE_DISPLAY && f1->type != DTYPE_PACKED && f1->type
            != DTYPE_BININT) || (f2->type != DTYPE_DISPLAY && f2->type
            != DTYPE_PACKED && f2->type != DTYPE_BININT))
    { /* compare strings */
        if (f1->all || f2->all)
            return (compare_all(f1, s1, f2, s2));
        maxi = (f1->len < f2->len) ? f1->len : f2->len; /* min (f1->len, f2->len) */
        for (i = 0; i < maxi; i++)
        {
            if (us1[i] == us2[i])
                continue;
            c1 = s1[i];
            c2 = s2[i];
            /* ignore the signs if any */
            if (f1->type == DTYPE_DISPLAY && tcob_picElemVal(f1->pic, 0) == 'S')
            {
                c1 = (char) tcob_char_to_sign(c1);
                c1 = c1 < 0 ? (c1 * -1) + '0' : c1 + '0';
            }
            if (f2->type == DTYPE_DISPLAY && tcob_picElemVal(f2->pic, 0) == 'S')
            {
                c2 = (char) tcob_char_to_sign(c2);
                c2 = c2 < 0 ? (c2 * -1) + '0' : c2 + '0';
            }
            if (c1 == c2)
                continue;
            if (c1 > c2)
                return 1;
            if (c1 < c2)
                return -1;
        }
        if (f1->len > f2->len)
            for (; i < f1->len; i++)
            {
                if (us1[i] != ' ')
                    return 1;
            }
        else
            for (; i < f2->len; i++)
            {
                if (us2[i] != ' ')
                    return -1;
            }
    }
    else
    {
        tcob_fldtod(f1, s1, &fp1);
        tcob_fldtod(f2, s2, &fp2);
        if (fp1 > fp2)
            return 1;
        if (fp2 > fp1)
            return -1;
    }
    return 0;
}

/*------------------------------------------------------------------------*\
 |                                                                        |
 |                          tcob_assign_int                               |
 |                                                                        |
 \*------------------------------------------------------------------------*/

void
tcob_assign_int(struct fld_desc *desc, char *val, int value)
{
    tcob_move(&_generic_4binary, (char *) & value, desc, val);
}

/* end of MCMATH.C */