GnuCOBOL  2.0
A free COBOL compiler
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Macros
Data Structures | Macros | Enumerations | Functions | Variables
intrinsic.c File Reference
#include "config.h"
#include <stdio.h>
#include <stdlib.h>
#include <stddef.h>
#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#include <errno.h>
#include <time.h>
#include <math.h>
#include "libcob.h"
#include "coblocal.h"
Include dependency graph for intrinsic.c:

Data Structures

struct  calc_struct
 
struct  date_format
 
struct  time_format
 

Macros

#define COB_LIB_EXPIMP
 
#define MAX_DATE_STR_LENGTH   11U
 
#define MAX_TIME_STR_LENGTH   26U
 
#define MAX_DATETIME_STR_LENGTH   36U
 
#define COB_PI_LEN   2820UL
 
#define COB_SQRT_TWO_LEN   3827UL
 
#define COB_LOG_HALF_LEN   2784UL
 

Enumerations

enum  days_format { DAYS_MMDD, DAYS_DDD, DAYS_WWWD }
 
enum  formatted_time_extra { EXTRA_NONE = 0, EXTRA_Z, EXTRA_OFFSET_TIME }
 

Functions

static void make_field_entry (cob_field *f)
 
static int leap_year (const int year)
 
static int comp_field (const void *m1, const void *m2)
 
static void calc_ref_mod (cob_field *f, const int offset, const int length)
 
static COB_INLINE COB_A_INLINE void cob_decimal_set (cob_decimal *dst, const cob_decimal *src)
 
static void cob_trim_decimal (cob_decimal *d)
 
static void cob_alloc_set_field_int (const int val)
 
static void cob_alloc_set_field_uint (const cob_u32_t val)
 
static void cob_alloc_field (cob_decimal *d)
 
static cob_field * cob_mod_or_rem (cob_field *f1, cob_field *f2, const int func_is_rem)
 
static int cob_check_numval (const cob_field *srcfield, const cob_field *currency, const int chkcurr, const int anycase)
 
static int cob_check_numval_f (const cob_field *srcfield)
 
static void cob_decimal_set_mpf (cob_decimal *d, const mpf_t src)
 
static void cob_decimal_get_mpf (mpf_t dst, const cob_decimal *d)
 
static void cob_mpf_exp (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_log (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_log10 (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_sin (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_cos (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_tan (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_atan (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_asin (mpf_t dst_val, const mpf_t src_val)
 
static void cob_mpf_acos (mpf_t dst_val, const mpf_t src_val)
 
static int valid_integer_date (const int days)
 
static int valid_year (const int year)
 
static int valid_time (const int seconds_from_midnight)
 
static void date_of_integer (int days, int *year, int *month, int *day)
 
static void day_of_integer (int days, int *year, int *day)
 
static int valid_day_and_format (const int day, const char *format)
 
static int num_leading_nonspace (const char *str)
 
static void format_as_yyyymmdd (const int day_num, const int with_hyphen, char *buff)
 
static void format_as_yyyyddd (const int day_num, const int with_hyphen, char *buff)
 
static int get_day_of_week (const int day_num)
 
static int get_iso_week_one (const int day_num, const int day_of_year)
 
static void get_iso_week (const int day_num, int *year, int *week)
 
static void format_as_yyyywwwd (const int day_num, const int with_hyphen, char *buff)
 
static struct date_format parse_date_format_string (const char *format_str)
 
static void format_date (const struct date_format format, const int days, char *buff)
 
static int decimal_places_for_seconds (const char *str, const ptrdiff_t point_pos)
 
static int rest_is_z (const char *str)
 
static int rest_is_offset_format (const char *str, const int with_colon)
 
static int valid_offset_time (const int offset)
 
static void add_decimal_digits (const int decimal_places, char *buff, ptrdiff_t *buff_pos)
 
static void add_z (const ptrdiff_t buff_pos, char *buff)
 
static void add_offset_time (const int with_colon, const int offset_time, const ptrdiff_t buff_pos, char *buff)
 
static struct time_format parse_time_format_string (const char *str)
 
static void format_time (const struct time_format format, int time, int *offset_time, char *buff)
 
static void split_around_t (const char *str, char *first, char *second)
 
static int try_get_valid_offset_time (const struct time_format time_format, cob_field *offset_time_field, int *offset_time, int **offset_time_ptr)
 
cob_field * cob_switch_value (const int id)
 
void cob_decimal_pow (cob_decimal *pd1, cob_decimal *pd2)
 
void cob_put_indirect_field (cob_field *f)
 
void cob_get_indirect_field (cob_field *f)
 
void cob_decimal_move_temp (cob_field *src, cob_field *dst)
 
int cob_valid_date_format (const char *format)
 
int cob_valid_time_format (const char *format)
 
int cob_valid_datetime_format (const char *format)
 
cob_field * cob_intr_binop (cob_field *f1, const int op, cob_field *f2)
 
cob_field * cob_intr_length (cob_field *srcfield)
 
cob_field * cob_intr_byte_length (cob_field *srcfield)
 
cob_field * cob_intr_integer (cob_field *srcfield)
 
cob_field * cob_intr_integer_part (cob_field *srcfield)
 
cob_field * cob_intr_fraction_part (cob_field *srcfield)
 
cob_field * cob_intr_sign (cob_field *srcfield)
 
cob_field * cob_intr_upper_case (const int offset, const int length, cob_field *srcfield)
 
cob_field * cob_intr_lower_case (const int offset, const int length, cob_field *srcfield)
 
cob_field * cob_intr_reverse (const int offset, const int length, cob_field *srcfield)
 
cob_field * cob_intr_module_date (void)
 
cob_field * cob_intr_module_time (void)
 
cob_field * cob_intr_module_id (void)
 
cob_field * cob_intr_module_caller_id (void)
 
cob_field * cob_intr_module_formatted_date (void)
 
cob_field * cob_intr_module_source (void)
 
cob_field * cob_intr_module_path (void)
 
cob_field * cob_intr_concatenate (const int offset, const int length, const int params,...)
 
cob_field * cob_intr_substitute (const int offset, const int length, const int params,...)
 
cob_field * cob_intr_substitute_case (const int offset, const int length, const int params,...)
 
cob_field * cob_intr_trim (const int offset, const int length, cob_field *srcfield, const int direction)
 
cob_field * cob_intr_exception_file (void)
 
cob_field * cob_intr_exception_location (void)
 
cob_field * cob_intr_exception_status (void)
 
cob_field * cob_intr_exception_statement (void)
 
cob_field * cob_intr_when_compiled (const int offset, const int length, cob_field *f)
 
cob_field * cob_intr_current_date (const int offset, const int length)
 
cob_field * cob_intr_char (cob_field *srcfield)
 
cob_field * cob_intr_ord (cob_field *srcfield)
 
cob_field * cob_intr_stored_char_length (cob_field *srcfield)
 
cob_field * cob_intr_combined_datetime (cob_field *srcdays, cob_field *srctime)
 
cob_field * cob_intr_date_of_integer (cob_field *srcdays)
 
cob_field * cob_intr_day_of_integer (cob_field *srcdays)
 
cob_field * cob_intr_integer_of_date (cob_field *srcfield)
 
cob_field * cob_intr_integer_of_day (cob_field *srcfield)
 
cob_field * cob_intr_test_date_yyyymmdd (cob_field *srcfield)
 
cob_field * cob_intr_test_day_yyyyddd (cob_field *srcfield)
 
cob_field * cob_intr_factorial (cob_field *srcfield)
 
cob_field * cob_intr_e (void)
 
cob_field * cob_intr_pi (void)
 
cob_field * cob_intr_exp (cob_field *srcfield)
 
cob_field * cob_intr_exp10 (cob_field *srcfield)
 
cob_field * cob_intr_log (cob_field *srcfield)
 
cob_field * cob_intr_log10 (cob_field *srcfield)
 
cob_field * cob_intr_abs (cob_field *srcfield)
 
cob_field * cob_intr_acos (cob_field *srcfield)
 
cob_field * cob_intr_asin (cob_field *srcfield)
 
cob_field * cob_intr_atan (cob_field *srcfield)
 
cob_field * cob_intr_cos (cob_field *srcfield)
 
cob_field * cob_intr_sin (cob_field *srcfield)
 
cob_field * cob_intr_tan (cob_field *srcfield)
 
cob_field * cob_intr_sqrt (cob_field *srcfield)
 
cob_field * cob_intr_numval (cob_field *srcfield)
 
cob_field * cob_intr_numval_c (cob_field *srcfield, cob_field *currency)
 
cob_field * cob_intr_numval_f (cob_field *srcfield)
 
cob_field * cob_intr_annuity (cob_field *srcfield1, cob_field *srcfield2)
 
cob_field * cob_intr_sum (const int params,...)
 
cob_field * cob_intr_ord_min (const int params,...)
 
cob_field * cob_intr_ord_max (const int params,...)
 
cob_field * cob_intr_min (const int params,...)
 
cob_field * cob_intr_max (const int params,...)
 
cob_field * cob_intr_midrange (const int params,...)
 
cob_field * cob_intr_median (const int params,...)
 
cob_field * cob_intr_mean (const int params,...)
 
cob_field * cob_intr_mod (cob_field *srcfield1, cob_field *srcfield2)
 
cob_field * cob_intr_range (const int params,...)
 
cob_field * cob_intr_rem (cob_field *srcfield1, cob_field *srcfield2)
 
cob_field * cob_intr_random (const int params,...)
 
cob_field * cob_intr_variance (const int params,...)
 
cob_field * cob_intr_standard_deviation (const int params,...)
 
cob_field * cob_intr_present_value (const int params,...)
 
cob_field * cob_intr_year_to_yyyy (const int params,...)
 
cob_field * cob_intr_date_to_yyyymmdd (const int params,...)
 
cob_field * cob_intr_day_to_yyyyddd (const int params,...)
 
cob_field * cob_intr_seconds_past_midnight (void)
 
cob_field * cob_intr_seconds_from_formatted_time (cob_field *format, cob_field *value)
 
cob_field * cob_intr_locale_date (const int offset, const int length, cob_field *srcfield, cob_field *locale_field)
 
cob_field * cob_intr_locale_time (const int offset, const int length, cob_field *srcfield, cob_field *locale_field)
 
cob_field * cob_intr_lcl_time_from_secs (const int offset, const int length, cob_field *srcfield, cob_field *locale_field)
 
cob_field * cob_intr_mon_decimal_point (void)
 
cob_field * cob_intr_num_decimal_point (void)
 
cob_field * cob_intr_mon_thousands_sep (void)
 
cob_field * cob_intr_num_thousands_sep (void)
 
cob_field * cob_intr_currency_symbol (void)
 
cob_field * cob_intr_test_numval (cob_field *srcfield)
 
cob_field * cob_intr_test_numval_c (cob_field *srcfield, cob_field *currency)
 
cob_field * cob_intr_test_numval_f (cob_field *srcfield)
 
cob_field * cob_intr_lowest_algebraic (cob_field *srcfield)
 
cob_field * cob_intr_highest_algebraic (cob_field *srcfield)
 
cob_field * cob_intr_locale_compare (const int params,...)
 
cob_field * cob_intr_formatted_date (const int offset, const int length, cob_field *format_field, cob_field *days_field)
 
cob_field * cob_intr_formatted_time (const int offset, const int length, const int params,...)
 
cob_field * cob_intr_formatted_datetime (const int offset, const int length, const int params,...)
 
cob_field * cob_intr_integer_of_formatted_date (cob_field *format_field, cob_field *date_field)
 
cob_field * cob_intr_boolean_of_integer (cob_field *f1, cob_field *f2)
 
cob_field * cob_intr_char_national (cob_field *srcfield)
 
cob_field * cob_intr_display_of (const int offset, const int length, const int params,...)
 
cob_field * cob_intr_exception_file_n (void)
 
cob_field * cob_intr_exception_location_n (void)
 
cob_field * cob_intr_formatted_current_date (const int offset, const int length, cob_field *srcfield)
 
cob_field * cob_intr_integer_of_boolean (cob_field *srcfield)
 
cob_field * cob_intr_national_of (const int offset, const int length, const int params,...)
 
cob_field * cob_intr_standard_compare (const int params,...)
 
cob_field * cob_intr_test_formatted_datetime (cob_field *f1, cob_field *f2)
 
void cob_exit_intrinsic (void)
 
void cob_init_intrinsic (cob_global *lptr)
 

Variables

static cob_global * cobglobptr
 
static const cob_field_attr const_alpha_attr
 
static cob_field * move_field
 
static cob_decimal d1
 
static cob_decimal d2
 
static cob_decimal d3
 
static cob_decimal d4
 
static cob_decimal d5
 
static mpz_t cob_mexp
 
static mpz_t cob_mpzt
 
static mpf_t cob_mpft
 
static mpf_t cob_mpft2
 
static mpf_t cob_mpft_get
 
static mpf_t cob_log_half
 
static mpf_t cob_sqrt_two
 
static mpf_t cob_pi
 
static struct calc_struct * calc_base
 
static cob_field * curr_field
 
static cob_u32_t curr_entry
 
static const int normal_days []
 
static const int leap_days []
 
static const int normal_month_days []
 
static const int leap_month_days []
 
static const size_t max_date_length = 10U
 
static const size_t max_time_decimal_places = 9U
 
static const size_t max_time_length = 25U
 
static const size_t max_datetime_length = 35U
 
static const char cob_pi_str []
 
static const char cob_sqrt_two_str []
 
static const char cob_log_half_str []
 

Macro Definition Documentation

#define COB_LIB_EXPIMP
#define COB_LOG_HALF_LEN   2784UL

Referenced by cob_init_intrinsic().

#define COB_PI_LEN   2820UL

Referenced by cob_init_intrinsic().

#define COB_SQRT_TWO_LEN   3827UL

Referenced by cob_init_intrinsic().

#define MAX_DATE_STR_LENGTH   11U

Referenced by cob_intr_formatted_date(), and cob_intr_formatted_datetime().

#define MAX_DATETIME_STR_LENGTH   36U

Referenced by cob_intr_formatted_datetime(), and cob_valid_datetime_format().

#define MAX_TIME_STR_LENGTH   26U

Referenced by cob_intr_formatted_datetime(), and cob_intr_formatted_time().

Enumeration Type Documentation

enum days_format
Enumerator
DAYS_MMDD 
DAYS_DDD 
DAYS_WWWD 
1688  {
1689  DAYS_MMDD,
1690  DAYS_DDD,
1691  DAYS_WWWD
1692 };
enum formatted_time_extra
Enumerator
EXTRA_NONE 
EXTRA_Z 
EXTRA_OFFSET_TIME 
1808  {
1809  EXTRA_NONE = 0,
1810  EXTRA_Z,
1811  EXTRA_OFFSET_TIME
1812 };

Function Documentation

static void add_decimal_digits ( const int  decimal_places,
char *  buff,
ptrdiff_t *  buff_pos 
)
static

Referenced by format_time().

1774 {
1775  /* Precondition: buff, buff_pos != NULL */
1776 
1777  buff[*buff_pos] = '.';
1778  memset (buff + *buff_pos + 1, '0', decimal_places);
1779 
1780  *buff_pos += 1 + decimal_places;
1781 }
static void add_offset_time ( const int  with_colon,
const int  offset_time,
const ptrdiff_t  buff_pos,
char *  buff 
)
static

Referenced by format_time().

1794 {
1795  int hours;
1796  int minutes;
1797  const char *format_str;
1798 
1799  /* Precondition: buff != NULL */
1800 
1801  hours = offset_time / 60;
1802  minutes = abs (offset_time) % 60;
1803 
1804  format_str = with_colon ? "%+2.2d:%2.2d" : "%+2.2d%2.2d";
1805  sprintf (buff + buff_pos, format_str, hours, minutes);
1806 }
static void add_z ( const ptrdiff_t  buff_pos,
char *  buff 
)
static

Referenced by format_time().

1785 {
1786  /* Precondition: buff != NULL */
1787 
1788  buff[buff_pos] = 'Z';
1789 }
static void calc_ref_mod ( cob_field *  f,
const int  offset,
const int  length 
)
static

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

Referenced by cob_intr_concatenate(), cob_intr_current_date(), cob_intr_formatted_date(), cob_intr_formatted_datetime(), cob_intr_formatted_time(), cob_intr_lcl_time_from_secs(), cob_intr_locale_date(), cob_intr_locale_time(), cob_intr_lower_case(), cob_intr_reverse(), cob_intr_substitute(), cob_intr_substitute_case(), cob_intr_trim(), cob_intr_upper_case(), and cob_intr_when_compiled().

470 {
471  size_t calcoff;
472  size_t size;
473 
474  if ((size_t)offset <= f->size) {
475  calcoff = (size_t)offset - 1;
476  size = f->size - calcoff;
477  if (length > 0 && (size_t)length < size) {
478  size = (size_t)length;
479  }
480  f->size = size;
481  if (calcoff > 0) {
482  memmove (f->data, f->data + calcoff, size);
483  }
484  }
485 }
static void cob_alloc_field ( cob_decimal *  d)
static

References COB_ATTR_INIT, COB_DECIMAL_NAN, COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, COB_FLAG_HAVE_SIGN, cob_set_exception(), cob_trim_decimal(), COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DISPLAY, make_field_entry(), NULL, cob_decimal::scale, sign, unlikely, and cob_decimal::value.

Referenced by cob_intr_acos(), cob_intr_annuity(), cob_intr_asin(), cob_intr_atan(), cob_intr_binop(), cob_intr_cos(), cob_intr_e(), cob_intr_exp(), cob_intr_exp10(), cob_intr_factorial(), cob_intr_fraction_part(), cob_intr_highest_algebraic(), cob_intr_integer(), cob_intr_integer_part(), cob_intr_log(), cob_intr_log10(), cob_intr_lowest_algebraic(), cob_intr_mean(), cob_intr_median(), cob_intr_midrange(), cob_intr_numval(), cob_intr_numval_c(), cob_intr_numval_f(), cob_intr_pi(), cob_intr_present_value(), cob_intr_range(), cob_intr_sin(), cob_intr_sqrt(), cob_intr_standard_deviation(), cob_intr_sum(), cob_intr_tan(), cob_intr_variance(), and cob_mod_or_rem().

547 {
548  size_t bitnum;
549  size_t sign;
550  size_t attrsign;
551  int size;
552  int scale;
553  cob_field_attr attr;
554  cob_field field;
555 
556  if (unlikely(d->scale == COB_DECIMAL_NAN)) {
557  /* Check this */
558  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
559  COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
560  0, 0, NULL);
561  COB_FIELD_INIT (4, NULL, &attr);
562  make_field_entry (&field);
563  return;
564  }
565 
566  if (mpz_sgn (d->value) < 0) {
567  attrsign = COB_FLAG_HAVE_SIGN;
568  sign = 1;
569  } else {
570  attrsign = 0;
571  sign = 0;
572  }
573 
574  cob_trim_decimal (d);
575 
576  bitnum = mpz_sizeinbase (d->value, 2);
577  if (bitnum < (33 - sign) && d->scale < 10) {
578  /* 4 bytes binary */
579  COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
580  d->scale, attrsign, NULL);
581  COB_FIELD_INIT (4, NULL, &attr);
582  make_field_entry (&field);
583  } else if (bitnum < (65 - sign) && d->scale < 19) {
584  /* 8 bytes binary */
585  COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 20,
586  d->scale, attrsign, NULL);
587  COB_FIELD_INIT (8, NULL, &attr);
588  make_field_entry (&field);
589  } else {
590  /* Display decimal */
591  size = (int)mpz_sizeinbase (d->value, 10);
592  if (d->scale > size) {
593  size = d->scale;
594  }
595  scale = d->scale;
596  COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, size,
597  scale, attrsign, NULL);
598  COB_FIELD_INIT (size, NULL, &attr);
599  make_field_entry (&field);
600  }
601 }
static void cob_alloc_set_field_int ( const int  val)
static

References COB_ATTR_INIT, COB_FIELD_INIT, COB_FLAG_HAVE_SIGN, COB_TYPE_NUMERIC_BINARY, cob_u16_t, cob_field::data, make_field_entry(), and NULL.

Referenced by cob_intr_date_to_yyyymmdd(), cob_intr_day_to_yyyyddd(), cob_intr_integer_of_date(), cob_intr_seconds_past_midnight(), cob_intr_sign(), cob_intr_test_numval(), cob_intr_test_numval_c(), cob_intr_test_numval_f(), cob_intr_year_to_yyyy(), and cob_switch_value().

515 {
516  cob_u16_t attrsign;
517  cob_field_attr attr;
518  cob_field field;
519 
520  if (val < 0) {
521  attrsign = COB_FLAG_HAVE_SIGN;
522  } else {
523  attrsign = 0;
524  }
525  COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
526  0, attrsign, NULL);
527  COB_FIELD_INIT (4, NULL, &attr);
528  make_field_entry (&field);
529  memcpy (curr_field->data, &val, sizeof(int));
530 }
static void cob_alloc_set_field_uint ( const cob_u32_t  val)
static

References COB_ATTR_INIT, COB_FIELD_INIT, COB_TYPE_NUMERIC_BINARY, cob_u32_t, cob_field::data, make_field_entry(), and NULL.

Referenced by cob_intr_acos(), cob_intr_annuity(), cob_intr_asin(), cob_intr_atan(), cob_intr_byte_length(), cob_intr_date_to_yyyymmdd(), cob_intr_day_to_yyyyddd(), cob_intr_exp(), cob_intr_exp10(), cob_intr_factorial(), cob_intr_highest_algebraic(), cob_intr_integer_of_date(), cob_intr_integer_of_day(), cob_intr_length(), cob_intr_log(), cob_intr_log10(), cob_intr_lowest_algebraic(), cob_intr_numval(), cob_intr_numval_c(), cob_intr_numval_f(), cob_intr_ord(), cob_intr_ord_max(), cob_intr_ord_min(), cob_intr_seconds_from_formatted_time(), cob_intr_sqrt(), cob_intr_standard_deviation(), cob_intr_stored_char_length(), cob_intr_test_date_yyyymmdd(), cob_intr_test_day_yyyyddd(), cob_intr_variance(), cob_intr_year_to_yyyy(), and cob_mod_or_rem().

534 {
535  cob_field_attr attr;
536  cob_field field;
537 
538  COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
539  0, 0, NULL);
540  COB_FIELD_INIT (4, NULL, &attr);
541  make_field_entry (&field);
542  memcpy (curr_field->data, &val, sizeof(cob_u32_t));
543 }
static int cob_check_numval ( const cob_field *  srcfield,
const cob_field *  currency,
const int  chkcurr,
const int  anycase 
)
static

References COB_MAX_DIGITS, COB_MODULE_PTR, cob_field::data, NULL, p, and cob_field::size.

Referenced by cob_intr_numval(), cob_intr_numval_c(), cob_intr_test_numval(), and cob_intr_test_numval_c().

661 {
662  unsigned char *p;
663  unsigned char *begp;
664  unsigned char *endp;
665  size_t pos;
666  size_t plus_minus;
667  size_t digits;
668  size_t dec_seen;
669  size_t space_seen;
670  size_t break_needed;
671  size_t currcy_size;
672  int n;
673  unsigned char dec_pt;
674  unsigned char cur_symb;
675 
676  begp = NULL;
677  currcy_size = 0;
678  if (currency) {
679  endp = NULL;
680  p = currency->data;
681  for (pos = 0; pos < currency->size; pos++, p++) {
682  switch (*p) {
683  case '0':
684  case '1':
685  case '2':
686  case '3':
687  case '4':
688  case '5':
689  case '6':
690  case '7':
691  case '8':
692  case '9':
693  case '+':
694  case '-':
695  case '.':
696  case ',':
697  case '*':
698  return 1;
699  case ' ':
700  break;
701  default:
702  if (pos < currency->size - 1) {
703  if (!memcmp (p, "CR", (size_t)2)) {
704  return 1;
705  }
706  if (!memcmp (p, "DB", (size_t)2)) {
707  return 1;
708  }
709  }
710  if (!begp) {
711  begp = p;
712  }
713  endp = p;
714  break;
715  }
716  }
717  if (!begp) {
718  return 1;
719  }
720  currcy_size = endp - begp;
721  currcy_size++;
722  if (currcy_size >= srcfield->size) {
723  begp = NULL;
724  currcy_size = 0;
725  }
726  } else if (chkcurr) {
727  cur_symb = COB_MODULE_PTR->currency_symbol;
728  begp = &cur_symb;
729  currcy_size = 1;
730  }
731 
732  if (!srcfield->size) {
733  return 1;
734  }
735 
736  p = srcfield->data;
737  plus_minus = 0;
738  digits = 0;
739  dec_seen = 0;
740  space_seen = 0;
741  break_needed = 0;
742  dec_pt = COB_MODULE_PTR->decimal_point;
743 
744  /* Check leading positions */
745  for (n = 0; n < (int)srcfield->size; ++n, ++p) {
746  switch (*p) {
747  case '0':
748  case '1':
749  case '2':
750  case '3':
751  case '4':
752  case '5':
753  case '6':
754  case '7':
755  case '8':
756  case '9':
757  break_needed = 1;
758  break;
759  case ' ':
760  continue;
761  case '+':
762  case '-':
763  if (plus_minus) {
764  return n + 1;
765  }
766  plus_minus = 1;
767  continue;
768  case ',':
769  case '.':
770  if (*p != dec_pt) {
771  return n + 1;
772  }
773  break_needed = 1;
774  break;
775  default:
776  if (begp && n < (int)(srcfield->size - currcy_size)) {
777  if (!memcmp (p, begp, currcy_size)) {
778  break;
779  }
780  }
781  return n + 1;
782  }
783  if (break_needed) {
784  break;
785  }
786  }
787 
788  if (n == (int)srcfield->size) {
789  return n + 1;
790  }
791 
792  for (; n < (int)srcfield->size; ++n, ++p) {
793  switch (*p) {
794  case '0':
795  case '1':
796  case '2':
797  case '3':
798  case '4':
799  case '5':
800  case '6':
801  case '7':
802  case '8':
803  case '9':
804  if (++digits > COB_MAX_DIGITS || space_seen) {
805  return n + 1;
806  }
807  continue;
808  case ',':
809  case '.':
810  if (dec_seen || space_seen) {
811  return n + 1;
812  }
813  if (*p == dec_pt) {
814  dec_seen = 1;
815  } else if (!chkcurr) {
816  return n + 1;
817  }
818  continue;
819  case ' ':
820  space_seen = 1;
821  continue;
822  case '+':
823  case '-':
824  if (plus_minus) {
825  return n + 1;
826  }
827  plus_minus = 1;
828  continue;
829  case 'c':
830  if (!anycase) {
831  return n + 1;
832  }
833  /* Fall through */
834  case 'C':
835  if (plus_minus) {
836  return n + 1;
837  }
838  if (n < (int)srcfield->size - 1) {
839  if (*(p + 1) == 'R' ||
840  (anycase && *(p + 1) == 'r')) {
841  plus_minus = 1;
842  p++;
843  n++;
844  continue;
845  }
846  }
847  return n + 2;
848  case 'd':
849  if (!anycase) {
850  return n + 1;
851  }
852  /* Fall through */
853  case 'D':
854  if (plus_minus) {
855  return n + 1;
856  }
857  if (n < (int)srcfield->size - 1) {
858  if (*(p + 1) == 'B' ||
859  (anycase && *(p + 1) == 'b')) {
860  plus_minus = 1;
861  p++;
862  n++;
863  continue;
864  }
865  }
866  return n + 2;
867  default:
868  return n + 1;
869  }
870  }
871 
872  if (!digits) {
873  return n + 1;
874  }
875 
876  return 0;
877 }
static int cob_check_numval_f ( const cob_field *  srcfield)
static

References COB_MAX_DIGITS, COB_MODULE_PTR, cob_field::data, p, and cob_field::size.

Referenced by cob_intr_numval_f(), and cob_intr_test_numval_f().

885 {
886  unsigned char *p;
887  size_t plus_minus;
888  size_t digits;
889  size_t dec_seen;
890  size_t space_seen;
891  size_t e_seen;
892  size_t break_needed;
893  size_t exponent;
894  size_t e_plus_minus;
895  int n;
896  unsigned char dec_pt;
897 
898  if (!srcfield->size) {
899  return 1;
900  }
901  p = srcfield->data;
902  plus_minus = 0;
903  digits = 0;
904  dec_seen = 0;
905  space_seen = 0;
906  e_seen = 0;
907  break_needed = 0;
908  exponent = 0;
909  e_plus_minus = 0;
910  dec_pt = COB_MODULE_PTR->decimal_point;
911 
912  /* Check leading positions */
913  for (n = 0; n < (int)srcfield->size; ++n, ++p) {
914  switch (*p) {
915  case '0':
916  case '1':
917  case '2':
918  case '3':
919  case '4':
920  case '5':
921  case '6':
922  case '7':
923  case '8':
924  case '9':
925  break_needed = 1;
926  break;
927  case ' ':
928  continue;
929  case '+':
930  case '-':
931  if (plus_minus) {
932  return n + 1;
933  }
934  plus_minus = 1;
935  continue;
936  case ',':
937  case '.':
938  if (*p != dec_pt) {
939  return n + 1;
940  }
941  break_needed = 1;
942  break;
943  default:
944  return n + 1;
945  }
946  if (break_needed) {
947  break;
948  }
949  }
950 
951  if (n == (int)srcfield->size) {
952  return n + 1;
953  }
954 
955  for (; n < (int)srcfield->size; ++n, ++p) {
956  switch (*p) {
957  case '0':
958  case '1':
959  case '2':
960  case '3':
961  case '4':
962  case '5':
963  case '6':
964  case '7':
965  case '8':
966  case '9':
967  if (e_seen) {
968  if (++exponent > 4 || !e_plus_minus) {
969  return n + 1;
970  }
971  } else if (++digits > COB_MAX_DIGITS || space_seen) {
972  return n + 1;
973  }
974  continue;
975  case ',':
976  case '.':
977  if (dec_seen || space_seen || e_seen) {
978  return n + 1;
979  }
980  if (*p == dec_pt) {
981  dec_seen = 1;
982  continue;
983  }
984  return n + 1;
985  case ' ':
986  space_seen = 1;
987  continue;
988  case 'E':
989  if (e_seen) {
990  return n + 1;
991  }
992  e_seen = 1;
993  continue;
994  case '+':
995  case '-':
996  if (e_seen) {
997  if (e_plus_minus) {
998  return n + 1;
999  }
1000  e_plus_minus = 1;
1001  } else {
1002  if (plus_minus) {
1003  return n + 1;
1004  }
1005  plus_minus = 1;
1006  }
1007  continue;
1008  default:
1009  return n + 1;
1010  }
1011  }
1012 
1013  if (!digits || (e_seen && !exponent)) {
1014  return n + 1;
1015  }
1016 
1017  return 0;
1018 }
static void cob_decimal_get_mpf ( mpf_t  dst,
const cob_decimal *  d 
)
static

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

Referenced by cob_decimal_pow(), cob_intr_acos(), cob_intr_asin(), cob_intr_atan(), cob_intr_cos(), cob_intr_exp(), cob_intr_log(), cob_intr_log10(), cob_intr_sin(), and cob_intr_tan().

1055 {
1056  cob_sli_t scale;
1057 
1058  mpf_set_z (dst, d->value);
1059  scale = d->scale;
1060  if (scale < 0) {
1061  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-scale);
1062  mpf_set_z (cob_mpft_get, cob_mexp);
1063  mpf_mul (dst, dst, cob_mpft_get);
1064  } else if (scale > 0) {
1065  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)scale);
1066  mpf_set_z (cob_mpft_get, cob_mexp);
1067  mpf_div (dst, dst, cob_mpft_get);
1068  }
1069 }
void cob_decimal_move_temp ( cob_field *  src,
cob_field *  dst 
)

References COB_ATTR_INIT, cob_decimal_get_field(), cob_decimal_set_field(), COB_FIELD_INIT, COB_FLAG_HAVE_SIGN, cob_move(), cob_trim_decimal(), COB_TYPE_NUMERIC_DISPLAY, make_field_entry(), NULL, cob_decimal::scale, and cob_decimal::value.

Referenced by cob_move().

2076 {
2077  int size;
2078  int scale;
2079  cob_field_attr attr;
2080  cob_field field;
2081 
2082  cob_decimal_set_field (&d1, src);
2083  cob_trim_decimal (&d1);
2084 
2085  size = (int)mpz_sizeinbase (d1.value, 10);
2086  if (d1.scale > size) {
2087  size = d1.scale;
2088  }
2089  scale = d1.scale;
2090  COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, size,
2091  scale, COB_FLAG_HAVE_SIGN, NULL);
2092  COB_FIELD_INIT (size, NULL, &attr);
2093  make_field_entry (&field);
2094  (void)cob_decimal_get_field (&d1, curr_field, 0);
2095  cob_move (curr_field, dst);
2096 }
void cob_decimal_pow ( cob_decimal *  pd1,
cob_decimal *  pd2 
)

References cob_decimal_div(), cob_decimal_get_mpf(), COB_DECIMAL_NAN, cob_decimal_set(), cob_decimal_set_mpf(), cob_mpf_exp(), cob_mpf_log(), cob_mpft, cob_mpft2, cob_set_exception(), cob_trim_decimal(), cob_uli_t, cob_decimal::scale, sign, unlikely, and cob_decimal::value.

Referenced by cob_intr_annuity(), cob_intr_binop(), cob_intr_exp10(), cob_intr_sqrt(), and cob_intr_standard_deviation().

1962 {
1963  cob_uli_t n;
1964  int sign;
1965 
1966  if (unlikely(pd1->scale == COB_DECIMAL_NAN)) {
1967  return;
1968  }
1969  if (unlikely(pd2->scale == COB_DECIMAL_NAN)) {
1970  pd1->scale = COB_DECIMAL_NAN;
1971  return;
1972  }
1973 
1974  sign = mpz_sgn (pd1->value);
1975 
1976  if (!mpz_sgn (pd2->value)) {
1977  /* Exponent is zero */
1978  if (!sign) {
1979  /* 0 ^ 0 */
1980  cob_set_exception (COB_EC_SIZE_EXPONENTIATION);
1981  }
1982  mpz_set_ui (pd1->value, 1UL);
1983  pd1->scale = 0;
1984  return;
1985  }
1986  if (!sign) {
1987  /* Value is zero */
1988  pd1->scale = 0;
1989  return;
1990  }
1991 
1992  cob_trim_decimal (pd2);
1993 
1994  if (sign < 0 && pd2->scale) {
1995  /* Negative exponent and non-integer power */
1996  pd1->scale = COB_DECIMAL_NAN;
1997  cob_set_exception (COB_EC_SIZE_EXPONENTIATION);
1998  return;
1999  }
2000 
2001  cob_trim_decimal (pd1);
2002 
2003  if (!pd2->scale) {
2004  /* Integer power */
2005  if (!mpz_cmp_ui (pd2->value, 1UL)) {
2006  /* Power is 1 */
2007  return;
2008  }
2009  if (mpz_sgn (pd2->value) < 0 && mpz_fits_slong_p (pd2->value)) {
2010  /* Negative power */
2011  mpz_abs (pd2->value, pd2->value);
2012  n = mpz_get_ui (pd2->value);
2013  mpz_pow_ui (pd1->value, pd1->value, n);
2014  if (pd1->scale) {
2015  pd1->scale *= n;
2016  cob_trim_decimal (pd1);
2017  }
2018  cob_decimal_set (pd2, pd1);
2019  mpz_set_ui (pd1->value, 1UL),
2020  pd1->scale = 0;
2021  cob_decimal_div (pd1, pd2);
2022  cob_trim_decimal (pd1);
2023  return;
2024  }
2025  if (mpz_fits_ulong_p (pd2->value)) {
2026  /* Positive power */
2027  n = mpz_get_ui (pd2->value);
2028  mpz_pow_ui (pd1->value, pd1->value, n);
2029  if (pd1->scale) {
2030  pd1->scale *= n;
2031  cob_trim_decimal (pd1);
2032  }
2033  return;
2034  }
2035  }
2036 
2037  if (sign < 0) {
2038  mpz_abs (pd1->value, pd1->value);
2039  }
2040  cob_decimal_get_mpf (cob_mpft, pd1);
2041  if (pd2->scale == 1 && !mpz_cmp_ui (pd2->value, 5UL)) {
2042  /* Square root short cut */
2043  mpf_sqrt (cob_mpft2, cob_mpft);
2044  } else {
2045  cob_decimal_get_mpf (cob_mpft2, pd2);
2046  cob_mpf_log (cob_mpft, cob_mpft);
2047  mpf_mul (cob_mpft, cob_mpft, cob_mpft2);
2048  cob_mpf_exp (cob_mpft2, cob_mpft);
2049  }
2050  cob_decimal_set_mpf (pd1, cob_mpft2);
2051  if (sign < 0) {
2052  mpz_neg (pd1->value, pd1->value);
2053  }
2054 }
static COB_INLINE COB_A_INLINE void cob_decimal_set ( cob_decimal *  dst,
const cob_decimal *  src 
)
static

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

Referenced by cob_decimal_pow().

491 {
492  mpz_set (dst->value, src->value);
493  dst->scale = src->scale;
494 }
static void cob_decimal_set_mpf ( cob_decimal *  d,
const mpf_t  src 
)
static

References cob_gmp_free(), cob_mexp, cob_sli_t, cob_uli_t, NULL, p, cob_decimal::scale, and cob_decimal::value.

Referenced by cob_decimal_pow(), cob_intr_acos(), cob_intr_asin(), cob_intr_atan(), cob_intr_cos(), cob_intr_e(), cob_intr_exp(), cob_intr_log(), cob_intr_log10(), cob_intr_pi(), cob_intr_sin(), and cob_intr_tan().

1024 {
1025  char *p;
1026  char *q;
1027  cob_sli_t scale;
1028  cob_sli_t len;
1029 
1030  if (!mpf_sgn (src)) {
1031  mpz_set_ui (d->value, 0UL);
1032  d->scale = 0;
1033  return;
1034  }
1035  q = mpf_get_str (NULL, &scale, 10, (size_t)96, src);
1036  p = q;
1037  mpz_set_str (d->value, p, 10);
1038  if (*p == '-') {
1039  ++p;
1040  }
1041  len = (cob_sli_t)strlen (p);
1042  cob_gmp_free (q);
1043  len -= scale;
1044  if (len >= 0) {
1045  d->scale = len;
1046  } else {
1047  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-len);
1048  mpz_mul (d->value, d->value, cob_mexp);
1049  d->scale = 0;
1050  }
1051 }
void cob_exit_intrinsic ( void  )

References calc_base, calc_struct::calc_field, COB_DEPTH_LEVEL, cob_free(), cob_log_half, cob_mexp, cob_mpft, cob_mpft2, cob_mpft_get, cob_mpzt, cob_pi, cob_sqrt_two, cob_u32_t, cob_field::data, and cob_decimal::value.

Referenced by cob_terminate_routines().

5827 {
5828  struct calc_struct *calc_temp;
5829  cob_u32_t i;
5830 
5831  mpf_clear (cob_log_half);
5832  mpf_clear (cob_sqrt_two);
5833  mpf_clear (cob_pi);
5834 
5835  mpf_clear (cob_mpft_get);
5836  mpf_clear (cob_mpft2);
5837  mpf_clear (cob_mpft);
5838 
5839  mpz_clear (d5.value);
5840  mpz_clear (d4.value);
5841  mpz_clear (d3.value);
5842  mpz_clear (d2.value);
5843  mpz_clear (d1.value);
5844 
5845  mpz_clear (cob_mpzt);
5846  mpz_clear (cob_mexp);
5847 
5848  calc_temp = calc_base;
5849  for (i = 0; i < COB_DEPTH_LEVEL; ++i, ++calc_temp) {
5850  if (calc_temp->calc_field.data) {
5851  cob_free (calc_temp->calc_field.data);
5852  }
5853  }
5854  cob_free (calc_base);
5855 }
void cob_get_indirect_field ( cob_field *  f)

References cob_move().

2068 {
2069  cob_move (move_field, f);
2070 }
void cob_init_intrinsic ( cob_global *  lptr)

References calc_base, calc_struct::calc_field, calc_struct::calc_size, COB_DEPTH_LEVEL, cob_log_half, COB_LOG_HALF_LEN, cob_log_half_str, cob_malloc(), cob_mexp, COB_MPF_PREC, cob_mpft, cob_mpft2, cob_mpft_get, COB_MPZ_DEF, cob_mpzt, cob_pi, COB_PI_LEN, cob_pi_str, cob_sqrt_two, COB_SQRT_TWO_LEN, cob_sqrt_two_str, cob_u32_t, curr_entry, cob_field::data, NULL, cob_decimal::scale, cob_field::size, and cob_decimal::value.

Referenced by cob_init().

5859 {
5860  struct calc_struct *calc_temp;
5861  cob_u32_t i;
5862 
5863  cobglobptr = lptr;
5864 
5865  move_field = NULL;
5866  curr_entry = 0;
5867  curr_field = NULL;
5868  calc_base = cob_malloc (COB_DEPTH_LEVEL * sizeof(struct calc_struct));
5869  calc_temp = calc_base;
5870  for (i = 0; i < COB_DEPTH_LEVEL; ++i, ++calc_temp) {
5871  calc_temp->calc_field.data = cob_malloc ((size_t)256);
5872  calc_temp->calc_field.size = 256;
5873  calc_temp->calc_size = 256;
5874  }
5875 
5876  mpz_init2 (cob_mexp, COB_MPZ_DEF);
5877  mpz_init2 (cob_mpzt, COB_MPZ_DEF);
5878  mpz_init2 (d1.value, 1536UL);
5879  d1.scale = 0;
5880  mpz_init2 (d2.value, 1536UL);
5881  d2.scale = 0;
5882  mpz_init2 (d3.value, 1536UL);
5883  d3.scale = 0;
5884  mpz_init2 (d4.value, 1536UL);
5885  d4.scale = 0;
5886  mpz_init2 (d5.value, 1536UL);
5887  d5.scale = 0;
5888 
5889  mpf_init2 (cob_mpft, COB_MPF_PREC);
5890  mpf_init2 (cob_mpft2, COB_MPF_PREC);
5891  mpf_init2 (cob_mpft_get, COB_MPF_PREC);
5892 
5893  mpf_init2 (cob_pi, COB_PI_LEN);
5894  mpf_set_str (cob_pi, cob_pi_str, 10);
5895 
5896  mpf_init2 (cob_sqrt_two, COB_SQRT_TWO_LEN);
5897  mpf_set_str (cob_sqrt_two, cob_sqrt_two_str, 10);
5898 
5899  mpf_init2 (cob_log_half, COB_LOG_HALF_LEN);
5900  mpf_set_str (cob_log_half, cob_log_half_str, 10);
5901 }
cob_field* cob_intr_abs ( cob_field *  srcfield)

References cob_decimal_get_field(), cob_decimal_set_field(), curr_field, make_field_entry(), and cob_decimal::value.

3438 {
3439  cob_decimal_set_field (&d1, srcfield);
3440  mpz_abs (d1.value, d1.value);
3441 
3442  make_field_entry (srcfield);
3443  (void)cob_decimal_get_field (&d1, curr_field, 0);
3444  return curr_field;
3445 }
cob_field* cob_intr_acos ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_cmp(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), COB_EC_ARGUMENT_FUNCTION, cob_mpf_acos(), cob_mpft, cob_set_exception(), curr_field, cob_decimal::scale, and cob_decimal::value.

3449 {
3450  cob_decimal_set_field (&d1, srcfield);
3451 
3452  mpz_set (d4.value, d1.value);
3453  mpz_set (d5.value, d1.value);
3454  d4.scale = d1.scale;
3455  d5.scale = d1.scale;
3456  mpz_set_si (d2.value, -1L);
3457  d2.scale = 0;
3458  mpz_set_ui (d3.value, 1UL);
3459  d3.scale = 0;
3460 
3461  cob_set_exception (0);
3462  if (cob_decimal_cmp (&d4, &d2) < 0 || cob_decimal_cmp (&d5, &d3) > 0) {
3463  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3464  cob_alloc_set_field_uint (0);
3465  return curr_field;
3466  }
3467 
3468  cob_decimal_get_mpf (cob_mpft, &d1);
3469  cob_mpf_acos (cob_mpft, cob_mpft);
3470  cob_decimal_set_mpf (&d1, cob_mpft);
3471  cob_alloc_field (&d1);
3472  (void)cob_decimal_get_field (&d1, curr_field, 0);
3473 
3474  return curr_field;
3475 }
cob_field* cob_intr_annuity ( cob_field *  srcfield1,
cob_field *  srcfield2 
)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_pow(), cob_decimal_set_field(), cob_decimal_sub(), COB_EC_ARGUMENT_FUNCTION, cob_set_exception(), cob_trim_decimal(), curr_field, cob_decimal::scale, sign, and cob_decimal::value.

3892 {
3893  int sign;
3894 
3895  cob_decimal_set_field (&d1, srcfield1);
3896  cob_decimal_set_field (&d2, srcfield2);
3897 
3898  /* P1 >= 0, P2 > 0 and integer */
3899  sign = mpz_sgn (d1.value);
3900  if (sign < 0 || mpz_sgn (d2.value) <= 0 || d2.scale != 0) {
3901  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3902  cob_alloc_set_field_uint (0);
3903  return curr_field;
3904  }
3905 
3906  if (!sign) {
3907  mpz_set_ui (d1.value, 1UL);
3908  d1.scale = 0;
3909  cob_decimal_div (&d1, &d2);
3910  cob_alloc_field (&d1);
3911  (void)cob_decimal_get_field (&d1, curr_field, 0);
3912  return curr_field;
3913  }
3914 
3915  /* x = P1 / (1 - (1 + P1) ^ (-P2)) */
3916  mpz_neg (d2.value, d2.value);
3917 
3918  mpz_set (d3.value, d1.value);
3919  d3.scale = d1.scale;
3920  mpz_set_ui (d4.value, 1UL);
3921  d4.scale = 0;
3922  cob_decimal_add (&d3, &d4);
3923  cob_trim_decimal (&d3);
3924  cob_trim_decimal (&d2);
3925  cob_decimal_pow (&d3, &d2);
3926  mpz_set_ui (d4.value, 1UL);
3927  d4.scale = 0;
3928  cob_decimal_sub (&d4, &d3);
3929  cob_trim_decimal (&d4);
3930  cob_trim_decimal (&d1);
3931  cob_decimal_div (&d1, &d4);
3932  cob_alloc_field (&d1);
3933  (void)cob_decimal_get_field (&d1, curr_field, 0);
3934  return curr_field;
3935 }
cob_field* cob_intr_asin ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_cmp(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), COB_EC_ARGUMENT_FUNCTION, cob_mpf_asin(), cob_mpft, cob_set_exception(), curr_field, cob_decimal::scale, and cob_decimal::value.

3479 {
3480  cob_decimal_set_field (&d1, srcfield);
3481 
3482  mpz_set (d4.value, d1.value);
3483  mpz_set (d5.value, d1.value);
3484  d4.scale = d1.scale;
3485  d5.scale = d1.scale;
3486  mpz_set_si (d2.value, -1L);
3487  d2.scale = 0;
3488  mpz_set_ui (d3.value, 1UL);
3489  d3.scale = 0;
3490 
3491  cob_set_exception (0);
3492  if (cob_decimal_cmp (&d4, &d2) < 0 || cob_decimal_cmp (&d5, &d3) > 0) {
3493  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3494  cob_alloc_set_field_uint (0);
3495  return curr_field;
3496  }
3497 
3498  if (!mpz_sgn (d1.value)) {
3499  /* Asin (0) = 0 */
3500  cob_alloc_set_field_uint (0);
3501  return curr_field;
3502  }
3503 
3504  cob_decimal_get_mpf (cob_mpft, &d1);
3505  cob_mpf_asin (cob_mpft, cob_mpft);
3506  cob_decimal_set_mpf (&d1, cob_mpft);
3507  cob_alloc_field (&d1);
3508  (void)cob_decimal_get_field (&d1, curr_field, 0);
3509 
3510  return curr_field;
3511 }
cob_field* cob_intr_atan ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), cob_mpf_atan(), cob_mpft, cob_set_exception(), curr_field, and cob_decimal::value.

3515 {
3516  cob_decimal_set_field (&d1, srcfield);
3517 
3518  cob_set_exception (0);
3519 
3520  if (!mpz_sgn (d1.value)) {
3521  /* Atan (0) = 0 */
3522  cob_alloc_set_field_uint (0);
3523  return curr_field;
3524  }
3525 
3526  cob_decimal_get_mpf (cob_mpft, &d1);
3527  cob_mpf_atan (cob_mpft, cob_mpft);
3528  cob_decimal_set_mpf (&d1, cob_mpft);
3529  cob_alloc_field (&d1);
3530  (void)cob_decimal_get_field (&d1, curr_field, 0);
3531 
3532  return curr_field;
3533 }
cob_field* cob_intr_binop ( cob_field *  f1,
const int  op,
cob_field *  f2 
)

References cob_alloc_field(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_mul(), cob_decimal_pow(), cob_decimal_set_field(), cob_decimal_sub(), COB_EC_SIZE_ZERO_DIVIDE, cob_set_exception(), curr_field, cob_decimal::scale, and cob_decimal::value.

2174 {
2175  cob_decimal_set_field (&d1, f1);
2176  cob_decimal_set_field (&d2, f2);
2177  switch (op) {
2178  case '+':
2179  cob_decimal_add (&d1, &d2);
2180  break;
2181  case '-':
2182  cob_decimal_sub (&d1, &d2);
2183  break;
2184  case '*':
2185  cob_decimal_mul (&d1, &d2);
2186  break;
2187  case '/':
2188  cob_set_exception (0);
2189  if (!mpz_sgn (d2.value)) {
2190  /* Divide by zero */
2191  cob_set_exception (COB_EC_SIZE_ZERO_DIVIDE);
2192  mpz_set_ui (d1.value, 0UL);
2193  d1.scale = 0;
2194  } else {
2195  cob_decimal_div (&d1, &d2);
2196  }
2197  break;
2198  case '^':
2199  cob_decimal_pow (&d1, &d2);
2200  break;
2201  default:
2202  break;
2203  }
2204 
2205  cob_alloc_field (&d1);
2206  (void)cob_decimal_get_field (&d1, curr_field, 0);
2207  return curr_field;
2208 }
cob_field* cob_intr_boolean_of_integer ( cob_field *  f1,
cob_field *  f2 
)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5738 {
5739  COB_UNUSED (f1);
5740  COB_UNUSED (f2);
5741 
5742  cob_fatal_error (COB_FERROR_FUNCTION);
5743 }
cob_field* cob_intr_byte_length ( cob_field *  srcfield)

References cob_alloc_set_field_uint(), cob_u32_t, curr_field, and cob_field::size.

2225 {
2226  cob_alloc_set_field_uint ((cob_u32_t)srcfield->size);
2227  return curr_field;
2228 }
cob_field* cob_intr_char ( cob_field *  srcfield)

References COB_FIELD_INIT, cob_get_int(), curr_field, cob_field::data, make_field_entry(), and NULL.

2964 {
2965  int i;
2966  cob_field field;
2967 
2968  COB_FIELD_INIT (1, NULL, &const_alpha_attr);
2969  make_field_entry (&field);
2970 
2971  i = cob_get_int (srcfield);
2972  if (i < 1 || i > 256) {
2973  *curr_field->data = 0;
2974  } else {
2975  *curr_field->data = i - 1;
2976  }
2977  return curr_field;
2978 }
cob_field* cob_intr_char_national ( cob_field *  srcfield)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5747 {
5748  COB_UNUSED (srcfield);
5749 
5750  cob_fatal_error (COB_FERROR_FUNCTION);
5751 }
cob_field* cob_intr_combined_datetime ( cob_field *  srcdays,
cob_field *  srctime 
)

References COB_ATTR_INIT, COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, cob_get_int(), cob_set_exception(), COB_TYPE_NUMERIC_DISPLAY, curr_field, cob_field::data, make_field_entry(), NULL, valid_integer_date(), and valid_time().

3007 {
3008  int srdays;
3009  int srtime;
3010  cob_field_attr attr;
3011  cob_field field;
3012  char buff[16];
3013 
3014  COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 12, 5, 0, NULL);
3015  COB_FIELD_INIT (12, NULL, &attr);
3016  make_field_entry (&field);
3017 
3018  cob_set_exception (0);
3019  srdays = cob_get_int (srcdays);
3020  if (!valid_integer_date (srdays)) {
3021  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3022  memset (curr_field->data, '0', (size_t)12);
3023  return curr_field;
3024  }
3025  srtime = cob_get_int (srctime);
3026  if (!valid_time (srtime)) {
3027  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3028  memset (curr_field->data, '0', (size_t)12);
3029  return curr_field;
3030  }
3031  snprintf (buff, (size_t)15, "%7.7d%5.5d", srdays, srtime);
3032  memcpy (curr_field->data, buff, (size_t)12);
3033  return curr_field;
3034 }
cob_field* cob_intr_concatenate ( const int  offset,
const int  length,
const int  params,
  ... 
)

References calc_ref_mod(), COB_FIELD_INIT, cob_free(), cob_malloc(), curr_field, cob_field::data, make_field_entry(), NULL, p, params, cob_field::size, and unlikely.

2469 {
2470  cob_field **f;
2471  unsigned char *p;
2472  size_t calcsize;
2473  int i;
2474  cob_field field;
2475  va_list args;
2476 
2477  f = cob_malloc ((size_t)params * sizeof (cob_field *));
2478 
2479  va_start (args, params);
2480 
2481  /* Extract args / calculate size */
2482  calcsize = 0;
2483  for (i = 0; i < params; ++i) {
2484  f[i] = va_arg (args, cob_field *);
2485  calcsize += f[i]->size;
2486  }
2487  va_end (args);
2488 
2489  COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
2490  make_field_entry (&field);
2491 
2492  p = curr_field->data;
2493  for (i = 0; i < params; ++i) {
2494  memcpy (p, f[i]->data, f[i]->size);
2495  p += f[i]->size;
2496  }
2497 
2498  if (unlikely(offset > 0)) {
2499  calc_ref_mod (curr_field, offset, length);
2500  }
2501  cob_free (f);
2502  return curr_field;
2503 }
cob_field* cob_intr_cos ( cob_field *  srcfield)

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), cob_mpf_cos(), cob_mpft, cob_set_exception(), and curr_field.

3537 {
3538  cob_decimal_set_field (&d1, srcfield);
3539 
3540  cob_set_exception (0);
3541 
3542  cob_decimal_get_mpf (cob_mpft, &d1);
3543  cob_mpf_cos (cob_mpft, cob_mpft);
3544  cob_decimal_set_mpf (&d1, cob_mpft);
3545  cob_alloc_field (&d1);
3546  (void)cob_decimal_get_field (&d1, curr_field, 0);
3547 
3548  return curr_field;
3549 }
cob_field* cob_intr_currency_symbol ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, cob_set_exception(), curr_field, cob_field::data, make_field_entry(), NULL, p, and cob_field::size.

5211 {
5212 #ifdef HAVE_LOCALECONV
5213  struct lconv *p;
5214  size_t size;
5215 #endif
5216  cob_field field;
5217 
5218  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5219  cob_set_exception (0);
5220 
5221 #ifdef HAVE_LOCALECONV
5222  p = localeconv ();
5223  size = strlen (p->currency_symbol);
5224  if (size) {
5225  field.size = size;
5226  } else {
5227  field.size = 1;
5228  }
5229  make_field_entry (&field);
5230  if (size) {
5231  memcpy (curr_field->data, p->currency_symbol, size);
5232  } else {
5233  curr_field->size = 0;
5234  curr_field->data[0] = 0;
5235  }
5236 #else
5237  field.size = 1;
5238  make_field_entry (&field);
5239  curr_field->data[0] = COB_MODULE_PTR->currency_symbol;
5240 #endif
5241  return curr_field;
5242 }
cob_field* cob_intr_current_date ( const int  offset,
const int  length 
)

References calc_ref_mod(), COB_FIELD_INIT, curr_field, cob_field::data, make_field_entry(), NULL, and unlikely.

2869 {
2870 #if defined(_WIN32) && !defined(__CYGWIN__)
2871  struct tm *tmptr;
2872  long contz;
2873  struct _timeb tmb;
2874  cob_field field;
2875 #else
2876 
2877  struct tm *tmptr;
2878 #if !defined(__linux__) && !defined(__CYGWIN__) && !defined(COB_STRFTIME) && defined(HAVE_TIMEZONE)
2879  long contz;
2880 #endif
2881  time_t curtime;
2882  cob_field field;
2883 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
2884  struct timeval tmv;
2885  char buff2[8];
2886 #endif
2887 #endif
2888  char buff[24];
2889 
2890  COB_FIELD_INIT (21, NULL, &const_alpha_attr);
2891  make_field_entry (&field);
2892  memset (buff, 0, sizeof(buff));
2893 
2894 #if defined(_WIN32) && !defined(__CYGWIN__)
2895  _ftime (&tmb);
2896  tmptr = localtime (&(tmb.time));
2897  /* Leap seconds ? */
2898  if (tmptr->tm_sec >= 60) {
2899  tmptr->tm_sec = 59;
2900  }
2901  if (tmb.timezone <= 0) {
2902  contz = -tmb.timezone;
2903  snprintf (buff, (size_t)23,
2904  "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d+%2.2ld%2.2ld",
2905  tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
2906  tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
2907  tmb.millitm / 100, contz / 60, contz % 60);
2908  } else {
2909  contz = tmb.timezone;
2910  snprintf (buff, (size_t)23,
2911  "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d-%2.2ld%2.2ld",
2912  tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
2913  tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
2914  tmb.millitm / 100, contz / 60, contz % 60);
2915  }
2916 #else /* defined(_WIN32) && !defined(__CYGWIN__) */
2917 
2918 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
2919  gettimeofday (&tmv, NULL);
2920  curtime = tmv.tv_sec;
2921 #else
2922  curtime = time (NULL);
2923 #endif
2924  tmptr = localtime (&curtime);
2925  /* Leap seconds ? */
2926  if (tmptr->tm_sec >= 60) {
2927  tmptr->tm_sec = 59;
2928  }
2929 
2930 #if defined(__linux__) || defined(__CYGWIN__) || defined(COB_STRFTIME)
2931  strftime (buff, (size_t)22, "%Y%m%d%H%M%S00%z", tmptr);
2932 #elif defined(HAVE_TIMEZONE)
2933  strftime (buff, (size_t)17, "%Y%m%d%H%M%S00", tmptr);
2934  contz = timezone;
2935  if (tmptr->tm_isdst > 0) {
2936  contz -= 3600;
2937  }
2938  if (contz <= 0) {
2939  contz = -contz;
2940  buff[16] = '+';
2941  } else {
2942  buff[16] = '-';
2943  }
2944  sprintf(&buff[17], "%2.2ld%2.2ld", contz / 3600, (contz % 3600) / 60);
2945 #else
2946  strftime (buff, (size_t)22, "%Y%m%d%H%M%S0000000", tmptr);
2947 #endif
2948 
2949 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
2950  snprintf(buff2, (size_t)7, "%2.2ld", tmv.tv_usec / 10000);
2951  memcpy (&buff[14], buff2, (size_t)2);
2952 #endif
2953 #endif
2954 
2955  memcpy (curr_field->data, buff, (size_t)21);
2956  if (unlikely(offset > 0)) {
2957  calc_ref_mod (curr_field, offset, length);
2958  }
2959  return curr_field;
2960 }
cob_field* cob_intr_date_of_integer ( cob_field *  srcdays)

References COB_ATTR_INIT, COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, cob_get_int(), cob_set_exception(), COB_TYPE_NUMERIC_DISPLAY, curr_field, cob_field::data, date_of_integer(), make_field_entry(), NULL, and valid_integer_date().

3038 {
3039  int days;
3040  int month;
3041  int year;
3042  cob_field_attr attr;
3043  cob_field field;
3044  char buff[16];
3045 
3046  COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
3047  COB_FIELD_INIT (8, NULL, &attr);
3048  make_field_entry (&field);
3049 
3050  cob_set_exception (0);
3051  /* Base 1601-01-01 */
3052  days = cob_get_int (srcdays);
3053  if (!valid_integer_date (days)) {
3054  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3055  memset (curr_field->data, '0', (size_t)8);
3056  return curr_field;
3057  }
3058 
3059  date_of_integer (days, &year, &month, &days);
3060 
3061  snprintf (buff, (size_t)15, "%4.4d%2.2d%2.2d", year, month, days);
3062  memcpy (curr_field->data, buff, (size_t)8);
3063  return curr_field;
3064 }
cob_field* cob_intr_date_to_yyyymmdd ( const int  params,
  ... 
)

References cob_alloc_set_field_int(), cob_alloc_set_field_uint(), COB_EC_ARGUMENT_FUNCTION, cob_get_int(), cob_set_exception(), curr_field, NULL, and valid_year().

4485 {
4486  cob_field *f;
4487  struct tm *timeptr;
4488  va_list args;
4489  time_t t;
4490  int year;
4491  int mmdd;
4492  int interval;
4493  int xqtyear;
4494  int maxyear;
4495 
4496  cob_set_exception (0);
4497  va_start (args, params);
4498  f = va_arg (args, cob_field *);
4499  year = cob_get_int (f);
4500  mmdd = year % 10000;
4501  year /= 10000;
4502  if (params > 1) {
4503  f = va_arg (args, cob_field *);
4504  interval = cob_get_int (f);
4505  } else {
4506  interval = 50;
4507  }
4508  if (params > 2) {
4509  f = va_arg (args, cob_field *);
4510  xqtyear = cob_get_int (f);
4511  } else {
4512  t = time (NULL);
4513  timeptr = localtime (&t);
4514  xqtyear = 1900 + timeptr->tm_year;
4515  }
4516  va_end (args);
4517 
4518  if (year < 0 || year > 999999) {
4519  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4520  cob_alloc_set_field_uint (0);
4521  return curr_field;
4522  }
4523  if (!valid_year (xqtyear)) {
4524  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4525  cob_alloc_set_field_uint (0);
4526  return curr_field;
4527  }
4528  maxyear = xqtyear + interval;
4529  if (maxyear < 1700 || maxyear > 9999) {
4530  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4531  cob_alloc_set_field_uint (0);
4532  return curr_field;
4533  }
4534  if (maxyear % 100 >= year) {
4535  year += 100 * (maxyear / 100);
4536  } else {
4537  year += 100 * ((maxyear / 100) - 1);
4538  }
4539  year *= 10000;
4540  year += mmdd;
4541  cob_alloc_set_field_int (year);
4542  return curr_field;
4543 }
cob_field* cob_intr_day_of_integer ( cob_field *  srcdays)

References COB_ATTR_INIT, COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, cob_get_int(), cob_set_exception(), COB_TYPE_NUMERIC_DISPLAY, curr_field, cob_field::data, day_of_integer(), make_field_entry(), NULL, and valid_integer_date().

3068 {
3069  int days;
3070  int baseyear;
3071  cob_field_attr attr;
3072  cob_field field;
3073  char buff[16];
3074 
3075  COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 7, 0, 0, NULL);
3076  COB_FIELD_INIT (7, NULL, &attr);
3077  make_field_entry (&field);
3078 
3079  cob_set_exception (0);
3080  /* Base 1601-01-01 */
3081  days = cob_get_int (srcdays);
3082  if (!valid_integer_date (days)) {
3083  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3084  memset (curr_field->data, '0', (size_t)7);
3085  return curr_field;
3086  }
3087 
3088  day_of_integer (days, &baseyear, &days);
3089  snprintf (buff, (size_t)15, "%4.4d%3.3d", baseyear, days);
3090 
3091  memcpy (curr_field->data, buff, (size_t)7);
3092  return curr_field;
3093 }
cob_field* cob_intr_day_to_yyyyddd ( const int  params,
  ... 
)

References cob_alloc_set_field_int(), cob_alloc_set_field_uint(), COB_EC_ARGUMENT_FUNCTION, cob_get_int(), cob_set_exception(), curr_field, NULL, and valid_year().

4547 {
4548  cob_field *f;
4549  struct tm *timeptr;
4550  va_list args;
4551  time_t t;
4552  int year;
4553  int days;
4554  int interval;
4555  int xqtyear;
4556  int maxyear;
4557 
4558  cob_set_exception (0);
4559  va_start (args, params);
4560  f = va_arg (args, cob_field *);
4561  year = cob_get_int (f);
4562  days = year % 1000;
4563  year /= 1000;
4564  if (params > 1) {
4565  f = va_arg (args, cob_field *);
4566  interval = cob_get_int (f);
4567  } else {
4568  interval = 50;
4569  }
4570  if (params > 2) {
4571  f = va_arg (args, cob_field *);
4572  xqtyear = cob_get_int (f);
4573  } else {
4574  t = time (NULL);
4575  timeptr = localtime (&t);
4576  xqtyear = 1900 + timeptr->tm_year;
4577  }
4578  va_end (args);
4579 
4580  if (year < 0 || year > 999999) {
4581  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4582  cob_alloc_set_field_uint (0);
4583  return curr_field;
4584  }
4585  if (!valid_year (xqtyear)) {
4586  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4587  cob_alloc_set_field_uint (0);
4588  return curr_field;
4589  }
4590  maxyear = xqtyear + interval;
4591  if (maxyear < 1700 || maxyear > 9999) {
4592  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4593  cob_alloc_set_field_uint (0);
4594  return curr_field;
4595  }
4596  if (maxyear % 100 >= year) {
4597  year += 100 * (maxyear / 100);
4598  } else {
4599  year += 100 * ((maxyear / 100) - 1);
4600  }
4601  year *= 1000;
4602  year += days;
4603  cob_alloc_set_field_int (year);
4604  return curr_field;
4605 }
cob_field* cob_intr_display_of ( const int  offset,
const int  length,
const int  params,
  ... 
)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5756 {
5757  COB_UNUSED (offset);
5758  COB_UNUSED (length);
5759  COB_UNUSED (params);
5760 
5761  cob_fatal_error (COB_FERROR_FUNCTION);
5762 }
cob_field* cob_intr_e ( void  )

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_set_mpf(), cob_mpf_exp(), cob_mpft, and curr_field.

3286 {
3287  mpf_set_ui (cob_mpft, 1UL);
3288  cob_mpf_exp (cob_mpft, cob_mpft);
3289  cob_decimal_set_mpf (&d1, cob_mpft);
3290  cob_alloc_field (&d1);
3291  (void)cob_decimal_get_field (&d1, curr_field, 0);
3292 
3293  return curr_field;
3294 }
cob_field* cob_intr_exception_file ( void  )

References __cob_global::cob_error_file, __cob_global::cob_exception_code, COB_FIELD_INIT, curr_field, cob_field::data, cob_file::file_status, make_field_entry(), NULL, cob_file::select_name, and cob_field::size.

2748 {
2749  size_t flen;
2750  cob_field field;
2751 
2752  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
2753  if (cobglobptr->cob_exception_code == 0 || !cobglobptr->cob_error_file ||
2754  (cobglobptr->cob_exception_code & 0x0500) != 0x0500) {
2755  field.size = 2;
2756  make_field_entry (&field);
2757  memcpy (curr_field->data, "00", (size_t)2);
2758  } else {
2759  flen = strlen (cobglobptr->cob_error_file->select_name);
2760  field.size = flen + 2;
2761  make_field_entry (&field);
2762  memcpy (curr_field->data,
2763  cobglobptr->cob_error_file->file_status, (size_t)2);
2764  memcpy (&(curr_field->data[2]),
2765  cobglobptr->cob_error_file->select_name, flen);
2766  }
2767  return curr_field;
2768 }
cob_field* cob_intr_exception_file_n ( void  )

References cob_fatal_error(), and COB_FERROR_FUNCTION.

5766 {
5767  cob_fatal_error (COB_FERROR_FUNCTION);
5768 }
cob_field* cob_intr_exception_location ( void  )

References COB_FIELD_INIT, cob_free(), __cob_global::cob_got_exception, cob_malloc(), __cob_global::cob_orig_line, __cob_global::cob_orig_paragraph, __cob_global::cob_orig_program_id, __cob_global::cob_orig_section, COB_SMALL_BUFF, COB_SMALL_MAX, curr_field, cob_field::data, make_field_entry(), NULL, and cob_field::size.

2772 {
2773  char *buff;
2774  cob_field field;
2775 
2776  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
2777  if (!cobglobptr->cob_got_exception || !cobglobptr->cob_orig_program_id) {
2778  field.size = 1;
2779  make_field_entry (&field);
2780  *(curr_field->data) = ' ';
2781  return curr_field;
2782  }
2783  buff = cob_malloc ((size_t)COB_SMALL_BUFF);
2784  if (cobglobptr->cob_orig_section && cobglobptr->cob_orig_paragraph) {
2785  snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s OF %s; %u",
2786  cobglobptr->cob_orig_program_id,
2787  cobglobptr->cob_orig_paragraph,
2788  cobglobptr->cob_orig_section,
2789  cobglobptr->cob_orig_line);
2790  } else if (cobglobptr->cob_orig_section) {
2791  snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u",
2792  cobglobptr->cob_orig_program_id,
2793  cobglobptr->cob_orig_section,
2794  cobglobptr->cob_orig_line);
2795  } else if (cobglobptr->cob_orig_paragraph) {
2796  snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u",
2797  cobglobptr->cob_orig_program_id,
2798  cobglobptr->cob_orig_paragraph,
2799  cobglobptr->cob_orig_line);
2800  } else {
2801  snprintf (buff, (size_t)COB_SMALL_MAX, "%s; ; %u",
2802  cobglobptr->cob_orig_program_id,
2803  cobglobptr->cob_orig_line);
2804  }
2805  field.size = strlen (buff);
2806  make_field_entry (&field);
2807  memcpy (curr_field->data, buff, field.size);
2808  cob_free (buff);
2809  return curr_field;
2810 }
cob_field* cob_intr_exception_location_n ( void  )

References cob_fatal_error(), and COB_FERROR_FUNCTION.

5772 {
5773  cob_fatal_error (COB_FERROR_FUNCTION);
5774 }
cob_field* cob_intr_exception_statement ( void  )

References __cob_global::cob_exception_code, COB_FIELD_INIT, __cob_global::cob_orig_statement, curr_field, cob_field::data, make_field_entry(), and NULL.

2834 {
2835  size_t flen;
2836  cob_field field;
2837 
2838  COB_FIELD_INIT (31, NULL, &const_alpha_attr);
2839  make_field_entry (&field);
2840 
2841  memset (curr_field->data, ' ', (size_t)31);
2842  if (cobglobptr->cob_exception_code && cobglobptr->cob_orig_statement) {
2843  flen = strlen (cobglobptr->cob_orig_statement);
2844  if (flen > 31) {
2845  memcpy (curr_field->data,
2846  cobglobptr->cob_orig_statement, (size_t)31);
2847  } else {
2848  memcpy (curr_field->data,
2849  cobglobptr->cob_orig_statement, flen);
2850  }
2851  }
2852  return curr_field;
2853 }
cob_field* cob_intr_exception_status ( void  )

References __cob_global::cob_exception_code, COB_FIELD_INIT, cob_get_exception_name(), curr_field, cob_field::data, make_field_entry(), and NULL.

2814 {
2815  const char *except_name;
2816  cob_field field;
2817 
2818  COB_FIELD_INIT (31, NULL, &const_alpha_attr);
2819  make_field_entry (&field);
2820 
2821  memset (curr_field->data, ' ', (size_t)31);
2822  if (cobglobptr->cob_exception_code) {
2823  except_name = cob_get_exception_name ();
2824  if (except_name == NULL) {
2825  except_name = "EXCEPTION-OBJECT";
2826  }
2827  memcpy (curr_field->data, except_name, strlen (except_name));
2828  }
2829  return curr_field;
2830 }
cob_field* cob_intr_exp ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), cob_mpf_exp(), cob_mpft, cob_set_exception(), curr_field, and cob_decimal::value.

3309 {
3310  cob_decimal_set_field (&d1, srcfield);
3311 
3312  cob_set_exception (0);
3313 
3314  if (!mpz_sgn (d1.value)) {
3315  /* Power is zero */
3316  cob_alloc_set_field_uint (1);
3317  return curr_field;
3318  }
3319 
3320  cob_decimal_get_mpf (cob_mpft, &d1);
3321  cob_mpf_exp (cob_mpft, cob_mpft);
3322  cob_decimal_set_mpf (&d1, cob_mpft);
3323  cob_alloc_field (&d1);
3324  (void)cob_decimal_get_field (&d1, curr_field, 0);
3325 
3326  return curr_field;
3327 }
cob_field* cob_intr_exp10 ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), cob_decimal_pow(), cob_decimal_set_field(), cob_set_exception(), cob_trim_decimal(), curr_field, cob_decimal::scale, sign, and cob_decimal::value.

3331 {
3332  int sign;
3333 
3334  cob_decimal_set_field (&d1, srcfield);
3335 
3336  cob_set_exception (0);
3337 
3338  sign = mpz_sgn (d1.value);
3339  if (!sign) {
3340  /* Power is zero */
3341  cob_alloc_set_field_uint (1);
3342  return curr_field;
3343  }
3344 
3345  cob_trim_decimal (&d1);
3346 
3347  if (!d1.scale) {
3348  /* Integer positive/negative powers */
3349  if (sign < 0 && mpz_fits_sint_p (d1.value)) {
3350  mpz_abs (d1.value, d1.value);
3351  d1.scale = mpz_get_si (d1.value);
3352  mpz_set_ui (d1.value, 1UL);
3353  cob_alloc_field (&d1);
3354  (void)cob_decimal_get_field (&d1, curr_field, 0);
3355  return curr_field;
3356  }
3357  if (sign > 0 && mpz_fits_ulong_p (d1.value)) {
3358  mpz_ui_pow_ui (d1.value, 10UL, mpz_get_ui (d1.value));
3359  cob_alloc_field (&d1);
3360  (void)cob_decimal_get_field (&d1, curr_field, 0);
3361  return curr_field;
3362  }
3363  }
3364 
3365  mpz_set_ui (d2.value, 10UL);
3366  d2.scale = 0;
3367  cob_decimal_pow (&d2, &d1);
3368  cob_alloc_field (&d2);
3369  (void)cob_decimal_get_field (&d2, curr_field, 0);
3370 
3371  return curr_field;
3372 }
cob_field* cob_intr_factorial ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), COB_EC_ARGUMENT_FUNCTION, cob_get_int(), cob_set_exception(), cob_uli_t, curr_field, cob_decimal::scale, and cob_decimal::value.

3265 {
3266  int srcval;
3267 
3268  cob_set_exception (0);
3269  srcval = cob_get_int (srcfield);
3270  d1.scale = 0;
3271  if (srcval < 0) {
3272  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3273  cob_alloc_set_field_uint (0);
3274  return curr_field;
3275  } else {
3276  mpz_fac_ui (d1.value, (cob_uli_t)srcval);
3277  }
3278 
3279  cob_alloc_field (&d1);
3280  (void)cob_decimal_get_field (&d1, curr_field, 0);
3281  return curr_field;
3282 }
cob_field* cob_intr_formatted_current_date ( const int  offset,
const int  length,
cob_field *  srcfield 
)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5779 {
5780  COB_UNUSED (offset);
5781  COB_UNUSED (length);
5782  COB_UNUSED (srcfield);
5783 
5784  cob_fatal_error (COB_FERROR_FUNCTION);
5785 }
cob_field* cob_intr_formatted_date ( const int  offset,
const int  length,
cob_field *  format_field,
cob_field *  days_field 
)

References calc_ref_mod(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, cob_get_int(), cob_set_exception(), curr_field, cob_field::data, format_date(), make_field_entry(), MAX_DATE_STR_LENGTH, NULL, num_leading_nonspace(), parse_date_format_string(), unlikely, and valid_day_and_format().

5509 {
5510  cob_field field;
5511  size_t field_length =
5512  num_leading_nonspace ((char *) format_field->data);
5513  char format_str[MAX_DATE_STR_LENGTH] = { '\0' };
5514  int days;
5515  struct date_format format;
5516  char buff[MAX_DATE_STR_LENGTH] = { '\0' };
5517 
5518  memcpy (format_str, format_field->data, field_length);
5519 
5520  COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
5521  make_field_entry (&field);
5522 
5523  cob_set_exception (0);
5524  days = cob_get_int (days_field);
5525 
5526  if (!valid_day_and_format (days, format_str)) {
5527  goto invalid_args;
5528  }
5529 
5530  format = parse_date_format_string (format_str);
5531  format_date (format, days, buff);
5532 
5533  memcpy (curr_field->data, buff, (size_t) field_length);
5534  goto end_of_func;
5535 
5536  invalid_args:
5537  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5538  memset (curr_field->data, ' ', strlen (format_str));
5539 
5540  end_of_func:
5541  if (unlikely(offset > 0)) {
5542  calc_ref_mod (curr_field, offset, length);
5543  }
5544  return curr_field;
5545 }
cob_field* cob_intr_formatted_datetime ( const int  offset,
const int  length,
const int  params,
  ... 
)

References calc_ref_mod(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, cob_get_int(), cob_set_exception(), cob_valid_datetime_format(), curr_field, cob_field::data, format_date(), format_time(), make_field_entry(), MAX_DATE_STR_LENGTH, MAX_DATETIME_STR_LENGTH, MAX_TIME_STR_LENGTH, NULL, num_leading_nonspace(), parse_date_format_string(), parse_time_format_string(), split_around_t(), try_get_valid_offset_time(), unlikely, valid_integer_date(), and valid_time().

5630 {
5631  va_list args;
5632  cob_field *fmt_field;
5633  cob_field *days_field;
5634  cob_field *time_field;
5635  cob_field *offset_time_field;
5636  cob_field field;
5637  size_t field_length;
5638  char fmt_str[MAX_DATETIME_STR_LENGTH] = { '\0' };
5639  char date_fmt_str[MAX_DATE_STR_LENGTH] = { '\0' };
5640  char time_fmt_str[MAX_TIME_STR_LENGTH] = { '\0' };
5641  struct date_format date_fmt;
5642  struct time_format time_fmt;
5643  char formatted_date[MAX_DATE_STR_LENGTH] = { '\0' };
5644  char formatted_time[MAX_TIME_STR_LENGTH] = { '\0' };
5645  int days;
5646  int time;
5647  int offset_time;
5648  int *offset_time_ptr;
5649  char buff[MAX_DATETIME_STR_LENGTH] = { '\0' };
5650 
5651  if (!(params == 3 || params == 4)) {
5652  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5653  make_field_entry (&field);
5654  goto invalid_args;
5655  }
5656 
5657  /* Get arguments */
5658  va_start (args, params);
5659 
5660  fmt_field = va_arg (args, cob_field *);
5661  days_field = va_arg (args, cob_field *);
5662  time_field = va_arg (args, cob_field *);
5663  if (params == 4) {
5664  offset_time_field = va_arg (args, cob_field *);
5665  } else {
5666  offset_time_field = NULL;
5667  }
5668 
5669  va_end (args);
5670 
5671  field_length = num_leading_nonspace ((char *) fmt_field->data);
5672  memcpy (fmt_str, fmt_field->data, field_length);
5673 
5674  COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
5675  make_field_entry (&field);
5676 
5677  cob_set_exception (0);
5678 
5679  /* Validate the formats, dates and times */
5680  if (!cob_valid_datetime_format (fmt_str)) {
5681  goto invalid_args;
5682  }
5683 
5684  days = cob_get_int (days_field);
5685  time = cob_get_int (time_field);
5686 
5687  if (!valid_integer_date (days) || !valid_time (time)) {
5688  goto invalid_args;
5689  }
5690 
5691  split_around_t (fmt_str, date_fmt_str, time_fmt_str);
5692 
5693  time_fmt = parse_time_format_string (time_fmt_str);
5694  if (try_get_valid_offset_time (time_fmt, offset_time_field,
5695  &offset_time, &offset_time_ptr)) {
5696  goto invalid_args;
5697  }
5698 
5699  date_fmt = parse_date_format_string (date_fmt_str);
5700 
5701  /* Format */
5702 
5703  format_date (date_fmt, days, formatted_date);
5704  format_time (time_fmt, time, offset_time_ptr, formatted_time);
5705 
5706  sprintf (buff, "%sT%s", formatted_date, formatted_time);
5707 
5708  memcpy (curr_field->data, buff, (size_t) field_length);
5709  goto end_of_func;
5710 
5711  invalid_args:
5712  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5713  if (fmt_str != NULL) {
5714  memset (curr_field->data, ' ', strlen (fmt_str));
5715  }
5716 
5717  end_of_func:
5718  if (unlikely (offset > 0)) {
5719  calc_ref_mod (curr_field, offset, length);
5720  }
5721  return curr_field;
5722 }
cob_field* cob_intr_formatted_time ( const int  offset,
const int  length,
const int  params,
  ... 
)

References calc_ref_mod(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, cob_get_int(), cob_set_exception(), cob_valid_time_format(), curr_field, cob_field::data, format_time(), make_field_entry(), MAX_TIME_STR_LENGTH, NULL, num_leading_nonspace(), parse_time_format_string(), try_get_valid_offset_time(), unlikely, and valid_time().

5550 {
5551  va_list args;
5552  cob_field *format_field;
5553  cob_field *time_field;
5554  cob_field *offset_time_field;
5555  cob_field field;
5556  size_t field_length;
5557  char buff[MAX_TIME_STR_LENGTH] = { '\0' };
5558  char format_str[MAX_TIME_STR_LENGTH] = { '\0' };
5559  int time;
5560  int offset_time;
5561  int *offset_time_ptr;
5562  struct time_format format;
5563 
5564  if (!(params == 2 || params == 3)) {
5565  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5566  make_field_entry (&field);
5567  goto invalid_args;
5568  }
5569 
5570  /* Get args */
5571  va_start (args, params);
5572 
5573  format_field = va_arg (args, cob_field *);
5574  time_field = va_arg (args, cob_field *);
5575  if (params == 3) {
5576  offset_time_field = va_arg (args, cob_field *);
5577  } else {
5578  offset_time_field = NULL;
5579  }
5580 
5581  va_end (args);
5582 
5583  /* Initialise buffers */
5584  field_length = num_leading_nonspace ((char *) format_field->data);
5585  memcpy (format_str, format_field->data, field_length);
5586 
5587  COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
5588  make_field_entry (&field);
5589 
5590  cob_set_exception (0);
5591 
5592  /* Extract and validate the times and time format */
5593 
5594  time = cob_get_int (time_field);
5595  if (!valid_time (time)) {
5596  goto invalid_args;
5597  }
5598 
5599  if (!cob_valid_time_format (format_str)) {
5600  goto invalid_args;
5601  }
5602  format = parse_time_format_string (format_str);
5603 
5604  if (try_get_valid_offset_time (format, offset_time_field,
5605  &offset_time, &offset_time_ptr)) {
5606  goto invalid_args;
5607  }
5608 
5609  format_time (format, time, offset_time_ptr, buff);
5610 
5611  memcpy (curr_field->data, buff, (size_t) field_length);
5612  goto end_of_func;
5613 
5614 invalid_args:
5615  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5616  if (format_str != NULL) {
5617  memset (curr_field->data, ' ', strlen (format_str));
5618  }
5619 
5620  end_of_func:
5621  if (unlikely(offset > 0)) {
5622  calc_ref_mod (curr_field, offset, length);
5623  }
5624  return curr_field;
5625 }
cob_field* cob_intr_fraction_part ( cob_field *  srcfield)

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_set_field(), cob_mexp, cob_uli_t, curr_field, cob_decimal::scale, and cob_decimal::value.

2277 {
2278  cob_decimal_set_field (&d1, srcfield);
2279  /* Check scale */
2280  if (d1.scale > 0) {
2281  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
2282  mpz_tdiv_r (d1.value, d1.value, cob_mexp);
2283  } else {
2284  /* No decimals */
2285  mpz_set_ui (d1.value, 0UL);
2286  d1.scale = 0;
2287  }
2288 
2289  cob_alloc_field (&d1);
2290  (void)cob_decimal_get_field (&d1, curr_field, 0);
2291  return curr_field;
2292 }
cob_field* cob_intr_highest_algebraic ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_BINARY_TRUNC, COB_FIELD_DIGITS, COB_FIELD_HAVE_SIGN, COB_FIELD_INIT, COB_FIELD_REAL_BINARY, COB_FIELD_SCALE, COB_FIELD_SIZE, COB_FIELD_TYPE, cob_set_exception(), COB_TYPE_ALPHANUMERIC, COB_TYPE_ALPHANUMERIC_EDITED, COB_TYPE_NATIONAL, COB_TYPE_NATIONAL_EDITED, COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_EDITED, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_PACKED, cob_uli_t, curr_field, cob_field::data, make_field_entry(), NULL, cob_decimal::scale, and cob_decimal::value.

5339 {
5340  cob_uli_t expo;
5341  size_t size;
5342  cob_field field;
5343 
5344  switch (COB_FIELD_TYPE (srcfield)) {
5345  case COB_TYPE_ALPHANUMERIC:
5346  case COB_TYPE_NATIONAL:
5347  size = COB_FIELD_SIZE (srcfield);
5348  COB_FIELD_INIT (size, NULL, &const_alpha_attr);
5349  make_field_entry (&field);
5350  memset (curr_field->data, 255, size);
5351  break;
5352 
5353  case COB_TYPE_ALPHANUMERIC_EDITED:
5354  case COB_TYPE_NATIONAL_EDITED:
5355  size = COB_FIELD_DIGITS (srcfield);
5356  COB_FIELD_INIT (size, NULL, &const_alpha_attr);
5357  make_field_entry (&field);
5358  memset (curr_field->data, 255, size);
5359  break;
5360 
5361  case COB_TYPE_NUMERIC_BINARY:
5362  if (COB_FIELD_REAL_BINARY (srcfield) ||
5363  !COB_FIELD_BINARY_TRUNC (srcfield)) {
5364  if (!COB_FIELD_HAVE_SIGN (srcfield)) {
5365  expo = COB_FIELD_SIZE (srcfield) * 8U;
5366  } else {
5367  expo = (COB_FIELD_SIZE (srcfield) * 8U) - 1U;
5368  }
5369  mpz_ui_pow_ui (d1.value, 2UL, expo);
5370  mpz_sub_ui (d1.value, d1.value, 1UL);
5371  d1.scale = COB_FIELD_SCALE (srcfield);
5372  cob_alloc_field (&d1);
5373  (void)cob_decimal_get_field (&d1, curr_field, 0);
5374  break;
5375  }
5376  expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5377  mpz_ui_pow_ui (d1.value, 10UL, expo);
5378  mpz_sub_ui (d1.value, d1.value, 1UL);
5379  d1.scale = COB_FIELD_SCALE (srcfield);
5380  cob_alloc_field (&d1);
5381  (void)cob_decimal_get_field (&d1, curr_field, 0);
5382  break;
5383 
5384  case COB_TYPE_NUMERIC_FLOAT:
5385  case COB_TYPE_NUMERIC_DOUBLE:
5386  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5387  cob_alloc_set_field_uint (0);
5388  break;
5389 
5390  case COB_TYPE_NUMERIC_DISPLAY:
5391  case COB_TYPE_NUMERIC_PACKED:
5392  case COB_TYPE_NUMERIC_EDITED:
5393  expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5394  mpz_ui_pow_ui (d1.value, 10UL, expo);
5395  mpz_sub_ui (d1.value, d1.value, 1UL);
5396  d1.scale = COB_FIELD_SCALE (srcfield);
5397  cob_alloc_field (&d1);
5398  (void)cob_decimal_get_field (&d1, curr_field, 0);
5399  break;
5400  default:
5401  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5402  cob_alloc_set_field_uint (0);
5403  break;
5404  }
5405  return curr_field;
5406 }
cob_field* cob_intr_integer ( cob_field *  srcfield)

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_set_field(), cob_mexp, cob_mpzt, cob_uli_t, curr_field, cob_decimal::scale, sign, and cob_decimal::value.

2232 {
2233  int sign;
2234 
2235  cob_decimal_set_field (&d1, srcfield);
2236  /* Check scale */
2237  if (d1.scale < 0) {
2238  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d1.scale);
2239  mpz_mul (d1.value, d1.value, cob_mexp);
2240  } else if (d1.scale > 0) {
2241  sign = mpz_sgn (d1.value);
2242  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
2243  mpz_tdiv_qr (d1.value, cob_mpzt, d1.value, cob_mexp);
2244  /* Check negative and has decimal places */
2245  if (sign < 0 && mpz_sgn (cob_mpzt)) {
2246  mpz_sub_ui (d1.value, d1.value, 1UL);
2247  }
2248  }
2249  d1.scale = 0;
2250 
2251  cob_alloc_field (&d1);
2252  (void)cob_decimal_get_field (&d1, curr_field, 0);
2253  return curr_field;
2254 }
cob_field* cob_intr_integer_of_boolean ( cob_field *  srcfield)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5789 {
5790  COB_UNUSED (srcfield);
5791 
5792  cob_fatal_error (COB_FERROR_FUNCTION);
5793 }
cob_field* cob_intr_integer_of_date ( cob_field *  srcfield)

References cob_alloc_set_field_int(), cob_alloc_set_field_uint(), COB_EC_ARGUMENT_FUNCTION, cob_get_int(), cob_set_exception(), curr_field, leap_days, leap_month_days, leap_year(), normal_days, normal_month_days, and valid_year().

3097 {
3098  int indate;
3099  int days;
3100  int totaldays;
3101  int month;
3102  int year;
3103  int baseyear;
3104 
3105  cob_set_exception (0);
3106  /* Base 1601-01-01 */
3107  indate = cob_get_int (srcfield);
3108  year = indate / 10000;
3109  if (!valid_year (year)) {
3110  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3111  cob_alloc_set_field_uint (0);
3112  return curr_field;
3113  }
3114  indate %= 10000;
3115  month = indate / 100;
3116  if (month < 1 || month > 12) {
3117  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3118  cob_alloc_set_field_uint (0);
3119  return curr_field;
3120  }
3121  days = indate % 100;
3122  if (days < 1 || days > 31) {
3123  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3124  cob_alloc_set_field_uint (0);
3125  return curr_field;
3126  }
3127  if (leap_year (year)) {
3128  if (days > leap_month_days[month]) {
3129  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3130  cob_alloc_set_field_uint (0);
3131  return curr_field;
3132  }
3133  } else {
3134  if (days > normal_month_days[month]) {
3135  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3136  cob_alloc_set_field_uint (0);
3137  return curr_field;
3138  }
3139  }
3140  totaldays = 0;
3141  baseyear = 1601;
3142  while (baseyear != year) {
3143  if (leap_year (baseyear)) {
3144  totaldays += 366;
3145  } else {
3146  totaldays += 365;
3147  }
3148  ++baseyear;
3149  }
3150  if (leap_year (baseyear)) {
3151  totaldays += leap_days[month - 1];
3152  } else {
3153  totaldays += normal_days[month - 1];
3154  }
3155  totaldays += days;
3156  cob_alloc_set_field_int (totaldays);
3157  return curr_field;
3158 }
cob_field* cob_intr_integer_of_day ( cob_field *  srcfield)

References cob_alloc_set_field_uint(), COB_EC_ARGUMENT_FUNCTION, cob_get_int(), cob_set_exception(), cob_u32_t, curr_field, leap_year(), and valid_year().

3162 {
3163  int indate;
3164  int days;
3165  cob_u32_t totaldays;
3166  int year;
3167  int baseyear;
3168 
3169  cob_set_exception (0);
3170  /* Base 1601-01-01 */
3171  indate = cob_get_int (srcfield);
3172  year = indate / 1000;
3173  if (!valid_year (year)) {
3174  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3175  cob_alloc_set_field_uint (0);
3176  return curr_field;
3177  }
3178  days = indate % 1000;
3179  if (days < 1 || days > 365 + leap_year (year)) {
3180  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3181  cob_alloc_set_field_uint (0);
3182  return curr_field;
3183  }
3184  totaldays = 0;
3185  baseyear = 1601;
3186  while (baseyear != year) {
3187  if (leap_year (baseyear)) {
3188  totaldays += 366;
3189  } else {
3190  totaldays += 365;
3191  }
3192  ++baseyear;
3193  }
3194  totaldays += days;
3195  cob_alloc_set_field_uint (totaldays);
3196  return curr_field;
3197 }
cob_field* cob_intr_integer_of_formatted_date ( cob_field *  format_field,
cob_field *  date_field 
)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5729 {
5730  COB_UNUSED (format_field);
5731  COB_UNUSED (date_field);
5732 
5733  cob_fatal_error (COB_FERROR_FUNCTION);
5734 }
cob_field* cob_intr_integer_part ( cob_field *  srcfield)

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_set_field(), cob_mexp, cob_uli_t, curr_field, cob_decimal::scale, and cob_decimal::value.

2258 {
2259  cob_decimal_set_field (&d1, srcfield);
2260  /* Check scale */
2261  if (d1.scale < 0) {
2262  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d1.scale);
2263  mpz_mul (d1.value, d1.value, cob_mexp);
2264  } else if (d1.scale > 0) {
2265  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
2266  mpz_tdiv_q (d1.value, d1.value, cob_mexp);
2267  }
2268  d1.scale = 0;
2269 
2270  cob_alloc_field (&d1);
2271  (void)cob_decimal_get_field (&d1, curr_field, 0);
2272  return curr_field;
2273 }
cob_field* cob_intr_lcl_time_from_secs ( const int  offset,
const int  length,
cob_field *  srcfield,
cob_field *  locale_field 
)

References calc_ref_mod(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, COB_FIELD_IS_NUMERIC, cob_field_to_string(), cob_get_int(), __cob_global::cob_locale, cob_set_exception(), COB_SMALL_BUFF, COB_SMALL_MAX, curr_field, cob_field::data, make_field_entry(), NULL, p, cob_field::size, unlikely, and valid_time().

4961 {
4962  cob_field field;
4963 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
4964  size_t len;
4965  int indate;
4966  int hours;
4967  int minutes;
4968  int seconds;
4969 #ifdef HAVE_LANGINFO_CODESET
4970  char *deflocale = NULL;
4971  struct tm tstruct;
4972  char buff2[128];
4973 #else
4974  unsigned char *p;
4975  LCID localeid = LOCALE_USER_DEFAULT;
4976  SYSTEMTIME syst;
4977 #endif
4978  char buff[128];
4979  char locale_buff[COB_SMALL_BUFF];
4980 #endif
4981 
4982  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
4983  cob_set_exception (0);
4984 
4985 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
4986  if (COB_FIELD_IS_NUMERIC (srcfield)) {
4987  indate = cob_get_int (srcfield);
4988  } else {
4989  goto derror;
4990  }
4991  if (!valid_time (indate)) {
4992  goto derror;
4993  }
4994  hours = indate / 3600;
4995  indate %= 3600;
4996  minutes = indate / 60;
4997  seconds = indate % 60;
4998 
4999 #ifdef HAVE_LANGINFO_CODESET
5000  memset ((void *)&tstruct, 0, sizeof(struct tm));
5001  tstruct.tm_hour = hours;
5002  tstruct.tm_min = minutes;
5003  tstruct.tm_sec = seconds;
5004  if (locale_field) {
5005  if (locale_field->size >= COB_SMALL_BUFF) {
5006  goto derror;
5007  }
5008  cob_field_to_string (locale_field, locale_buff,
5009  (size_t)COB_SMALL_MAX);
5010  deflocale = locale_buff;
5011  (void) setlocale (LC_TIME, deflocale);
5012  }
5013  memset (buff2, 0, sizeof(buff2));
5014  snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
5015  if (deflocale) {
5016  (void) setlocale (LC_ALL, cobglobptr->cob_locale);
5017  }
5018  strftime (buff, sizeof(buff), buff2, &tstruct);
5019 #else
5020  memset ((void *)&syst, 0, sizeof(syst));
5021  syst.wHour = hours;
5022  syst.wMinute = minutes;
5023  syst.wSecond = seconds;
5024  if (locale_field) {
5025  if (locale_field->size >= COB_SMALL_BUFF) {
5026  goto derror;
5027  }
5028  cob_field_to_string (locale_field, locale_buff,
5029  COB_SMALL_MAX);
5030  for (p = (unsigned char *)locale_buff; *p; ++p) {
5031  if (isalnum(*p) || *p == '_') {
5032  continue;
5033  }
5034  break;
5035  }
5036  *p = 0;
5037  for (len = 0; len < WINLOCSIZE; ++len) {
5038  if (!strcmp(locale_buff, wintable[len].winlocalename)) {
5039  localeid = wintable[len].winlocaleid;
5040  break;
5041  }
5042  }
5043  if (len == WINLOCSIZE) {
5044  goto derror;
5045  }
5046  }
5047  if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {
5048 
5049  goto derror;
5050  }
5051 #endif
5052  len = strlen (buff);
5053  field.size = len;
5054  make_field_entry (&field);
5055  memcpy (curr_field->data, buff, len);
5056  if (unlikely(offset > 0)) {
5057  calc_ref_mod (curr_field, offset, length);
5058  }
5059  return curr_field;
5060 derror:
5061 #endif
5062  field.size = 10;
5063  make_field_entry (&field);
5064  memset (curr_field->data, ' ', (size_t)10);
5065  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5066  return curr_field;
5067 }
cob_field* cob_intr_length ( cob_field *  srcfield)

References cob_alloc_set_field_uint(), COB_FIELD_IS_NATIONAL, COB_NATIONAL_SIZE, cob_u32_t, curr_field, and cob_field::size.

2214 {
2215  if (COB_FIELD_IS_NATIONAL (srcfield)) {
2216  cob_alloc_set_field_uint ((cob_u32_t)srcfield->size / COB_NATIONAL_SIZE);
2217  } else {
2218  cob_alloc_set_field_uint ((cob_u32_t)srcfield->size);
2219  }
2220  return curr_field;
2221 }
cob_field* cob_intr_locale_compare ( const int  params,
  ... 
)

References COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, cob_field_to_string(), cob_free(), __cob_global::cob_locale, cob_malloc(), cob_set_exception(), curr_field, cob_field::data, make_field_entry(), NULL, p, and cob_field::size.

5410 {
5411  cob_field *f1;
5412  cob_field *f2;
5413  cob_field *locale_field;
5414 #ifdef HAVE_STRCOLL
5415  unsigned char *p;
5416  unsigned char *p1;
5417  unsigned char *p2;
5418  char *deflocale;
5419  size_t size;
5420  size_t size2;
5421  int ret;
5422 #endif
5423  cob_field field;
5424  va_list args;
5425 
5426  cob_set_exception (0);
5427  va_start (args, params);
5428  f1 = va_arg (args, cob_field *);
5429  f2 = va_arg (args, cob_field *);
5430  if (params > 2) {
5431  locale_field = va_arg (args, cob_field *);
5432  } else {
5433  locale_field = NULL;
5434  }
5435  va_end (args);
5436 
5437  COB_FIELD_INIT (1, NULL, &const_alpha_attr);
5438  make_field_entry (&field);
5439 
5440 #ifdef HAVE_STRCOLL
5441  deflocale = NULL;
5442 
5443  size = f1->size;
5444  size2 = size;
5445  for (p = f1->data + size - 1U; p != f1->data; --p) {
5446  if (*p != ' ') {
5447  break;
5448  }
5449  size2--;
5450  }
5451  p1 = cob_malloc (size2 + 1U);
5452  memcpy (p1, f1->data, size2);
5453 
5454  size = f2->size;
5455  size2 = size;
5456  for (p = f2->data + size - 1U; p != f2->data; --p) {
5457  if (*p != ' ') {
5458  break;
5459  }
5460  size2--;
5461  }
5462  p2 = cob_malloc (size2 + 1U);
5463  memcpy (p2, f2->data, size2);
5464 
5465  if (locale_field) {
5466  if (!locale_field->size) {
5467  goto derror;
5468  }
5469 #ifdef HAVE_SETLOCALE
5470  deflocale = cob_malloc (locale_field->size + 1U);
5471  cob_field_to_string (locale_field, deflocale,
5472  (size_t)(locale_field->size + 1U));
5473  (void) setlocale (LC_COLLATE, deflocale);
5474 #else
5475  goto derror;
5476 #endif
5477  }
5478 
5479  ret = strcoll ((char *)p1, (char *)p2);
5480  if (ret < 0) {
5481  curr_field->data[0] = '<';
5482  } else if (ret > 0) {
5483  curr_field->data[0] = '>';
5484  } else {
5485  curr_field->data[0] = '=';
5486  }
5487  cob_free (p1);
5488  cob_free (p2);
5489 
5490 #ifdef HAVE_SETLOCALE
5491  if (deflocale) {
5492  (void) setlocale (LC_ALL, cobglobptr->cob_locale);
5493  cob_free (deflocale);
5494  }
5495 #endif
5496 
5497  return curr_field;
5498 derror:
5499 #endif
5500  curr_field->data[0] = ' ';
5501  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5502 
5503  return curr_field;
5504 }
cob_field* cob_intr_locale_date ( const int  offset,
const int  length,
cob_field *  srcfield,
cob_field *  locale_field 
)

References calc_ref_mod(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, COB_FIELD_IS_NUMERIC, cob_field_to_string(), cob_get_int(), __cob_global::cob_locale, cob_set_exception(), COB_SMALL_BUFF, COB_SMALL_MAX, curr_field, cob_field::data, leap_month_days, leap_year(), make_field_entry(), normal_month_days, NULL, p, cob_field::size, unlikely, and valid_year().

4692 {
4693  cob_field field;
4694 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
4695  size_t len;
4696  int indate;
4697  int days;
4698  int month;
4699  int year;
4700 #ifdef HAVE_LANGINFO_CODESET
4701  unsigned char *p;
4702  char *deflocale = NULL;
4703  struct tm tstruct;
4704  char buff2[128];
4705 #else
4706  unsigned char *p;
4707  LCID localeid = LOCALE_USER_DEFAULT;
4708  SYSTEMTIME syst;
4709 #endif
4710  char buff[128];
4711  char locale_buff[COB_SMALL_BUFF];
4712 #endif
4713 
4714  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
4715  cob_set_exception (0);
4716 
4717 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
4718  if (COB_FIELD_IS_NUMERIC (srcfield)) {
4719  indate = cob_get_int (srcfield);
4720  } else {
4721  if (srcfield->size < 8) {
4722  goto derror;
4723  }
4724  p = srcfield->data;
4725  indate = 0;
4726  for (len = 0; len < 8; ++len, ++p) {
4727  if (isdigit (*p)) {
4728  indate *= 10;
4729  indate += (*p - '0');
4730  } else {
4731  goto derror;
4732  }
4733  }
4734  }
4735  year = indate / 10000;
4736  if (!valid_year (year)) {
4737  goto derror;
4738  }
4739  indate %= 10000;
4740  month = indate / 100;
4741  if (month < 1 || month > 12) {
4742  goto derror;
4743  }
4744  days = indate % 100;
4745  if (days < 1 || days > 31) {
4746  goto derror;
4747  }
4748  if (leap_year (year)) {
4749  if (days > leap_month_days[month]) {
4750  goto derror;
4751  }
4752  } else {
4753  if (days > normal_month_days[month]) {
4754  goto derror;
4755  }
4756  }
4757 #ifdef HAVE_LANGINFO_CODESET
4758  month--;
4759 
4760  memset ((void *)&tstruct, 0, sizeof(struct tm));
4761  tstruct.tm_year = year - 1900;
4762  tstruct.tm_mon = month;
4763  tstruct.tm_mday = days;
4764  if (locale_field) {
4765  if (locale_field->size >= COB_SMALL_BUFF) {
4766  goto derror;
4767  }
4768  cob_field_to_string (locale_field, locale_buff,
4769  (size_t)COB_SMALL_MAX);
4770  deflocale = locale_buff;
4771  (void) setlocale (LC_TIME, deflocale);
4772  }
4773  memset (buff2, 0, sizeof(buff2));
4774  snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(D_FMT));
4775  if (deflocale) {
4776  (void) setlocale (LC_ALL, cobglobptr->cob_locale);
4777  }
4778  strftime (buff, sizeof(buff), buff2, &tstruct);
4779 #else
4780  memset ((void *)&syst, 0, sizeof(syst));
4781  syst.wYear = year;
4782  syst.wMonth = month;
4783  syst.wDay = days;
4784  if (locale_field) {
4785  if (locale_field->size >= COB_SMALL_BUFF) {
4786  goto derror;
4787  }
4788  cob_field_to_string (locale_field, locale_buff,
4789  COB_SMALL_MAX);
4790  for (p = (unsigned char *)locale_buff; *p; ++p) {
4791  if (isalnum(*p) || *p == '_') {
4792  continue;
4793  }
4794  break;
4795  }
4796  *p = 0;
4797  for (len = 0; len < WINLOCSIZE; ++len) {
4798  if (!strcmp(locale_buff, wintable[len].winlocalename)) {
4799  localeid = wintable[len].winlocaleid;
4800  break;
4801  }
4802  }
4803  if (len == WINLOCSIZE) {
4804  goto derror;
4805  }
4806  }
4807  if (!GetDateFormat (localeid, DATE_SHORTDATE, &syst, NULL, buff, sizeof(buff))) {
4808  goto derror;
4809  }
4810 #endif
4811  len = strlen (buff);
4812  field.size = len;
4813  make_field_entry (&field);
4814  memcpy (curr_field->data, buff, len);
4815  if (unlikely(offset > 0)) {
4816  calc_ref_mod (curr_field, offset, length);
4817  }
4818  return curr_field;
4819 derror:
4820 #endif
4821  field.size = 10;
4822  make_field_entry (&field);
4823  memset (curr_field->data, ' ', (size_t)10);
4824  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4825  return curr_field;
4826 }
cob_field* cob_intr_locale_time ( const int  offset,
const int  length,
cob_field *  srcfield,
cob_field *  locale_field 
)

References calc_ref_mod(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_INIT, COB_FIELD_IS_NUMERIC, cob_field_to_string(), cob_get_int(), __cob_global::cob_locale, cob_set_exception(), COB_SMALL_BUFF, COB_SMALL_MAX, curr_field, cob_field::data, make_field_entry(), NULL, p, cob_field::size, and unlikely.

4831 {
4832  cob_field field;
4833 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
4834  size_t len;
4835  int indate;
4836  int hours;
4837  int minutes;
4838  int seconds;
4839 #ifdef HAVE_LANGINFO_CODESET
4840  unsigned char *p;
4841  char *deflocale = NULL;
4842  struct tm tstruct;
4843  char buff2[128];
4844 #else
4845  unsigned char *p;
4846  LCID localeid = LOCALE_USER_DEFAULT;
4847  SYSTEMTIME syst;
4848 #endif
4849  char buff[128];
4850  char locale_buff[COB_SMALL_BUFF];
4851 #endif
4852 
4853  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
4854  cob_set_exception (0);
4855 
4856 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
4857  if (COB_FIELD_IS_NUMERIC (srcfield)) {
4858  indate = cob_get_int (srcfield);
4859  } else {
4860  if (srcfield->size < 6) {
4861  goto derror;
4862  }
4863  p = srcfield->data;
4864  indate = 0;
4865  for (len = 0; len < 6; ++len, ++p) {
4866  if (isdigit (*p)) {
4867  indate *= 10;
4868  indate += (*p - '0');
4869  } else {
4870  goto derror;
4871  }
4872  }
4873  }
4874  hours = indate / 10000;
4875  if (hours < 0 || hours > 24) {
4876  goto derror;
4877  }
4878  indate %= 10000;
4879  minutes = indate / 100;
4880  if (minutes < 0 || minutes > 59) {
4881  goto derror;
4882  }
4883  seconds = indate % 100;
4884  if (seconds < 0 || seconds > 59) {
4885  goto derror;
4886  }
4887 
4888 #ifdef HAVE_LANGINFO_CODESET
4889  memset ((void *)&tstruct, 0, sizeof(struct tm));
4890  tstruct.tm_hour = hours;
4891  tstruct.tm_min = minutes;
4892  tstruct.tm_sec = seconds;
4893  if (locale_field) {
4894  if (locale_field->size >= COB_SMALL_BUFF) {
4895  goto derror;
4896  }
4897  cob_field_to_string (locale_field, locale_buff,
4898  (size_t)COB_SMALL_MAX);
4899  deflocale = locale_buff;
4900  (void) setlocale (LC_TIME, deflocale);
4901  }
4902  memset (buff2, 0, sizeof(buff2));
4903  snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
4904  if (deflocale) {
4905  (void) setlocale (LC_ALL, cobglobptr->cob_locale);
4906  }
4907  strftime (buff, sizeof(buff), buff2, &tstruct);
4908 #else
4909  memset ((void *)&syst, 0, sizeof(syst));
4910  syst.wHour = hours;
4911  syst.wMinute = minutes;
4912  syst.wSecond = seconds;
4913  if (locale_field) {
4914  if (locale_field->size >= COB_SMALL_BUFF) {
4915  goto derror;
4916  }
4917  cob_field_to_string (locale_field, locale_buff,
4918  COB_SMALL_MAX);
4919  for (p = (unsigned char *)locale_buff; *p; ++p) {
4920  if (isalnum((int)*p) || *p == '_') {
4921  continue;
4922  }
4923  break;
4924  }
4925  *p = 0;
4926  for (len = 0; len < WINLOCSIZE; ++len) {
4927  if (!strcmp(locale_buff, wintable[len].winlocalename)) {
4928  localeid = wintable[len].winlocaleid;
4929  break;
4930  }
4931  }
4932  if (len == WINLOCSIZE) {
4933  goto derror;
4934  }
4935  }
4936  if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {
4937 
4938  goto derror;
4939  }
4940 #endif
4941  len = strlen (buff);
4942  field.size = len;
4943  make_field_entry (&field);
4944  memcpy (curr_field->data, buff, len);
4945  if (unlikely(offset > 0)) {
4946  calc_ref_mod (curr_field, offset, length);
4947  }
4948  return curr_field;
4949 derror:
4950 #endif
4951  field.size = 10;
4952  make_field_entry (&field);
4953  memset (curr_field->data, ' ', (size_t)10);
4954  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4955  return curr_field;
4956 }
cob_field* cob_intr_log ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), COB_EC_ARGUMENT_FUNCTION, cob_mpf_log(), cob_mpft, cob_set_exception(), cob_trim_decimal(), curr_field, cob_decimal::scale, and cob_decimal::value.

3376 {
3377  cob_decimal_set_field (&d1, srcfield);
3378 
3379  cob_set_exception (0);
3380  if (mpz_sgn (d1.value) <= 0) {
3381  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3382  cob_alloc_set_field_uint (0);
3383  return curr_field;
3384  }
3385 
3386  if (d1.scale) {
3387  cob_trim_decimal (&d1);
3388  }
3389 
3390  if (!d1.scale && !mpz_cmp_ui (d1.value, 1UL)) {
3391  /* Log (1) = 0 */
3392  cob_alloc_set_field_uint (0);
3393  return curr_field;
3394  }
3395 
3396  cob_decimal_get_mpf (cob_mpft, &d1);
3397  cob_mpf_log (cob_mpft, cob_mpft);
3398  cob_decimal_set_mpf (&d1, cob_mpft);
3399  cob_alloc_field (&d1);
3400  (void)cob_decimal_get_field (&d1, curr_field, 0);
3401 
3402  return curr_field;
3403 }
cob_field* cob_intr_log10 ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), COB_EC_ARGUMENT_FUNCTION, cob_mpf_log10(), cob_mpft, cob_set_exception(), cob_trim_decimal(), curr_field, cob_decimal::scale, and cob_decimal::value.

3407 {
3408  cob_decimal_set_field (&d1, srcfield);
3409 
3410  cob_set_exception (0);
3411  if (mpz_sgn (d1.value) <= 0) {
3412  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3413  cob_alloc_set_field_uint (0);
3414  return curr_field;
3415  }
3416 
3417  if (d1.scale) {
3418  cob_trim_decimal (&d1);
3419  }
3420 
3421  if (!d1.scale && !mpz_cmp_ui (d1.value, 1UL)) {
3422  /* Log10 (1) = 0 */
3423  cob_alloc_set_field_uint (0);
3424  return curr_field;
3425  }
3426 
3427  cob_decimal_get_mpf (cob_mpft, &d1);
3428  cob_mpf_log10 (cob_mpft, cob_mpft);
3429  cob_decimal_set_mpf (&d1, cob_mpft);
3430  cob_alloc_field (&d1);
3431  (void)cob_decimal_get_field (&d1, curr_field, 0);
3432 
3433  return curr_field;
3434 }
cob_field* cob_intr_lower_case ( const int  offset,
const int  length,
cob_field *  srcfield 
)

References calc_ref_mod(), cob_u8_t, curr_field, cob_field::data, make_field_entry(), cob_field::size, and unlikely.

2321 {
2322  size_t i, size;
2323 
2324  make_field_entry (srcfield);
2325 
2326  size = srcfield->size;
2327  for (i = 0; i < size; ++i) {
2328  curr_field->data[i] = (cob_u8_t)tolower (srcfield->data[i]);
2329  }
2330  if (unlikely(offset > 0)) {
2331  calc_ref_mod (curr_field, offset, length);
2332  }
2333  return curr_field;
2334 }
cob_field* cob_intr_lowest_algebraic ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), COB_EC_ARGUMENT_FUNCTION, COB_FIELD_BINARY_TRUNC, COB_FIELD_DIGITS, COB_FIELD_HAVE_SIGN, COB_FIELD_INIT, COB_FIELD_REAL_BINARY, COB_FIELD_SCALE, COB_FIELD_SIZE, COB_FIELD_TYPE, cob_set_exception(), COB_TYPE_ALPHANUMERIC, COB_TYPE_ALPHANUMERIC_EDITED, COB_TYPE_NATIONAL, COB_TYPE_NATIONAL_EDITED, COB_TYPE_NUMERIC_BINARY, COB_TYPE_NUMERIC_DISPLAY, COB_TYPE_NUMERIC_DOUBLE, COB_TYPE_NUMERIC_EDITED, COB_TYPE_NUMERIC_FLOAT, COB_TYPE_NUMERIC_PACKED, cob_uli_t, curr_field, make_field_entry(), NULL, cob_decimal::scale, and cob_decimal::value.

5267 {
5268  cob_uli_t expo;
5269  cob_field field;
5270 
5271  switch (COB_FIELD_TYPE (srcfield)) {
5272  case COB_TYPE_ALPHANUMERIC:
5273  case COB_TYPE_NATIONAL:
5274  COB_FIELD_INIT (COB_FIELD_SIZE (srcfield), NULL, &const_alpha_attr);
5275  make_field_entry (&field);
5276  break;
5277 
5278  case COB_TYPE_ALPHANUMERIC_EDITED:
5279  case COB_TYPE_NATIONAL_EDITED:
5280  COB_FIELD_INIT (COB_FIELD_DIGITS (srcfield), NULL, &const_alpha_attr);
5281  make_field_entry (&field);
5282  break;
5283 
5284  case COB_TYPE_NUMERIC_BINARY:
5285  if (!COB_FIELD_HAVE_SIGN (srcfield)) {
5286  cob_alloc_set_field_uint (0);
5287  break;
5288  }
5289  if (COB_FIELD_REAL_BINARY (srcfield) ||
5290  !COB_FIELD_BINARY_TRUNC (srcfield)) {
5291  expo = (cob_uli_t)((COB_FIELD_SIZE (srcfield) * 8U) - 1U);
5292  mpz_ui_pow_ui (d1.value, 2UL, expo);
5293  mpz_neg (d1.value, d1.value);
5294  d1.scale = COB_FIELD_SCALE (srcfield);
5295  cob_alloc_field (&d1);
5296  (void)cob_decimal_get_field (&d1, curr_field, 0);
5297  break;
5298  }
5299  expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5300  mpz_ui_pow_ui (d1.value, 10UL, expo);
5301  mpz_sub_ui (d1.value, d1.value, 1UL);
5302  mpz_neg (d1.value, d1.value);
5303  d1.scale = COB_FIELD_SCALE (srcfield);
5304  cob_alloc_field (&d1);
5305  (void)cob_decimal_get_field (&d1, curr_field, 0);
5306  break;
5307 
5308  case COB_TYPE_NUMERIC_FLOAT:
5309  case COB_TYPE_NUMERIC_DOUBLE:
5310  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5311  cob_alloc_set_field_uint (0);
5312  break;
5313 
5314  case COB_TYPE_NUMERIC_DISPLAY:
5315  case COB_TYPE_NUMERIC_PACKED:
5316  case COB_TYPE_NUMERIC_EDITED:
5317  if (!COB_FIELD_HAVE_SIGN (srcfield)) {
5318  cob_alloc_set_field_uint (0);
5319  break;
5320  }
5321  expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5322  mpz_ui_pow_ui (d1.value, 10UL, expo);
5323  mpz_sub_ui (d1.value, d1.value, 1UL);
5324  mpz_neg (d1.value, d1.value);
5325  d1.scale = COB_FIELD_SCALE (srcfield);
5326  cob_alloc_field (&d1);
5327  (void)cob_decimal_get_field (&d1, curr_field, 0);
5328  break;
5329  default:
5330  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5331  cob_alloc_set_field_uint (0);
5332  break;
5333  }
5334  return curr_field;
5335 }
cob_field* cob_intr_max ( const int  params,
  ... 
)

References cob_cmp(), curr_field, cob_field::data, make_field_entry(), params, and cob_field::size.

4039 {
4040  cob_field *f;
4041  cob_field *basef;
4042  va_list args;
4043  int i;
4044 
4045  va_start (args, params);
4046 
4047  basef = va_arg (args, cob_field *);
4048  for (i = 1; i < params; ++i) {
4049  f = va_arg (args, cob_field *);
4050  if (cob_cmp (f, basef) > 0) {
4051  basef = f;
4052  }
4053  }
4054  va_end (args);
4055 
4056  make_field_entry (basef);
4057  memcpy (curr_field->data, basef->data, basef->size);
4058  return curr_field;
4059 }
cob_field* cob_intr_mean ( const int  params,
  ... 
)

References cob_alloc_field(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_set_field(), cob_uli_t, curr_field, cob_field::data, make_field_entry(), params, cob_decimal::scale, cob_field::size, and cob_decimal::value.

4147 {
4148  cob_field *f;
4149  va_list args;
4150  int i;
4151 
4152  va_start (args, params);
4153 
4154  if (params == 1) {
4155  f = va_arg (args, cob_field *);
4156  va_end (args);
4157  make_field_entry (f);
4158  memcpy (curr_field->data, f->data, f->size);
4159  return curr_field;
4160  }
4161 
4162  mpz_set_ui (d1.value, 0UL);
4163  d1.scale = 0;
4164 
4165  for (i = 0; i < params; ++i) {
4166  f = va_arg (args, cob_field *);
4167  cob_decimal_set_field (&d2, f);
4168  cob_decimal_add (&d1, &d2);
4169  }
4170  va_end (args);
4171 
4172  mpz_set_ui (d2.value, (cob_uli_t)params);
4173  d2.scale = 0;
4174  cob_decimal_div (&d1, &d2);
4175 
4176  cob_alloc_field (&d1);
4177  (void)cob_decimal_get_field (&d1, curr_field, 0);
4178 
4179  return curr_field;
4180 }
cob_field* cob_intr_median ( const int  params,
  ... 
)

References cob_alloc_field(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_set_field(), cob_free(), cob_malloc(), comp_field(), curr_field, cob_field::data, make_field_entry(), params, cob_decimal::scale, cob_field::size, and cob_decimal::value.

4099 {
4100  cob_field *f;
4101  cob_field **field_alloc;
4102  va_list args;
4103  int i;
4104 
4105  va_start (args, params);
4106 
4107  f = va_arg (args, cob_field *);
4108  if (params == 1) {
4109  va_end (args);
4110  make_field_entry (f);
4111  memcpy (curr_field->data, f->data, f->size);
4112  return curr_field;
4113  }
4114 
4115  field_alloc = cob_malloc ((size_t)params * sizeof (cob_field *));
4116  field_alloc[0] = f;
4117 
4118  for (i = 1; i < params; ++i) {
4119  field_alloc[i] = va_arg (args, cob_field *);
4120  }
4121  va_end (args);
4122 
4123  qsort (field_alloc, (size_t)params, (size_t)sizeof (cob_field *),
4124  comp_field);
4125 
4126  i = params / 2;
4127  if (params % 2) {
4128  f = field_alloc[i];
4129  make_field_entry (f);
4130  memcpy (curr_field->data, f->data, f->size);
4131  } else {
4132  cob_decimal_set_field (&d1, field_alloc[i-1]);
4133  cob_decimal_set_field (&d2, field_alloc[i]);
4134  cob_decimal_add (&d1, &d2);
4135  mpz_set_ui (d2.value, 2UL);
4136  d2.scale = 0;
4137  cob_decimal_div (&d1, &d2);
4138  cob_alloc_field (&d1);
4139  (void)cob_decimal_get_field (&d1, curr_field, 0);
4140  }
4141  cob_free (field_alloc);
4142  return curr_field;
4143 }
cob_field* cob_intr_midrange ( const int  params,
  ... 
)

References cob_alloc_field(), cob_cmp(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_set_field(), curr_field, params, cob_decimal::scale, and cob_decimal::value.

4063 {
4064  cob_field *f;
4065  cob_field *basemin;
4066  cob_field *basemax;
4067  va_list args;
4068  int i;
4069 
4070  va_start (args, params);
4071 
4072  basemin = va_arg (args, cob_field *);
4073  basemax = basemin;
4074  for (i = 1; i < params; ++i) {
4075  f = va_arg (args, cob_field *);
4076  if (cob_cmp (f, basemin) < 0) {
4077  basemin = f;
4078  }
4079  if (cob_cmp (f, basemax) > 0) {
4080  basemax = f;
4081  }
4082  }
4083  va_end (args);
4084 
4085  cob_decimal_set_field (&d1, basemin);
4086  cob_decimal_set_field (&d2, basemax);
4087  cob_decimal_add (&d1, &d2);
4088  mpz_set_ui (d2.value, 2UL);
4089  d2.scale = 0;
4090  cob_decimal_div (&d1, &d2);
4091 
4092  cob_alloc_field (&d1);
4093  (void)cob_decimal_get_field (&d1, curr_field, 0);
4094  return curr_field;
4095 }
cob_field* cob_intr_min ( const int  params,
  ... 
)

References cob_cmp(), curr_field, cob_field::data, make_field_entry(), params, and cob_field::size.

4015 {
4016  cob_field *f;
4017  cob_field *basef;
4018  va_list args;
4019  int i;
4020 
4021  va_start (args, params);
4022 
4023  basef = va_arg (args, cob_field *);
4024  for (i = 1; i < params; ++i) {
4025  f = va_arg (args, cob_field *);
4026  if (cob_cmp (f, basef) < 0) {
4027  basef = f;
4028  }
4029  }
4030  va_end (args);
4031 
4032  make_field_entry (basef);
4033  memcpy (curr_field->data, basef->data, basef->size);
4034  return curr_field;
4035 }
cob_field* cob_intr_mod ( cob_field *  srcfield1,
cob_field *  srcfield2 
)

References cob_mod_or_rem().

4184 {
4185  return cob_mod_or_rem (srcfield1, srcfield2, 0);
4186 }
cob_field* cob_intr_module_caller_id ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, curr_field, cob_field::data, make_field_entry(), NULL, and cob_field::size.

2398 {
2399  size_t calcsize;
2400  cob_field field;
2401 
2402  if (!COB_MODULE_PTR->next) {
2403  COB_FIELD_INIT (1, NULL, &const_alpha_attr);
2404  make_field_entry (&field);
2405  curr_field->size = 0;
2406  curr_field->data[0] = ' ';
2407  return curr_field;
2408  }
2409  calcsize = strlen (COB_MODULE_PTR->next->module_name);
2410  COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
2411  make_field_entry (&field);
2412  memcpy (curr_field->data, COB_MODULE_PTR->next->module_name,
2413  calcsize);
2414  return curr_field;
2415 }
cob_field* cob_intr_module_date ( void  )

References COB_ATTR_INIT, COB_FIELD_INIT, COB_MODULE_PTR, COB_TYPE_NUMERIC_DISPLAY, curr_field, cob_field::data, make_field_entry(), and NULL.

2355 {
2356  cob_field_attr attr;
2357  cob_field field;
2358  char buff[16];
2359 
2360  COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
2361  COB_FIELD_INIT (8, NULL, &attr);
2362  make_field_entry (&field);
2363  snprintf (buff, sizeof(buff), "%8.8u", COB_MODULE_PTR->module_date);
2364  memcpy (curr_field->data, buff, (size_t)8);
2365  return curr_field;
2366 }
cob_field* cob_intr_module_formatted_date ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, curr_field, cob_field::data, make_field_entry(), and NULL.

2419 {
2420  size_t calcsize;
2421  cob_field field;
2422 
2423  calcsize = strlen (COB_MODULE_PTR->module_formatted_date);
2424  COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
2425  make_field_entry (&field);
2426  memcpy (curr_field->data, COB_MODULE_PTR->module_formatted_date,
2427  calcsize);
2428  return curr_field;
2429 }
cob_field* cob_intr_module_id ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, curr_field, cob_field::data, make_field_entry(), and NULL.

2385 {
2386  size_t calcsize;
2387  cob_field field;
2388 
2389  calcsize = strlen (COB_MODULE_PTR->module_name);
2390  COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
2391  make_field_entry (&field);
2392  memcpy (curr_field->data, COB_MODULE_PTR->module_name, calcsize);
2393  return curr_field;
2394 }
cob_field* cob_intr_module_path ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, curr_field, cob_field::data, make_field_entry(), NULL, and cob_field::size.

2446 {
2447  size_t calcsize;
2448  cob_field field;
2449 
2450  if (!COB_MODULE_PTR->module_path ||
2451  !*(COB_MODULE_PTR->module_path)) {
2452  COB_FIELD_INIT (1, NULL, &const_alpha_attr);
2453  make_field_entry (&field);
2454  curr_field->size = 0;
2455  curr_field->data[0] = ' ';
2456  return curr_field;
2457  }
2458  calcsize = strlen (*(COB_MODULE_PTR->module_path));
2459  COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
2460  make_field_entry (&field);
2461  memcpy (curr_field->data, *(COB_MODULE_PTR->module_path),
2462  calcsize);
2463  return curr_field;
2464 }
cob_field* cob_intr_module_source ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, curr_field, cob_field::data, make_field_entry(), and NULL.

2433 {
2434  size_t calcsize;
2435  cob_field field;
2436 
2437  calcsize = strlen (COB_MODULE_PTR->module_source);
2438  COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
2439  make_field_entry (&field);
2440  memcpy (curr_field->data, COB_MODULE_PTR->module_source, calcsize);
2441  return curr_field;
2442 }
cob_field* cob_intr_module_time ( void  )

References COB_ATTR_INIT, COB_FIELD_INIT, COB_MODULE_PTR, COB_TYPE_NUMERIC_DISPLAY, curr_field, cob_field::data, make_field_entry(), and NULL.

2370 {
2371  cob_field_attr attr;
2372  cob_field field;
2373  char buff[8];
2374 
2375  COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 6, 0, 0, NULL);
2376  COB_FIELD_INIT (6, NULL, &attr);
2377  make_field_entry (&field);
2378  snprintf (buff, sizeof(buff), "%6.6u", COB_MODULE_PTR->module_time);
2379  memcpy (curr_field->data, buff, (size_t)6);
2380  return curr_field;
2381 }
cob_field* cob_intr_mon_decimal_point ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, cob_set_exception(), curr_field, cob_field::data, make_field_entry(), NULL, p, and cob_field::size.

5071 {
5072 #ifdef HAVE_LOCALECONV
5073  struct lconv *p;
5074  size_t size;
5075 #endif
5076  cob_field field;
5077 
5078  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5079  cob_set_exception (0);
5080 
5081 #ifdef HAVE_LOCALECONV
5082  p = localeconv ();
5083  size = strlen (p->mon_decimal_point);
5084  if (size) {
5085  field.size = size;
5086  } else {
5087  field.size = 1;
5088  }
5089  make_field_entry (&field);
5090  if (size) {
5091  memcpy (curr_field->data, p->mon_decimal_point, size);
5092  } else {
5093  curr_field->size = 0;
5094  curr_field->data[0] = 0;
5095  }
5096 #else
5097  field.size = 1;
5098  make_field_entry (&field);
5099  curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5100 #endif
5101  return curr_field;
5102 }
cob_field* cob_intr_mon_thousands_sep ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, cob_set_exception(), curr_field, cob_field::data, make_field_entry(), NULL, p, and cob_field::size.

5141 {
5142 #ifdef HAVE_LOCALECONV
5143  struct lconv *p;
5144  size_t size;
5145 #endif
5146  cob_field field;
5147 
5148  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5149  cob_set_exception (0);
5150 
5151 #ifdef HAVE_LOCALECONV
5152  p = localeconv ();
5153  size = strlen (p->mon_thousands_sep);
5154  if (size) {
5155  field.size = size;
5156  } else {
5157  field.size = 1;
5158  }
5159  make_field_entry (&field);
5160  if (size) {
5161  memcpy (curr_field->data, p->mon_thousands_sep, size);
5162  } else {
5163  curr_field->size = 0;
5164  curr_field->data[0] = 0;
5165  }
5166 #else
5167  field.size = 1;
5168  make_field_entry (&field);
5169  curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5170 #endif
5171  return curr_field;
5172 }
cob_field* cob_intr_national_of ( const int  offset,
const int  length,
const int  params,
  ... 
)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5797 {
5798  COB_UNUSED (offset);
5799  COB_UNUSED (length);
5800  COB_UNUSED (params);
5801 
5802  cob_fatal_error (COB_FERROR_FUNCTION);
5803 }
cob_field* cob_intr_num_decimal_point ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, cob_set_exception(), curr_field, cob_field::data, make_field_entry(), NULL, p, and cob_field::size.

5106 {
5107 #ifdef HAVE_LOCALECONV
5108  struct lconv *p;
5109  size_t size;
5110 #endif
5111  cob_field field;
5112 
5113  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5114  cob_set_exception (0);
5115 
5116 #ifdef HAVE_LOCALECONV
5117  p = localeconv ();
5118  size = strlen (p->decimal_point);
5119  if (size) {
5120  field.size = size;
5121  } else {
5122  field.size = 1;
5123  }
5124  make_field_entry (&field);
5125  if (size) {
5126  memcpy (curr_field->data, p->decimal_point, size);
5127  } else {
5128  curr_field->size = 0;
5129  curr_field->data[0] = 0;
5130  }
5131 #else
5132  field.size = 1;
5133  make_field_entry (&field);
5134  curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5135 #endif
5136  return curr_field;
5137 }
cob_field* cob_intr_num_thousands_sep ( void  )

References COB_FIELD_INIT, COB_MODULE_PTR, cob_set_exception(), curr_field, cob_field::data, make_field_entry(), NULL, p, and cob_field::size.

5176 {
5177 #ifdef HAVE_LOCALECONV
5178  struct lconv *p;
5179  size_t size;
5180 #endif
5181  cob_field field;
5182 
5183  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5184  cob_set_exception (0);
5185 
5186 #ifdef HAVE_LOCALECONV
5187  p = localeconv ();
5188  size = strlen (p->thousands_sep);
5189  if (size) {
5190  field.size = size;
5191  } else {
5192  field.size = 1;
5193  }
5194  make_field_entry (&field);
5195  if (size) {
5196  memcpy (curr_field->data, p->thousands_sep, size);
5197  } else {
5198  curr_field->size = 0;
5199  curr_field->data[0] = 0;
5200  }
5201 #else
5202  field.size = 1;
5203  make_field_entry (&field);
5204  curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5205 #endif
5206  return curr_field;
5207 }
cob_field* cob_intr_numval ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_check_numval(), cob_decimal_get_field(), COB_EC_ARGUMENT_FUNCTION, cob_free(), cob_malloc(), COB_MAX_DIGITS, COB_MODULE_PTR, cob_set_exception(), curr_field, cob_field::data, NULL, cob_decimal::scale, sign, cob_field::size, and cob_decimal::value.

3608 {
3609  unsigned char *final_buff;
3610  size_t i;
3611  int final_digits;
3612  int decimal_digits;
3613  int sign;
3614  int decimal_seen;
3615  unsigned char dec_pt;
3616 
3617  /* Validate source field */
3618  if (cob_check_numval (srcfield, NULL, 0, 0)) {
3619  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3620  cob_alloc_set_field_uint (0);
3621  return curr_field;
3622  }
3623 
3624  final_digits = 0;
3625  decimal_digits = 0;
3626  sign = 0;
3627  decimal_seen = 0;
3628  dec_pt = COB_MODULE_PTR->decimal_point;
3629  final_buff = cob_malloc (srcfield->size + 1U);
3630 
3631  for (i = 0; i < srcfield->size; ++i) {
3632  if (i < (srcfield->size - 1)) {
3633  if (memcmp (&srcfield->data[i], "CR", (size_t)2) == 0 ||
3634  memcmp (&srcfield->data[i], "DB", (size_t)2) == 0) {
3635  sign = 1;
3636  break;
3637  }
3638  }
3639  if (srcfield->data[i] == ' ') {
3640  continue;
3641  }
3642  if (srcfield->data[i] == '+') {
3643  continue;
3644  }
3645  if (srcfield->data[i] == '-') {
3646  sign = 1;
3647  continue;
3648  }
3649  if (srcfield->data[i] == dec_pt) {
3650  decimal_seen = 1;
3651  continue;
3652  }
3653  if (srcfield->data[i] >= (unsigned char)'0' &&
3654  srcfield->data[i] <= (unsigned char)'9') {
3655  if (decimal_seen) {
3656  decimal_digits++;
3657  }
3658  final_buff[final_digits++] = srcfield->data[i];
3659  }
3660  if (final_digits > COB_MAX_DIGITS) {
3661  break;
3662  }
3663  }
3664 
3665  if (!final_digits) {
3666  final_buff[0] = '0';
3667  }
3668  mpz_set_str (d1.value, (char *)final_buff, 10);
3669  cob_free (final_buff);
3670  if (sign && mpz_sgn (d1.value)) {
3671  mpz_neg (d1.value, d1.value);
3672  }
3673  d1.scale = decimal_digits;
3674  cob_alloc_field (&d1);
3675  (void)cob_decimal_get_field (&d1, curr_field, 0);
3676 
3677  return curr_field;
3678 }
cob_field* cob_intr_numval_c ( cob_field *  srcfield,
cob_field *  currency 
)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_check_numval(), cob_decimal_get_field(), COB_EC_ARGUMENT_FUNCTION, cob_free(), cob_malloc(), COB_MAX_DIGITS, COB_MODULE_PTR, cob_set_exception(), curr_field, cob_field::data, NULL, cob_decimal::scale, sign, cob_field::size, and cob_decimal::value.

3682 {
3683  unsigned char *final_buff;
3684  unsigned char *currency_data;
3685  size_t i;
3686  int decimal_digits;
3687  int final_digits;
3688  int sign;
3689  int decimal_seen;
3690  unsigned char dec_pt;
3691  unsigned char cur_symb;
3692 
3693  /* Validate source field */
3694  if (cob_check_numval (srcfield, currency, 1, 0)) {
3695  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3696  cob_alloc_set_field_uint (0);
3697  return curr_field;
3698  }
3699 
3700  decimal_digits = 0;
3701  final_digits = 0;
3702  sign = 0;
3703  decimal_seen = 0;
3704  dec_pt = COB_MODULE_PTR->decimal_point;
3705  cur_symb = COB_MODULE_PTR->currency_symbol;
3706  final_buff = cob_malloc (srcfield->size + 1U);
3707 
3708  currency_data = NULL;
3709  if (currency) {
3710  if (currency->size < srcfield->size) {
3711  currency_data = currency->data;
3712  }
3713  }
3714  for (i = 0; i < srcfield->size; ++i) {
3715  if (i < (srcfield->size - 1)) {
3716  if (memcmp (&srcfield->data[i], "CR", (size_t)2) == 0 ||
3717  memcmp (&srcfield->data[i], "DB", (size_t)2) == 0) {
3718  sign = 1;
3719  break;
3720  }
3721  }
3722  if (currency_data) {
3723  if (i < (srcfield->size - currency->size)) {
3724  if (!memcmp (&srcfield->data[i],
3725  currency_data, currency->size)) {
3726  i += (currency->size - 1);
3727  continue;
3728  }
3729  }
3730  } else if (srcfield->data[i] == cur_symb) {
3731  continue;
3732  }
3733  if (srcfield->data[i] == ' ') {
3734  continue;
3735  }
3736  if (srcfield->data[i] == '+') {
3737  continue;
3738  }
3739  if (srcfield->data[i] == '-') {
3740  sign = 1;
3741  continue;
3742  }
3743  if (srcfield->data[i] == dec_pt) {
3744  decimal_seen = 1;
3745  continue;
3746  }
3747  if (srcfield->data[i] >= (unsigned char)'0' &&
3748  srcfield->data[i] <= (unsigned char)'9') {
3749  if (decimal_seen) {
3750  decimal_digits++;
3751  }
3752  final_buff[final_digits++] = srcfield->data[i];
3753  }
3754  if (final_digits > COB_MAX_DIGITS) {
3755  break;
3756  }
3757  }
3758 
3759  if (!final_digits) {
3760  final_buff[0] = '0';
3761  }
3762  mpz_set_str (d1.value, (char *)final_buff, 10);
3763  cob_free (final_buff);
3764  if (sign && mpz_sgn (d1.value)) {
3765  mpz_neg (d1.value, d1.value);
3766  }
3767  d1.scale = decimal_digits;
3768  cob_alloc_field (&d1);
3769  (void)cob_decimal_get_field (&d1, curr_field, 0);
3770 
3771  return curr_field;
3772 }
cob_field* cob_intr_numval_f ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_check_numval_f(), cob_decimal_get_field(), COB_EC_ARGUMENT_FUNCTION, cob_free(), cob_malloc(), cob_mexp, COB_MODULE_PTR, cob_set_exception(), cob_uli_t, curr_field, cob_field::data, p, cob_decimal::scale, cob_field::size, and cob_decimal::value.

3776 {
3777  unsigned char *final_buff;
3778  unsigned char *p;
3779  size_t plus_minus;
3780  size_t digits;
3781  size_t decimal_digits;
3782  size_t dec_seen;
3783  size_t e_seen;
3784  size_t exponent;
3785  size_t e_plus_minus;
3786  size_t n;
3787  unsigned char dec_pt;
3788 
3789  /* Validate source field */
3790  if (cob_check_numval_f (srcfield)) {
3791  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3792  cob_alloc_set_field_uint (0);
3793  return curr_field;
3794  }
3795 
3796  plus_minus = 0;
3797  digits = 0;
3798  decimal_digits = 0;
3799  dec_seen = 0;
3800  e_seen = 0;
3801  exponent = 0;
3802  e_plus_minus = 0;
3803  dec_pt = COB_MODULE_PTR->decimal_point;
3804 
3805  final_buff = cob_malloc (srcfield->size + 1U);
3806  p = srcfield->data;
3807  for (n = 0; n < srcfield->size; ++n, ++p) {
3808  switch (*p) {
3809  case '0':
3810  case '1':
3811  case '2':
3812  case '3':
3813  case '4':
3814  case '5':
3815  case '6':
3816  case '7':
3817  case '8':
3818  case '9':
3819  if (e_seen) {
3820  exponent *= 10;
3821  exponent += (*p & 0x0F);
3822  } else {
3823  if (dec_seen) {
3824  decimal_digits++;
3825  }
3826  final_buff[digits++] = *p;
3827  }
3828  continue;
3829  case 'E':
3830  e_seen = 1;
3831  continue;
3832  case '-':
3833  if (e_seen) {
3834  e_plus_minus = 1;
3835  } else {
3836  plus_minus = 1;
3837  }
3838  continue;
3839  default:
3840  if (*p == dec_pt) {
3841  dec_seen = 1;
3842  }
3843  continue;
3844  }
3845  }
3846 
3847  if (!digits) {
3848  final_buff[0] = '0';
3849  }
3850 
3851  mpz_set_str (d1.value, (char *)final_buff, 10);
3852  cob_free (final_buff);
3853  if (!mpz_sgn (d1.value)) {
3854  /* Value is zero ; sign and exponent irrelevant */
3855  d1.scale = 0;
3856  cob_alloc_field (&d1);
3857  (void)cob_decimal_get_field (&d1, curr_field, 0);
3858  return curr_field;
3859  }
3860  if (plus_minus) {
3861  mpz_neg (d1.value, d1.value);
3862  }
3863  if (exponent) {
3864  if (e_plus_minus) {
3865  /* Negative exponent */
3866  d1.scale = decimal_digits + exponent;
3867  } else {
3868  /* Positive exponent */
3869  if (decimal_digits >= exponent) {
3870  d1.scale = decimal_digits - exponent;
3871  } else {
3872  exponent -= decimal_digits;
3873  mpz_ui_pow_ui (cob_mexp, 10UL,
3874  (cob_uli_t)exponent);
3875  mpz_mul (d1.value, d1.value, cob_mexp);
3876  d1.scale = 0;
3877  }
3878  }
3879  } else {
3880  /* No exponent */
3881  d1.scale = decimal_digits;
3882  }
3883 
3884  cob_alloc_field (&d1);
3885  (void)cob_decimal_get_field (&d1, curr_field, 0);
3886 
3887  return curr_field;
3888 }
cob_field* cob_intr_ord ( cob_field *  srcfield)

References cob_alloc_set_field_uint(), cob_u32_t, curr_field, and cob_field::data.

2982 {
2983  cob_alloc_set_field_uint ((cob_u32_t)(*srcfield->data + 1U));
2984  return curr_field;
2985 }
cob_field* cob_intr_ord_max ( const int  params,
  ... 
)

References cob_alloc_set_field_uint(), cob_cmp(), cob_u32_t, curr_field, and params.

3989 {
3990  cob_field *f;
3991  cob_field *basef;
3992  cob_u32_t ordmax;
3993  int i;
3994  va_list args;
3995 
3996  va_start (args, params);
3997 
3998  ordmax = 1;
3999  basef = va_arg (args, cob_field *);
4000  for (i = 1; i < params; ++i) {
4001  f = va_arg (args, cob_field *);
4002  if (cob_cmp (f, basef) > 0) {
4003  basef = f;
4004  ordmax = i + 1;
4005  }
4006  }
4007  va_end (args);
4008 
4009  cob_alloc_set_field_uint (ordmax);
4010  return curr_field;
4011 }
cob_field* cob_intr_ord_min ( const int  params,
  ... 
)

References cob_alloc_set_field_uint(), cob_cmp(), cob_u32_t, curr_field, and params.

3963 {
3964  cob_field *f;
3965  cob_field *basef;
3966  int i;
3967  cob_u32_t ordmin;
3968  va_list args;
3969 
3970  va_start (args, params);
3971 
3972  ordmin = 1;
3973  basef = va_arg (args, cob_field *);
3974  for (i = 1; i < params; ++i) {
3975  f = va_arg (args, cob_field *);
3976  if (cob_cmp (f, basef) < 0) {
3977  basef = f;
3978  ordmin = i + 1;
3979  }
3980  }
3981  va_end (args);
3982 
3983  cob_alloc_set_field_uint (ordmin);
3984  return curr_field;
3985 }
cob_field* cob_intr_pi ( void  )

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_set_mpf(), cob_mpft, cob_pi, and curr_field.

3298 {
3299  mpf_set (cob_mpft, cob_pi);
3300  cob_decimal_set_mpf (&d1, cob_mpft);
3301  cob_alloc_field (&d1);
3302  (void)cob_decimal_get_field (&d1, curr_field, 0);
3303 
3304  return curr_field;
3305 }
cob_field* cob_intr_present_value ( const int  params,
  ... 
)

References cob_alloc_field(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_set_field(), cob_uli_t, curr_field, params, cob_decimal::scale, and cob_decimal::value.

4390 {
4391  cob_field *f;
4392  va_list args;
4393  int i;
4394 
4395  va_start (args, params);
4396 
4397  f = va_arg (args, cob_field *);
4398 
4399  cob_decimal_set_field (&d1, f);
4400  mpz_set_ui (d2.value, 1UL);
4401  d2.scale = 0;
4402  cob_decimal_add (&d1, &d2);
4403 
4404  mpz_set_ui (d4.value, 0UL);
4405  d4.scale = 0;
4406 
4407  for (i = 1; i < params; ++i) {
4408  f = va_arg (args, cob_field *);
4409  cob_decimal_set_field (&d2, f);
4410  mpz_set (d3.value, d1.value);
4411  d3.scale = d1.scale;
4412  if (i > 1) {
4413  mpz_pow_ui (d3.value, d3.value, (cob_uli_t)i);
4414  d3.scale *= i;
4415  }
4416  cob_decimal_div (&d2, &d3);
4417  cob_decimal_add (&d4, &d2);
4418  }
4419  va_end (args);
4420 
4421  cob_alloc_field (&d4);
4422  (void)cob_decimal_get_field (&d4, curr_field, 0);
4423  return curr_field;
4424 }
cob_field* cob_intr_random ( const int  params,
  ... 
)

References COB_ATTR_INIT, COB_FIELD_INIT, COB_FLAG_HAVE_SIGN, cob_get_int(), COB_TYPE_NUMERIC_DOUBLE, curr_field, cob_field::data, make_field_entry(), and NULL.

4227 {
4228  cob_field *f;
4229  va_list args;
4230  double val;
4231  int seed;
4232  int randnum;
4233  cob_field_attr attr;
4234  cob_field field;
4235 
4236  COB_ATTR_INIT (COB_TYPE_NUMERIC_DOUBLE, 20, 9, COB_FLAG_HAVE_SIGN, NULL);
4237  COB_FIELD_INIT (sizeof(double), NULL, &attr);
4238  va_start (args, params);
4239 
4240  if (params) {
4241  f = va_arg (args, cob_field *);
4242  seed = cob_get_int (f);
4243  if (seed < 0) {
4244  seed = 0;
4245  }
4246 #ifdef __CYGWIN__
4247  srandom ((unsigned int)seed);
4248 #else
4249  srand ((unsigned int)seed);
4250 #endif
4251  }
4252  va_end (args);
4253 
4254 #ifdef __CYGWIN__
4255  randnum = (int)random ();
4256 #else
4257  randnum = rand ();
4258 #endif
4259  make_field_entry (&field);
4260  val = (double)randnum / (double)RAND_MAX;
4261  memcpy (curr_field->data, &val, sizeof(val));
4262  return curr_field;
4263 }
cob_field* cob_intr_range ( const int  params,
  ... 
)

References cob_alloc_field(), cob_cmp(), cob_decimal_get_field(), cob_decimal_set_field(), cob_decimal_sub(), curr_field, and params.

4190 {
4191  cob_field *f, *basemin, *basemax;
4192  va_list args;
4193  int i;
4194 
4195  va_start (args, params);
4196 
4197  basemin = va_arg (args, cob_field *);
4198  basemax = basemin;
4199  for (i = 1; i < params; ++i) {
4200  f = va_arg (args, cob_field *);
4201  if (cob_cmp (f, basemin) < 0) {
4202  basemin = f;
4203  }
4204  if (cob_cmp (f, basemax) > 0) {
4205  basemax = f;
4206  }
4207  }
4208  va_end (args);
4209 
4210  cob_decimal_set_field (&d1, basemax);
4211  cob_decimal_set_field (&d2, basemin);
4212  cob_decimal_sub (&d1, &d2);
4213 
4214  cob_alloc_field (&d1);
4215  (void)cob_decimal_get_field (&d1, curr_field, 0);
4216  return curr_field;
4217 }
cob_field* cob_intr_rem ( cob_field *  srcfield1,
cob_field *  srcfield2 
)

References cob_mod_or_rem().

4221 {
4222  return cob_mod_or_rem (srcfield1, srcfield2, 1);
4223 }
cob_field* cob_intr_reverse ( const int  offset,
const int  length,
cob_field *  srcfield 
)

References calc_ref_mod(), curr_field, cob_field::data, make_field_entry(), cob_field::size, and unlikely.

2338 {
2339  size_t i, size;
2340 
2341  make_field_entry (srcfield);
2342 
2343  size = srcfield->size;
2344  for (i = 0; i < size; ++i) {
2345  curr_field->data[i] = srcfield->data[size - i - 1];
2346  }
2347  if (unlikely(offset > 0)) {
2348  calc_ref_mod (curr_field, offset, length);
2349  }
2350  return curr_field;
2351 }
cob_field* cob_intr_seconds_from_formatted_time ( cob_field *  format,
cob_field *  value 
)

References cob_alloc_set_field_uint(), COB_EC_ARGUMENT_FUNCTION, cob_set_exception(), cob_u32_t, curr_field, cob_field::data, and cob_field::size.

4628 {
4629  unsigned char *p1;
4630  unsigned char *p2;
4631  size_t n;
4632  cob_u32_t seconds = 0;
4633  cob_u32_t minutes = 0;
4634  cob_u32_t hours = 0;
4635  cob_u32_t seconds_seen = 0;
4636  cob_u32_t minutes_seen = 0;
4637  cob_u32_t hours_seen = 0;
4638 
4639  cob_set_exception (0);
4640  if (value->size < format->size) {
4641  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4642  cob_alloc_set_field_uint (0);
4643  return curr_field;
4644  }
4645  p1 = format->data;
4646  p2 = value->data;
4647  for (n = 0; n < format->size - 1; ++n, ++p1, ++p2) {
4648  if (!memcmp (p1, "hh", (size_t)2) && !hours_seen) {
4649  if (*p2 >= (unsigned char)'0' &&
4650  *p2 <= (unsigned char)'9' &&
4651  *(p2 + 1) >= (unsigned char)'0' &&
4652  *(p2 + 1) <= (unsigned char)'9') {
4653  hours = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
4654  hours_seen = 1;
4655  continue;
4656  }
4657  }
4658  if (!memcmp (p1, "mm", (size_t)2) && !minutes_seen) {
4659  if (*p2 >= (unsigned char)'0' &&
4660  *p2 <= (unsigned char)'9' &&
4661  *(p2 + 1) >= (unsigned char)'0' &&
4662  *(p2 + 1) <= (unsigned char)'9') {
4663  minutes = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
4664  minutes_seen = 1;
4665  continue;
4666  }
4667  }
4668  if (!memcmp (p1, "ss", (size_t)2) && !seconds_seen) {
4669  if (*p2 >= (unsigned char)'0' &&
4670  *p2 <= (unsigned char)'9' &&
4671  *(p2 + 1) >= (unsigned char)'0' &&
4672  *(p2 + 1) <= (unsigned char)'9') {
4673  seconds = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
4674  seconds_seen = 1;
4675  continue;
4676  }
4677  }
4678  }
4679  if (hours_seen && minutes_seen && seconds_seen) {
4680  seconds += (hours * 3600) + (minutes * 60);
4681  } else {
4682  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4683  seconds = 0;
4684  }
4685  cob_alloc_set_field_uint (seconds);
4686  return curr_field;
4687 }
cob_field* cob_intr_seconds_past_midnight ( void  )

References cob_alloc_set_field_int(), curr_field, and NULL.

4609 {
4610  struct tm *timeptr;
4611  time_t t;
4612  int seconds;
4613 
4614  t = time (NULL);
4615  timeptr = localtime (&t);
4616  /* Leap seconds ? */
4617  if (timeptr->tm_sec >= 60) {
4618  timeptr->tm_sec = 59;
4619  }
4620  seconds = (timeptr->tm_hour * 3600) + (timeptr->tm_min * 60) +
4621  timeptr->tm_sec;
4622  cob_alloc_set_field_int (seconds);
4623  return curr_field;
4624 }
cob_field* cob_intr_sign ( cob_field *  srcfield)

References cob_alloc_set_field_int(), cob_decimal_set_field(), curr_field, and cob_decimal::value.

2296 {
2297  cob_decimal_set_field (&d1, srcfield);
2298  cob_alloc_set_field_int (mpz_sgn (d1.value));
2299  return curr_field;
2300 }
cob_field* cob_intr_sin ( cob_field *  srcfield)

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), cob_mpf_sin(), cob_mpft, cob_set_exception(), and curr_field.

3553 {
3554  cob_decimal_set_field (&d1, srcfield);
3555 
3556  cob_set_exception (0);
3557 
3558  cob_decimal_get_mpf (cob_mpft, &d1);
3559  cob_mpf_sin (cob_mpft, cob_mpft);
3560  cob_decimal_set_mpf (&d1, cob_mpft);
3561  cob_alloc_field (&d1);
3562  (void)cob_decimal_get_field (&d1, curr_field, 0);
3563 
3564  return curr_field;
3565 }
cob_field* cob_intr_sqrt ( cob_field *  srcfield)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_get_field(), cob_decimal_pow(), cob_decimal_set_field(), COB_EC_ARGUMENT_FUNCTION, cob_set_exception(), cob_trim_decimal(), curr_field, cob_decimal::scale, and cob_decimal::value.

3585 {
3586  cob_decimal_set_field (&d1, srcfield);
3587 
3588  cob_set_exception (0);
3589  if (mpz_sgn (d1.value) < 0) {
3590  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
3591  cob_alloc_set_field_uint (0);
3592  return curr_field;
3593  }
3594 
3595  mpz_set_ui (d2.value, 5UL);
3596  d2.scale = 1;
3597  cob_trim_decimal (&d1);
3598  cob_decimal_pow (&d1, &d2);
3599 
3600  cob_alloc_field (&d1);
3601  (void)cob_decimal_get_field (&d1, curr_field, 0);
3602 
3603  return curr_field;
3604 }
cob_field* cob_intr_standard_compare ( const int  params,
  ... 
)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5807 {
5808  COB_UNUSED (params);
5809 
5810  cob_fatal_error (COB_FERROR_FUNCTION);
5811 }
cob_field* cob_intr_standard_deviation ( const int  params,
  ... 
)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_mul(), cob_decimal_pow(), cob_decimal_set_field(), cob_decimal_sub(), cob_set_exception(), cob_trim_decimal(), cob_uli_t, curr_field, params, cob_decimal::scale, and cob_decimal::value.

4322 {
4323  cob_field *f;
4324  va_list args;
4325  int i;
4326 
4327  va_start (args, params);
4328 
4329  if (params == 1) {
4330  va_end (args);
4331  cob_alloc_set_field_uint (0);
4332  return curr_field;
4333  }
4334 
4335  /* MEAN for all params */
4336  mpz_set_ui (d1.value, 0UL);
4337  d1.scale = 0;
4338 
4339  for (i = 0; i < params; ++i) {
4340  f = va_arg (args, cob_field *);
4341  cob_decimal_set_field (&d2, f);
4342  cob_decimal_add (&d1, &d2);
4343  }
4344  va_end (args);
4345 
4346  mpz_set_ui (d2.value, (cob_uli_t)params);
4347  d2.scale = 0;
4348  cob_decimal_div (&d1, &d2);
4349 
4350  /* Got the MEAN in d1, iterate again */
4351 
4352  mpz_set_ui (d4.value, 0UL);
4353  d4.scale = 0;
4354 
4355  va_start (args, params);
4356 
4357  for (i = 0; i < params; ++i) {
4358  f = va_arg (args, cob_field *);
4359  cob_decimal_set_field (&d2, f);
4360  cob_decimal_sub (&d2, &d1);
4361  cob_decimal_mul (&d2, &d2);
4362  cob_decimal_add (&d4, &d2);
4363  }
4364  va_end (args);
4365 
4366  mpz_set_ui (d3.value, (cob_uli_t)params);
4367  d3.scale = 0;
4368  cob_decimal_div (&d4, &d3);
4369 
4370  /* We have the VARIANCE in d4, sqrt = STANDARD-DEVIATION */
4371 
4372  cob_trim_decimal (&d4);
4373 
4374  cob_set_exception (0);
4375 
4376  mpz_set_ui (d3.value, 5UL);
4377  d3.scale = 1;
4378 
4379  cob_trim_decimal (&d4);
4380  cob_decimal_pow (&d4, &d3);
4381 
4382  cob_alloc_field (&d4);
4383  (void)cob_decimal_get_field (&d4, curr_field, 0);
4384 
4385  return curr_field;
4386 }
cob_field* cob_intr_stored_char_length ( cob_field *  srcfield)

References cob_alloc_set_field_uint(), cob_u32_t, curr_field, cob_field::data, p, and cob_field::size.

2989 {
2990  unsigned char *p;
2991  cob_u32_t count;
2992 
2993  count = srcfield->size;
2994  p = srcfield->data + srcfield->size - 1;
2995  for (; count > 0; count--, p--) {
2996  if (*p != ' ') {
2997  break;
2998  }
2999  }
3000 
3001  cob_alloc_set_field_uint (count);
3002  return curr_field;
3003 }
cob_field* cob_intr_substitute ( const int  offset,
const int  length,
const int  params,
  ... 
)

References calc_ref_mod(), COB_FIELD_INIT, cob_free(), cob_malloc(), curr_field, cob_field::data, found, make_field_entry(), NULL, cob_field::size, and unlikely.

2508 {
2509  cob_field *var;
2510  cob_field **f1;
2511  cob_field **f2;
2512  unsigned char *p1;
2513  unsigned char *p2;
2514  size_t varsize;
2515  size_t calcsize;
2516  size_t n;
2517  size_t found;
2518  int numreps;
2519  int i;
2520  cob_field field;
2521  va_list args;
2522 
2523  numreps = params / 2;
2524  f1 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
2525  f2 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
2526 
2527  va_start (args, params);
2528 
2529  var = va_arg (args, cob_field *);
2530  varsize = var->size;
2531 
2532  /* Extract args */
2533  for (i = 0; i < params - 1; ++i) {
2534  if ((i % 2) == 0) {
2535  f1[i / 2] = va_arg (args, cob_field *);
2536  } else {
2537  f2[i / 2] = va_arg (args, cob_field *);
2538  }
2539  }
2540  va_end (args);
2541 
2542  /* Calculate required size */
2543  calcsize = 0;
2544  found = 0;
2545  p1 = var->data;
2546  for (n = 0; n < varsize; ) {
2547  for (i = 0; i < numreps; ++i) {
2548  if (n + f1[i]->size <= varsize) {
2549  if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
2550  p1 += f1[i]->size;
2551  n += f1[i]->size;
2552  calcsize += f2[i]->size;
2553  found = 1;
2554  break;
2555  }
2556  }
2557  }
2558  if (found) {
2559  found = 0;
2560  continue;
2561  }
2562  ++n;
2563  ++p1;
2564  ++calcsize;
2565  }
2566 
2567  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
2568  field.size = calcsize;
2569  make_field_entry (&field);
2570 
2571  found = 0;
2572  p1 = var->data;
2573  p2 = curr_field->data;
2574  for (n = 0; n < varsize; ) {
2575  for (i = 0; i < numreps; ++i) {
2576  if (n + f1[i]->size <= varsize) {
2577  if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
2578  memcpy (p2, f2[i]->data, f2[i]->size);
2579  p1 += f1[i]->size;
2580  p2 += f2[i]->size;
2581  n += f1[i]->size;
2582  found = 1;
2583  break;
2584  }
2585  }
2586  }
2587  if (found) {
2588  found = 0;
2589  continue;
2590  }
2591  ++n;
2592  *p2++ = *p1++;
2593  }
2594  if (unlikely(offset > 0)) {
2595  calc_ref_mod (curr_field, offset, length);
2596  }
2597  cob_free (f1);
2598  cob_free (f2);
2599  return curr_field;
2600 }
cob_field* cob_intr_substitute_case ( const int  offset,
const int  length,
const int  params,
  ... 
)

References calc_ref_mod(), COB_FIELD_INIT, cob_free(), cob_malloc(), curr_field, cob_field::data, found, make_field_entry(), NULL, cob_field::size, and unlikely.

2605 {
2606  cob_field *var;
2607  cob_field **f1;
2608  cob_field **f2;
2609  unsigned char *p1;
2610  unsigned char *p2;
2611  size_t varsize;
2612  size_t calcsize;
2613  size_t n;
2614  size_t found;
2615  int numreps;
2616  int i;
2617  cob_field field;
2618  va_list args;
2619 
2620  numreps = params / 2;
2621  f1 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
2622  f2 = cob_malloc ((size_t)numreps * sizeof (cob_field *));
2623 
2624  va_start (args, params);
2625 
2626  var = va_arg (args, cob_field *);
2627  varsize = var->size;
2628 
2629  /* Extract args */
2630  for (i = 0; i < params - 1; ++i) {
2631  if ((i % 2) == 0) {
2632  f1[i / 2] = va_arg (args, cob_field *);
2633  } else {
2634  f2[i / 2] = va_arg (args, cob_field *);
2635  }
2636  }
2637  va_end (args);
2638 
2639  /* Calculate required size */
2640  calcsize = 0;
2641  found = 0;
2642  p1 = var->data;
2643  for (n = 0; n < varsize; ) {
2644  for (i = 0; i < numreps; ++i) {
2645  if (n + f1[i]->size <= varsize) {
2646  if (!strncasecmp ((const char *)p1,
2647  (const char *)(f1[i]->data),
2648  f1[i]->size)) {
2649  p1 += f1[i]->size;
2650  n += f1[i]->size;
2651  calcsize += f2[i]->size;
2652  found = 1;
2653  break;
2654  }
2655  }
2656  }
2657  if (found) {
2658  found = 0;
2659  continue;
2660  }
2661  ++n;
2662  ++p1;
2663  ++calcsize;
2664  }
2665 
2666  COB_FIELD_INIT (0, NULL, &const_alpha_attr);
2667  field.size = calcsize;
2668  make_field_entry (&field);
2669 
2670  found = 0;
2671  p1 = var->data;
2672  p2 = curr_field->data;
2673  for (n = 0; n < varsize; ) {
2674  for (i = 0; i < numreps; ++i) {
2675  if (n + f1[i]->size <= varsize) {
2676  if (!strncasecmp ((const char *)p1,
2677  (const char *)(f1[i]->data),
2678  f1[i]->size)) {
2679  memcpy (p2, f2[i]->data, f2[i]->size);
2680  p1 += f1[i]->size;
2681  p2 += f2[i]->size;
2682  n += f1[i]->size;
2683  found = 1;
2684  break;
2685  }
2686  }
2687  }
2688  if (found) {
2689  found = 0;
2690  continue;
2691  }
2692  ++n;
2693  *p2++ = *p1++;
2694  }
2695  if (unlikely(offset > 0)) {
2696  calc_ref_mod (curr_field, offset, length);
2697  }
2698  cob_free (f1);
2699  cob_free (f2);
2700  return curr_field;
2701 }
cob_field* cob_intr_sum ( const int  params,
  ... 
)

References cob_alloc_field(), cob_decimal_add(), cob_decimal_get_field(), cob_decimal_set_field(), curr_field, params, cob_decimal::scale, and cob_decimal::value.

3939 {
3940  cob_field *f;
3941  va_list args;
3942  int i;
3943 
3944  mpz_set_ui (d1.value, 0UL);
3945  d1.scale = 0;
3946 
3947  va_start (args, params);
3948 
3949  for (i = 0; i < params; ++i) {
3950  f = va_arg (args, cob_field *);
3951  cob_decimal_set_field (&d2, f);
3952  cob_decimal_add (&d1, &d2);
3953  }
3954  va_end (args);
3955 
3956  cob_alloc_field (&d1);
3957  (void)cob_decimal_get_field (&d1, curr_field, 0);
3958  return curr_field;
3959 }
cob_field* cob_intr_tan ( cob_field *  srcfield)

References cob_alloc_field(), cob_decimal_get_field(), cob_decimal_get_mpf(), cob_decimal_set_field(), cob_decimal_set_mpf(), cob_mpf_tan(), cob_mpft, cob_set_exception(), and curr_field.

3569 {
3570  cob_decimal_set_field (&d1, srcfield);
3571 
3572  cob_set_exception (0);
3573 
3574  cob_decimal_get_mpf (cob_mpft, &d1);
3575  cob_mpf_tan (cob_mpft, cob_mpft);
3576  cob_decimal_set_mpf (&d1, cob_mpft);
3577  cob_alloc_field (&d1);
3578  (void)cob_decimal_get_field (&d1, curr_field, 0);
3579 
3580  return curr_field;
3581 }
cob_field* cob_intr_test_date_yyyymmdd ( cob_field *  srcfield)

References cob_alloc_set_field_uint(), cob_get_int(), curr_field, leap_month_days, leap_year(), normal_month_days, and valid_year().

3201 {
3202  int indate;
3203  int days;
3204  int month;
3205  int year;
3206 
3207  /* Base 1601-01-01 */
3208  indate = cob_get_int (srcfield);
3209  year = indate / 10000;
3210  if (!valid_year (year)) {
3211  cob_alloc_set_field_uint (1);
3212  return curr_field;
3213  }
3214  indate %= 10000;
3215  month = indate / 100;
3216  if (month < 1 || month > 12) {
3217  cob_alloc_set_field_uint (2);
3218  return curr_field;
3219  }
3220  days = indate % 100;
3221  if (days < 1 || days > 31) {
3222  cob_alloc_set_field_uint (3);
3223  return curr_field;
3224  }
3225  if (leap_year (year)) {
3226  if (days > leap_month_days[month]) {
3227  cob_alloc_set_field_uint (3);
3228  return curr_field;
3229  }
3230  } else {
3231  if (days > normal_month_days[month]) {
3232  cob_alloc_set_field_uint (3);
3233  return curr_field;
3234  }
3235  }
3236  cob_alloc_set_field_uint (0);
3237  return curr_field;
3238 }
cob_field* cob_intr_test_day_yyyyddd ( cob_field *  srcfield)

References cob_alloc_set_field_uint(), cob_get_int(), curr_field, leap_year(), and valid_year().

3242 {
3243  int indate;
3244  int days;
3245  int year;
3246 
3247  /* Base 1601-01-01 */
3248  indate = cob_get_int (srcfield);
3249  year = indate / 1000;
3250  if (!valid_year (year)) {
3251  cob_alloc_set_field_uint (1);
3252  return curr_field;
3253  }
3254  days = indate % 1000;
3255  if (days < 1 || days > 365 + leap_year (year)) {
3256  cob_alloc_set_field_uint (2);
3257  return curr_field;
3258  }
3259  cob_alloc_set_field_uint (0);
3260  return curr_field;
3261 }
cob_field* cob_intr_test_formatted_datetime ( cob_field *  f1,
cob_field *  f2 
)

References cob_fatal_error(), COB_FERROR_FUNCTION, and COB_UNUSED.

5815 {
5816  COB_UNUSED (f1);
5817  COB_UNUSED (f2);
5818 
5819  cob_fatal_error (COB_FERROR_FUNCTION);
5820 }
cob_field* cob_intr_test_numval ( cob_field *  srcfield)

References cob_alloc_set_field_int(), cob_check_numval(), curr_field, and NULL.

5246 {
5247  cob_alloc_set_field_int (cob_check_numval (srcfield, NULL, 0, 0));
5248  return curr_field;
5249 }
cob_field* cob_intr_test_numval_c ( cob_field *  srcfield,
cob_field *  currency 
)

References cob_alloc_set_field_int(), cob_check_numval(), and curr_field.

5253 {
5254  cob_alloc_set_field_int (cob_check_numval (srcfield, currency, 1, 0));
5255  return curr_field;
5256 }
cob_field* cob_intr_test_numval_f ( cob_field *  srcfield)

References cob_alloc_set_field_int(), cob_check_numval_f(), and curr_field.

5260 {
5261  cob_alloc_set_field_int (cob_check_numval_f (srcfield));
5262  return curr_field;
5263 }
cob_field* cob_intr_trim ( const int  offset,
const int  length,
cob_field *  srcfield,
const int  direction 
)

References calc_ref_mod(), curr_field, cob_field::data, make_field_entry(), cob_field::size, and unlikely.

2706 {
2707  unsigned char *begin;
2708  unsigned char *end;
2709  size_t i;
2710  size_t size;
2711 
2712  make_field_entry (srcfield);
2713 
2714  for (i = 0; i < srcfield->size; ++i) {
2715  if (srcfield->data[i] != ' ') {
2716  break;
2717  }
2718  }
2719  if (i == srcfield->size) {
2720  curr_field->size = 0;
2721  curr_field->data[0] = ' ';
2722  return curr_field;
2723  }
2724 
2725  begin = srcfield->data;
2726  if (direction != 2) {
2727  for (; *begin == ' '; ++begin) ;
2728  }
2729  end = srcfield->data + srcfield->size - 1;
2730  if (direction != 1) {
2731  for (; *end == ' '; end--) ;
2732  }
2733 
2734  size = 0;
2735  for (i = 0; begin <= end; ++begin, ++i) {
2736  curr_field->data[i] = *begin;
2737  ++size;
2738  }
2739  curr_field->size = size;
2740  if (unlikely(offset > 0)) {
2741  calc_ref_mod (curr_field, offset, length);
2742  }
2743  return curr_field;
2744 }
cob_field* cob_intr_upper_case ( const int  offset,
const int  length,
cob_field *  srcfield 
)

References calc_ref_mod(), cob_u8_t, curr_field, cob_field::data, make_field_entry(), cob_field::size, and unlikely.

2304 {
2305  size_t i, size;
2306 
2307  make_field_entry (srcfield);
2308 
2309  size = srcfield->size;
2310  for (i = 0; i < size; ++i) {
2311  curr_field->data[i] = (cob_u8_t)toupper (srcfield->data[i]);
2312  }
2313  if (unlikely(offset > 0)) {
2314  calc_ref_mod (curr_field, offset, length);
2315  }
2316  return curr_field;
2317 }
cob_field* cob_intr_variance ( const int  params,
  ... 
)

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_add(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_mul(), cob_decimal_set_field(), cob_decimal_sub(), cob_uli_t, curr_field, params, cob_decimal::scale, and cob_decimal::value.

4267 {
4268  cob_field *f;
4269  va_list args;
4270  int i;
4271 
4272  va_start (args, params);
4273 
4274  if (params == 1) {
4275  va_end (args);
4276  cob_alloc_set_field_uint (0);
4277  return curr_field;
4278  }
4279 
4280  /* MEAN for all params */
4281  mpz_set_ui (d1.value, 0UL);
4282  d1.scale = 0;
4283 
4284  for (i = 0; i < params; ++i) {
4285  f = va_arg (args, cob_field *);
4286  cob_decimal_set_field (&d2, f);
4287  cob_decimal_add (&d1, &d2);
4288  }
4289  va_end (args);
4290 
4291  mpz_set_ui (d2.value, (cob_uli_t)params);
4292  d2.scale = 0;
4293  cob_decimal_div (&d1, &d2);
4294 
4295  /* Got the MEAN in d1, iterate again */
4296 
4297  mpz_set_ui (d4.value, 0UL);
4298  d4.scale = 0;
4299 
4300  va_start (args, params);
4301 
4302  for (i = 0; i < params; ++i) {
4303  f = va_arg (args, cob_field *);
4304  cob_decimal_set_field (&d2, f);
4305  cob_decimal_sub (&d2, &d1);
4306  cob_decimal_mul (&d2, &d2);
4307  cob_decimal_add (&d4, &d2);
4308  }
4309  va_end (args);
4310 
4311  mpz_set_ui (d3.value, (cob_uli_t)params);
4312  d3.scale = 0;
4313  cob_decimal_div (&d4, &d3);
4314 
4315  cob_alloc_field (&d4);
4316  (void)cob_decimal_get_field (&d4, curr_field, 0);
4317  return curr_field;
4318 }
cob_field* cob_intr_when_compiled ( const int  offset,
const int  length,
cob_field *  f 
)

References calc_ref_mod(), curr_field, cob_field::data, make_field_entry(), cob_field::size, and unlikely.

2857 {
2858  make_field_entry (f);
2859 
2860  memcpy (curr_field->data, f->data, f->size);
2861  if (unlikely(offset > 0)) {
2862  calc_ref_mod (curr_field, offset, length);
2863  }
2864  return curr_field;
2865 }
cob_field* cob_intr_year_to_yyyy ( const int  params,
  ... 
)

References cob_alloc_set_field_int(), cob_alloc_set_field_uint(), COB_EC_ARGUMENT_FUNCTION, cob_get_int(), cob_set_exception(), curr_field, NULL, and valid_year().

4428 {
4429  cob_field *f;
4430  struct tm *timeptr;
4431  va_list args;
4432  time_t t;
4433  int year;
4434  int interval;
4435  int xqtyear;
4436  int maxyear;
4437 
4438  cob_set_exception (0);
4439  va_start (args, params);
4440  f = va_arg (args, cob_field *);
4441  year = cob_get_int (f);
4442  if (params > 1) {
4443  f = va_arg (args, cob_field *);
4444  interval = cob_get_int (f);
4445  } else {
4446  interval = 50;
4447  }
4448  if (params > 2) {
4449  f = va_arg (args, cob_field *);
4450  xqtyear = cob_get_int (f);
4451  } else {
4452  t = time (NULL);
4453  timeptr = localtime (&t);
4454  xqtyear = 1900 + timeptr->tm_year;
4455  }
4456  va_end (args);
4457 
4458  if (year < 0 || year > 99) {
4459  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4460  cob_alloc_set_field_uint (0);
4461  return curr_field;
4462  }
4463  if (!valid_year (xqtyear)) {
4464  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4465  cob_alloc_set_field_uint (0);
4466  return curr_field;
4467  }
4468  maxyear = xqtyear + interval;
4469  if (maxyear < 1700 || maxyear > 9999) {
4470  cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4471  cob_alloc_set_field_uint (0);
4472  return curr_field;
4473  }
4474  if (maxyear % 100 >= year) {
4475  year += 100 * (maxyear / 100);
4476  } else {
4477  year += 100 * ((maxyear / 100) - 1);
4478  }
4479  cob_alloc_set_field_int (year);
4480  return curr_field;
4481 }
static cob_field* cob_mod_or_rem ( cob_field *  f1,
cob_field *  f2,
const int  func_is_rem 
)
static

References cob_alloc_field(), cob_alloc_set_field_uint(), cob_decimal_div(), cob_decimal_get_field(), cob_decimal_mul(), cob_decimal_set_field(), cob_decimal_sub(), COB_EC_SIZE_ZERO_DIVIDE, cob_mexp, cob_mpzt, cob_set_exception(), cob_uli_t, curr_field, cob_decimal::scale, sign, and cob_decimal::value.

Referenced by cob_intr_mod(), and cob_intr_rem().

607 {
608  int sign;
609 
610  cob_set_exception (0);
611  cob_decimal_set_field (&d2, f1);
612  cob_decimal_set_field (&d3, f2);
613 
614  if (!mpz_sgn (d3.value)) {
615  /* Divide by zero */
616  cob_set_exception (COB_EC_SIZE_ZERO_DIVIDE);
617  cob_alloc_set_field_uint (0);
618  return curr_field;
619  }
620 
621  cob_decimal_div (&d2, &d3);
622 
623  /* Caclulate integer / integer-part */
624  if (d2.scale < 0) {
625  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d2.scale);
626  mpz_mul (d2.value, d2.value, cob_mexp);
627  } else if (d2.scale > 0) {
628  sign = mpz_sgn (d2.value);
629  mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d2.scale);
630  if (func_is_rem) {
631  /* REMAINDER function - INTEGER-PART */
632  mpz_tdiv_q (d2.value, d2.value, cob_mexp);
633  } else {
634  /* MOD function - INTEGER */
635  mpz_tdiv_qr (d2.value, cob_mpzt, d2.value, cob_mexp);
636  /* Check negative and has decimal places */
637  if (sign < 0 && mpz_sgn (cob_mpzt)) {
638  mpz_sub_ui (d2.value, d2.value, 1UL);
639  }
640  }
641  }
642  d2.scale = 0;
643 
644  cob_decimal_set_field (&d1, f2);
645  cob_decimal_mul (&d2, &d1);
646  cob_decimal_set_field (&d1, f1);
647  cob_decimal_sub (&d1, &d2);
648 
649  cob_alloc_field (&d1);
650  (void)cob_decimal_get_field (&d1, curr_field, 0);
651  return curr_field;
652 }
static void cob_mpf_acos ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References cob_mpf_atan(), COB_MPF_PREC, and cob_pi.

Referenced by cob_intr_acos().

1451 {
1452  mpf_t vf1, vf2;
1453  mpf_t dst_temp;
1454 
1455  mpf_init2 (dst_temp, COB_MPF_PREC);
1456 
1457  if (!mpf_sgn (src_val)) {
1458  mpf_set (dst_temp, cob_pi);
1459  mpf_div_ui (dst_temp, dst_temp, 2UL);
1460  mpf_set (dst_val, dst_temp);
1461  mpf_clear (dst_temp);
1462  return;
1463  }
1464  if (!mpf_cmp_ui (src_val, 1UL)) {
1465  mpf_set_ui (dst_val, 0UL);
1466  mpf_clear (dst_temp);
1467  return;
1468  }
1469  if (!mpf_cmp_si (src_val, -1L)) {
1470  mpf_set (dst_val, cob_pi);
1471  mpf_clear (dst_temp);
1472  return;
1473  }
1474 
1475  mpf_init2 (vf1, COB_MPF_PREC);
1476  mpf_init2 (vf2, COB_MPF_PREC);
1477 
1478  mpf_add_ui (vf2, src_val, 1UL);
1479  mpf_mul (vf1, src_val, src_val);
1480  mpf_ui_sub (vf1, 1UL, vf1);
1481  mpf_sqrt (vf1, vf1);
1482  mpf_div (vf1, vf1, vf2);
1483  cob_mpf_atan (dst_temp, vf1);
1484  mpf_mul_ui (dst_temp, dst_temp, 2UL);
1485 
1486  mpf_set (dst_val, dst_temp);
1487  mpf_clear (dst_temp);
1488 
1489  mpf_clear (vf2);
1490  mpf_clear (vf1);
1491 }
static void cob_mpf_asin ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References cob_mpf_atan(), COB_MPF_PREC, and cob_pi.

Referenced by cob_intr_asin().

1404 {
1405  mpf_t vf1, vf2;
1406  mpf_t dst_temp;
1407 
1408  mpf_init2 (dst_temp, COB_MPF_PREC);
1409 
1410  if (!mpf_cmp_ui (src_val, 1UL) || !mpf_cmp_si (src_val, -1L)) {
1411  mpf_set (dst_temp, cob_pi);
1412  mpf_div_ui (dst_temp, dst_temp, 2UL);
1413  if (mpf_sgn (src_val) < 0) {
1414  mpf_neg (dst_temp, dst_temp);
1415  }
1416  mpf_set (dst_val, dst_temp);
1417  mpf_clear (dst_temp);
1418  return;
1419  }
1420  if (!mpz_sgn (src_val)) {
1421  mpf_set_ui (dst_val, 0UL);
1422  mpf_clear (dst_temp);
1423  return;
1424  }
1425 
1426  mpf_init2 (vf1, COB_MPF_PREC);
1427  mpf_init2 (vf2, COB_MPF_PREC);
1428 
1429  mpf_mul (vf2, src_val, src_val);
1430  mpf_ui_sub (vf2, 1UL, vf2);
1431  mpf_sqrt (vf2, vf2);
1432 
1433  mpf_add_ui (vf2, vf2, 1UL);
1434 
1435  mpf_div (vf1, src_val, vf2);
1436  cob_mpf_atan (dst_temp, vf1);
1437  mpf_mul_ui (dst_temp, dst_temp, 2UL);
1438 
1439  mpf_set (dst_val, dst_temp);
1440  mpf_clear (dst_temp);
1441 
1442  mpf_clear (vf2);
1443  mpf_clear (vf1);
1444 }
static void cob_mpf_atan ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References COB_MPF_PREC, cob_pi, cob_sqrt_two, and cob_uli_t.

Referenced by cob_intr_atan(), cob_mpf_acos(), and cob_mpf_asin().

1340 {
1341  mpf_t vf1, vf2, vf3, vf4;
1342  mpf_t dst_temp;
1343  cob_uli_t n;
1344 
1345  mpf_init2 (dst_temp, COB_MPF_PREC);
1346 
1347  mpf_init2 (vf1, COB_MPF_PREC);
1348  mpf_init2 (vf2, COB_MPF_PREC);
1349  mpf_init2 (vf3, COB_MPF_PREC);
1350  mpf_init2 (vf4, COB_MPF_PREC);
1351 
1352  mpf_abs (vf1, src_val);
1353  mpf_add_ui (vf3, cob_sqrt_two, 1UL);
1354 
1355  if (mpf_cmp (vf1, vf3) > 0) {
1356  mpf_set (dst_temp, cob_pi);
1357  mpf_div_2exp (dst_temp, dst_temp, 1UL);
1358  mpf_ui_div (vf1, 1UL, vf1);
1359  mpf_neg (vf1, vf1);
1360  } else {
1361  mpf_sub_ui (vf4, cob_sqrt_two, 1UL);
1362  if (mpf_cmp (vf1, vf4) > 0) {
1363  mpf_set (dst_temp, cob_pi);
1364  mpf_div_2exp (dst_temp, dst_temp, 2UL);
1365  mpf_sub_ui (vf3, vf1, 1UL);
1366  mpf_add_ui (vf4, vf1, 1UL);
1367  mpf_div (vf1, vf3, vf4);
1368  } else {
1369  mpf_set_ui (dst_temp, 0UL);
1370  }
1371  }
1372  mpf_mul (vf2, vf1, vf1);
1373  mpf_neg (vf2, vf2);
1374  mpf_add (dst_temp, dst_temp, vf1);
1375 
1376  n = 1;
1377 
1378  do {
1379  mpf_mul (vf1, vf1, vf2);
1380  mpf_div_ui (vf3, vf1, 2UL * n + 1UL);
1381  mpf_set (vf4, dst_temp);
1382  mpf_add (dst_temp, dst_temp, vf3);
1383  ++n;
1384  } while (!mpf_eq (vf4, dst_temp, COB_MPF_PREC));
1385 
1386  if (mpf_sgn (src_val) < 0) {
1387  mpf_neg (dst_temp, dst_temp);
1388  }
1389 
1390  mpf_set (dst_val, dst_temp);
1391  mpf_clear (dst_temp);
1392 
1393  mpf_clear (vf4);
1394  mpf_clear (vf3);
1395  mpf_clear (vf2);
1396  mpf_clear (vf1);
1397 }
static void cob_mpf_cos ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References COB_MPF_PREC, cob_mpf_sin(), and cob_pi.

Referenced by cob_intr_cos(), and cob_mpf_tan().

1303 {
1304  mpf_t vf1;
1305 
1306  mpf_init2 (vf1, COB_MPF_PREC);
1307 
1308  mpf_set (vf1, cob_pi);
1309  mpf_div_2exp (vf1, vf1, 1UL);
1310  mpf_sub (vf1, vf1, src_val);
1311  cob_mpf_sin (dst_val, vf1);
1312 
1313  mpf_clear (vf1);
1314 }
static void cob_mpf_exp ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References COB_MPF_CUTOFF, COB_MPF_PREC, cob_sli_t, cob_u32_t, and cob_uli_t.

Referenced by cob_decimal_pow(), cob_intr_e(), and cob_intr_exp().

1079 {
1080  mpf_t vf1, vf2, vf3;
1081  mpf_t dst_temp;
1082  cob_sli_t expon, i;
1083  cob_uli_t n;
1084  cob_u32_t is_negative;
1085 
1086 
1087  mpf_init2 (dst_temp, COB_MPF_PREC);
1088 
1089  mpf_init2 (vf1, COB_MPF_PREC);
1090  mpf_set (vf1, src_val);
1091  mpf_init2 (vf2, COB_MPF_PREC);
1092  mpf_set_ui (vf2, 1UL);
1093  mpf_init2 (vf3, COB_MPF_PREC);
1094 
1095  mpf_set_ui (dst_temp, 1UL);
1096 
1097  if (mpf_sgn (vf1) < 0) {
1098  mpf_neg (vf1, vf1);
1099  is_negative = 1;
1100  } else {
1101  is_negative = 0;
1102  }
1103 
1104  mpf_get_d_2exp (&expon, vf1);
1105  if (expon > 0) {
1106  mpf_div_2exp (vf1, vf1, (cob_uli_t)expon);
1107  }
1108 
1109  n = 1;
1110  do {
1111  mpf_mul (vf2, vf2, vf1);
1112  mpf_div_ui (vf2, vf2, (cob_uli_t)n);
1113  mpf_set (vf3, dst_temp);
1114  mpf_add (dst_temp, dst_temp, vf2);
1115  ++n;
1116  } while (!mpf_eq (vf3, dst_temp, COB_MPF_CUTOFF));
1117 
1118  for (i = 0; i < expon; ++i) {
1119  mpf_mul (dst_temp, dst_temp, dst_temp);
1120  }
1121 
1122  if (is_negative) {
1123  mpf_ui_div (dst_temp, 1UL, dst_temp);
1124  }
1125 
1126  mpf_set (dst_val, dst_temp);
1127  mpf_clear (dst_temp);
1128 
1129  mpf_clear (vf3);
1130  mpf_clear (vf2);
1131  mpf_clear (vf1);
1132 }
static void cob_mpf_log ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References cob_log_half, COB_MPF_CUTOFF, COB_MPF_PREC, cob_sli_t, and cob_uli_t.

Referenced by cob_decimal_pow(), cob_intr_log(), and cob_mpf_log10().

1139 {
1140  mpf_t vf1, vf2, vf3, vf4;
1141  mpf_t dst_temp;
1142  cob_sli_t expon;
1143  cob_uli_t n;
1144 
1145 
1146 
1147  if (mpf_sgn (src_val) <= 0 || !mpf_cmp_ui (src_val, 1UL)) {
1148  mpf_set_ui (dst_val, 0UL);
1149  return;
1150  }
1151 
1152  mpf_init2 (dst_temp, COB_MPF_PREC);
1153 
1154  mpf_init2 (vf1, COB_MPF_PREC);
1155  mpf_set (vf1, src_val);
1156  mpf_init2 (vf2, COB_MPF_PREC);
1157  mpf_init2 (vf3, COB_MPF_PREC);
1158  mpf_set_si (vf3, -1L);
1159  mpf_init2 (vf4, COB_MPF_PREC);
1160 
1161  mpf_set_ui (dst_temp, 0UL);
1162  mpf_get_d_2exp (&expon, vf1);
1163  if (expon != 0) {
1164  mpf_set (dst_temp, cob_log_half);
1165  if (expon > 0) {
1166  mpf_mul_ui (dst_temp, dst_temp, (cob_uli_t)expon);
1167  mpf_neg (dst_temp, dst_temp);
1168  mpf_div_2exp (vf1, vf1, (cob_uli_t)expon);
1169  } else {
1170  mpf_mul_ui (dst_temp, dst_temp, (cob_uli_t)-expon);
1171  mpf_mul_2exp (vf1, vf1, (cob_uli_t)-expon);
1172  }
1173  }
1174  mpf_ui_sub (vf1, 1UL, vf1);
1175 
1176  n = 1;
1177  do {
1178  mpf_mul (vf3, vf3, vf1);
1179  mpf_div_ui (vf2, vf3, n);
1180  mpf_set (vf4, dst_temp);
1181  mpf_add (dst_temp, dst_temp, vf2);
1182  ++n;
1183  } while (!mpf_eq (vf4, dst_temp, COB_MPF_CUTOFF));
1184 
1185  mpf_set (dst_val, dst_temp);
1186  mpf_clear (dst_temp);
1187 
1188  mpf_clear (vf4);
1189  mpf_clear (vf3);
1190  mpf_clear (vf2);
1191  mpf_clear (vf1);
1192 }
static void cob_mpf_log10 ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References cob_mpf_log(), and COB_MPF_PREC.

Referenced by cob_intr_log10().

1199 {
1200  mpf_t vf1;
1201  mpf_t dst_temp;
1202 
1203  mpf_init2 (dst_temp, COB_MPF_PREC);
1204 
1205  mpf_init2 (vf1, COB_MPF_PREC);
1206 
1207  cob_mpf_log (dst_temp, src_val);
1208  mpf_set_ui (vf1, 10UL);
1209  cob_mpf_log (vf1, vf1);
1210  mpf_div (dst_temp, dst_temp, vf1);
1211 
1212  mpf_set (dst_val, dst_temp);
1213  mpf_clear (dst_temp);
1214 
1215  mpf_clear (vf1);
1216 }
static void cob_mpf_sin ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References COB_MPF_PREC, cob_pi, cob_uli_t, and sign.

Referenced by cob_intr_sin(), cob_mpf_cos(), and cob_mpf_tan().

1224 {
1225  mpf_t vf1, vf2, vf3, vf4, vf5;
1226  mpf_t dst_temp;
1227  cob_uli_t arcquad;
1228  cob_uli_t n;
1229  int sign;
1230 
1231  mpf_init2 (dst_temp, COB_MPF_PREC);
1232 
1233  mpf_init2 (vf1, COB_MPF_PREC);
1234  mpf_init2 (vf2, COB_MPF_PREC);
1235  mpf_init2 (vf3, COB_MPF_PREC);
1236  mpf_init2 (vf4, COB_MPF_PREC);
1237  mpf_init2 (vf5, COB_MPF_PREC);
1238  sign = mpf_sgn (src_val);
1239 
1240  mpf_abs (vf4, src_val);
1241  mpf_set (vf3, cob_pi);
1242  mpf_div_2exp (vf3, vf3, 1UL);
1243  mpf_div (vf1, vf4, vf3);
1244  mpf_floor (vf4, vf1);
1245 
1246  if (mpf_cmp_ui (vf4, 4UL) >= 0) {
1247  mpf_div_2exp (vf2, vf4, 2UL);
1248  mpf_floor (vf2, vf2);
1249  mpf_mul_2exp (vf2, vf2, 2UL);
1250  mpf_sub (vf2, vf4, vf2);
1251  } else {
1252  mpf_set (vf2, vf4);
1253  }
1254 
1255  arcquad = mpf_get_ui (vf2);
1256  mpf_sub (vf2, vf1, vf4);
1257  mpf_mul (vf4, vf3, vf2);
1258 
1259  if (arcquad > 1) {
1260  sign = -sign;
1261  }
1262  if (arcquad & 1) {
1263  mpf_sub (vf4, vf3, vf4);
1264  }
1265 
1266  mpf_mul (vf3, vf4, vf4);
1267  mpf_neg (vf3, vf3);
1268 
1269  n = 1;
1270  mpf_set_ui (vf2, 1UL);
1271  mpf_set_ui (dst_temp, 1UL);
1272 
1273  do {
1274  ++n;
1275  mpf_div_ui (vf2, vf2, n);
1276  ++n;
1277  mpf_div_ui (vf2, vf2, n);
1278  mpf_mul (vf2, vf2, vf3);
1279  mpf_set (vf5, dst_temp);
1280  mpf_add (dst_temp, dst_temp, vf2);
1281  } while (!mpf_eq (vf5, dst_temp, COB_MPF_PREC));
1282 
1283  mpf_mul (dst_temp, dst_temp, vf4);
1284  if (sign < 0) {
1285  mpf_neg (dst_temp, dst_temp);
1286  }
1287 
1288  mpf_set (dst_val, dst_temp);
1289  mpf_clear (dst_temp);
1290 
1291  mpf_clear (vf5);
1292  mpf_clear (vf4);
1293  mpf_clear (vf3);
1294  mpf_clear (vf2);
1295  mpf_clear (vf1);
1296 }
static void cob_mpf_tan ( mpf_t  dst_val,
const mpf_t  src_val 
)
static

References cob_mpf_cos(), COB_MPF_PREC, and cob_mpf_sin().

Referenced by cob_intr_tan().

1321 {
1322  mpf_t vf1;
1323  mpf_t vf2;
1324 
1325  mpf_init2 (vf1, COB_MPF_PREC);
1326  mpf_init2 (vf2, COB_MPF_PREC);
1327 
1328  cob_mpf_sin (vf1, src_val);
1329  cob_mpf_cos (vf2, src_val);
1330  mpf_div (dst_val, vf1, vf2);
1331 
1332  mpf_clear (vf1);
1333  mpf_clear (vf2);
1334 }
void cob_put_indirect_field ( cob_field *  f)

References curr_field, cob_field::data, make_field_entry(), and cob_field::size.

2060 {
2061  make_field_entry (f);
2062  memcpy (curr_field->data, f->data, f->size);
2063  move_field = curr_field;
2064 }
cob_field* cob_switch_value ( const int  id)

References cob_alloc_set_field_int(), cob_get_switch(), and curr_field.

1952 {
1953  cob_alloc_set_field_int (cob_get_switch (id));
1954  return curr_field;
1955 }
static void cob_trim_decimal ( cob_decimal *  d)
static

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

Referenced by cob_alloc_field(), cob_decimal_move_temp(), cob_decimal_pow(), cob_intr_annuity(), cob_intr_exp10(), cob_intr_log(), cob_intr_log10(), cob_intr_sqrt(), and cob_intr_standard_deviation().

499 {
500  if (!mpz_sgn (d->value)) {
501  /* Value is zero */
502  d->scale = 0;
503  return;
504  }
505  for ( ; d->scale > 0; d->scale--) {
506  if (!mpz_divisible_ui_p (d->value, 10UL)) {
507  break;
508  }
509  mpz_tdiv_q_ui (d->value, d->value, 10UL);
510  }
511 }
int cob_valid_date_format ( const char *  format)

Referenced by cob_valid_datetime_format(), valid_day_and_format(), and valid_format().

2102 {
2103  return !strcmp (format, "YYYYMMDD")
2104  || !strcmp (format, "YYYY-MM-DD")
2105  || !strcmp (format, "YYYYDDD")
2106  || !strcmp (format, "YYYY-DDD")
2107  || !strcmp (format, "YYYYWwwD")
2108  || !strcmp (format, "YYYY-Www-D");
2109 }
int cob_valid_datetime_format ( const char *  format)

References cob_valid_date_format(), cob_valid_time_format(), MAX_DATETIME_STR_LENGTH, parse_date_format_string(), parse_time_format_string(), split_around_t(), time_format::with_colons, and date_format::with_hyphens.

Referenced by cob_intr_formatted_datetime(), offset_time_format(), and valid_format().

2147 {
2148  char date_format_str[MAX_DATETIME_STR_LENGTH] = { '\0' };
2149  char time_format_str[MAX_DATETIME_STR_LENGTH] = { '\0' };
2150  struct date_format date_format;
2151  struct time_format time_format;
2152 
2153  split_around_t (format, date_format_str, time_format_str);
2154 
2155  if (!cob_valid_date_format (date_format_str)
2156  || !cob_valid_time_format (time_format_str)) {
2157  return 0;
2158  }
2159 
2160  /* Check time and date formats match */
2161  date_format = parse_date_format_string (date_format_str);
2162  time_format = parse_time_format_string (time_format_str);
2163  if (date_format.with_hyphens != time_format.with_colons) {
2164  return 0;
2165  }
2166 
2167  return 1;
2168 }
int cob_valid_time_format ( const char *  format)

References time_format::decimal_places, decimal_places_for_seconds(), max_time_decimal_places, rest_is_offset_format(), rest_is_z(), and time_format::with_colons.

Referenced by cob_intr_formatted_time(), cob_valid_datetime_format(), offset_time_format(), and valid_format().

2113 {
2114  int with_colons;
2115  ptrdiff_t format_offset;
2116  int decimal_places = 0;
2117 
2118  if (!strncmp (format, "hhmmss", 6)) {
2119  with_colons = 0;
2120  format_offset = 6;
2121  } else if (!strncmp (format, "hh:mm:ss", 8)) {
2122  with_colons = 1;
2123  format_offset = 8;
2124  } else {
2125  return 0;
2126  }
2127 
2128  if (format[format_offset] == '.') {
2129  decimal_places = decimal_places_for_seconds (format, format_offset);
2130  format_offset += decimal_places + 1;
2131  if (!(1 <= decimal_places && decimal_places <= max_time_decimal_places)) {
2132  return 0;
2133  }
2134  }
2135 
2136  if (strlen (format) > format_offset
2137  && !rest_is_z (format + format_offset)
2138  && !rest_is_offset_format (format + format_offset, with_colons)) {
2139  return 0;
2140  }
2141 
2142  return 1;
2143 }
static int comp_field ( const void *  m1,
const void *  m2 
)
static

References cob_cmp().

Referenced by cob_intr_median().

458 {
459  cob_field *f1;
460  cob_field *f2;
461 
462  f1 = *(cob_field **) m1;
463  f2 = *(cob_field **) m2;
464  return cob_cmp (f1, f2);
465 }
static void date_of_integer ( int  days,
int *  year,
int *  month,
int *  day 
)
static

References leap_days, leap_year(), and normal_days.

Referenced by cob_intr_date_of_integer(), and format_as_yyyymmdd().

1513 {
1514  int baseyear = 1601;
1515  int leapyear = 365;
1516  int i;
1517 
1518  while (days > leapyear) {
1519  days -= leapyear;
1520  ++baseyear;
1521  if (leap_year (baseyear)) {
1522  leapyear = 366;
1523  } else {
1524  leapyear = 365;
1525  }
1526  }
1527  for (i = 0; i < 13; ++i) {
1528  if (leap_year (baseyear)) {
1529  if (days <= leap_days[i]) {
1530  days -= leap_days[i-1];
1531  break;
1532  }
1533  } else {
1534  if (days <= normal_days[i]) {
1535  days -= normal_days[i-1];
1536  break;
1537  }
1538  }
1539  }
1540 
1541  *year = baseyear;
1542  *month = i;
1543  *day = days;
1544 }
static void day_of_integer ( int  days,
int *  year,
int *  day 
)
static

References leap_year().

Referenced by cob_intr_day_of_integer(), format_as_yyyyddd(), format_as_yyyywwwd(), and get_iso_week().

1548 {
1549  int leapyear = 365;
1550 
1551  /* Precondition: year, day != NULL */
1552 
1553  *year = 1601;
1554 
1555  while (days > leapyear) {
1556  days -= leapyear;
1557  ++*year;
1558  if (leap_year (*year)) {
1559  leapyear = 366;
1560  } else {
1561  leapyear = 365;
1562  }
1563  }
1564 
1565  *day = days;
1566 }
static int decimal_places_for_seconds ( const char *  str,
const ptrdiff_t  point_pos 
)
static

Referenced by cob_valid_time_format(), and parse_time_format_string().

1739 {
1740  ptrdiff_t offset = point_pos;
1741  int decimal_places = 0;
1742 
1743  while (str[++offset] == 's') {
1744  ++decimal_places;
1745  }
1746 
1747  return decimal_places;
1748 }
static void format_as_yyyyddd ( const int  day_num,
const int  with_hyphen,
char *  buff 
)
static

References day_of_integer().

Referenced by format_date().

1602 {
1603  int day_of_year;
1604  int year;
1605  const char *format_str;
1606 
1607  /* Precondition: valid_integer_date (day_num) and buff != NULL */
1608 
1609  day_of_integer (day_num, &year, &day_of_year);
1610 
1611  format_str = with_hyphen ? "%4.4d-%3.3d" : "%4.4d%3.3d";
1612  sprintf (buff, format_str, year, day_of_year);
1613 }
static void format_as_yyyymmdd ( const int  day_num,
const int  with_hyphen,
char *  buff 
)
static

References date_of_integer().

Referenced by format_date().

1586 {
1587  int day_of_month;
1588  int month;
1589  int year;
1590  const char *format_str;
1591 
1592  /* Precondition: valid_integer_date (day_num) and buff != NULL */
1593 
1594  date_of_integer (day_num, &year, &month, &day_of_month);
1595 
1596  format_str = with_hyphen ? "%4.4d-%2.2d-%2.2d" : "%4.4d%2.2d%2.2d";
1597  sprintf (buff, format_str, year, month, day_of_month);
1598 }
static void format_as_yyyywwwd ( const int  day_num,
const int  with_hyphen,
char *  buff 
)
static

References day_of_integer(), get_day_of_week(), and get_iso_week().

Referenced by format_date().

1671 {
1672  int ignored_day_of_year;
1673  int week;
1674  int year;
1675  int day_of_week;
1676  const char *format_str;
1677 
1678  /* Precondition: valid_integer_date (day_num) and buff != NULL */
1679 
1680  day_of_integer (day_num, &year, &ignored_day_of_year);
1681  get_iso_week (day_num, &year, &week);
1682  day_of_week = get_day_of_week (day_num);
1683 
1684  format_str = with_hyphen ? "%4.4d-W%2.2d-%1.1d" : "%4.4dW%2.2d%1.1d";
1685  sprintf (buff, format_str, year, week, day_of_week + 1);
1686 }
static void format_date ( const struct date_format  format,
const int  days,
char *  buff 
)
static

References date_format::days, DAYS_DDD, DAYS_MMDD, format_as_yyyyddd(), format_as_yyyymmdd(), format_as_yyyywwwd(), and date_format::with_hyphens.

Referenced by cob_intr_formatted_date(), and cob_intr_formatted_datetime().

1721 {
1722  void (*formatting_func) (int, int, char *);
1723 
1724  /* Precondition: valid_integer_date (days) and buff != NULL */
1725 
1726  if (format.days == DAYS_MMDD) {
1727  formatting_func = &format_as_yyyymmdd;
1728  } else if (format.days == DAYS_DDD) {
1729  formatting_func = &format_as_yyyyddd;
1730  } else { /* DAYS_WWWD */
1731  formatting_func = &format_as_yyyywwwd;
1732  }
1733 
1734  (*formatting_func) (days, format.with_hyphens, buff);
1735 }
static void format_time ( const struct time_format  format,
int  time,
int *  offset_time,
char *  buff 
)
static

References add_decimal_digits(), add_offset_time(), add_z(), time_format::decimal_places, time_format::extra, EXTRA_OFFSET_TIME, EXTRA_Z, and time_format::with_colons.

Referenced by cob_intr_formatted_datetime(), and cob_intr_formatted_time().

1858 {
1859  int hours;
1860  int minutes;
1861  int seconds;
1862  ptrdiff_t buff_pos;
1863  const char *format_str;
1864 
1865  /* Preconditions:
1866  * valid_time (time)
1867  * buff != NULL
1868  * If offset_time == NULL,
1869  then format.extra != EXTRA_OFFSET_TIME
1870  else valid_offset_time (*offset_time)
1871  */
1872 
1873  if (format.with_colons) {
1874  format_str = "%2.2d:%2.2d:%2.2d";
1875  buff_pos = 8;
1876  } else {
1877  format_str = "%2.2d%2.2d%2.2d";
1878  buff_pos = 6;
1879  }
1880 
1881  /* Duplication! */
1882  hours = time / 3600;
1883  time %= 3600;
1884  minutes = time / 60;
1885  seconds = time % 60;
1886 
1887  sprintf (buff, format_str, hours, minutes, seconds);
1888 
1889  if (format.decimal_places != 0) {
1890  add_decimal_digits (format.decimal_places, buff, &buff_pos);
1891  }
1892 
1893  if (format.extra == EXTRA_Z) {
1894  add_z (buff_pos, buff);
1895  } else if (format.extra == EXTRA_OFFSET_TIME) {
1896  add_offset_time (format.with_colons, *offset_time, buff_pos, buff);
1897  }
1898 }
static int get_day_of_week ( const int  day_num)
static

Referenced by format_as_yyyywwwd(), and get_iso_week_one().

1618 {
1619  return (day_num - 1) % 7;
1620 }
static void get_iso_week ( const int  day_num,
int *  year,
int *  week 
)
static

References day_of_integer(), get_iso_week_one(), and leap_year().

Referenced by format_as_yyyywwwd().

1637 {
1638  int day_of_year;
1639  int days_to_dec_29;
1640  int dec_29;
1641  int week_one;
1642 
1643  /* Precondition: valid_integer_date (day_num) and year, week != NULL */
1644 
1645  day_of_integer (day_num, year, &day_of_year);
1646 
1647  days_to_dec_29 = 365 + leap_year (*year) - 2;
1648  dec_29 = day_num - day_of_year + days_to_dec_29;
1649 
1650  if (day_num >= dec_29) {
1651  week_one = get_iso_week_one (day_num + 365 + leap_year (*year), day_of_year);
1652  if (day_num < week_one) {
1653  week_one = get_iso_week_one (day_num, day_of_year);
1654  } else {
1655  ++*year;
1656  }
1657  } else {
1658  week_one = get_iso_week_one (day_num, day_of_year);
1659  if (day_num < week_one) {
1660  --*year;
1661  week_one = get_iso_week_one (day_num - day_of_year,
1662  365 + leap_year (*year));
1663  }
1664  }
1665 
1666  *week = (day_num - week_one) / 7 + 1;
1667 }
static int get_iso_week_one ( const int  day_num,
const int  day_of_year 
)
static

References get_day_of_week().

Referenced by get_iso_week().

1624 {
1625  int jan_4 = day_num - day_of_year + 4;
1626  int day_of_week = get_day_of_week (jan_4);
1627  int first_monday = jan_4 - day_of_week;
1628  return first_monday;
1629 }
static int leap_year ( const int  year)
static

Referenced by cob_intr_integer_of_date(), cob_intr_integer_of_day(), cob_intr_locale_date(), cob_intr_test_date_yyyymmdd(), cob_intr_test_day_yyyyddd(), date_of_integer(), day_of_integer(), and get_iso_week().

452 {
453  return ((year % 4 == 0 && year % 100 != 0) || (year % 400 == 0)) ? 1 : 0;
454 }
static void make_field_entry ( cob_field *  f)
static

References cob_field::attr, calc_struct::calc_attr, calc_struct::calc_field, calc_struct::calc_size, COB_DEPTH_LEVEL, cob_free(), cob_malloc(), curr_entry, cob_field::data, and cob_field::size.

Referenced by cob_alloc_field(), cob_alloc_set_field_int(), cob_alloc_set_field_uint(), cob_decimal_move_temp(), cob_intr_abs(), cob_intr_char(), cob_intr_combined_datetime(), cob_intr_concatenate(), cob_intr_currency_symbol(), cob_intr_current_date(), cob_intr_date_of_integer(), cob_intr_day_of_integer(), cob_intr_exception_file(), cob_intr_exception_location(), cob_intr_exception_statement(), cob_intr_exception_status(), cob_intr_formatted_date(), cob_intr_formatted_datetime(), cob_intr_formatted_time(), cob_intr_highest_algebraic(), cob_intr_lcl_time_from_secs(), cob_intr_locale_compare(), cob_intr_locale_date(), cob_intr_locale_time(), cob_intr_lower_case(), cob_intr_lowest_algebraic(), cob_intr_max(), cob_intr_mean(), cob_intr_median(), cob_intr_min(), cob_intr_module_caller_id(), cob_intr_module_date(), cob_intr_module_formatted_date(), cob_intr_module_id(), cob_intr_module_path(), cob_intr_module_source(), cob_intr_module_time(), cob_intr_mon_decimal_point(), cob_intr_mon_thousands_sep(), cob_intr_num_decimal_point(), cob_intr_num_thousands_sep(), cob_intr_random(), cob_intr_reverse(), cob_intr_substitute(), cob_intr_substitute_case(), cob_intr_trim(), cob_intr_upper_case(), cob_intr_when_compiled(), and cob_put_indirect_field().

422 {
423  unsigned char *s;
424  struct calc_struct *calc_temp;
425 
426  calc_temp = calc_base + curr_entry;
427  curr_field = &calc_temp->calc_field;
428  if (f->size > calc_temp->calc_size) {
429  if (curr_field->data) {
430  cob_free (curr_field->data);
431  }
432  calc_temp->calc_size = f->size + 1;
433  s = cob_malloc (f->size + 1U);
434  } else {
435  s = curr_field->data;
436  memset (s, 0, f->size);
437  }
438 
439  *curr_field = *f;
440  calc_temp->calc_attr = *(f->attr);
441  curr_field->attr = &calc_temp->calc_attr;
442 
443  curr_field->data = s;
444 
445  if (++curr_entry >= COB_DEPTH_LEVEL) {
446  curr_entry = 0;
447  }
448 }
static int num_leading_nonspace ( const char *  str)
static

Referenced by cob_intr_formatted_date(), cob_intr_formatted_datetime(), and cob_intr_formatted_time().

1576 {
1577  int i;
1578  int str_len = strlen (str);
1579 
1580  for (i = 0; i < str_len && !isspace ((int)str[i]); ++i);
1581  return i;
1582 }
static struct date_format parse_date_format_string ( const char *  format_str)
staticread

References date_format::days, DAYS_DDD, DAYS_MMDD, DAYS_WWWD, and date_format::with_hyphens.

Referenced by cob_intr_formatted_date(), cob_intr_formatted_datetime(), and cob_valid_datetime_format().

1701 {
1702  struct date_format format;
1703 
1704  /* Precondition: cob_valid_date_format (format_str) */
1705 
1706  if (!strcmp (format_str, "YYYYMMDD") || !strcmp (format_str, "YYYY-MM-DD")) {
1707  format.days = DAYS_MMDD;
1708  } else if (!strcmp (format_str, "YYYYDDD") || !strcmp (format_str, "YYYY-DDD")) {
1709  format.days = DAYS_DDD;
1710  } else { /* YYYYWwwD or YYYY-Www-D */
1711  format.days = DAYS_WWWD;
1712  }
1713 
1714  format.with_hyphens = format_str[4] == '-';
1715 
1716  return format;
1717 }
static struct time_format parse_time_format_string ( const char *  str)
staticread

References time_format::decimal_places, decimal_places_for_seconds(), time_format::extra, EXTRA_NONE, EXTRA_OFFSET_TIME, EXTRA_Z, rest_is_z(), and time_format::with_colons.

Referenced by cob_intr_formatted_datetime(), cob_intr_formatted_time(), and cob_valid_datetime_format().

1822 {
1823  struct time_format format;
1824  ptrdiff_t offset;
1825 
1826  /* Precondition: cob_valid_time_format (str) */
1827 
1828  if (!strncmp (str, "hhmmss", 6)) {
1829  format.with_colons = 0;
1830  offset = 6;
1831  } else { /* "hh:mm:ss" */
1832  format.with_colons = 1;
1833  offset = 8;
1834  }
1835 
1836  if (str[offset] == '.') {
1837  format.decimal_places = decimal_places_for_seconds (str, offset);
1838  offset += format.decimal_places + 1;
1839  } else {
1840  format.decimal_places = 0;
1841  }
1842 
1843  if (strlen (str) > offset) {
1844  if (rest_is_z (str + offset)) {
1845  format.extra = EXTRA_Z;
1846  } else { /* the rest is the offset time */
1847  format.extra = EXTRA_OFFSET_TIME;
1848  }
1849  } else {
1850  format.extra = EXTRA_NONE;
1851  }
1852 
1853  return format;
1854 }
static int rest_is_offset_format ( const char *  str,
const int  with_colon 
)
static

Referenced by cob_valid_time_format().

1758 {
1759  if (with_colon) {
1760  return !strcmp (str, "+hh:mm");
1761  } else {
1762  return !strcmp (str, "+hhmm");
1763  }
1764 }
static int rest_is_z ( const char *  str)
static

Referenced by cob_valid_time_format(), and parse_time_format_string().

1752 {
1753  return !strcmp (str, "Z");
1754 }
static void split_around_t ( const char *  str,
char *  first,
char *  second 
)
static

Referenced by cob_intr_formatted_datetime(), and cob_valid_datetime_format().

1902 {
1903  int i;
1904  size_t first_length;
1905  size_t second_length;
1906 
1907  /* Precondition: str, first, second != NULL */
1908 
1909  for (i = 0; str[i] != '\0' && str[i] != 'T'; ++i);
1910 
1911  first_length = i;
1912  strncpy (first, str, first_length);
1913  first[first_length] = '\0';
1914 
1915  if (strlen (str) - i == 0) {
1916  second[0] = '\0';
1917  } else {
1918  second_length = strlen (str) - i - 1U;
1919  strncpy (second, str + i + 1U, second_length);
1920  second[second_length] = '\0';
1921  }
1922 }
static int try_get_valid_offset_time ( const struct time_format  time_format,
cob_field *  offset_time_field,
int *  offset_time,
int **  offset_time_ptr 
)
static

References cob_get_int(), time_format::extra, EXTRA_OFFSET_TIME, NULL, and valid_offset_time().

Referenced by cob_intr_formatted_datetime(), and cob_intr_formatted_time().

1928 {
1929  if (time_format.extra == EXTRA_OFFSET_TIME) {
1930  if (offset_time_field != NULL) {
1931  *offset_time = cob_get_int (offset_time_field);
1932  if (valid_offset_time (*offset_time)) {
1933  *offset_time_ptr = offset_time;
1934  return 0;
1935  }
1936  }
1937  } else {
1938  *offset_time_ptr = NULL;
1939  return 0;
1940  }
1941 
1942  *offset_time_ptr = NULL;
1943  return 1;
1944 }
static int valid_day_and_format ( const int  day,
const char *  format 
)
static

References cob_valid_date_format(), and valid_integer_date().

Referenced by cob_intr_formatted_date().

1570 {
1571  return valid_integer_date (day) && cob_valid_date_format (format);
1572 }
static int valid_integer_date ( const int  days)
static

Referenced by cob_intr_combined_datetime(), cob_intr_date_of_integer(), cob_intr_day_of_integer(), cob_intr_formatted_datetime(), and valid_day_and_format().

1495 {
1496  return days >= 1 && days <= 3067671;
1497 }
static int valid_offset_time ( const int  offset)
static

Referenced by try_get_valid_offset_time().

1768 {
1769  return abs (offset) <= 1439;
1770 }
static int valid_time ( const int  seconds_from_midnight)
static

Referenced by cob_intr_combined_datetime(), cob_intr_formatted_datetime(), cob_intr_formatted_time(), and cob_intr_lcl_time_from_secs().

1507 {
1508  return seconds_from_midnight >= 1 && seconds_from_midnight <= 86400;
1509 }
static int valid_year ( const int  year)
static

Referenced by cob_intr_date_to_yyyymmdd(), cob_intr_day_to_yyyyddd(), cob_intr_integer_of_date(), cob_intr_integer_of_day(), cob_intr_locale_date(), cob_intr_test_date_yyyymmdd(), cob_intr_test_day_yyyyddd(), and cob_intr_year_to_yyyy().

1501 {
1502  return year >= 1601 && year <= 9999;
1503 }

Variable Documentation

struct calc_struct* calc_base
static

Referenced by cob_exit_intrinsic(), and cob_init_intrinsic().

mpf_t cob_log_half
static

Referenced by cob_exit_intrinsic(), cob_init_intrinsic(), and cob_mpf_log().

const char cob_log_half_str[]
static
Initial value:
=
"-0.69314718055994530941723212145817656807550013436"
"02552541206800094933936219696947156058633269964186"
"87542001481020570685733685520235758130557032670751"
"63507596193072757082837143519030703862389167347112"
"33501153644979552391204751726815749320651555247341"
"39525882950453007095326366642654104239157814952043"
"74043038550080194417064167151864471283996817178454"
"69570262716310645461502572074024816377733896385506"
"95260668341137273873722928956493547025762652098859"
"69320196505855476470330679365443254763274495125040"
"60694381471046899465062201677204245245296126879465"
"46193165174681392672504103802546259656869144192871"
"60829380317271436778265487756648508567407764845146"
"44399404614226031930967354025744460703080960850474"
"86638523138181676751438667476647890881437141985494"
"23151997354880375165861275352916610007105355824987"
"94147295092931138971559982056543928717"

Referenced by cob_init_intrinsic().

mpz_t cob_mexp
static

Referenced by cob_decimal_get_mpf(), cob_decimal_set_mpf(), cob_exit_intrinsic(), cob_init_intrinsic(), cob_intr_fraction_part(), cob_intr_integer(), cob_intr_integer_part(), cob_intr_numval_f(), and cob_mod_or_rem().

mpf_t cob_mpft
static

Referenced by cob_decimal_pow(), cob_exit_intrinsic(), cob_init_intrinsic(), cob_intr_acos(), cob_intr_asin(), cob_intr_atan(), cob_intr_cos(), cob_intr_e(), cob_intr_exp(), cob_intr_log(), cob_intr_log10(), cob_intr_pi(), cob_intr_sin(), and cob_intr_tan().

mpf_t cob_mpft2
static

Referenced by cob_decimal_pow(), cob_exit_intrinsic(), and cob_init_intrinsic().

mpf_t cob_mpft_get
static

Referenced by cob_decimal_get_mpf(), cob_exit_intrinsic(), and cob_init_intrinsic().

mpz_t cob_mpzt
static

Referenced by cob_exit_intrinsic(), cob_init_intrinsic(), cob_intr_integer(), and cob_mod_or_rem().

mpf_t cob_pi
static

Referenced by cob_exit_intrinsic(), cob_init_intrinsic(), cob_intr_pi(), cob_mpf_acos(), cob_mpf_asin(), cob_mpf_atan(), cob_mpf_cos(), and cob_mpf_sin().

const char cob_pi_str[]
static
Initial value:
=
"3.141592653589793238462643383279502884197169399375"
"10582097494459230781640628620899862803482534211706"
"79821480865132823066470938446095505822317253594081"
"28481117450284102701938521105559644622948954930381"
"96442881097566593344612847564823378678316527120190"
"91456485669234603486104543266482133936072602491412"
"73724587006606315588174881520920962829254091715364"
"36789259036001133053054882046652138414695194151160"
"94330572703657595919530921861173819326117931051185"
"48074462379962749567351885752724891227938183011949"
"12983367336244065664308602139494639522473719070217"
"98609437027705392171762931767523846748184676694051"
"32000568127145263560827785771342757789609173637178"
"72146844090122495343014654958537105079227968925892"
"35420199561121290219608640344181598136297747713099"
"60518707211349999998372978049951059731732816096318"
"59502445945534690830264252230825334468503526193118"
"817101"

Referenced by cob_init_intrinsic().

mpf_t cob_sqrt_two
static

Referenced by cob_exit_intrinsic(), cob_init_intrinsic(), and cob_mpf_atan().

const char cob_sqrt_two_str[]
static
Initial value:
=
"1.414213562373095048801688724209698078569671875376"
"94807317667973799073247846210703885038753432764157"
"27350138462309122970249248360558507372126441214970"
"99935831413222665927505592755799950501152782060571"
"47010955997160597027453459686201472851741864088919"
"86095523292304843087143214508397626036279952514079"
"89687253396546331808829640620615258352395054745750"
"28775996172983557522033753185701135437460340849884"
"71603868999706990048150305440277903164542478230684"
"92936918621580578463111596668713013015618568987237"
"23528850926486124949771542183342042856860601468247"
"20771435854874155657069677653720226485447015858801"
"62075847492265722600208558446652145839889394437092"
"65918003113882464681570826301005948587040031864803"
"42194897278290641045072636881313739855256117322040"
"24509122770022694112757362728049573810896750401836"
"98683684507257993647290607629969413804756548237289"
"97180326802474420629269124859052181004459842150591"
"12024944134172853147810580360337107730918286931471"
"01711116839165817268894197587165821521282295184884"
"72089694633862891562882765952635140542267653239694"
"61751129160240871551013515045538128756005263146801"
"71274026539694702403005174953188629256313851881634"
"78"

Referenced by cob_init_intrinsic().

cob_global* cobglobptr
static
const cob_field_attr const_alpha_attr
static
Initial value:
=
{COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL}
cob_u32_t curr_entry
static

Referenced by cob_init_intrinsic(), and make_field_entry().

cob_field* curr_field
static

Referenced by cob_intr_abs(), cob_intr_acos(), cob_intr_annuity(), cob_intr_asin(), cob_intr_atan(), cob_intr_binop(), cob_intr_byte_length(), cob_intr_char(), cob_intr_combined_datetime(), cob_intr_concatenate(), cob_intr_cos(), cob_intr_currency_symbol(), cob_intr_current_date(), cob_intr_date_of_integer(), cob_intr_date_to_yyyymmdd(), cob_intr_day_of_integer(), cob_intr_day_to_yyyyddd(), cob_intr_e(), cob_intr_exception_file(), cob_intr_exception_location(), cob_intr_exception_statement(), cob_intr_exception_status(), cob_intr_exp(), cob_intr_exp10(), cob_intr_factorial(), cob_intr_formatted_date(), cob_intr_formatted_datetime(), cob_intr_formatted_time(), cob_intr_fraction_part(), cob_intr_highest_algebraic(), cob_intr_integer(), cob_intr_integer_of_date(), cob_intr_integer_of_day(), cob_intr_integer_part(), cob_intr_lcl_time_from_secs(), cob_intr_length(), cob_intr_locale_compare(), cob_intr_locale_date(), cob_intr_locale_time(), cob_intr_log(), cob_intr_log10(), cob_intr_lower_case(), cob_intr_lowest_algebraic(), cob_intr_max(), cob_intr_mean(), cob_intr_median(), cob_intr_midrange(), cob_intr_min(), cob_intr_module_caller_id(), cob_intr_module_date(), cob_intr_module_formatted_date(), cob_intr_module_id(), cob_intr_module_path(), cob_intr_module_source(), cob_intr_module_time(), cob_intr_mon_decimal_point(), cob_intr_mon_thousands_sep(), cob_intr_num_decimal_point(), cob_intr_num_thousands_sep(), cob_intr_numval(), cob_intr_numval_c(), cob_intr_numval_f(), cob_intr_ord(), cob_intr_ord_max(), cob_intr_ord_min(), cob_intr_pi(), cob_intr_present_value(), cob_intr_random(), cob_intr_range(), cob_intr_reverse(), cob_intr_seconds_from_formatted_time(), cob_intr_seconds_past_midnight(), cob_intr_sign(), cob_intr_sin(), cob_intr_sqrt(), cob_intr_standard_deviation(), cob_intr_stored_char_length(), cob_intr_substitute(), cob_intr_substitute_case(), cob_intr_sum(), cob_intr_tan(), cob_intr_test_date_yyyymmdd(), cob_intr_test_day_yyyyddd(), cob_intr_test_numval(), cob_intr_test_numval_c(), cob_intr_test_numval_f(), cob_intr_trim(), cob_intr_upper_case(), cob_intr_variance(), cob_intr_when_compiled(), cob_intr_year_to_yyyy(), cob_mod_or_rem(), cob_put_indirect_field(), and cob_switch_value().

cob_decimal d1
static

Referenced by cb_build_cond(), cob_cmp_float(), cob_decimal_set_double(), cob_exit_numeric(), and cob_init_numeric().

cob_decimal d2
static

Referenced by cb_build_cond(), and cob_cmp_float().

cob_decimal d3
static
cob_decimal d4
static
cob_decimal d5
static
const int leap_days[]
static
Initial value:
=
{0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366}

Referenced by cob_intr_integer_of_date(), and date_of_integer().

const int leap_month_days[]
static
Initial value:
=
{0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}

Referenced by cob_intr_integer_of_date(), cob_intr_locale_date(), and cob_intr_test_date_yyyymmdd().

const size_t max_date_length = 10U
static
const size_t max_datetime_length = 35U
static
const size_t max_time_decimal_places = 9U
static

Referenced by cob_valid_time_format().

const size_t max_time_length = 25U
static
cob_field* move_field
static
const int normal_days[]
static
Initial value:
=
{0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365}

Referenced by cob_intr_integer_of_date(), and date_of_integer().

const int normal_month_days[]
static
Initial value:
=
{0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}

Referenced by cob_intr_integer_of_date(), cob_intr_locale_date(), and cob_intr_test_date_yyyymmdd().