OpenCOBOL 1.1pre-rel
Functions
intrinsic.h File Reference
#include <libcob/common.h>
Include dependency graph for intrinsic.h:
This graph shows which files directly or indirectly include this file:

Go to the source code of this file.

Functions

cob_fieldcob_intr_binop (cob_field *, int, cob_field *)
cob_fieldcob_intr_current_date (const int, const int)
cob_fieldcob_intr_when_compiled (const int, const int, cob_field *)
cob_fieldcob_intr_exception_file (void)
cob_fieldcob_intr_exception_location (void)
cob_fieldcob_intr_exception_status (void)
cob_fieldcob_intr_exception_statement (void)
cob_fieldcob_intr_char (cob_field *)
cob_fieldcob_intr_ord (cob_field *)
cob_fieldcob_intr_stored_char_length (cob_field *)
cob_fieldcob_intr_combined_datetime (cob_field *, cob_field *)
cob_fieldcob_intr_date_of_integer (cob_field *)
cob_fieldcob_intr_day_of_integer (cob_field *)
cob_fieldcob_intr_integer_of_date (cob_field *)
cob_fieldcob_intr_integer_of_day (cob_field *)
cob_fieldcob_intr_test_date_yyyymmdd (cob_field *)
cob_fieldcob_intr_test_day_yyyyddd (cob_field *)
cob_fieldcob_intr_factorial (cob_field *)
cob_fieldcob_intr_exp (cob_field *)
cob_fieldcob_intr_exp10 (cob_field *)
cob_fieldcob_intr_abs (cob_field *)
cob_fieldcob_intr_acos (cob_field *)
cob_fieldcob_intr_asin (cob_field *)
cob_fieldcob_intr_atan (cob_field *)
cob_fieldcob_intr_cos (cob_field *)
cob_fieldcob_intr_log (cob_field *)
cob_fieldcob_intr_log10 (cob_field *)
cob_fieldcob_intr_sin (cob_field *)
cob_fieldcob_intr_sqrt (cob_field *)
cob_fieldcob_intr_tan (cob_field *)
cob_fieldcob_intr_upper_case (const int, const int, cob_field *)
cob_fieldcob_intr_lower_case (const int, const int, cob_field *)
cob_fieldcob_intr_reverse (const int, const int, cob_field *)
cob_fieldcob_intr_concatenate (const int, const int, const int,...)
cob_fieldcob_intr_substitute (const int, const int, const int,...)
cob_fieldcob_intr_substitute_case (const int, const int, const int,...)
cob_fieldcob_intr_trim (const int, const int, cob_field *, const int)
cob_fieldcob_intr_length (cob_field *)
cob_fieldcob_intr_integer (cob_field *)
cob_fieldcob_intr_integer_part (cob_field *)
cob_fieldcob_intr_fraction_part (cob_field *)
cob_fieldcob_intr_sign (cob_field *)
cob_fieldcob_intr_numval (cob_field *)
cob_fieldcob_intr_numval_c (cob_field *, cob_field *)
cob_fieldcob_intr_annuity (cob_field *, cob_field *)
cob_fieldcob_intr_mod (cob_field *, cob_field *)
cob_fieldcob_intr_rem (cob_field *, cob_field *)
cob_fieldcob_intr_sum (const int,...)
cob_fieldcob_intr_ord_min (const int,...)
cob_fieldcob_intr_ord_max (const int,...)
cob_fieldcob_intr_min (const int,...)
cob_fieldcob_intr_max (const int,...)
cob_fieldcob_intr_midrange (const int,...)
cob_fieldcob_intr_median (const int,...)
cob_fieldcob_intr_mean (const int,...)
cob_fieldcob_intr_range (const int,...)
cob_fieldcob_intr_random (const int,...)
cob_fieldcob_intr_variance (const int,...)
cob_fieldcob_intr_standard_deviation (const int,...)
cob_fieldcob_intr_present_value (const int,...)
cob_fieldcob_intr_year_to_yyyy (const int,...)
cob_fieldcob_intr_date_to_yyyymmdd (const int,...)
cob_fieldcob_intr_day_to_yyyyddd (const int,...)
cob_fieldcob_intr_locale_date (const int, const int, cob_field *, cob_field *)
cob_fieldcob_intr_locale_time (const int, const int, cob_field *, cob_field *)
cob_fieldcob_intr_seconds_past_midnight (void)
cob_fieldcob_intr_lcl_time_from_secs (const int, const int, cob_field *, cob_field *)
cob_fieldcob_intr_seconds_from_formatted_time (cob_field *, cob_field *)

Function Documentation

cob_field* cob_intr_abs ( cob_field )

Definition at line 1545 of file intrinsic.c.

{

        make_field_entry (srcfield);

        cob_decimal_set_field (&d1, srcfield);
        mpz_abs (d1.value, d1.value);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_acos ( cob_field )

Definition at line 1557 of file intrinsic.c.

{
        unsigned long long      result;
        double                  mathd2;
        int                     i, tempres;
        cob_field_attr          attr;
        cob_field               field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, 0, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        cob_decimal_set_field (&d1, srcfield);
        make_field_entry (&field);
        
        errno = 0;
        mathd2 = acos (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }

        result = (unsigned long long) mathd2;
        mathd2 -= result;
        for (i = 0; i < 17; ++i) {
                mathd2 *= 10;
                tempres = (int) mathd2;
                result *= 10;
                result += tempres;
                mathd2 -= tempres;
        }
        memcpy (curr_field->data, (char *)&result, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_annuity ( cob_field ,
cob_field  
)

Definition at line 1974 of file intrinsic.c.

{
        double          mathd1, mathd2;

        make_double_entry ();

        cob_decimal_set_field (&d1, srcfield1);
        cob_decimal_set_field (&d2, srcfield2);
        
        mathd1 = intr_get_double (&d1);
        mathd2 = intr_get_double (&d2);
        if (mathd1 == 0) {
                mathd1 = 1.0 / mathd2;
                memcpy (curr_field->data, (char *)&mathd1, sizeof (double));
                return curr_field;
        }
        mathd1 /= (1.0 - pow (mathd1 + 1.0, 0.0 - mathd2));
        memcpy (curr_field->data, (char *)&mathd1, sizeof (double));
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_asin ( cob_field )

Definition at line 1591 of file intrinsic.c.

{
        long long               result;
        double                  mathd2;
        int                     i, tempres;
        cob_field_attr          attr;
        cob_field               field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        cob_decimal_set_field (&d1, srcfield);
        make_field_entry (&field);

        errno = 0;
        mathd2 = asin (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        result = (long long) mathd2;
        mathd2 -= result;
        for (i = 0; i < 17; ++i) {
                mathd2 *= 10;
                tempres = (int) mathd2;
                result *= 10;
                result += tempres;
                mathd2 -= tempres;
        }
        memcpy (curr_field->data, (char *)&result, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_atan ( cob_field )

Definition at line 1624 of file intrinsic.c.

{
        long long               result;
        double                  mathd2;
        int                     i, tempres;
        cob_field_attr          attr;
        cob_field               field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        cob_decimal_set_field (&d1, srcfield);
        make_field_entry (&field);

        errno = 0;
        mathd2 = atan (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        result = (long long) mathd2;
        mathd2 -= result;
        for (i = 0; i < 17; ++i) {
                mathd2 *= 10;
                tempres = (int) mathd2;
                result *= 10;
                result += tempres;
                mathd2 -= tempres;
        }
        memcpy (curr_field->data, (char *)&result, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_binop ( cob_field ,
int  ,
cob_field  
)

Definition at line 432 of file intrinsic.c.

{
/* RXW
        size_t          bitnum;
        size_t          sign;
        size_t          attrsign;
        cob_field_attr  attr;
        cob_field       field;
*/

        cob_decimal_set_field (&d1, f1);
        cob_decimal_set_field (&d2, f2);
        switch (op) {
        case '+':
                cob_decimal_add (&d1, &d2);
                break;
        case '-':
                cob_decimal_sub (&d1, &d2);
                break;
        case '*':
                cob_decimal_mul (&d1, &d2);
                break;
        case '/':
                cob_decimal_div (&d1, &d2);
                break;
        case '^':
                cob_decimal_pow (&d1, &d2);
                break;
        default:
                break;
        }

/* RXW
        if (mpz_sgn (d1.value) < 0) {
                attrsign = COB_FLAG_HAVE_SIGN;
                sign = 1;
        } else {
                attrsign = 0;
                sign = 0;
        }
        bitnum = mpz_sizeinbase (d1.value, 2);
        if (bitnum < 33 - sign) {
                COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, attrsign, NULL);
                COB_FIELD_INIT (4, NULL, &attr);
                attr.scale = d1.scale;
                make_field_entry (&field);
        } else if (bitnum < 65 - sign) {
                COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, attrsign, NULL);
                COB_FIELD_INIT (8, NULL, &attr);
                attr.scale = d1.scale;
                make_field_entry (&field);
        } else {
*/
                make_double_entry ();
/* RXW
        }
*/
        cob_decimal_get_field (&d1, curr_field, 0);
        
        return curr_field;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cob_field* cob_intr_char ( cob_field )

Definition at line 1121 of file intrinsic.c.

{
        int             i;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (1, NULL, &attr);
        make_field_entry (&field);

        i = cob_get_int (srcfield);
        if (i < 1 || i > 256) {
                *curr_field->data = 0;
        } else {
                *curr_field->data = i - 1;
        }
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_combined_datetime ( cob_field ,
cob_field  
)

Definition at line 1178 of file intrinsic.c.

{
        int             srdays;
        int             srtime;
        cob_field_attr  attr;
        cob_field       field;
        char            buff[16];

        COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 12, 5, 0, NULL);
        COB_FIELD_INIT (12, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        srdays = cob_get_int (srcdays);
        if (srdays < 1 || srdays > 3067671) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                memset (curr_field->data, '0', 12);
                return curr_field;
        }
        srtime = cob_get_int (srctime);
        if (srtime < 1 || srtime > 86400) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                memset (curr_field->data, '0', 12);
                return curr_field;
        }
        snprintf (buff, 15, "%7.7d%5.5d", srdays, srtime);
        memcpy (curr_field->data, buff, 12);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_concatenate ( const int  ,
const int  ,
const int  ,
  ... 
)

Definition at line 639 of file intrinsic.c.

{
        cob_field       **f;
        unsigned char   *p;
        size_t          calcsize;
        int             i;
        cob_field_attr  attr;
        cob_field       field;
        va_list         args;

        f = cob_malloc (params * sizeof (cob_field *));

        va_start (args, params);

        /* Extract args / calculate size */
        calcsize = 0;
        for (i = 0; i < params; ++i) {
                f[i] = va_arg (args, cob_field *);
                calcsize += f[i]->size;
        }

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (calcsize, NULL, &attr);
        make_field_entry (&field);

        p = curr_field->data;
        for (i = 0; i < params; ++i) {
                memcpy (p, f[i]->data, f[i]->size);
                p += f[i]->size;
        }

        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        free (f);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_cos ( cob_field )

Definition at line 1657 of file intrinsic.c.

{
        long long               result;
        double                  mathd2;
        int                     i, tempres;
        cob_field_attr          attr;
        cob_field               field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        cob_decimal_set_field (&d1, srcfield);
        make_field_entry (&field);

        errno = 0;
        mathd2 = cos (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        result = (long long) mathd2;
        mathd2 -= result;
        for (i = 0; i < 17; ++i) {
                mathd2 *= 10;
                tempres = (int) mathd2;
                result *= 10;
                result += tempres;
                mathd2 -= tempres;
        }
        memcpy (curr_field->data, (char *)&result, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_current_date ( const int  ,
const int   
)

Definition at line 1032 of file intrinsic.c.

{
#if     defined(_WIN32) && !defined(__CYGWIN__)
        long            contz;
        struct tm       *tmptr;
        struct _timeb   tmb;
        cob_field_attr  attr;
        cob_field       field;
#else
#if !defined(__linux__) && !defined(__CYGWIN__) && !defined(COB_STRFTIME) && defined(HAVE_TIMEZONE)
        struct tm       *tmptr;
        long            contz;
#endif
        time_t          curtime;
        cob_field_attr  attr;
        cob_field       field;
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
        struct timeval  tmv;
        char            buff2[8];
#endif
#endif  /* _WIN32 */
        char            buff[24];

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (21, NULL, &attr);
        make_field_entry (&field);
        memset (buff, 0, sizeof(buff));

#if     defined(_WIN32) && !defined(__CYGWIN__)
        _ftime (&tmb);
        tmptr = localtime (&(tmb.time));
        if (tmb.timezone <= 0) {
                contz = -tmb.timezone;
                snprintf (buff, 23,
                        "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d+%2.2ld%2.2ld",
                        tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
                        tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
                        tmb.millitm / 100, contz / 60, contz % 60);
        } else {
                contz = tmb.timezone;
                snprintf (buff, 23,
                        "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d-%2.2ld%2.2ld",
                        tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
                        tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
                        tmb.millitm / 100, contz / 60, contz % 60);
        }
#else
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
        gettimeofday (&tmv, NULL);
        curtime = tmv.tv_sec;
#else
        curtime = time (NULL);
#endif

#if defined(__linux__) || defined(__CYGWIN__) || defined(COB_STRFTIME)
        strftime (buff, 22, "%Y%m%d%H%M%S00%z", localtime (&curtime));
#elif defined(HAVE_TIMEZONE)
        tmptr = localtime (&curtime);
        strftime (buff, 17, "%Y%m%d%H%M%S00", tmptr);
        /* RXW - Hack for DST - Need something better */
        if (tmptr->tm_isdst > 0) {
                timezone -= 3600;
        }
        if (timezone <= 0) {
                contz = -timezone;
                buff[16] = '+';
        } else {
                contz = timezone;
                buff[16] = '-';
        }
        sprintf(&buff[17], "%2.2ld%2.2ld", contz / 3600, (contz % 3600) / 60);
#else
        strftime (buff, 22, "%Y%m%d%H%M%S0000000", localtime (&curtime));
#endif

#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
        snprintf(buff2, 7, "%2.2ld", tmv.tv_usec / 10000);
        memcpy (&buff[14], buff2, 2);
#endif
#endif  /* _WIN32 */

        memcpy (curr_field->data, buff, 21);
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
}
cob_field* cob_intr_date_of_integer ( cob_field )

Definition at line 1209 of file intrinsic.c.

{
        int             i;
        int             days;
        int             baseyear = 1601;
        int             leapyear = 365;
        cob_field_attr  attr;
        cob_field       field;
        char            buff[16];

        COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        /* Base 1601-01-01 */
        days = cob_get_int (srcdays);
        if (days < 1 || days > 3067671) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                memset (curr_field->data, '0', 8);
                return curr_field;
        }
        while (days > leapyear) {
                days -= leapyear;
                ++baseyear;
                if (leap_year (baseyear)) {
                        leapyear = 366;
                } else {
                        leapyear = 365;
                }
        }
        for (i = 0; i < 13; ++i) {
                if (leap_year (baseyear)) {
                        if (days <= leap_days[i]) {
                                days -= leap_days[i-1];
                                break;
                        }
                } else {
                        if (days <= normal_days[i]) {
                                days -= normal_days[i-1];
                                break;
                        }
                }
        }
        snprintf (buff, 15, "%4.4d%2.2d%2.2d", baseyear, i, days);
        memcpy (curr_field->data, buff, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_date_to_yyyymmdd ( const int  ,
  ... 
)

Definition at line 2646 of file intrinsic.c.

{
        cob_field       *f;
        struct tm       *timeptr;
        va_list         args;
        time_t          t;
        int             year;
        int             mmdd;
        int             interval;
        int             xqtyear;
        int             maxyear;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        va_start (args, params);
        f = va_arg (args, cob_field *);
        year = cob_get_int (f);
        mmdd = year % 10000;
        year /= 10000;
        if (params > 1) {
                f = va_arg (args, cob_field *);
                interval = cob_get_int (f);
        } else {
                interval = 50;
        }
        if (params > 2) {
                f = va_arg (args, cob_field *);
                xqtyear = cob_get_int (f);
        } else {
                t = time (NULL);
                timeptr = localtime (&t);
                xqtyear = 1900 + timeptr->tm_year;
        }
        va_end (args);

        if (year < 0 || year > 999999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        if (xqtyear < 1601 || xqtyear > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        maxyear = xqtyear + interval;
        if (maxyear < 1700 || maxyear > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        if (maxyear % 100 >= year) {
                year += 100 * (maxyear / 100);
        } else {
                year += 100 * ((maxyear / 100) - 1);
        }
        year *= 10000;
        year += mmdd;
        cob_set_int (curr_field, year);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_day_of_integer ( cob_field )

Definition at line 1259 of file intrinsic.c.

{
        int             days;
        int             baseyear = 1601;
        int             leapyear = 365;
        cob_field_attr  attr;
        cob_field       field;
        char            buff[16];

        COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 7, 0, 0, NULL);
        COB_FIELD_INIT (7, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        /* Base 1601-01-01 */
        days = cob_get_int (srcdays);
        if (days < 1 || days > 3067671) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                memset (curr_field->data, '0', 7);
                return curr_field;
        }
        while (days > leapyear) {
                days -= leapyear;
                ++baseyear;
                if (leap_year (baseyear)) {
                        leapyear = 366;
                } else {
                        leapyear = 365;
                }
        }
        snprintf (buff, 15, "%4.4d%3.3d", baseyear, days);
        memcpy (curr_field->data, buff, 7);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_day_to_yyyyddd ( const int  ,
  ... 
)

Definition at line 2714 of file intrinsic.c.

{
        cob_field       *f;
        struct tm       *timeptr;
        va_list         args;
        time_t          t;
        int             year;
        int             days;
        int             interval;
        int             xqtyear;
        int             maxyear;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        va_start (args, params);
        f = va_arg (args, cob_field *);
        year = cob_get_int (f);
        days = year % 1000;
        year /= 1000;
        if (params > 1) {
                f = va_arg (args, cob_field *);
                interval = cob_get_int (f);
        } else {
                interval = 50;
        }
        if (params > 2) {
                f = va_arg (args, cob_field *);
                xqtyear = cob_get_int (f);
        } else {
                t = time (NULL);
                timeptr = localtime (&t);
                xqtyear = 1900 + timeptr->tm_year;
        }
        va_end (args);

        if (year < 0 || year > 999999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        if (xqtyear < 1601 || xqtyear > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        maxyear = xqtyear + interval;
        if (maxyear < 1700 || maxyear > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        if (maxyear % 100 >= year) {
                year += 100 * (maxyear / 100);
        } else {
                year += 100 * ((maxyear / 100) - 1);
        }
        year *= 1000;
        year += days;
        cob_set_int (curr_field, year);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_exception_file ( void  )

Definition at line 916 of file intrinsic.c.

{
        size_t          flen;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (0, NULL, &attr);
        if (cob_exception_code == 0 || !cob_error_file ||
            (cob_exception_code & 0x0500) != 0x0500) {
                field.size = 2;
                make_field_entry (&field);
                memcpy (curr_field->data, "00", 2);
        } else {
                flen = strlen (cob_error_file->select_name);
                field.size = flen + 2;
                make_field_entry (&field);
                memcpy (curr_field->data, cob_error_file->file_status, 2);
                memcpy (&(curr_field->data[2]), cob_error_file->select_name, flen);
        }
        return curr_field;
}
cob_field* cob_intr_exception_location ( void  )

Definition at line 940 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (0, NULL, &attr);
        if (!cob_got_exception || !cob_orig_program_id) {
                field.size = 1;
                make_field_entry (&field);
                *(curr_field->data) = ' ';
                return curr_field;
        }
        memset (locale_buff, 0, COB_SMALL_BUFF);
        if (cob_orig_section && cob_orig_paragraph) {
                snprintf (locale_buff, COB_SMALL_MAX, "%s; %s OF %s; %d",
                          cob_orig_program_id, cob_orig_paragraph,
                          cob_orig_section, cob_orig_line);
        } else if (cob_orig_section) {
                snprintf (locale_buff, COB_SMALL_MAX, "%s; %s; %d",
                          cob_orig_program_id, cob_orig_section, cob_orig_line);
        } else if (cob_orig_paragraph) {
                snprintf (locale_buff, COB_SMALL_MAX, "%s; %s; %d",
                          cob_orig_program_id, cob_orig_paragraph, cob_orig_line);
        } else {
                snprintf (locale_buff, COB_SMALL_MAX, "%s; ; %d",
                          cob_orig_program_id, cob_orig_line);
        }
        field.size = strlen (locale_buff);
        make_field_entry (&field);
        memcpy (curr_field->data, locale_buff, field.size);
        return curr_field;
}
cob_field* cob_intr_exception_statement ( void  )

Definition at line 997 of file intrinsic.c.

{
        size_t          flen;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (31, NULL, &attr);
        make_field_entry (&field);

        memset (curr_field->data, ' ', 31);
        if (cob_exception_code && cob_orig_statement) {
                flen = strlen (cob_orig_statement);
                if (flen > 31) {
                        memcpy (curr_field->data, cob_orig_statement, 31);
                } else {
                        memcpy (curr_field->data, cob_orig_statement, flen);
                }
        }
        return curr_field;
}
cob_field* cob_intr_exception_status ( void  )

Definition at line 975 of file intrinsic.c.

{
        const char      *except_name;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (31, NULL, &attr);
        make_field_entry (&field);

        memset (curr_field->data, ' ', 31);
        if (cob_exception_code) {
                except_name = cob_get_exception_name (cob_exception_code);
                if (except_name == NULL) {
                        except_name = "EXCEPTION-OBJECT";
                }
                memcpy (curr_field->data, except_name, strlen (except_name));
        }
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_exp ( cob_field )

Definition at line 1509 of file intrinsic.c.

{
        double          mathd2;

        cob_decimal_set_field (&d1, srcfield);
        make_double_entry ();

        errno = 0;
        mathd2 = pow (2.7182818284590452354, intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        memcpy (curr_field->data, (char *)&mathd2, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_exp10 ( cob_field )

Definition at line 1527 of file intrinsic.c.

{
        double          mathd2;

        cob_decimal_set_field (&d1, srcfield);
        make_double_entry ();

        errno = 0;
        mathd2 = pow (10.0, intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        memcpy (curr_field->data, (char *)&mathd2, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_factorial ( cob_field )

Definition at line 1485 of file intrinsic.c.

{
        int             srcval;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, 0, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        srcval = cob_get_int (srcfield);
        if (srcval < 0) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        d1.scale = 0;
        mpz_fac_ui (d1.value, (unsigned int)srcval);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_fraction_part ( cob_field )

Definition at line 552 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 18, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        make_field_entry (&field);

        cob_move (srcfield, curr_field);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_integer ( cob_field )

Definition at line 511 of file intrinsic.c.

{
        int             i, scale;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        make_field_entry (&field);

        cob_decimal_set_field (&d1, srcfield);
        if (mpz_sgn (d1.value) >= 0) {
                cob_decimal_get_field (&d1, curr_field, 0);
                return curr_field;
        }
        scale = 1;
        for (i = 0; i < d1.scale; ++i) {
                scale *= 10;
        }
        if (mpz_fdiv_ui (d1.value, (unsigned int)scale)) {
                mpz_sub_ui (d1.value, d1.value, (unsigned int)scale);
        }
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cob_field* cob_intr_integer_of_date ( cob_field )

Definition at line 1295 of file intrinsic.c.

{
        int             indate;
        int             days;
        int             totaldays;
        int             month;
        int             year;
        int             baseyear = 1601;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        /* Base 1601-01-01 */
        indate = cob_get_int (srcfield);
        year = indate / 10000;
        if (year < 1601 || year > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        indate %= 10000;
        month = indate / 100;
        if (month < 1 || month > 12) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        days = indate % 100;
        if (days < 1 || days > 31) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        if (leap_year (year)) {
                if (days > leap_month_days[month]) {
                        cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                        cob_set_int (curr_field, 0);
                        return curr_field;
                }
        } else {
                if (days > normal_month_days[month]) {
                        cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                        cob_set_int (curr_field, 0);
                        return curr_field;
                }
        }
        totaldays = 0;
        while (baseyear != year) {
                if (leap_year (baseyear)) {
                        totaldays += 366;
                } else {
                        totaldays += 365;
                }
                ++baseyear;
        }
        if (leap_year (baseyear)) {
                totaldays += leap_days[month - 1];
        } else {
                totaldays += normal_days[month - 1];
        }
        totaldays += days;
        cob_set_int (curr_field, totaldays);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_integer_of_day ( cob_field )

Definition at line 1365 of file intrinsic.c.

{
        int             indate;
        int             days;
        int             totaldays;
        int             year;
        int             baseyear = 1601;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        /* Base 1601-01-01 */
        indate = cob_get_int (srcfield);
        year = indate / 1000;
        if (year < 1601 || year > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        days = indate % 1000;
        if (days < 1 || days > 365 + leap_year (year)) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        totaldays = 0;
        while (baseyear != year) {
                if (leap_year (baseyear)) {
                        totaldays += 366;
                } else {
                        totaldays += 365;
                }
                ++baseyear;
        }
        totaldays += days;
        cob_set_int (curr_field, totaldays);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_integer_part ( cob_field )

Definition at line 538 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        make_field_entry (&field);

        cob_move (srcfield, curr_field);
        return curr_field;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cob_field* cob_intr_lcl_time_from_secs ( const int  ,
const int  ,
cob_field ,
cob_field  
)

Definition at line 3149 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;
#if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
        size_t          len;
        int             indate;
        int             hours;
        int             minutes;
        int             seconds;
#ifdef  HAVE_LANGINFO_CODESET
        char            *deflocale = NULL;
        char            *localep = NULL;
        char            *localep2;
        struct tm       tstruct;
        char            buff2[128];
#else
        char            *p;
        LCID            localeid = LOCALE_USER_DEFAULT;
        SYSTEMTIME      syst;
#endif
        char            buff[128];
#endif

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (0, NULL, &attr);
        cob_exception_code = 0;

#if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
        if (COB_FIELD_IS_NUMERIC (srcfield)) {
                indate = cob_get_int (srcfield);
        } else {
                goto derror;
        }
        if (indate > 86400) {
                goto derror;
        }
        hours = indate / 3600;
        indate %= 3600;
        minutes = indate / 60;
        seconds = indate % 60;

#ifdef  HAVE_LANGINFO_CODESET
        memset ((void *)&tstruct, 0, sizeof(struct tm));
        tstruct.tm_hour = hours;
        tstruct.tm_min = minutes;
        tstruct.tm_sec = seconds;
        if (locale_field) {
                if (locale_field->size >= COB_SMALL_BUFF) {
                        goto derror;
                }
                cob_field_to_string (locale_field, locale_buff);
                deflocale = locale_buff;
                localep2 = setlocale (LC_TIME, NULL);
                if (localep2) {
                        localep = strdup (localep2);
                }
                (void) setlocale (LC_TIME, deflocale);
        }
        memset (buff2, 0, sizeof(buff2));
        snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
        if (deflocale) {
                if (localep) {
                        (void) setlocale (LC_TIME, localep);
                }
        }
        strftime (buff, sizeof(buff), buff2, &tstruct);
#else
        memset ((void *)&syst, 0, sizeof(syst));
        syst.wHour = hours;
        syst.wMinute = minutes;
        syst.wSecond = seconds;
        if (locale_field) {
                if (locale_field->size >= COB_SMALL_BUFF) {
                        goto derror;
                }
                cob_field_to_string (locale_field, locale_buff);
                for (p = locale_buff; *p; ++p) {
                        if (isalnum(*p) || *p == '_') {
                                continue;
                        }
                        break;
                }
                *p = 0;
                for (len = 0; len < WINLOCSIZE; ++len) {
                        if (!strcmp(locale_buff, wintable[len].winlocalename)) {
                                localeid = wintable[len].winlocaleid;
                                break;
                        }
                }
                if (len == WINLOCSIZE) {
                        goto derror;
                }
        }
        if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {

                goto derror;
        }
#endif
        len = strlen (buff);
        field.size = len;
        make_field_entry (&field);
        memcpy (curr_field->data, buff, len);
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
derror:
#endif
        field.size = 10;
        make_field_entry (&field);
        memset (curr_field->data, ' ', 10);
        cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_length ( cob_field )

Definition at line 497 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_set_int (curr_field, (int)srcfield->size);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_locale_date ( const int  ,
const int  ,
cob_field ,
cob_field  
)

Definition at line 2866 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;
#if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
        size_t          len;
        int             indate;
        int             days;
        int             month;
        int             year;
#ifdef  HAVE_LANGINFO_CODESET
        unsigned char   *p;
        char            *deflocale = NULL;
        char            *localep = NULL;
        char            *localep2;
        struct tm       tstruct;
        char            buff2[128];
#else
        char            *p;
        LCID            localeid = LOCALE_USER_DEFAULT;
        SYSTEMTIME      syst;
#endif
        char            buff[128];
#endif

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (0, NULL, &attr);
        cob_exception_code = 0;

#if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
        if (COB_FIELD_IS_NUMERIC (srcfield)) {
                indate = cob_get_int (srcfield);
        } else {
                if (srcfield->size < 8) {
                        goto derror;
                }
                p = srcfield->data;
                indate = 0;
                for (len = 0; len < 8; ++len, ++p) {
                        if (isdigit (*p)) {
                                indate *= 10;
                                indate += (*p - '0');
                        } else {
                                goto derror;
                        }
                }
        }
        year = indate / 10000;
        if (year < 1601 || year > 9999) {
                goto derror;
        }
        indate %= 10000;
        month = indate / 100;
        if (month < 1 || month > 12) {
                goto derror;
        }
        days = indate % 100;
        if (days < 1 || days > 31) {
                goto derror;
        }
        if (leap_year (year)) {
                if (days > leap_month_days[month]) {
                        goto derror;
                }
        } else {
                if (days > normal_month_days[month]) {
                        goto derror;
                }
        }
#ifdef  HAVE_LANGINFO_CODESET
        month--;

        memset ((void *)&tstruct, 0, sizeof(struct tm));
        tstruct.tm_year = year - 1900;
        tstruct.tm_mon = month;
        tstruct.tm_mday = days;
        if (locale_field) {
                if (locale_field->size >= COB_SMALL_BUFF) {
                        goto derror;
                }
                cob_field_to_string (locale_field, locale_buff);
                deflocale = locale_buff;
                localep2 = setlocale (LC_TIME, NULL);
                if (localep2) {
                        localep = strdup (localep2);
                }
                (void) setlocale (LC_TIME, deflocale);
        }
        memset (buff2, 0, sizeof(buff2));
        snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(D_FMT));
        if (deflocale) {
                if (localep) {
                        (void) setlocale (LC_TIME, localep);
                }
        }
        strftime (buff, sizeof(buff), buff2, &tstruct);
#else
        memset ((void *)&syst, 0, sizeof(syst));
        syst.wYear = year;
        syst.wMonth = month;
        syst.wDay = days;
        if (locale_field) {
                if (locale_field->size >= COB_SMALL_BUFF) {
                        goto derror;
                }
                cob_field_to_string (locale_field, locale_buff);
                for (p = locale_buff; *p; ++p) {
                        if (isalnum(*p) || *p == '_') {
                                continue;
                        }
                        break;
                }
                *p = 0;
                for (len = 0; len < WINLOCSIZE; ++len) {
                        if (!strcmp(locale_buff, wintable[len].winlocalename)) {
                                localeid = wintable[len].winlocaleid;
                                break;
                        }
                }
                if (len == WINLOCSIZE) {
                        goto derror;
                }
        }
        if (!GetDateFormat (localeid, DATE_SHORTDATE, &syst, NULL, buff, sizeof(buff))) {
                goto derror;
        }
#endif
        len = strlen (buff);
        field.size = len;
        make_field_entry (&field);
        memcpy (curr_field->data, buff, len);
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
derror:
#endif
        field.size = 10;
        make_field_entry (&field);
        memset (curr_field->data, ' ', 10);
        cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_locale_time ( const int  ,
const int  ,
cob_field ,
cob_field  
)

Definition at line 3012 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;
#if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
        size_t          len;
        int             indate;
        int             hours;
        int             minutes;
        int             seconds;
#ifdef  HAVE_LANGINFO_CODESET
        unsigned char   *p;
        char            *deflocale = NULL;
        char            *localep = NULL;
        char            *localep2;
        struct tm       tstruct;
        char            buff2[128];
#else
        char            *p;
        LCID            localeid = LOCALE_USER_DEFAULT;
        SYSTEMTIME      syst;
#endif
        char            buff[128];
#endif

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (0, NULL, &attr);
        cob_exception_code = 0;

#if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
        if (COB_FIELD_IS_NUMERIC (srcfield)) {
                indate = cob_get_int (srcfield);
        } else {
                if (srcfield->size < 6) {
                        goto derror;
                }
                p = srcfield->data;
                indate = 0;
                for (len = 0; len < 6; ++len, ++p) {
                        if (isdigit (*p)) {
                                indate *= 10;
                                indate += (*p - '0');
                        } else {
                                goto derror;
                        }
                }
        }
        hours = indate / 10000;
        if (hours < 0 || hours > 24) {
                goto derror;
        }
        indate %= 10000;
        minutes = indate / 100;
        if (minutes < 0 || minutes > 59) {
                goto derror;
        }
        seconds = indate % 100;
        if (seconds < 0 || seconds > 59) {
                goto derror;
        }

#ifdef  HAVE_LANGINFO_CODESET
        memset ((void *)&tstruct, 0, sizeof(struct tm));
        tstruct.tm_hour = hours;
        tstruct.tm_min = minutes;
        tstruct.tm_sec = seconds;
        if (locale_field) {
                if (locale_field->size >= COB_SMALL_BUFF) {
                        goto derror;
                }
                cob_field_to_string (locale_field, locale_buff);
                deflocale = locale_buff;
                localep2 = setlocale (LC_TIME, NULL);
                if (localep2) {
                        localep = strdup (localep2);
                }
                (void) setlocale (LC_TIME, deflocale);
        }
        memset (buff2, 0, sizeof(buff2));
        snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
        if (deflocale) {
                if (localep) {
                        (void) setlocale (LC_TIME, localep);
                }
        }
        strftime (buff, sizeof(buff), buff2, &tstruct);
#else
        memset ((void *)&syst, 0, sizeof(syst));
        syst.wHour = hours;
        syst.wMinute = minutes;
        syst.wSecond = seconds;
        if (locale_field) {
                if (locale_field->size >= COB_SMALL_BUFF) {
                        goto derror;
                }
                cob_field_to_string (locale_field, locale_buff);
                for (p = locale_buff; *p; ++p) {
                        if (isalnum(*p) || *p == '_') {
                                continue;
                        }
                        break;
                }
                *p = 0;
                for (len = 0; len < WINLOCSIZE; ++len) {
                        if (!strcmp(locale_buff, wintable[len].winlocalename)) {
                                localeid = wintable[len].winlocaleid;
                                break;
                        }
                }
                if (len == WINLOCSIZE) {
                        goto derror;
                }
        }
        if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {

                goto derror;
        }
#endif
        len = strlen (buff);
        field.size = len;
        make_field_entry (&field);
        memcpy (curr_field->data, buff, len);
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
derror:
#endif
        field.size = 10;
        make_field_entry (&field);
        memset (curr_field->data, ' ', 10);
        cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_log ( cob_field )

Definition at line 1690 of file intrinsic.c.

{
        double          mathd2;

        cob_decimal_set_field (&d1, srcfield);
        make_double_entry ();

        errno = 0;
        mathd2 = log (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        memcpy (curr_field->data, (char *)&mathd2, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_log10 ( cob_field )

Definition at line 1708 of file intrinsic.c.

{
        double          mathd2;

        cob_decimal_set_field (&d1, srcfield);
        make_double_entry ();

        errno = 0;
        mathd2 = log10 (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        memcpy (curr_field->data, (char *)&mathd2, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_lower_case ( const int  ,
const int  ,
cob_field  
)

Definition at line 605 of file intrinsic.c.

{
        size_t          i, size;

        make_field_entry (srcfield);

        size = srcfield->size;
        for (i = 0; i < size; ++i) {
                curr_field->data[i] = tolower (srcfield->data[i]);
        }
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
}
cob_field* cob_intr_max ( const int  ,
  ... 
)

Definition at line 2125 of file intrinsic.c.

{
        cob_field       *f, *basef;
        va_list         args;
        int             i;

        va_start (args, params);

        basef = va_arg (args, cob_field *);
        for (i = 1; i < params; ++i) {
                f = va_arg (args, cob_field *);
                if (cob_cmp (f, basef) > 0) {
                        basef = f;
                }
        }
        va_end (args);

        return basef;
}

Here is the call graph for this function:

cob_field* cob_intr_mean ( const int  ,
  ... 
)

Definition at line 2224 of file intrinsic.c.

{
        cob_field       *f;
        va_list         args;
        long long       n;
        union {
                unsigned char   data[8];
                long long       datall;
        } datun;
        int             i;
        cob_field_attr  attr;
        cob_field       field;


        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        mpz_set_ui (d1.value, 0);
        d1.scale = 0;

        va_start (args, params);
        for (i = 0; i < params; ++i) {
                f = va_arg (args, cob_field *);
                cob_decimal_set_field (&d2, f);
                cob_decimal_add (&d1, &d2);
        }
        va_end (args);

        mpz_set_ui (d2.value, (unsigned int)params);
        d2.scale = 0;
        cob_decimal_div (&d1, &d2);
        field.data = datun.data;
        cob_decimal_get_field (&d1, &field, 0);
        n = datun.datall;
        for (i = 0; n; n /= 10, ++i) ;
        field.data = NULL;
        if (i <= 18) {
                attr.scale = 18 - i;
        }
        make_field_entry (&field);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_median ( const int  ,
  ... 
)

Definition at line 2179 of file intrinsic.c.

{
        cob_field       *f;
        cob_field       **field_alloc;
        va_list         args;
        int             i;

        va_start (args, params);

        f = va_arg (args, cob_field *);
        if (params == 1) {
                va_end (args);
                return f;
        }

        field_alloc = cob_malloc (params * sizeof (cob_field *));
        field_alloc[0] = f;

        for (i = 1; i < params; ++i) {
                field_alloc[i] = va_arg (args, cob_field *);
        }
        va_end (args);

        qsort (field_alloc, (size_t)params, (size_t)sizeof (cob_field *), comp_field);

        i = params / 2;
        if (params % 2) {
                f = field_alloc[i];
        } else {
                make_double_entry ();
                cob_decimal_set_field (&d1, field_alloc[i-1]);
                cob_decimal_set_field (&d2, field_alloc[i]);
                cob_decimal_add (&d1, &d2);
                mpz_set_ui (d2.value, 2);
                d2.scale = 0;
                cob_decimal_div (&d1, &d2);
                cob_decimal_get_field (&d1, curr_field, 0);
                f = curr_field;
        }
        
        free (field_alloc);
        return f;
}

Here is the call graph for this function:

cob_field* cob_intr_midrange ( const int  ,
  ... 
)

Definition at line 2146 of file intrinsic.c.

{
        cob_field       *f, *basemin, *basemax;
        va_list         args;
        int             i;

        make_double_entry ();
        va_start (args, params);

        basemin = va_arg (args, cob_field *);
        basemax = basemin;
        for (i = 1; i < params; ++i) {
                f = va_arg (args, cob_field *);
                if (cob_cmp (f, basemin) < 0) {
                        basemin = f;
                }
                if (cob_cmp (f, basemax) > 0) {
                        basemax = f;
                }
        }
        va_end (args);

        cob_decimal_set_field (&d1, basemin);
        cob_decimal_set_field (&d2, basemax);
        cob_decimal_add (&d1, &d2);
        mpz_set_ui (d2.value, 2);
        d2.scale = 0;
        cob_decimal_div (&d1, &d2);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_min ( const int  ,
  ... 
)

Definition at line 2104 of file intrinsic.c.

{
        cob_field       *f, *basef;
        va_list         args;
        int             i;

        va_start (args, params);

        basef = va_arg (args, cob_field *);
        for (i = 1; i < params; ++i) {
                f = va_arg (args, cob_field *);
                if (cob_cmp (f, basef) < 0) {
                        basef = f;
                }
        }
        va_end (args);

        return basef;
}

Here is the call graph for this function:

cob_field* cob_intr_mod ( cob_field ,
cob_field  
)

Definition at line 2268 of file intrinsic.c.

{
        cob_field       *f1;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        make_field_entry (&field);

        f1 = cob_intr_integer (cob_intr_binop (srcfield1, '/', srcfield2));
        cob_decimal_set_field (&d1, srcfield2);
        cob_decimal_set_field (&d2, f1);
        cob_decimal_mul (&d2, &d1);
        cob_decimal_set_field (&d1, srcfield1);
        cob_decimal_sub (&d1, &d2);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_numval ( cob_field )

Definition at line 1795 of file intrinsic.c.

{
        long long       llval = 0;
        double          val;
        size_t          i;
        int             integer_digits = 0;
        int             decimal_digits = 0;
        int             sign = 0;
        int             decimal_seen = 0;
        cob_field_attr  attr;
        cob_field       field;
        unsigned char   integer_buff[64];
        unsigned char   decimal_buff[64];
        unsigned char   final_buff[64];

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        memset (integer_buff, 0, sizeof (integer_buff));
        memset (decimal_buff, 0, sizeof (decimal_buff));
        memset (final_buff, 0, sizeof (final_buff));

        for (i = 0; i < srcfield->size; ++i) {
                if (i < (srcfield->size - 2)) {
                        if (strcasecmp ((char *)&srcfield->data[i], "CR") == 0
                             || strcasecmp ((char *)&srcfield->data[i], "DB") == 0) {
                                sign = 1;
                                break;
                        }
                }
                if (srcfield->data[i] == ' ') {
                        continue;
                }
                if (srcfield->data[i] == '+') {
                        continue;
                }
                if (srcfield->data[i] == '-') {
                        sign = 1;
                        continue;
                }
                if (srcfield->data[i] == cob_current_module->decimal_point) {
                        decimal_seen = 1;
                        continue;
                }
                if (srcfield->data[i] >= '0' && srcfield->data[i] <= '9') {
                        llval *= 10;
                        llval += srcfield->data[i] - '0';
                        if (decimal_seen) {
                                decimal_buff[decimal_digits++] = srcfield->data[i];
                        } else {
                                integer_buff[integer_digits++] = srcfield->data[i];
                        }
                }
                if ((integer_digits + decimal_digits) > 30) {
                        break;
                }
        }
        if (!integer_digits) {
                integer_buff[0] = '0';
        }
        if (!decimal_digits) {
                decimal_buff[0] = '0';
        }
        if (sign) {
                llval = -llval;
        }
        if ((integer_digits + decimal_digits) <= 18) {
                attr.scale = decimal_digits;
                make_field_entry (&field);
                memcpy (curr_field->data, (char *)&llval, 8);
        } else {
                snprintf ((char *)final_buff, 63, "%s%s.%s", sign ? "-" : "",
                         integer_buff, decimal_buff);
                sscanf ((char *)final_buff, "%lf", &val);
                make_double_entry ();
                memcpy (curr_field->data, (char *)&val, sizeof (double));
        }
        return curr_field;
}
cob_field* cob_intr_numval_c ( cob_field ,
cob_field  
)

Definition at line 1875 of file intrinsic.c.

{
        unsigned char   *currency_data;
        long long       llval = 0;
        double          val;
        size_t          i;
        int             integer_digits = 0;
        int             decimal_digits = 0;
        int             sign = 0;
        int             decimal_seen = 0;
        cob_field_attr  attr;
        cob_field       field;
        unsigned char   integer_buff[64];
        unsigned char   decimal_buff[64];
        unsigned char   final_buff[64];

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        memset (integer_buff, 0, sizeof (integer_buff));
        memset (decimal_buff, 0, sizeof (decimal_buff));
        memset (final_buff, 0, sizeof (final_buff));

        currency_data = NULL;
        if (currency) {
                if (currency->size < srcfield->size) {
                        currency_data = currency->data;
                }
        }
        for (i = 0; i < srcfield->size; ++i) {
                if (i < (srcfield->size - 2)) {
                        if (strcasecmp ((char *)&srcfield->data[i], "CR") == 0
                             || strcasecmp ((char *)&srcfield->data[i], "DB") == 0) {
                                sign = 1;
                                break;
                        }
                }
                if (currency_data) {
                        if (i < (srcfield->size - currency->size)) {
                                if (memcmp ((char *)&srcfield->data[i], currency_data,
                                             currency->size) == 0) {
                                        i += (currency->size - 1);
                                        continue;
                                }
                        }
                }
                if (srcfield->data[i] == ' ') {
                        continue;
                }
                if (srcfield->data[i] == '+') {
                        continue;
                }
                if (srcfield->data[i] == '-') {
                        sign = 1;
                        continue;
                }
                if (srcfield->data[i] == cob_current_module->decimal_point) {
                        decimal_seen = 1;
                        continue;
                }
                if (srcfield->data[i] == cob_current_module->currency_symbol) {
                        continue;
                }
                if (srcfield->data[i] >= '0' && srcfield->data[i] <= '9') {
                        llval *= 10;
                        llval += srcfield->data[i] - '0';
                        if (decimal_seen) {
                                decimal_buff[decimal_digits++] = srcfield->data[i];
                        } else {
                                integer_buff[integer_digits++] = srcfield->data[i];
                        }
                }
                if ((integer_digits + decimal_digits) > 30) {
                        break;
                }
        }
        if (!integer_digits) {
                integer_buff[0] = '0';
        }
        if (!decimal_digits) {
                decimal_buff[0] = '0';
        }
        if (sign) {
                llval = -llval;
        }
        if ((integer_digits + decimal_digits) <= 18) {
                attr.scale = decimal_digits;
                make_field_entry (&field);
                memcpy (curr_field->data, (char *)&llval, 8);
        } else {
                snprintf ((char *)final_buff, 63, "%s%s.%s", sign ? "-" : "",
                         integer_buff, decimal_buff);
                sscanf ((char *)final_buff, "%lf", &val);
                make_double_entry ();
                memcpy (curr_field->data, (char *)&val, sizeof (double));
        }
        return curr_field;
}
cob_field* cob_intr_ord ( cob_field )

Definition at line 1141 of file intrinsic.c.

{
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);
        
        cob_set_int (curr_field, (int)(*srcfield->data + 1));
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_ord_max ( const int  ,
  ... 
)

Definition at line 2069 of file intrinsic.c.

{
        cob_field       *f, *basef;
        int             ordmin = 0;
        int             i;
        va_list         args;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        if (params <= 1) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }

        va_start (args, params);

        basef = va_arg (args, cob_field *);
        for (i = 1; i < params; ++i) {
                f = va_arg (args, cob_field *);
                if (cob_cmp (f, basef) > 0) {
                        basef = f;
                        ordmin = i;
                }
        }
        va_end (args);

        cob_set_int (curr_field, ordmin + 1);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_ord_min ( const int  ,
  ... 
)

Definition at line 2034 of file intrinsic.c.

{
        cob_field       *f, *basef;
        int             i;
        int             ordmin = 0;
        va_list         args;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        if (params <= 1) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }

        va_start (args, params);

        basef = va_arg (args, cob_field *);
        for (i = 1; i < params; ++i) {
                f = va_arg (args, cob_field *);
                if (cob_cmp (f, basef) < 0) {
                        basef = f;
                        ordmin = i;
                }
        }
        va_end (args);

        cob_set_int (curr_field, ordmin + 1);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_present_value ( const int  ,
  ... 
)

Definition at line 2538 of file intrinsic.c.

{
        cob_field       *f;
        va_list         args;
        int             i;

        va_start (args, params);
        make_double_entry ();

        if (params < 2) {
                va_end (args);
                fprintf (stderr, "Wrong number of parameters for FUNCTION PRESENT-VALUE\n");
                fflush (stderr);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        f = va_arg (args, cob_field *);
        cob_decimal_set_field (&d1, f);
        mpz_set_ui (d2.value, 1);
        d2.scale = 0;
        cob_decimal_add (&d1, &d2);

        mpz_set_ui (d4.value, 0);
        d4.scale = 0;

        for (i = 1; i < params; ++i) {
                f = va_arg (args, cob_field *);
                cob_decimal_set_field (&d2, f);
                mpz_set (d3.value, d1.value);
                d3.scale = d1.scale;
                if (i > 1) {
                        mpz_set_ui (d5.value, (unsigned int)i);
                        d5.scale = 0;
                        cob_decimal_pow (&d3, &d5);
                }
                cob_decimal_div (&d2, &d3);
                cob_decimal_add (&d4, &d2);
        }
        va_end (args);

        cob_decimal_get_field (&d4, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_random ( const int  ,
  ... 
)

Definition at line 2352 of file intrinsic.c.

{
        cob_field       *f;
        va_list         args;
        int             seed = 1;
        int             randnum;
        int             i;
        int             exp10;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 9, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        va_start (args, params);

        if (params) {
                f = va_arg (args, cob_field *);
                seed = cob_get_int (f);
                if (seed < 0) {
                        seed = 0;
                }
#ifdef  __CYGWIN__
                srandom ((unsigned int)seed);
#else
                srand ((unsigned int)seed);
#endif
        }
        va_end (args);

#ifdef  __CYGWIN__
        randnum = (int)random ();
#else
        randnum = rand ();
#endif
        exp10 = 1;
        for (i = 0; i < 10; ++i) {
                if ((randnum / exp10) == 0) {
                        break;
                }
                exp10 *= 10;
        }
        if (i == 0) {
                i = 1;
        }
        attr.scale = i;
        make_field_entry (&field);
        *(long long *)curr_field->data = (long long)randnum;
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_range ( const int  ,
  ... 
)

Definition at line 2289 of file intrinsic.c.

{
        cob_field       *f, *basemin, *basemax;
        va_list         args;
        int             i;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        va_start (args, params);

        basemin = va_arg (args, cob_field *);
        basemax = basemin;
        for (i = 1; i < params; ++i) {
                f = va_arg (args, cob_field *);
                if (cob_cmp (f, basemin) < 0) {
                        basemin = f;
                }
                if (cob_cmp (f, basemax) > 0) {
                        basemax = f;
                }
        }
        va_end (args);

        attr.scale = COB_FIELD_SCALE(basemin);
        if (COB_FIELD_SCALE(basemax) > attr.scale) {
                attr.scale = COB_FIELD_SCALE(basemax);
        }
        make_field_entry (&field);
        cob_decimal_set_field (&d1, basemax);
        cob_decimal_set_field (&d2, basemin);
        cob_decimal_sub (&d1, &d2);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_rem ( cob_field ,
cob_field  
)

Definition at line 2327 of file intrinsic.c.

{
        cob_field       *f1;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        f1 = cob_intr_integer_part (cob_intr_binop (srcfield1, '/', srcfield2));
        cob_decimal_set_field (&d1, srcfield2);
        cob_decimal_set_field (&d2, f1);
        cob_decimal_mul (&d2, &d1);
        cob_decimal_set_field (&d1, srcfield1);
        cob_decimal_sub (&d1, &d2);

        attr.scale = COB_FIELD_SCALE(srcfield1);
        if (COB_FIELD_SCALE(srcfield2) > attr.scale) {
                attr.scale = COB_FIELD_SCALE(srcfield2);
        }
        make_field_entry (&field);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_reverse ( const int  ,
const int  ,
cob_field  
)

Definition at line 622 of file intrinsic.c.

{
        size_t          i, size;

        make_field_entry (srcfield);

        size = srcfield->size;
        for (i = 0; i < size; ++i) {
                curr_field->data[i] = srcfield->data[srcfield->size - i - 1];
        }
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
}
cob_field* cob_intr_seconds_from_formatted_time ( cob_field ,
cob_field  
)

Definition at line 2803 of file intrinsic.c.

{
        unsigned char   *p1;
        unsigned char   *p2;
        size_t          n;
        int             seconds = 0;
        int             minutes = 0;
        int             hours = 0;
        int             seconds_seen = 0;
        int             minutes_seen = 0;
        int             hours_seen = 0;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        if (value->size < format->size) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        p1 = format->data;
        p2 = value->data;
        for (n = 0; n < format->size - 1; ++n, ++p1, ++p2) {
                if (!memcmp (p1, "hh", 2) && !hours_seen) {
                        if (*p2 >= '0' && *p2 <= '9' &&
                            *(p2 + 1) >= '0' && *(p2 + 1) <= '9') {
                                hours = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
                                hours_seen = 1;
                                continue;
                        }
                }
                if (!memcmp (p1, "mm", 2) && !minutes_seen) {
                        if (*p2 >= '0' && *p2 <= '9' &&
                            *(p2 + 1) >= '0' && *(p2 + 1) <= '9') {
                                minutes = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
                                minutes_seen = 1;
                                continue;
                        }
                }
                if (!memcmp (p1, "ss", 2) && !seconds_seen) {
                        if (*p2 >= '0' && *p2 <= '9' &&
                            *(p2 + 1) >= '0' && *(p2 + 1) <= '9') {
                                seconds = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
                                seconds_seen = 1;
                                continue;
                        }
                }
        }
        if (hours_seen && minutes_seen && seconds_seen) {
                seconds += (hours * 3600) + (minutes * 60);
        } else {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                seconds = 0;
        }
        cob_set_int (curr_field, seconds);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_seconds_past_midnight ( void  )

Definition at line 2782 of file intrinsic.c.

{
        struct tm       *timeptr;
        time_t          t;
        int             seconds;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        t = time (NULL);
        timeptr = localtime (&t);
        seconds = (timeptr->tm_hour * 3600) + (timeptr->tm_min * 60) +
                        timeptr->tm_sec;
        cob_set_int (curr_field, seconds);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_sign ( cob_field )

Definition at line 566 of file intrinsic.c.

{
        int             n;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_set_int (curr_field, 0);
        n = cob_cmp (srcfield, curr_field);
        if (n < 0) {
                cob_set_int (curr_field, -1);
        } else if (n > 0) {
                cob_set_int (curr_field, 1);
        }

        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_sin ( cob_field )

Definition at line 1726 of file intrinsic.c.

{
        long long               result;
        double                  mathd2;
        int                     i, tempres;
        cob_field_attr          attr;
        cob_field               field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        cob_decimal_set_field (&d1, srcfield);
        make_field_entry (&field);

        errno = 0;
        mathd2 = sin (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        result = (long long) mathd2;
        mathd2 -= result;
        for (i = 0; i < 17; ++i) {
                mathd2 *= 10;
                tempres = (int) mathd2;
                result *= 10;
                result += tempres;
                mathd2 -= tempres;
        }
        memcpy (curr_field->data, (char *)&result, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_sqrt ( cob_field )

Definition at line 1759 of file intrinsic.c.

{
        double          mathd2;

        cob_decimal_set_field (&d1, srcfield);
        make_double_entry ();

        errno = 0;
        mathd2 = sqrt (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        memcpy (curr_field->data, (char *)&mathd2, 8);
        return curr_field;
}

Here is the call graph for this function:

Here is the caller graph for this function:

cob_field* cob_intr_standard_deviation ( const int  ,
  ... 
)

Definition at line 2472 of file intrinsic.c.

{
        cob_field       *f;
        va_list         args;
        int             i;

        va_start (args, params);
        make_double_entry ();

        if (params == 1) {
                va_end (args);
                cob_set_int (curr_field, 0);
                return curr_field;
        }

        /* MEAN for all params */
        mpz_set_ui (d1.value, 0);
        d1.scale = 0;

        for (i = 0; i < params; ++i) {
                f = va_arg (args, cob_field *);
                cob_decimal_set_field (&d2, f);
                cob_decimal_add (&d1, &d2);
        }
        va_end (args);
        mpz_set_ui (d2.value, (unsigned int)params);
        d2.scale = 0;
        cob_decimal_div (&d1, &d2);

        /* Got the MEAN in d1, iterate again */

        mpz_set_ui (d4.value, 0);
        d4.scale = 0;

        va_start (args, params);

        for (i = 0; i < params; ++i) {
                f = va_arg (args, cob_field *);
                cob_decimal_set_field (&d2, f);
                cob_decimal_sub (&d2, &d1);
                cob_decimal_mul (&d2, &d2);
                cob_decimal_add (&d4, &d2);
        }
        va_end (args);

        mpz_set_ui (d3.value, (unsigned int)params);
        d3.scale = 0;
        cob_decimal_div (&d4, &d3);
        /* We have the VARIANCE in d4, sqrt = STANDARD-DEVIATION */

/* Do not know why this does not work
        d5.scale = d4.scale;
        mpz_mul_ui (d5.value, d4.value, 1000000000);
        mpz_mul_ui (d4.value, d5.value, 1000000000);
        mpz_sqrt (d5.value, d4.value);
        mpz_div_ui (d4.value, d5.value, 1000000000);
        cob_decimal_get_field (&d4, curr_field, 0);
        return curr_field;
*/

        cob_decimal_get_field (&d4, curr_field, 0);
        f = cob_intr_sqrt (curr_field);
        return f;
}

Here is the call graph for this function:

cob_field* cob_intr_stored_char_length ( cob_field )

Definition at line 1155 of file intrinsic.c.

{
        unsigned char   *p;
        int             count;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);
        
        count = srcfield->size;
        p = srcfield->data + srcfield->size - 1;
        for (; count > 0; count--, p--) {
                if (*p != ' ') {
                        break;
                }
        }
        cob_set_int (curr_field, count);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_substitute ( const int  ,
const int  ,
const int  ,
  ... 
)

Definition at line 678 of file intrinsic.c.

{
        cob_field       *var;
        cob_field       **f1;
        cob_field       **f2;
        unsigned char   *p1;
        unsigned char   *p2;
        size_t          varsize;
        size_t          calcsize;
        size_t          n;
        size_t          found;
        int             numreps;
        int             i;
        cob_field_attr  attr;
        cob_field       field;
        va_list         args;

        numreps = params / 2;
        f1 = cob_malloc (numreps * sizeof (cob_field *));
        f2 = cob_malloc (numreps * sizeof (cob_field *));

        va_start (args, params);

        var = va_arg (args, cob_field *);
        varsize = var->size;

        /* Extract args */
        for (i = 0; i < params - 1; ++i) {
                if ((i % 2) == 0) {
                        f1[i / 2] = va_arg (args, cob_field *);
                } else {
                        f2[i / 2] = va_arg (args, cob_field *);
                }
        }

        /* Calculate required size */
        calcsize = 0;
        found = 0;
        p1 = var->data;
        for (n = 0; n < varsize; ) {
                for (i = 0; i < numreps; ++i) {
                        if (n + f1[i]->size <= varsize) {
                                if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
                                        p1 += f1[i]->size;
                                        n += f1[i]->size;
                                        calcsize += f2[i]->size;
                                        found = 1;
                                        break;
                                }
                        }
                }
                if (found) {
                        found = 0;
                        continue;
                }
                ++n;
                ++p1;
                ++calcsize;
        }

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (0, NULL, &attr);
        field.size = calcsize;
        make_field_entry (&field);

        found = 0;
        p1 = var->data;
        p2 = curr_field->data;
        for (n = 0; n < varsize; ) {
                for (i = 0; i < numreps; ++i) {
                        if (n + f1[i]->size <= varsize) {
                                if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
                                        memcpy (p2, f2[i]->data, f2[i]->size);
                                        p1 += f1[i]->size;
                                        p2 += f2[i]->size;
                                        n += f1[i]->size;
                                        found = 1;
                                        break;
                                }
                        }
                }
                if (found) {
                        found = 0;
                        continue;
                }
                ++n;
                *p2++ = *p1++;
        }
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        free (f1);
        free (f2);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_substitute_case ( const int  ,
const int  ,
const int  ,
  ... 
)

Definition at line 775 of file intrinsic.c.

{
        cob_field       *var;
        cob_field       **f1;
        cob_field       **f2;
        unsigned char   *p1;
        unsigned char   *p2;
        size_t          varsize;
        size_t          calcsize;
        size_t          n;
        size_t          found;
        int             numreps;
        int             i;
        cob_field_attr  attr;
        cob_field       field;
        va_list         args;

        numreps = params / 2;
        f1 = cob_malloc (numreps * sizeof (cob_field *));
        f2 = cob_malloc (numreps * sizeof (cob_field *));

        va_start (args, params);

        var = va_arg (args, cob_field *);
        varsize = var->size;

        /* Extract args */
        for (i = 0; i < params - 1; ++i) {
                if ((i % 2) == 0) {
                        f1[i / 2] = va_arg (args, cob_field *);
                } else {
                        f2[i / 2] = va_arg (args, cob_field *);
                }
        }

        /* Calculate required size */
        calcsize = 0;
        found = 0;
        p1 = var->data;
        for (n = 0; n < varsize; ) {
                for (i = 0; i < numreps; ++i) {
                        if (n + f1[i]->size <= varsize) {
                                if (!strncasecmp ((const char *)p1,
                                                  (const char *)(f1[i]->data),
                                                  f1[i]->size)) {
                                        p1 += f1[i]->size;
                                        n += f1[i]->size;
                                        calcsize += f2[i]->size;
                                        found = 1;
                                        break;
                                }
                        }
                }
                if (found) {
                        found = 0;
                        continue;
                }
                ++n;
                ++p1;
                ++calcsize;
        }

        COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
        COB_FIELD_INIT (0, NULL, &attr);
        field.size = calcsize;
        make_field_entry (&field);

        found = 0;
        p1 = var->data;
        p2 = curr_field->data;
        for (n = 0; n < varsize; ) {
                for (i = 0; i < numreps; ++i) {
                        if (n + f1[i]->size <= varsize) {
                                if (!strncasecmp ((const char *)p1,
                                                  (const char *)(f1[i]->data),
                                                  f1[i]->size)) {
                                        memcpy (p2, f2[i]->data, f2[i]->size);
                                        p1 += f1[i]->size;
                                        p2 += f2[i]->size;
                                        n += f1[i]->size;
                                        found = 1;
                                        break;
                                }
                        }
                }
                if (found) {
                        found = 0;
                        continue;
                }
                ++n;
                *p2++ = *p1++;
        }
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        free (f1);
        free (f2);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_sum ( const int  ,
  ... 
)

Definition at line 1996 of file intrinsic.c.

{
        cob_field       *f;
        va_list         args;
        int             i;
        int             digits = 0;
        int             scale = 0;
        cob_field_attr  attr;
        cob_field       field;


        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        mpz_set_ui (d1.value, 0);
        d1.scale = 0;

        va_start (args, params);

        for (i = 0; i < params; ++i) {
                f = va_arg (args, cob_field *);
                if ((COB_FIELD_DIGITS(f) - COB_FIELD_SCALE(f)) > digits) {
                        digits = COB_FIELD_DIGITS(f) - COB_FIELD_SCALE(f);
                }
                if (COB_FIELD_SCALE(f) > scale) {
                        scale = COB_FIELD_SCALE(f);
                }
                cob_decimal_set_field (&d2, f);
                cob_decimal_add (&d1, &d2);
        }
        va_end (args);

        attr.scale = scale;
        make_field_entry (&field);
        cob_decimal_get_field (&d1, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_tan ( cob_field )

Definition at line 1777 of file intrinsic.c.

{
        double          mathd2;

        cob_decimal_set_field (&d1, srcfield);
        make_double_entry ();

        errno = 0;
        mathd2 = tan (intr_get_double (&d1));
        if (errno) {
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        memcpy (curr_field->data, (char *)&mathd2, 8);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_test_date_yyyymmdd ( cob_field )

Definition at line 1409 of file intrinsic.c.

{
        int             indate;
        int             days;
        int             month;
        int             year;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        /* Base 1601-01-01 */
        indate = cob_get_int (srcfield);
        year = indate / 10000;
        if (year < 1601 || year > 9999) {
                cob_set_int (curr_field, 1);
                return curr_field;
        }
        indate %= 10000;
        month = indate / 100;
        if (month < 1 || month > 12) {
                cob_set_int (curr_field, 2);
                return curr_field;
        }
        days = indate % 100;
        if (days < 1 || days > 31) {
                cob_set_int (curr_field, 3);
                return curr_field;
        }
        if (leap_year (year)) {
                if (days > leap_month_days[month]) {
                        cob_set_int (curr_field, 3);
                        return curr_field;
                }
        } else {
                if (days > normal_month_days[month]) {
                        cob_set_int (curr_field, 3);
                        return curr_field;
                }
        }
        cob_set_int (curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_test_day_yyyyddd ( cob_field )

Definition at line 1456 of file intrinsic.c.

{
        int             indate;
        int             days;
        int             year;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        /* Base 1601-01-01 */
        indate = cob_get_int (srcfield);
        year = indate / 1000;
        if (year < 1601 || year > 9999) {
                cob_set_int (curr_field, 1);
                return curr_field;
        }
        days = indate % 1000;
        if (days < 1 || days > 365 + leap_year (year)) {
                cob_set_int (curr_field, 2);
                return curr_field;
        }
        cob_set_int (curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_trim ( const int  ,
const int  ,
cob_field ,
const int   
)

Definition at line 876 of file intrinsic.c.

{
        unsigned char   *begin;
        unsigned char   *end;
        size_t          i;
        size_t          size = 0;

        make_field_entry (srcfield);

        for (i = 0; i < srcfield->size; ++i) {
                if (srcfield->data[i] != ' ') {
                        break;
                }
        }
        if (i == srcfield->size) {
                curr_field->size = 1;
                curr_field->data[0] = ' ';
                return curr_field;
        }
        begin = srcfield->data;
        if (direction != 2) {
                for (; *begin == ' '; ++begin) ;
        }
        end = srcfield->data + srcfield->size - 1;
        if (direction != 1) {
                for (; *end == ' '; end--) ;
        }
        for (i = 0; begin <= end; ++begin, ++i) {
                curr_field->data[i] = *begin;
                ++size;
        }
        curr_field->size = size;
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
}
cob_field* cob_intr_upper_case ( const int  ,
const int  ,
cob_field  
)

Definition at line 588 of file intrinsic.c.

{
        size_t          i, size;

        make_field_entry (srcfield);

        size = srcfield->size;
        for (i = 0; i < size; ++i) {
                curr_field->data[i] = toupper (srcfield->data[i]);
        }
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
}
cob_field* cob_intr_variance ( const int  ,
  ... 
)

Definition at line 2403 of file intrinsic.c.

{
        cob_field       *f;
        va_list         args;
        long long       n;
        union {
                unsigned char   data[8];
                long long       datall;
        } datun;
        int             i;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
        COB_FIELD_INIT (8, NULL, &attr);
        if (params == 1) {
                make_field_entry (&field);
                cob_set_int (curr_field, 0);
                return curr_field;
        }

        /* MEAN for all params */
        mpz_set_ui (d1.value, 0);
        d1.scale = 0;

        va_start (args, params);
        for (i = 0; i < params; ++i) {
                f = va_arg (args, cob_field *);
                cob_decimal_set_field (&d2, f);
                cob_decimal_add (&d1, &d2);
        }
        va_end (args);
        mpz_set_ui (d2.value, (unsigned int)params);
        d2.scale = 0;
        cob_decimal_div (&d1, &d2);

        /* Got the MEAN in d1, iterate again */

        mpz_set_ui (d4.value, 0);
        d4.scale = 0;

        va_start (args, params);

        for (i = 0; i < params; ++i) {
                f = va_arg (args, cob_field *);
                cob_decimal_set_field (&d2, f);
                cob_decimal_sub (&d2, &d1);
                cob_decimal_mul (&d2, &d2);
                cob_decimal_add (&d4, &d2);
        }
        va_end (args);

        mpz_set_ui (d3.value, (unsigned int)params);
        d3.scale = 0;
        cob_decimal_div (&d4, &d3);
        field.data = datun.data;
        cob_decimal_get_field (&d4, &field, 0);
        n = datun.datall;
        for (i = 0; n; n /= 10, ++i) ;
        field.data = NULL;
        if (i <= 18) {
                attr.scale = 18 - i;
        }
        make_field_entry (&field);
        cob_decimal_get_field (&d4, curr_field, 0);
        return curr_field;
}

Here is the call graph for this function:

cob_field* cob_intr_when_compiled ( const int  ,
const int  ,
cob_field  
)

Definition at line 1020 of file intrinsic.c.

{
        make_field_entry (f);

        memcpy (curr_field->data, f->data, f->size);
        if (unlikely(offset > 0)) {
                calc_ref_mod (curr_field, offset, length);
        }
        return curr_field;
}
cob_field* cob_intr_year_to_yyyy ( const int  ,
  ... 
)

Definition at line 2583 of file intrinsic.c.

{
        cob_field       *f;
        struct tm       *timeptr;
        va_list         args;
        time_t          t;
        int             year;
        int             interval;
        int             xqtyear;
        int             maxyear;
        cob_field_attr  attr;
        cob_field       field;

        COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
        COB_FIELD_INIT (4, NULL, &attr);
        make_field_entry (&field);

        cob_exception_code = 0;
        va_start (args, params);
        f = va_arg (args, cob_field *);
        year = cob_get_int (f);
        if (params > 1) {
                f = va_arg (args, cob_field *);
                interval = cob_get_int (f);
        } else {
                interval = 50;
        }
        if (params > 2) {
                f = va_arg (args, cob_field *);
                xqtyear = cob_get_int (f);
        } else {
                t = time (NULL);
                timeptr = localtime (&t);
                xqtyear = 1900 + timeptr->tm_year;
        }
        va_end (args);

        if (year < 0 || year > 99) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        if (xqtyear < 1601 || xqtyear > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        maxyear = xqtyear + interval;
        if (maxyear < 1700 || maxyear > 9999) {
                cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
                cob_set_int (curr_field, 0);
                return curr_field;
        }
        if (maxyear % 100 >= year) {
                year += 100 * (maxyear / 100);
        } else {
                year += 100 * ((maxyear / 100) - 1);
        }
        cob_set_int (curr_field, year);
        return curr_field;
}

Here is the call graph for this function:

 All Classes Files Functions Variables Typedefs Enumerations Enumerator Defines