OpenCOBOL 1.1pre-rel
intrinsic.c
Go to the documentation of this file.
00001 /*
00002  * Copyright (C) 2005-2009 Roger While
00003  *
00004  * This library is free software; you can redistribute it and/or
00005  * modify it under the terms of the GNU Lesser General Public License
00006  * as published by the Free Software Foundation; either version 2.1,
00007  * or (at your option) any later version.
00008  * 
00009  * This library is distributed in the hope that it will be useful,
00010  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00011  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00012  * GNU Lesser General Public License for more details.
00013  * 
00014  * You should have received a copy of the GNU Lesser General Public
00015  * License along with this library; see the file COPYING.LIB.  If
00016  * not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor
00017  * Boston, MA 02110-1301 USA
00018  */
00019 
00020 #include "config.h"
00021 
00022 #include <stdio.h>
00023 #include <stdlib.h>
00024 #include <stdarg.h>
00025 #include <string.h>
00026 #include <ctype.h>
00027 #include <time.h>
00028 #ifdef HAVE_SYS_TIME_H
00029 #include <sys/time.h>
00030 #endif
00031 #include <errno.h>
00032 #include <math.h>
00033 #if defined(_WIN32) || defined(__CYGWIN__)
00034 #undef  HAVE_LANGINFO_CODESET
00035 #define WINDOWS_LEAN_AND_MEAN
00036 #include <windows.h>
00037 #endif
00038 #ifdef  HAVE_LANGINFO_CODESET
00039 #include <langinfo.h>
00040 #endif
00041 #ifdef  HAVE_LOCALE_H
00042 #include <locale.h>
00043 #endif
00044 #ifdef  _WIN32
00045 #include <sys/timeb.h>
00046 #endif
00047 
00048 #include "byteswap.h"
00049 #include "common.h"
00050 #include "coblocal.h"
00051 #include "move.h"
00052 #include "numeric.h"
00053 #include "fileio.h"
00054 #include "intrinsic.h"
00055 
00056 /* Stacked field level */
00057 #define DEPTH_LEVEL     8
00058 
00059 #define COB_FIELD_INIT(x,y,z)   do { \
00060         field.size = x; \
00061         field.data = y; \
00062         field.attr = z; \
00063         } while (0)
00064 
00065 static char             *locale_buff;
00066 
00067 /* Working fields */
00068 static cob_decimal      d1, d2, d3, d4, d5;
00069 
00070 /* Stack definitions for created fields */
00071 static int              curr_entry = 0;
00072 static cob_field        *curr_field = NULL;
00073 static cob_field_attr   *curr_attr = NULL;
00074 static cob_field        calc_field[DEPTH_LEVEL];
00075 static cob_field_attr   calc_attr[DEPTH_LEVEL];
00076 static size_t           calc_size[DEPTH_LEVEL];
00077         
00078 
00079 /* Constants for date/day calculations */
00080 static const int normal_days[] =        {0,31,59,90,120,151,181,212,243,273,304,334,365};
00081 static const int leap_days[] =          {0,31,60,91,121,152,182,213,244,274,305,335,366};
00082 static const int normal_month_days[] =  {0,31,28,31,30,31,30,31,31,30,31,30,31};
00083 static const int leap_month_days[] =    {0,31,29,31,30,31,30,31,31,30,31,30,31};
00084 
00085 /* Locale name to Locale ID table */
00086 #if defined(_WIN32) || defined(__CYGWIN__)
00087 
00088 struct winlocale {
00089         const char      *winlocalename;
00090         const int       winlocaleid;
00091 };
00092 
00093 static const struct winlocale   wintable[] =
00094 {
00095         { "af_ZA",              0x0436 },
00096         { "am_ET",              0x045e },
00097         { "ar_AE",              0x3801 },
00098         { "ar_BH",              0x3c01 },
00099         { "ar_DZ",              0x1401 },
00100         { "ar_EG",              0x0c01 },
00101         { "ar_IQ",              0x0801 },
00102         { "ar_JO",              0x2c01 },
00103         { "ar_KW",              0x3401 },
00104         { "ar_LB",              0x3001 },
00105         { "ar_LY",              0x1001 },
00106         { "ar_MA",              0x1801 },
00107         { "ar_OM",              0x2001 },
00108         { "ar_QA",              0x4001 },
00109         { "ar_SA",              0x0401 },
00110         { "ar_SY",              0x2801 },
00111         { "ar_TN",              0x1c01 },
00112         { "ar_YE",              0x2401 },
00113         { "arn_CL",             0x047a },
00114         { "as_IN",              0x044d },
00115         { "az_Cyrl_AZ",         0x082c },
00116         { "az_Latn_AZ",         0x042c },
00117         { "ba_RU",              0x046d },
00118         { "be_BY",              0x0423 },
00119         { "bg_BG",              0x0402 },
00120         { "bn_IN",              0x0445 },
00121         { "bo_BT",              0x0851 },
00122         { "bo_CN",              0x0451 },
00123         { "br_FR",              0x047e },
00124         { "bs_Cyrl_BA",         0x201a },
00125         { "bs_Latn_BA",         0x141a },
00126         { "ca_ES",              0x0403 },
00127         { "cs_CZ",              0x0405 },
00128         { "cy_GB",              0x0452 },
00129         { "da_DK",              0x0406 },
00130         { "de_AT",              0x0c07 },
00131         { "de_CH",              0x0807 },
00132         { "de_DE",              0x0407 },
00133         { "de_LI",              0x1407 },
00134         { "de_LU",              0x1007 },
00135         { "dsb_DE",             0x082e },
00136         { "dv_MV",              0x0465 },
00137         { "el_GR",              0x0408 },
00138         { "en_029",             0x2409 },
00139         { "en_AU",              0x0c09 },
00140         { "en_BZ",              0x2809 },
00141         { "en_CA",              0x1009 },
00142         { "en_GB",              0x0809 },
00143         { "en_IE",              0x1809 },
00144         { "en_IN",              0x4009 },
00145         { "en_JM",              0x2009 },
00146         { "en_MY",              0x4409 },
00147         { "en_NZ",              0x1409 },
00148         { "en_PH",              0x3409 },
00149         { "en_SG",              0x4809 },
00150         { "en_TT",              0x2c09 },
00151         { "en_US",              0x0409 },
00152         { "en_ZA",              0x1c09 },
00153         { "en_ZW",              0x3009 },
00154         { "es_AR",              0x2c0a },
00155         { "es_BO",              0x400a },
00156         { "es_CL",              0x340a },
00157         { "es_CO",              0x240a },
00158         { "es_CR",              0x140a },
00159         { "es_DO",              0x1c0a },
00160         { "es_EC",              0x300a },
00161         { "es_ES",              0x0c0a },
00162         { "es_GT",              0x100a },
00163         { "es_HN",              0x480a },
00164         { "es_MX",              0x080a },
00165         { "es_NI",              0x4c0a },
00166         { "es_PA",              0x180a },
00167         { "es_PE",              0x280a },
00168         { "es_PR",              0x500a },
00169         { "es_PY",              0x3c0a },
00170         { "es_SV",              0x440a },
00171         { "es_US",              0x540a },
00172         { "es_UY",              0x380a },
00173         { "es_VE",              0x200a },
00174         { "et_EE",              0x0425 },
00175         { "eu_ES",              0x042d },
00176         { "fa_IR",              0x0429 },
00177         { "fi_FI",              0x040b },
00178         { "fil_PH",             0x0464 },
00179         { "fo_FO",              0x0438 },
00180         { "fr_BE",              0x080c },
00181         { "fr_CA",              0x0c0c },
00182         { "fr_CH",              0x100c },
00183         { "fr_FR",              0x040c },
00184         { "fr_LU",              0x140c },
00185         { "fr_MC",              0x180c },
00186         { "fy_NL",              0x0462 },
00187         { "ga_IE",              0x083c },
00188         { "gbz_AF",             0x048c },
00189         { "gl_ES",              0x0456 },
00190         { "gsw_FR",             0x0484 },
00191         { "gu_IN",              0x0447 },
00192         { "ha_Latn_NG",         0x0468 },
00193         { "he_IL",              0x040d },
00194         { "hi_IN",              0x0439 },
00195         { "hr_BA",              0x101a },
00196         { "hr_HR",              0x041a },
00197         { "hu_HU",              0x040e },
00198         { "hy_AM",              0x042b },
00199         { "id_ID",              0x0421 },
00200         { "ig_NG",              0x0470 },
00201         { "ii_CN",              0x0478 },
00202         { "is_IS",              0x040f },
00203         { "it_CH",              0x0810 },
00204         { "it_IT",              0x0410 },
00205         { "iu_Cans_CA",         0x045d },
00206         { "iu_Latn_CA",         0x085d },
00207         { "ja_JP",              0x0411 },
00208         { "ka_GE",              0x0437 },
00209         { "kh_KH",              0x0453 },
00210         { "kk_KZ",              0x043f },
00211         { "kl_GL",              0x046f },
00212         { "kn_IN",              0x044b },
00213         { "ko_KR",              0x0412 },
00214         { "kok_IN",             0x0457 },
00215         { "ky_KG",              0x0440 },
00216         { "lb_LU",              0x046e },
00217         { "lo_LA",              0x0454 },
00218         { "lt_LT",              0x0427 },
00219         { "lv_LV",              0x0426 },
00220         { "mi_NZ",              0x0481 },
00221         { "mk_MK",              0x042f },
00222         { "ml_IN",              0x044c },
00223         { "mn_Cyrl_MN",         0x0450 },
00224         { "mn_Mong_CN",         0x0850 },
00225         { "moh_CA",             0x047c },
00226         { "mr_IN",              0x044e },
00227         { "ms_BN",              0x083e },
00228         { "ms_MY",              0x043e },
00229         { "mt_MT",              0x043a },
00230         { "nb_NO",              0x0414 },
00231         { "ne_NP",              0x0461 },
00232         { "nl_BE",              0x0813 },
00233         { "nl_NL",              0x0413 },
00234         { "nn_NO",              0x0814 },
00235         { "ns_ZA",              0x046c },
00236         { "oc_FR",              0x0482 },
00237         { "or_IN",              0x0448 },
00238         { "pa_IN",              0x0446 },
00239         { "pl_PL",              0x0415 },
00240         { "ps_AF",              0x0463 },
00241         { "pt_BR",              0x0416 },
00242         { "pt_PT",              0x0816 },
00243         { "qut_GT",             0x0486 },
00244         { "quz_BO",             0x046b },
00245         { "quz_EC",             0x086b },
00246         { "quz_PE",             0x0c6b },
00247         { "rm_CH",              0x0417 },
00248         { "ro_RO",              0x0418 },
00249         { "ru_RU",              0x0419 },
00250         { "rw_RW",              0x0487 },
00251         { "sa_IN",              0x044f },
00252         { "sah_RU",             0x0485 },
00253         { "se_FI",              0x0c3b },
00254         { "se_NO",              0x043b },
00255         { "se_SE",              0x083b },
00256         { "si_LK",              0x045b },
00257         { "sk_SK",              0x041b },
00258         { "sl_SI",              0x0424 },
00259         { "sma_NO",             0x183b },
00260         { "sma_SE",             0x1c3b },
00261         { "smj_NO",             0x103b },
00262         { "smj_SE",             0x143b },
00263         { "smn_FI",             0x243b },
00264         { "sms_FI",             0x203b },
00265         { "sq_AL",              0x041c },
00266         { "sr_Cyrl_BA",         0x1c1a },
00267         { "sr_Cyrl_CS",         0x0c1a },
00268         { "sr_Latn_BA",         0x181a },
00269         { "sr_Latn_CS",         0x081a },
00270         { "sv_FI",              0x081d },
00271         { "sv_SE",              0x041d },
00272         { "sw_KE",              0x0441 },
00273         { "syr_SY",             0x045a },
00274         { "ta_IN",              0x0449 },
00275         { "te_IN",              0x044a },
00276         { "tg_Cyrl_TJ",         0x0428 },
00277         { "th_TH",              0x041e },
00278         { "tk_TM",              0x0442 },
00279         { "tmz_Latn_DZ",        0x085f },
00280         { "tn_ZA",              0x0432 },
00281         { "tr_IN",              0x0820 },
00282         { "tr_TR",              0x041f },
00283         { "tt_RU",              0x0444 },
00284         { "ug_CN",              0x0480 },
00285         { "uk_UA",              0x0422 },
00286         { "ur_PK",              0x0420 },
00287         { "uz_Cyrl_UZ",         0x0843 },
00288         { "uz_Latn_UZ",         0x0443 },
00289         { "vi_VN",              0x042a },
00290         { "wen_DE",             0x042e },
00291         { "wo_SN",              0x0488 },
00292         { "xh_ZA",              0x0434 },
00293         { "yo_NG",              0x046a },
00294         { "zh_CN",              0x0804 },
00295         { "zh_HK",              0x0c04 },
00296         { "zh_MO",              0x1404 },
00297         { "zh_SG",              0x1004 },
00298         { "zh_TW",              0x0404 },
00299         { "zu_ZA",              0x0435 }
00300 };
00301 
00302 #define WINLOCSIZE      sizeof(wintable) / sizeof(struct winlocale)
00303 
00304 #endif
00305 
00306 
00307 /* Local functions */
00308 
00309 static void COB_NOINLINE
00310 make_double_entry (void)
00311 {
00312         unsigned char           *s;
00313 
00314         curr_field = &calc_field[curr_entry];
00315         curr_attr = &calc_attr[curr_entry];
00316         if (calc_size[curr_entry] < sizeof (double)) {
00317                 calc_size[curr_entry] = sizeof (double) + 1;
00318                 if (curr_field->data) {
00319                         free (curr_field->data);
00320                 }
00321                 s = cob_malloc (sizeof (double) + 1);
00322         } else {
00323                 s = curr_field->data;
00324                 memset (s, 0, sizeof (double));
00325         }
00326 
00327         curr_attr->type = COB_TYPE_NUMERIC_DOUBLE;
00328         curr_attr->digits = 18;
00329         curr_attr->scale = 9;
00330         curr_attr->flags = COB_FLAG_HAVE_SIGN;
00331         curr_attr->pic = NULL;
00332 
00333         curr_field->size = sizeof (double);
00334         curr_field->data = s;
00335         curr_field->attr = curr_attr;
00336                 
00337         if (++curr_entry >= DEPTH_LEVEL) {
00338                 curr_entry = 0;
00339         }
00340 }
00341 
00342 static void COB_NOINLINE
00343 make_field_entry (cob_field *f)
00344 {
00345         unsigned char           *s;
00346 
00347         curr_field = &calc_field[curr_entry];
00348         curr_attr = &calc_attr[curr_entry];
00349         if (f->size > calc_size[curr_entry]) {
00350                 calc_size[curr_entry] = f->size + 1;
00351                 if (curr_field->data) {
00352                         free (curr_field->data);
00353                 }
00354                 s = cob_malloc (f->size + 1);
00355         } else {
00356                 s = curr_field->data;
00357                 memset (s, 0, f->size);
00358         }
00359         *curr_field = *f;
00360         *curr_attr = *(f->attr);
00361         curr_field->data = s;
00362         curr_field->attr = curr_attr;
00363                 
00364         if (++curr_entry >= DEPTH_LEVEL) {
00365                 curr_entry = 0;
00366         }
00367 }
00368 
00369 static int
00370 leap_year (const int year)
00371 {
00372         return ((year % 4 == 0 && year % 100 != 0) || (year % 400 == 0)) ? 1 : 0;
00373 }
00374 
00375 /* Leave in
00376 static void
00377 intr_set_double (cob_decimal *d, double v)
00378 {
00379         mpz_set_d (d->value, v * 1.0e9);
00380         d->scale = 9;
00381 }
00382 */
00383 
00384 static double COB_NOINLINE
00385 intr_get_double (cob_decimal *d)
00386 {
00387         double  v;
00388         int     n;
00389 
00390         v = mpz_get_d (d->value);
00391         n = d->scale;
00392         for (; n > 0; --n) v /= 10;
00393         for (; n < 0; ++n) v *= 10;
00394         return v;
00395 }
00396 
00397 static int
00398 comp_field (const void *m1, const void *m2)
00399 {
00400         cob_field       *f1;
00401         cob_field       *f2;
00402 
00403         f1 = *(cob_field **) m1;
00404         f2 = *(cob_field **) m2;
00405         return cob_cmp (f1, f2);
00406 }
00407 
00408 static void COB_NOINLINE
00409 calc_ref_mod (cob_field *f, const int offset, const int length)
00410 {
00411         size_t          calcoff;
00412         size_t          size;
00413 
00414         if ((size_t)offset <= f->size) {
00415                 calcoff = (size_t)offset - 1;
00416                 size = f->size - calcoff;
00417                 if (length > 0 && (size_t)length < size) {
00418                         size = (size_t)length;
00419                 }
00420                 f->size = size;
00421                 if (calcoff > 0) {
00422                         memmove (f->data, f->data + calcoff, size);
00423                 }
00424         }
00425 }
00426 
00427 /* Global functions */
00428 
00429 /* Numeric expressions */
00430 
00431 cob_field *
00432 cob_intr_binop (cob_field *f1, int op, cob_field *f2)
00433 {
00434 /* RXW
00435         size_t          bitnum;
00436         size_t          sign;
00437         size_t          attrsign;
00438         cob_field_attr  attr;
00439         cob_field       field;
00440 */
00441 
00442         cob_decimal_set_field (&d1, f1);
00443         cob_decimal_set_field (&d2, f2);
00444         switch (op) {
00445         case '+':
00446                 cob_decimal_add (&d1, &d2);
00447                 break;
00448         case '-':
00449                 cob_decimal_sub (&d1, &d2);
00450                 break;
00451         case '*':
00452                 cob_decimal_mul (&d1, &d2);
00453                 break;
00454         case '/':
00455                 cob_decimal_div (&d1, &d2);
00456                 break;
00457         case '^':
00458                 cob_decimal_pow (&d1, &d2);
00459                 break;
00460         default:
00461                 break;
00462         }
00463 
00464 /* RXW
00465         if (mpz_sgn (d1.value) < 0) {
00466                 attrsign = COB_FLAG_HAVE_SIGN;
00467                 sign = 1;
00468         } else {
00469                 attrsign = 0;
00470                 sign = 0;
00471         }
00472         bitnum = mpz_sizeinbase (d1.value, 2);
00473         if (bitnum < 33 - sign) {
00474                 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, attrsign, NULL);
00475                 COB_FIELD_INIT (4, NULL, &attr);
00476                 attr.scale = d1.scale;
00477                 make_field_entry (&field);
00478         } else if (bitnum < 65 - sign) {
00479                 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, attrsign, NULL);
00480                 COB_FIELD_INIT (8, NULL, &attr);
00481                 attr.scale = d1.scale;
00482                 make_field_entry (&field);
00483         } else {
00484 */
00485                 make_double_entry ();
00486 /* RXW
00487         }
00488 */
00489         cob_decimal_get_field (&d1, curr_field, 0);
00490         
00491         return curr_field;
00492 }
00493 
00494 /* Intrinsics */
00495 
00496 cob_field *
00497 cob_intr_length (cob_field *srcfield)
00498 {
00499         cob_field_attr  attr;
00500         cob_field       field;
00501 
00502         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
00503         COB_FIELD_INIT (4, NULL, &attr);
00504         make_field_entry (&field);
00505 
00506         cob_set_int (curr_field, (int)srcfield->size);
00507         return curr_field;
00508 }
00509 
00510 cob_field *
00511 cob_intr_integer (cob_field *srcfield)
00512 {
00513         int             i, scale;
00514         cob_field_attr  attr;
00515         cob_field       field;
00516 
00517         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
00518         COB_FIELD_INIT (8, NULL, &attr);
00519         make_field_entry (&field);
00520 
00521         cob_decimal_set_field (&d1, srcfield);
00522         if (mpz_sgn (d1.value) >= 0) {
00523                 cob_decimal_get_field (&d1, curr_field, 0);
00524                 return curr_field;
00525         }
00526         scale = 1;
00527         for (i = 0; i < d1.scale; ++i) {
00528                 scale *= 10;
00529         }
00530         if (mpz_fdiv_ui (d1.value, (unsigned int)scale)) {
00531                 mpz_sub_ui (d1.value, d1.value, (unsigned int)scale);
00532         }
00533         cob_decimal_get_field (&d1, curr_field, 0);
00534         return curr_field;
00535 }
00536 
00537 cob_field *
00538 cob_intr_integer_part (cob_field *srcfield)
00539 {
00540         cob_field_attr  attr;
00541         cob_field       field;
00542 
00543         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
00544         COB_FIELD_INIT (8, NULL, &attr);
00545         make_field_entry (&field);
00546 
00547         cob_move (srcfield, curr_field);
00548         return curr_field;
00549 }
00550 
00551 cob_field *
00552 cob_intr_fraction_part (cob_field *srcfield)
00553 {
00554         cob_field_attr  attr;
00555         cob_field       field;
00556 
00557         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 18, COB_FLAG_HAVE_SIGN, NULL);
00558         COB_FIELD_INIT (8, NULL, &attr);
00559         make_field_entry (&field);
00560 
00561         cob_move (srcfield, curr_field);
00562         return curr_field;
00563 }
00564 
00565 cob_field *
00566 cob_intr_sign (cob_field *srcfield)
00567 {
00568         int             n;
00569         cob_field_attr  attr;
00570         cob_field       field;
00571 
00572         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, COB_FLAG_HAVE_SIGN, NULL);
00573         COB_FIELD_INIT (4, NULL, &attr);
00574         make_field_entry (&field);
00575 
00576         cob_set_int (curr_field, 0);
00577         n = cob_cmp (srcfield, curr_field);
00578         if (n < 0) {
00579                 cob_set_int (curr_field, -1);
00580         } else if (n > 0) {
00581                 cob_set_int (curr_field, 1);
00582         }
00583 
00584         return curr_field;
00585 }
00586 
00587 cob_field *
00588 cob_intr_upper_case (const int offset, const int length, cob_field *srcfield)
00589 {
00590         size_t          i, size;
00591 
00592         make_field_entry (srcfield);
00593 
00594         size = srcfield->size;
00595         for (i = 0; i < size; ++i) {
00596                 curr_field->data[i] = toupper (srcfield->data[i]);
00597         }
00598         if (unlikely(offset > 0)) {
00599                 calc_ref_mod (curr_field, offset, length);
00600         }
00601         return curr_field;
00602 }
00603 
00604 cob_field *
00605 cob_intr_lower_case (const int offset, const int length, cob_field *srcfield)
00606 {
00607         size_t          i, size;
00608 
00609         make_field_entry (srcfield);
00610 
00611         size = srcfield->size;
00612         for (i = 0; i < size; ++i) {
00613                 curr_field->data[i] = tolower (srcfield->data[i]);
00614         }
00615         if (unlikely(offset > 0)) {
00616                 calc_ref_mod (curr_field, offset, length);
00617         }
00618         return curr_field;
00619 }
00620 
00621 cob_field *
00622 cob_intr_reverse (const int offset, const int length, cob_field *srcfield)
00623 {
00624         size_t          i, size;
00625 
00626         make_field_entry (srcfield);
00627 
00628         size = srcfield->size;
00629         for (i = 0; i < size; ++i) {
00630                 curr_field->data[i] = srcfield->data[srcfield->size - i - 1];
00631         }
00632         if (unlikely(offset > 0)) {
00633                 calc_ref_mod (curr_field, offset, length);
00634         }
00635         return curr_field;
00636 }
00637 
00638 cob_field *
00639 cob_intr_concatenate (const int offset, const int length, const int params, ...)
00640 {
00641         cob_field       **f;
00642         unsigned char   *p;
00643         size_t          calcsize;
00644         int             i;
00645         cob_field_attr  attr;
00646         cob_field       field;
00647         va_list         args;
00648 
00649         f = cob_malloc (params * sizeof (cob_field *));
00650 
00651         va_start (args, params);
00652 
00653         /* Extract args / calculate size */
00654         calcsize = 0;
00655         for (i = 0; i < params; ++i) {
00656                 f[i] = va_arg (args, cob_field *);
00657                 calcsize += f[i]->size;
00658         }
00659 
00660         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
00661         COB_FIELD_INIT (calcsize, NULL, &attr);
00662         make_field_entry (&field);
00663 
00664         p = curr_field->data;
00665         for (i = 0; i < params; ++i) {
00666                 memcpy (p, f[i]->data, f[i]->size);
00667                 p += f[i]->size;
00668         }
00669 
00670         if (unlikely(offset > 0)) {
00671                 calc_ref_mod (curr_field, offset, length);
00672         }
00673         free (f);
00674         return curr_field;
00675 }
00676 
00677 cob_field *
00678 cob_intr_substitute (const int offset, const int length, const int params, ...)
00679 {
00680         cob_field       *var;
00681         cob_field       **f1;
00682         cob_field       **f2;
00683         unsigned char   *p1;
00684         unsigned char   *p2;
00685         size_t          varsize;
00686         size_t          calcsize;
00687         size_t          n;
00688         size_t          found;
00689         int             numreps;
00690         int             i;
00691         cob_field_attr  attr;
00692         cob_field       field;
00693         va_list         args;
00694 
00695         numreps = params / 2;
00696         f1 = cob_malloc (numreps * sizeof (cob_field *));
00697         f2 = cob_malloc (numreps * sizeof (cob_field *));
00698 
00699         va_start (args, params);
00700 
00701         var = va_arg (args, cob_field *);
00702         varsize = var->size;
00703 
00704         /* Extract args */
00705         for (i = 0; i < params - 1; ++i) {
00706                 if ((i % 2) == 0) {
00707                         f1[i / 2] = va_arg (args, cob_field *);
00708                 } else {
00709                         f2[i / 2] = va_arg (args, cob_field *);
00710                 }
00711         }
00712 
00713         /* Calculate required size */
00714         calcsize = 0;
00715         found = 0;
00716         p1 = var->data;
00717         for (n = 0; n < varsize; ) {
00718                 for (i = 0; i < numreps; ++i) {
00719                         if (n + f1[i]->size <= varsize) {
00720                                 if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
00721                                         p1 += f1[i]->size;
00722                                         n += f1[i]->size;
00723                                         calcsize += f2[i]->size;
00724                                         found = 1;
00725                                         break;
00726                                 }
00727                         }
00728                 }
00729                 if (found) {
00730                         found = 0;
00731                         continue;
00732                 }
00733                 ++n;
00734                 ++p1;
00735                 ++calcsize;
00736         }
00737 
00738         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
00739         COB_FIELD_INIT (0, NULL, &attr);
00740         field.size = calcsize;
00741         make_field_entry (&field);
00742 
00743         found = 0;
00744         p1 = var->data;
00745         p2 = curr_field->data;
00746         for (n = 0; n < varsize; ) {
00747                 for (i = 0; i < numreps; ++i) {
00748                         if (n + f1[i]->size <= varsize) {
00749                                 if (!memcmp (p1, f1[i]->data, f1[i]->size)) {
00750                                         memcpy (p2, f2[i]->data, f2[i]->size);
00751                                         p1 += f1[i]->size;
00752                                         p2 += f2[i]->size;
00753                                         n += f1[i]->size;
00754                                         found = 1;
00755                                         break;
00756                                 }
00757                         }
00758                 }
00759                 if (found) {
00760                         found = 0;
00761                         continue;
00762                 }
00763                 ++n;
00764                 *p2++ = *p1++;
00765         }
00766         if (unlikely(offset > 0)) {
00767                 calc_ref_mod (curr_field, offset, length);
00768         }
00769         free (f1);
00770         free (f2);
00771         return curr_field;
00772 }
00773 
00774 cob_field *
00775 cob_intr_substitute_case (const int offset, const int length, const int params, ...)
00776 {
00777         cob_field       *var;
00778         cob_field       **f1;
00779         cob_field       **f2;
00780         unsigned char   *p1;
00781         unsigned char   *p2;
00782         size_t          varsize;
00783         size_t          calcsize;
00784         size_t          n;
00785         size_t          found;
00786         int             numreps;
00787         int             i;
00788         cob_field_attr  attr;
00789         cob_field       field;
00790         va_list         args;
00791 
00792         numreps = params / 2;
00793         f1 = cob_malloc (numreps * sizeof (cob_field *));
00794         f2 = cob_malloc (numreps * sizeof (cob_field *));
00795 
00796         va_start (args, params);
00797 
00798         var = va_arg (args, cob_field *);
00799         varsize = var->size;
00800 
00801         /* Extract args */
00802         for (i = 0; i < params - 1; ++i) {
00803                 if ((i % 2) == 0) {
00804                         f1[i / 2] = va_arg (args, cob_field *);
00805                 } else {
00806                         f2[i / 2] = va_arg (args, cob_field *);
00807                 }
00808         }
00809 
00810         /* Calculate required size */
00811         calcsize = 0;
00812         found = 0;
00813         p1 = var->data;
00814         for (n = 0; n < varsize; ) {
00815                 for (i = 0; i < numreps; ++i) {
00816                         if (n + f1[i]->size <= varsize) {
00817                                 if (!strncasecmp ((const char *)p1,
00818                                                   (const char *)(f1[i]->data),
00819                                                   f1[i]->size)) {
00820                                         p1 += f1[i]->size;
00821                                         n += f1[i]->size;
00822                                         calcsize += f2[i]->size;
00823                                         found = 1;
00824                                         break;
00825                                 }
00826                         }
00827                 }
00828                 if (found) {
00829                         found = 0;
00830                         continue;
00831                 }
00832                 ++n;
00833                 ++p1;
00834                 ++calcsize;
00835         }
00836 
00837         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
00838         COB_FIELD_INIT (0, NULL, &attr);
00839         field.size = calcsize;
00840         make_field_entry (&field);
00841 
00842         found = 0;
00843         p1 = var->data;
00844         p2 = curr_field->data;
00845         for (n = 0; n < varsize; ) {
00846                 for (i = 0; i < numreps; ++i) {
00847                         if (n + f1[i]->size <= varsize) {
00848                                 if (!strncasecmp ((const char *)p1,
00849                                                   (const char *)(f1[i]->data),
00850                                                   f1[i]->size)) {
00851                                         memcpy (p2, f2[i]->data, f2[i]->size);
00852                                         p1 += f1[i]->size;
00853                                         p2 += f2[i]->size;
00854                                         n += f1[i]->size;
00855                                         found = 1;
00856                                         break;
00857                                 }
00858                         }
00859                 }
00860                 if (found) {
00861                         found = 0;
00862                         continue;
00863                 }
00864                 ++n;
00865                 *p2++ = *p1++;
00866         }
00867         if (unlikely(offset > 0)) {
00868                 calc_ref_mod (curr_field, offset, length);
00869         }
00870         free (f1);
00871         free (f2);
00872         return curr_field;
00873 }
00874 
00875 cob_field *
00876 cob_intr_trim (const int offset, const int length,
00877                 cob_field *srcfield, const int direction)
00878 {
00879         unsigned char   *begin;
00880         unsigned char   *end;
00881         size_t          i;
00882         size_t          size = 0;
00883 
00884         make_field_entry (srcfield);
00885 
00886         for (i = 0; i < srcfield->size; ++i) {
00887                 if (srcfield->data[i] != ' ') {
00888                         break;
00889                 }
00890         }
00891         if (i == srcfield->size) {
00892                 curr_field->size = 1;
00893                 curr_field->data[0] = ' ';
00894                 return curr_field;
00895         }
00896         begin = srcfield->data;
00897         if (direction != 2) {
00898                 for (; *begin == ' '; ++begin) ;
00899         }
00900         end = srcfield->data + srcfield->size - 1;
00901         if (direction != 1) {
00902                 for (; *end == ' '; end--) ;
00903         }
00904         for (i = 0; begin <= end; ++begin, ++i) {
00905                 curr_field->data[i] = *begin;
00906                 ++size;
00907         }
00908         curr_field->size = size;
00909         if (unlikely(offset > 0)) {
00910                 calc_ref_mod (curr_field, offset, length);
00911         }
00912         return curr_field;
00913 }
00914 
00915 cob_field *
00916 cob_intr_exception_file (void)
00917 {
00918         size_t          flen;
00919         cob_field_attr  attr;
00920         cob_field       field;
00921 
00922         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
00923         COB_FIELD_INIT (0, NULL, &attr);
00924         if (cob_exception_code == 0 || !cob_error_file ||
00925             (cob_exception_code & 0x0500) != 0x0500) {
00926                 field.size = 2;
00927                 make_field_entry (&field);
00928                 memcpy (curr_field->data, "00", 2);
00929         } else {
00930                 flen = strlen (cob_error_file->select_name);
00931                 field.size = flen + 2;
00932                 make_field_entry (&field);
00933                 memcpy (curr_field->data, cob_error_file->file_status, 2);
00934                 memcpy (&(curr_field->data[2]), cob_error_file->select_name, flen);
00935         }
00936         return curr_field;
00937 }
00938 
00939 cob_field *
00940 cob_intr_exception_location (void)
00941 {
00942         cob_field_attr  attr;
00943         cob_field       field;
00944 
00945         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
00946         COB_FIELD_INIT (0, NULL, &attr);
00947         if (!cob_got_exception || !cob_orig_program_id) {
00948                 field.size = 1;
00949                 make_field_entry (&field);
00950                 *(curr_field->data) = ' ';
00951                 return curr_field;
00952         }
00953         memset (locale_buff, 0, COB_SMALL_BUFF);
00954         if (cob_orig_section && cob_orig_paragraph) {
00955                 snprintf (locale_buff, COB_SMALL_MAX, "%s; %s OF %s; %d",
00956                           cob_orig_program_id, cob_orig_paragraph,
00957                           cob_orig_section, cob_orig_line);
00958         } else if (cob_orig_section) {
00959                 snprintf (locale_buff, COB_SMALL_MAX, "%s; %s; %d",
00960                           cob_orig_program_id, cob_orig_section, cob_orig_line);
00961         } else if (cob_orig_paragraph) {
00962                 snprintf (locale_buff, COB_SMALL_MAX, "%s; %s; %d",
00963                           cob_orig_program_id, cob_orig_paragraph, cob_orig_line);
00964         } else {
00965                 snprintf (locale_buff, COB_SMALL_MAX, "%s; ; %d",
00966                           cob_orig_program_id, cob_orig_line);
00967         }
00968         field.size = strlen (locale_buff);
00969         make_field_entry (&field);
00970         memcpy (curr_field->data, locale_buff, field.size);
00971         return curr_field;
00972 }
00973 
00974 cob_field *
00975 cob_intr_exception_status (void)
00976 {
00977         const char      *except_name;
00978         cob_field_attr  attr;
00979         cob_field       field;
00980 
00981         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
00982         COB_FIELD_INIT (31, NULL, &attr);
00983         make_field_entry (&field);
00984 
00985         memset (curr_field->data, ' ', 31);
00986         if (cob_exception_code) {
00987                 except_name = cob_get_exception_name (cob_exception_code);
00988                 if (except_name == NULL) {
00989                         except_name = "EXCEPTION-OBJECT";
00990                 }
00991                 memcpy (curr_field->data, except_name, strlen (except_name));
00992         }
00993         return curr_field;
00994 }
00995 
00996 cob_field *
00997 cob_intr_exception_statement (void)
00998 {
00999         size_t          flen;
01000         cob_field_attr  attr;
01001         cob_field       field;
01002 
01003         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
01004         COB_FIELD_INIT (31, NULL, &attr);
01005         make_field_entry (&field);
01006 
01007         memset (curr_field->data, ' ', 31);
01008         if (cob_exception_code && cob_orig_statement) {
01009                 flen = strlen (cob_orig_statement);
01010                 if (flen > 31) {
01011                         memcpy (curr_field->data, cob_orig_statement, 31);
01012                 } else {
01013                         memcpy (curr_field->data, cob_orig_statement, flen);
01014                 }
01015         }
01016         return curr_field;
01017 }
01018 
01019 cob_field *
01020 cob_intr_when_compiled (const int offset, const int length, cob_field *f)
01021 {
01022         make_field_entry (f);
01023 
01024         memcpy (curr_field->data, f->data, f->size);
01025         if (unlikely(offset > 0)) {
01026                 calc_ref_mod (curr_field, offset, length);
01027         }
01028         return curr_field;
01029 }
01030 
01031 cob_field *
01032 cob_intr_current_date (const int offset, const int length)
01033 {
01034 #if     defined(_WIN32) && !defined(__CYGWIN__)
01035         long            contz;
01036         struct tm       *tmptr;
01037         struct _timeb   tmb;
01038         cob_field_attr  attr;
01039         cob_field       field;
01040 #else
01041 #if !defined(__linux__) && !defined(__CYGWIN__) && !defined(COB_STRFTIME) && defined(HAVE_TIMEZONE)
01042         struct tm       *tmptr;
01043         long            contz;
01044 #endif
01045         time_t          curtime;
01046         cob_field_attr  attr;
01047         cob_field       field;
01048 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
01049         struct timeval  tmv;
01050         char            buff2[8];
01051 #endif
01052 #endif  /* _WIN32 */
01053         char            buff[24];
01054 
01055         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
01056         COB_FIELD_INIT (21, NULL, &attr);
01057         make_field_entry (&field);
01058         memset (buff, 0, sizeof(buff));
01059 
01060 #if     defined(_WIN32) && !defined(__CYGWIN__)
01061         _ftime (&tmb);
01062         tmptr = localtime (&(tmb.time));
01063         if (tmb.timezone <= 0) {
01064                 contz = -tmb.timezone;
01065                 snprintf (buff, 23,
01066                         "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d+%2.2ld%2.2ld",
01067                         tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
01068                         tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
01069                         tmb.millitm / 100, contz / 60, contz % 60);
01070         } else {
01071                 contz = tmb.timezone;
01072                 snprintf (buff, 23,
01073                         "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d-%2.2ld%2.2ld",
01074                         tmptr->tm_year + 1900, tmptr->tm_mon + 1, tmptr->tm_mday,
01075                         tmptr->tm_hour, tmptr->tm_min, tmptr->tm_sec,
01076                         tmb.millitm / 100, contz / 60, contz % 60);
01077         }
01078 #else
01079 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
01080         gettimeofday (&tmv, NULL);
01081         curtime = tmv.tv_sec;
01082 #else
01083         curtime = time (NULL);
01084 #endif
01085 
01086 #if defined(__linux__) || defined(__CYGWIN__) || defined(COB_STRFTIME)
01087         strftime (buff, 22, "%Y%m%d%H%M%S00%z", localtime (&curtime));
01088 #elif defined(HAVE_TIMEZONE)
01089         tmptr = localtime (&curtime);
01090         strftime (buff, 17, "%Y%m%d%H%M%S00", tmptr);
01091         /* RXW - Hack for DST - Need something better */
01092         if (tmptr->tm_isdst > 0) {
01093                 timezone -= 3600;
01094         }
01095         if (timezone <= 0) {
01096                 contz = -timezone;
01097                 buff[16] = '+';
01098         } else {
01099                 contz = timezone;
01100                 buff[16] = '-';
01101         }
01102         sprintf(&buff[17], "%2.2ld%2.2ld", contz / 3600, (contz % 3600) / 60);
01103 #else
01104         strftime (buff, 22, "%Y%m%d%H%M%S0000000", localtime (&curtime));
01105 #endif
01106 
01107 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
01108         snprintf(buff2, 7, "%2.2ld", tmv.tv_usec / 10000);
01109         memcpy (&buff[14], buff2, 2);
01110 #endif
01111 #endif  /* _WIN32 */
01112 
01113         memcpy (curr_field->data, buff, 21);
01114         if (unlikely(offset > 0)) {
01115                 calc_ref_mod (curr_field, offset, length);
01116         }
01117         return curr_field;
01118 }
01119 
01120 cob_field *
01121 cob_intr_char (cob_field *srcfield)
01122 {
01123         int             i;
01124         cob_field_attr  attr;
01125         cob_field       field;
01126 
01127         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
01128         COB_FIELD_INIT (1, NULL, &attr);
01129         make_field_entry (&field);
01130 
01131         i = cob_get_int (srcfield);
01132         if (i < 1 || i > 256) {
01133                 *curr_field->data = 0;
01134         } else {
01135                 *curr_field->data = i - 1;
01136         }
01137         return curr_field;
01138 }
01139 
01140 cob_field *
01141 cob_intr_ord (cob_field *srcfield)
01142 {
01143         cob_field_attr  attr;
01144         cob_field       field;
01145 
01146         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
01147         COB_FIELD_INIT (4, NULL, &attr);
01148         make_field_entry (&field);
01149         
01150         cob_set_int (curr_field, (int)(*srcfield->data + 1));
01151         return curr_field;
01152 }
01153 
01154 cob_field *
01155 cob_intr_stored_char_length (cob_field *srcfield)
01156 {
01157         unsigned char   *p;
01158         int             count;
01159         cob_field_attr  attr;
01160         cob_field       field;
01161 
01162         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
01163         COB_FIELD_INIT (4, NULL, &attr);
01164         make_field_entry (&field);
01165         
01166         count = srcfield->size;
01167         p = srcfield->data + srcfield->size - 1;
01168         for (; count > 0; count--, p--) {
01169                 if (*p != ' ') {
01170                         break;
01171                 }
01172         }
01173         cob_set_int (curr_field, count);
01174         return curr_field;
01175 }
01176 
01177 cob_field *
01178 cob_intr_combined_datetime (cob_field *srcdays, cob_field *srctime)
01179 {
01180         int             srdays;
01181         int             srtime;
01182         cob_field_attr  attr;
01183         cob_field       field;
01184         char            buff[16];
01185 
01186         COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 12, 5, 0, NULL);
01187         COB_FIELD_INIT (12, NULL, &attr);
01188         make_field_entry (&field);
01189 
01190         cob_exception_code = 0;
01191         srdays = cob_get_int (srcdays);
01192         if (srdays < 1 || srdays > 3067671) {
01193                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01194                 memset (curr_field->data, '0', 12);
01195                 return curr_field;
01196         }
01197         srtime = cob_get_int (srctime);
01198         if (srtime < 1 || srtime > 86400) {
01199                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01200                 memset (curr_field->data, '0', 12);
01201                 return curr_field;
01202         }
01203         snprintf (buff, 15, "%7.7d%5.5d", srdays, srtime);
01204         memcpy (curr_field->data, buff, 12);
01205         return curr_field;
01206 }
01207 
01208 cob_field *
01209 cob_intr_date_of_integer (cob_field *srcdays)
01210 {
01211         int             i;
01212         int             days;
01213         int             baseyear = 1601;
01214         int             leapyear = 365;
01215         cob_field_attr  attr;
01216         cob_field       field;
01217         char            buff[16];
01218 
01219         COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
01220         COB_FIELD_INIT (8, NULL, &attr);
01221         make_field_entry (&field);
01222 
01223         cob_exception_code = 0;
01224         /* Base 1601-01-01 */
01225         days = cob_get_int (srcdays);
01226         if (days < 1 || days > 3067671) {
01227                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01228                 memset (curr_field->data, '0', 8);
01229                 return curr_field;
01230         }
01231         while (days > leapyear) {
01232                 days -= leapyear;
01233                 ++baseyear;
01234                 if (leap_year (baseyear)) {
01235                         leapyear = 366;
01236                 } else {
01237                         leapyear = 365;
01238                 }
01239         }
01240         for (i = 0; i < 13; ++i) {
01241                 if (leap_year (baseyear)) {
01242                         if (days <= leap_days[i]) {
01243                                 days -= leap_days[i-1];
01244                                 break;
01245                         }
01246                 } else {
01247                         if (days <= normal_days[i]) {
01248                                 days -= normal_days[i-1];
01249                                 break;
01250                         }
01251                 }
01252         }
01253         snprintf (buff, 15, "%4.4d%2.2d%2.2d", baseyear, i, days);
01254         memcpy (curr_field->data, buff, 8);
01255         return curr_field;
01256 }
01257 
01258 cob_field *
01259 cob_intr_day_of_integer (cob_field *srcdays)
01260 {
01261         int             days;
01262         int             baseyear = 1601;
01263         int             leapyear = 365;
01264         cob_field_attr  attr;
01265         cob_field       field;
01266         char            buff[16];
01267 
01268         COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 7, 0, 0, NULL);
01269         COB_FIELD_INIT (7, NULL, &attr);
01270         make_field_entry (&field);
01271 
01272         cob_exception_code = 0;
01273         /* Base 1601-01-01 */
01274         days = cob_get_int (srcdays);
01275         if (days < 1 || days > 3067671) {
01276                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01277                 memset (curr_field->data, '0', 7);
01278                 return curr_field;
01279         }
01280         while (days > leapyear) {
01281                 days -= leapyear;
01282                 ++baseyear;
01283                 if (leap_year (baseyear)) {
01284                         leapyear = 366;
01285                 } else {
01286                         leapyear = 365;
01287                 }
01288         }
01289         snprintf (buff, 15, "%4.4d%3.3d", baseyear, days);
01290         memcpy (curr_field->data, buff, 7);
01291         return curr_field;
01292 }
01293 
01294 cob_field *
01295 cob_intr_integer_of_date (cob_field *srcfield)
01296 {
01297         int             indate;
01298         int             days;
01299         int             totaldays;
01300         int             month;
01301         int             year;
01302         int             baseyear = 1601;
01303         cob_field_attr  attr;
01304         cob_field       field;
01305 
01306         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
01307         COB_FIELD_INIT (4, NULL, &attr);
01308         make_field_entry (&field);
01309 
01310         cob_exception_code = 0;
01311         /* Base 1601-01-01 */
01312         indate = cob_get_int (srcfield);
01313         year = indate / 10000;
01314         if (year < 1601 || year > 9999) {
01315                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01316                 cob_set_int (curr_field, 0);
01317                 return curr_field;
01318         }
01319         indate %= 10000;
01320         month = indate / 100;
01321         if (month < 1 || month > 12) {
01322                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01323                 cob_set_int (curr_field, 0);
01324                 return curr_field;
01325         }
01326         days = indate % 100;
01327         if (days < 1 || days > 31) {
01328                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01329                 cob_set_int (curr_field, 0);
01330                 return curr_field;
01331         }
01332         if (leap_year (year)) {
01333                 if (days > leap_month_days[month]) {
01334                         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01335                         cob_set_int (curr_field, 0);
01336                         return curr_field;
01337                 }
01338         } else {
01339                 if (days > normal_month_days[month]) {
01340                         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01341                         cob_set_int (curr_field, 0);
01342                         return curr_field;
01343                 }
01344         }
01345         totaldays = 0;
01346         while (baseyear != year) {
01347                 if (leap_year (baseyear)) {
01348                         totaldays += 366;
01349                 } else {
01350                         totaldays += 365;
01351                 }
01352                 ++baseyear;
01353         }
01354         if (leap_year (baseyear)) {
01355                 totaldays += leap_days[month - 1];
01356         } else {
01357                 totaldays += normal_days[month - 1];
01358         }
01359         totaldays += days;
01360         cob_set_int (curr_field, totaldays);
01361         return curr_field;
01362 }
01363 
01364 cob_field *
01365 cob_intr_integer_of_day (cob_field *srcfield)
01366 {
01367         int             indate;
01368         int             days;
01369         int             totaldays;
01370         int             year;
01371         int             baseyear = 1601;
01372         cob_field_attr  attr;
01373         cob_field       field;
01374 
01375         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
01376         COB_FIELD_INIT (4, NULL, &attr);
01377         make_field_entry (&field);
01378 
01379         cob_exception_code = 0;
01380         /* Base 1601-01-01 */
01381         indate = cob_get_int (srcfield);
01382         year = indate / 1000;
01383         if (year < 1601 || year > 9999) {
01384                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01385                 cob_set_int (curr_field, 0);
01386                 return curr_field;
01387         }
01388         days = indate % 1000;
01389         if (days < 1 || days > 365 + leap_year (year)) {
01390                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01391                 cob_set_int (curr_field, 0);
01392                 return curr_field;
01393         }
01394         totaldays = 0;
01395         while (baseyear != year) {
01396                 if (leap_year (baseyear)) {
01397                         totaldays += 366;
01398                 } else {
01399                         totaldays += 365;
01400                 }
01401                 ++baseyear;
01402         }
01403         totaldays += days;
01404         cob_set_int (curr_field, totaldays);
01405         return curr_field;
01406 }
01407 
01408 cob_field *
01409 cob_intr_test_date_yyyymmdd (cob_field *srcfield)
01410 {
01411         int             indate;
01412         int             days;
01413         int             month;
01414         int             year;
01415         cob_field_attr  attr;
01416         cob_field       field;
01417 
01418         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
01419         COB_FIELD_INIT (4, NULL, &attr);
01420         make_field_entry (&field);
01421 
01422         /* Base 1601-01-01 */
01423         indate = cob_get_int (srcfield);
01424         year = indate / 10000;
01425         if (year < 1601 || year > 9999) {
01426                 cob_set_int (curr_field, 1);
01427                 return curr_field;
01428         }
01429         indate %= 10000;
01430         month = indate / 100;
01431         if (month < 1 || month > 12) {
01432                 cob_set_int (curr_field, 2);
01433                 return curr_field;
01434         }
01435         days = indate % 100;
01436         if (days < 1 || days > 31) {
01437                 cob_set_int (curr_field, 3);
01438                 return curr_field;
01439         }
01440         if (leap_year (year)) {
01441                 if (days > leap_month_days[month]) {
01442                         cob_set_int (curr_field, 3);
01443                         return curr_field;
01444                 }
01445         } else {
01446                 if (days > normal_month_days[month]) {
01447                         cob_set_int (curr_field, 3);
01448                         return curr_field;
01449                 }
01450         }
01451         cob_set_int (curr_field, 0);
01452         return curr_field;
01453 }
01454 
01455 cob_field *
01456 cob_intr_test_day_yyyyddd (cob_field *srcfield)
01457 {
01458         int             indate;
01459         int             days;
01460         int             year;
01461         cob_field_attr  attr;
01462         cob_field       field;
01463 
01464         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
01465         COB_FIELD_INIT (4, NULL, &attr);
01466         make_field_entry (&field);
01467 
01468         /* Base 1601-01-01 */
01469         indate = cob_get_int (srcfield);
01470         year = indate / 1000;
01471         if (year < 1601 || year > 9999) {
01472                 cob_set_int (curr_field, 1);
01473                 return curr_field;
01474         }
01475         days = indate % 1000;
01476         if (days < 1 || days > 365 + leap_year (year)) {
01477                 cob_set_int (curr_field, 2);
01478                 return curr_field;
01479         }
01480         cob_set_int (curr_field, 0);
01481         return curr_field;
01482 }
01483 
01484 cob_field *
01485 cob_intr_factorial (cob_field *srcfield)
01486 {
01487         int             srcval;
01488         cob_field_attr  attr;
01489         cob_field       field;
01490 
01491         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, 0, NULL);
01492         COB_FIELD_INIT (8, NULL, &attr);
01493         make_field_entry (&field);
01494 
01495         cob_exception_code = 0;
01496         srcval = cob_get_int (srcfield);
01497         if (srcval < 0) {
01498                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
01499                 cob_set_int (curr_field, 0);
01500                 return curr_field;
01501         }
01502         d1.scale = 0;
01503         mpz_fac_ui (d1.value, (unsigned int)srcval);
01504         cob_decimal_get_field (&d1, curr_field, 0);
01505         return curr_field;
01506 }
01507 
01508 cob_field *
01509 cob_intr_exp (cob_field *srcfield)
01510 {
01511         double          mathd2;
01512 
01513         cob_decimal_set_field (&d1, srcfield);
01514         make_double_entry ();
01515 
01516         errno = 0;
01517         mathd2 = pow (2.7182818284590452354, intr_get_double (&d1));
01518         if (errno) {
01519                 cob_set_int (curr_field, 0);
01520                 return curr_field;
01521         }
01522         memcpy (curr_field->data, (char *)&mathd2, 8);
01523         return curr_field;
01524 }
01525 
01526 cob_field *
01527 cob_intr_exp10 (cob_field *srcfield)
01528 {
01529         double          mathd2;
01530 
01531         cob_decimal_set_field (&d1, srcfield);
01532         make_double_entry ();
01533 
01534         errno = 0;
01535         mathd2 = pow (10.0, intr_get_double (&d1));
01536         if (errno) {
01537                 cob_set_int (curr_field, 0);
01538                 return curr_field;
01539         }
01540         memcpy (curr_field->data, (char *)&mathd2, 8);
01541         return curr_field;
01542 }
01543 
01544 cob_field *
01545 cob_intr_abs (cob_field *srcfield)
01546 {
01547 
01548         make_field_entry (srcfield);
01549 
01550         cob_decimal_set_field (&d1, srcfield);
01551         mpz_abs (d1.value, d1.value);
01552         cob_decimal_get_field (&d1, curr_field, 0);
01553         return curr_field;
01554 }
01555 
01556 cob_field *
01557 cob_intr_acos (cob_field *srcfield)
01558 {
01559         unsigned long long      result;
01560         double                  mathd2;
01561         int                     i, tempres;
01562         cob_field_attr          attr;
01563         cob_field               field;
01564 
01565         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, 0, NULL);
01566         COB_FIELD_INIT (8, NULL, &attr);
01567         cob_decimal_set_field (&d1, srcfield);
01568         make_field_entry (&field);
01569         
01570         errno = 0;
01571         mathd2 = acos (intr_get_double (&d1));
01572         if (errno) {
01573                 cob_set_int (curr_field, 0);
01574                 return curr_field;
01575         }
01576 
01577         result = (unsigned long long) mathd2;
01578         mathd2 -= result;
01579         for (i = 0; i < 17; ++i) {
01580                 mathd2 *= 10;
01581                 tempres = (int) mathd2;
01582                 result *= 10;
01583                 result += tempres;
01584                 mathd2 -= tempres;
01585         }
01586         memcpy (curr_field->data, (char *)&result, 8);
01587         return curr_field;
01588 }
01589 
01590 cob_field *
01591 cob_intr_asin (cob_field *srcfield)
01592 {
01593         long long               result;
01594         double                  mathd2;
01595         int                     i, tempres;
01596         cob_field_attr          attr;
01597         cob_field               field;
01598 
01599         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
01600         COB_FIELD_INIT (8, NULL, &attr);
01601         cob_decimal_set_field (&d1, srcfield);
01602         make_field_entry (&field);
01603 
01604         errno = 0;
01605         mathd2 = asin (intr_get_double (&d1));
01606         if (errno) {
01607                 cob_set_int (curr_field, 0);
01608                 return curr_field;
01609         }
01610         result = (long long) mathd2;
01611         mathd2 -= result;
01612         for (i = 0; i < 17; ++i) {
01613                 mathd2 *= 10;
01614                 tempres = (int) mathd2;
01615                 result *= 10;
01616                 result += tempres;
01617                 mathd2 -= tempres;
01618         }
01619         memcpy (curr_field->data, (char *)&result, 8);
01620         return curr_field;
01621 }
01622 
01623 cob_field *
01624 cob_intr_atan (cob_field *srcfield)
01625 {
01626         long long               result;
01627         double                  mathd2;
01628         int                     i, tempres;
01629         cob_field_attr          attr;
01630         cob_field               field;
01631 
01632         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
01633         COB_FIELD_INIT (8, NULL, &attr);
01634         cob_decimal_set_field (&d1, srcfield);
01635         make_field_entry (&field);
01636 
01637         errno = 0;
01638         mathd2 = atan (intr_get_double (&d1));
01639         if (errno) {
01640                 cob_set_int (curr_field, 0);
01641                 return curr_field;
01642         }
01643         result = (long long) mathd2;
01644         mathd2 -= result;
01645         for (i = 0; i < 17; ++i) {
01646                 mathd2 *= 10;
01647                 tempres = (int) mathd2;
01648                 result *= 10;
01649                 result += tempres;
01650                 mathd2 -= tempres;
01651         }
01652         memcpy (curr_field->data, (char *)&result, 8);
01653         return curr_field;
01654 }
01655 
01656 cob_field *
01657 cob_intr_cos (cob_field *srcfield)
01658 {
01659         long long               result;
01660         double                  mathd2;
01661         int                     i, tempres;
01662         cob_field_attr          attr;
01663         cob_field               field;
01664 
01665         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
01666         COB_FIELD_INIT (8, NULL, &attr);
01667         cob_decimal_set_field (&d1, srcfield);
01668         make_field_entry (&field);
01669 
01670         errno = 0;
01671         mathd2 = cos (intr_get_double (&d1));
01672         if (errno) {
01673                 cob_set_int (curr_field, 0);
01674                 return curr_field;
01675         }
01676         result = (long long) mathd2;
01677         mathd2 -= result;
01678         for (i = 0; i < 17; ++i) {
01679                 mathd2 *= 10;
01680                 tempres = (int) mathd2;
01681                 result *= 10;
01682                 result += tempres;
01683                 mathd2 -= tempres;
01684         }
01685         memcpy (curr_field->data, (char *)&result, 8);
01686         return curr_field;
01687 }
01688 
01689 cob_field *
01690 cob_intr_log (cob_field *srcfield)
01691 {
01692         double          mathd2;
01693 
01694         cob_decimal_set_field (&d1, srcfield);
01695         make_double_entry ();
01696 
01697         errno = 0;
01698         mathd2 = log (intr_get_double (&d1));
01699         if (errno) {
01700                 cob_set_int (curr_field, 0);
01701                 return curr_field;
01702         }
01703         memcpy (curr_field->data, (char *)&mathd2, 8);
01704         return curr_field;
01705 }
01706 
01707 cob_field *
01708 cob_intr_log10 (cob_field *srcfield)
01709 {
01710         double          mathd2;
01711 
01712         cob_decimal_set_field (&d1, srcfield);
01713         make_double_entry ();
01714 
01715         errno = 0;
01716         mathd2 = log10 (intr_get_double (&d1));
01717         if (errno) {
01718                 cob_set_int (curr_field, 0);
01719                 return curr_field;
01720         }
01721         memcpy (curr_field->data, (char *)&mathd2, 8);
01722         return curr_field;
01723 }
01724 
01725 cob_field *
01726 cob_intr_sin (cob_field *srcfield)
01727 {
01728         long long               result;
01729         double                  mathd2;
01730         int                     i, tempres;
01731         cob_field_attr          attr;
01732         cob_field               field;
01733 
01734         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 17, COB_FLAG_HAVE_SIGN, NULL);
01735         COB_FIELD_INIT (8, NULL, &attr);
01736         cob_decimal_set_field (&d1, srcfield);
01737         make_field_entry (&field);
01738 
01739         errno = 0;
01740         mathd2 = sin (intr_get_double (&d1));
01741         if (errno) {
01742                 cob_set_int (curr_field, 0);
01743                 return curr_field;
01744         }
01745         result = (long long) mathd2;
01746         mathd2 -= result;
01747         for (i = 0; i < 17; ++i) {
01748                 mathd2 *= 10;
01749                 tempres = (int) mathd2;
01750                 result *= 10;
01751                 result += tempres;
01752                 mathd2 -= tempres;
01753         }
01754         memcpy (curr_field->data, (char *)&result, 8);
01755         return curr_field;
01756 }
01757 
01758 cob_field *
01759 cob_intr_sqrt (cob_field *srcfield)
01760 {
01761         double          mathd2;
01762 
01763         cob_decimal_set_field (&d1, srcfield);
01764         make_double_entry ();
01765 
01766         errno = 0;
01767         mathd2 = sqrt (intr_get_double (&d1));
01768         if (errno) {
01769                 cob_set_int (curr_field, 0);
01770                 return curr_field;
01771         }
01772         memcpy (curr_field->data, (char *)&mathd2, 8);
01773         return curr_field;
01774 }
01775 
01776 cob_field *
01777 cob_intr_tan (cob_field *srcfield)
01778 {
01779         double          mathd2;
01780 
01781         cob_decimal_set_field (&d1, srcfield);
01782         make_double_entry ();
01783 
01784         errno = 0;
01785         mathd2 = tan (intr_get_double (&d1));
01786         if (errno) {
01787                 cob_set_int (curr_field, 0);
01788                 return curr_field;
01789         }
01790         memcpy (curr_field->data, (char *)&mathd2, 8);
01791         return curr_field;
01792 }
01793 
01794 cob_field *
01795 cob_intr_numval (cob_field *srcfield)
01796 {
01797         long long       llval = 0;
01798         double          val;
01799         size_t          i;
01800         int             integer_digits = 0;
01801         int             decimal_digits = 0;
01802         int             sign = 0;
01803         int             decimal_seen = 0;
01804         cob_field_attr  attr;
01805         cob_field       field;
01806         unsigned char   integer_buff[64];
01807         unsigned char   decimal_buff[64];
01808         unsigned char   final_buff[64];
01809 
01810         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
01811         COB_FIELD_INIT (8, NULL, &attr);
01812         memset (integer_buff, 0, sizeof (integer_buff));
01813         memset (decimal_buff, 0, sizeof (decimal_buff));
01814         memset (final_buff, 0, sizeof (final_buff));
01815 
01816         for (i = 0; i < srcfield->size; ++i) {
01817                 if (i < (srcfield->size - 2)) {
01818                         if (strcasecmp ((char *)&srcfield->data[i], "CR") == 0
01819                              || strcasecmp ((char *)&srcfield->data[i], "DB") == 0) {
01820                                 sign = 1;
01821                                 break;
01822                         }
01823                 }
01824                 if (srcfield->data[i] == ' ') {
01825                         continue;
01826                 }
01827                 if (srcfield->data[i] == '+') {
01828                         continue;
01829                 }
01830                 if (srcfield->data[i] == '-') {
01831                         sign = 1;
01832                         continue;
01833                 }
01834                 if (srcfield->data[i] == cob_current_module->decimal_point) {
01835                         decimal_seen = 1;
01836                         continue;
01837                 }
01838                 if (srcfield->data[i] >= '0' && srcfield->data[i] <= '9') {
01839                         llval *= 10;
01840                         llval += srcfield->data[i] - '0';
01841                         if (decimal_seen) {
01842                                 decimal_buff[decimal_digits++] = srcfield->data[i];
01843                         } else {
01844                                 integer_buff[integer_digits++] = srcfield->data[i];
01845                         }
01846                 }
01847                 if ((integer_digits + decimal_digits) > 30) {
01848                         break;
01849                 }
01850         }
01851         if (!integer_digits) {
01852                 integer_buff[0] = '0';
01853         }
01854         if (!decimal_digits) {
01855                 decimal_buff[0] = '0';
01856         }
01857         if (sign) {
01858                 llval = -llval;
01859         }
01860         if ((integer_digits + decimal_digits) <= 18) {
01861                 attr.scale = decimal_digits;
01862                 make_field_entry (&field);
01863                 memcpy (curr_field->data, (char *)&llval, 8);
01864         } else {
01865                 snprintf ((char *)final_buff, 63, "%s%s.%s", sign ? "-" : "",
01866                          integer_buff, decimal_buff);
01867                 sscanf ((char *)final_buff, "%lf", &val);
01868                 make_double_entry ();
01869                 memcpy (curr_field->data, (char *)&val, sizeof (double));
01870         }
01871         return curr_field;
01872 }
01873 
01874 cob_field *
01875 cob_intr_numval_c (cob_field *srcfield, cob_field *currency)
01876 {
01877         unsigned char   *currency_data;
01878         long long       llval = 0;
01879         double          val;
01880         size_t          i;
01881         int             integer_digits = 0;
01882         int             decimal_digits = 0;
01883         int             sign = 0;
01884         int             decimal_seen = 0;
01885         cob_field_attr  attr;
01886         cob_field       field;
01887         unsigned char   integer_buff[64];
01888         unsigned char   decimal_buff[64];
01889         unsigned char   final_buff[64];
01890 
01891         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
01892         COB_FIELD_INIT (8, NULL, &attr);
01893         memset (integer_buff, 0, sizeof (integer_buff));
01894         memset (decimal_buff, 0, sizeof (decimal_buff));
01895         memset (final_buff, 0, sizeof (final_buff));
01896 
01897         currency_data = NULL;
01898         if (currency) {
01899                 if (currency->size < srcfield->size) {
01900                         currency_data = currency->data;
01901                 }
01902         }
01903         for (i = 0; i < srcfield->size; ++i) {
01904                 if (i < (srcfield->size - 2)) {
01905                         if (strcasecmp ((char *)&srcfield->data[i], "CR") == 0
01906                              || strcasecmp ((char *)&srcfield->data[i], "DB") == 0) {
01907                                 sign = 1;
01908                                 break;
01909                         }
01910                 }
01911                 if (currency_data) {
01912                         if (i < (srcfield->size - currency->size)) {
01913                                 if (memcmp ((char *)&srcfield->data[i], currency_data,
01914                                              currency->size) == 0) {
01915                                         i += (currency->size - 1);
01916                                         continue;
01917                                 }
01918                         }
01919                 }
01920                 if (srcfield->data[i] == ' ') {
01921                         continue;
01922                 }
01923                 if (srcfield->data[i] == '+') {
01924                         continue;
01925                 }
01926                 if (srcfield->data[i] == '-') {
01927                         sign = 1;
01928                         continue;
01929                 }
01930                 if (srcfield->data[i] == cob_current_module->decimal_point) {
01931                         decimal_seen = 1;
01932                         continue;
01933                 }
01934                 if (srcfield->data[i] == cob_current_module->currency_symbol) {
01935                         continue;
01936                 }
01937                 if (srcfield->data[i] >= '0' && srcfield->data[i] <= '9') {
01938                         llval *= 10;
01939                         llval += srcfield->data[i] - '0';
01940                         if (decimal_seen) {
01941                                 decimal_buff[decimal_digits++] = srcfield->data[i];
01942                         } else {
01943                                 integer_buff[integer_digits++] = srcfield->data[i];
01944                         }
01945                 }
01946                 if ((integer_digits + decimal_digits) > 30) {
01947                         break;
01948                 }
01949         }
01950         if (!integer_digits) {
01951                 integer_buff[0] = '0';
01952         }
01953         if (!decimal_digits) {
01954                 decimal_buff[0] = '0';
01955         }
01956         if (sign) {
01957                 llval = -llval;
01958         }
01959         if ((integer_digits + decimal_digits) <= 18) {
01960                 attr.scale = decimal_digits;
01961                 make_field_entry (&field);
01962                 memcpy (curr_field->data, (char *)&llval, 8);
01963         } else {
01964                 snprintf ((char *)final_buff, 63, "%s%s.%s", sign ? "-" : "",
01965                          integer_buff, decimal_buff);
01966                 sscanf ((char *)final_buff, "%lf", &val);
01967                 make_double_entry ();
01968                 memcpy (curr_field->data, (char *)&val, sizeof (double));
01969         }
01970         return curr_field;
01971 }
01972 
01973 cob_field *
01974 cob_intr_annuity (cob_field *srcfield1, cob_field *srcfield2)
01975 {
01976         double          mathd1, mathd2;
01977 
01978         make_double_entry ();
01979 
01980         cob_decimal_set_field (&d1, srcfield1);
01981         cob_decimal_set_field (&d2, srcfield2);
01982         
01983         mathd1 = intr_get_double (&d1);
01984         mathd2 = intr_get_double (&d2);
01985         if (mathd1 == 0) {
01986                 mathd1 = 1.0 / mathd2;
01987                 memcpy (curr_field->data, (char *)&mathd1, sizeof (double));
01988                 return curr_field;
01989         }
01990         mathd1 /= (1.0 - pow (mathd1 + 1.0, 0.0 - mathd2));
01991         memcpy (curr_field->data, (char *)&mathd1, sizeof (double));
01992         return curr_field;
01993 }
01994 
01995 cob_field *
01996 cob_intr_sum (const int params, ...)
01997 {
01998         cob_field       *f;
01999         va_list         args;
02000         int             i;
02001         int             digits = 0;
02002         int             scale = 0;
02003         cob_field_attr  attr;
02004         cob_field       field;
02005 
02006 
02007         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
02008         COB_FIELD_INIT (8, NULL, &attr);
02009         mpz_set_ui (d1.value, 0);
02010         d1.scale = 0;
02011 
02012         va_start (args, params);
02013 
02014         for (i = 0; i < params; ++i) {
02015                 f = va_arg (args, cob_field *);
02016                 if ((COB_FIELD_DIGITS(f) - COB_FIELD_SCALE(f)) > digits) {
02017                         digits = COB_FIELD_DIGITS(f) - COB_FIELD_SCALE(f);
02018                 }
02019                 if (COB_FIELD_SCALE(f) > scale) {
02020                         scale = COB_FIELD_SCALE(f);
02021                 }
02022                 cob_decimal_set_field (&d2, f);
02023                 cob_decimal_add (&d1, &d2);
02024         }
02025         va_end (args);
02026 
02027         attr.scale = scale;
02028         make_field_entry (&field);
02029         cob_decimal_get_field (&d1, curr_field, 0);
02030         return curr_field;
02031 }
02032 
02033 cob_field *
02034 cob_intr_ord_min (const int params, ...)
02035 {
02036         cob_field       *f, *basef;
02037         int             i;
02038         int             ordmin = 0;
02039         va_list         args;
02040         cob_field_attr  attr;
02041         cob_field       field;
02042 
02043         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
02044         COB_FIELD_INIT (4, NULL, &attr);
02045         make_field_entry (&field);
02046 
02047         if (params <= 1) {
02048                 cob_set_int (curr_field, 0);
02049                 return curr_field;
02050         }
02051 
02052         va_start (args, params);
02053 
02054         basef = va_arg (args, cob_field *);
02055         for (i = 1; i < params; ++i) {
02056                 f = va_arg (args, cob_field *);
02057                 if (cob_cmp (f, basef) < 0) {
02058                         basef = f;
02059                         ordmin = i;
02060                 }
02061         }
02062         va_end (args);
02063 
02064         cob_set_int (curr_field, ordmin + 1);
02065         return curr_field;
02066 }
02067 
02068 cob_field *
02069 cob_intr_ord_max (const int params, ...)
02070 {
02071         cob_field       *f, *basef;
02072         int             ordmin = 0;
02073         int             i;
02074         va_list         args;
02075         cob_field_attr  attr;
02076         cob_field       field;
02077 
02078         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
02079         COB_FIELD_INIT (4, NULL, &attr);
02080         make_field_entry (&field);
02081 
02082         if (params <= 1) {
02083                 cob_set_int (curr_field, 0);
02084                 return curr_field;
02085         }
02086 
02087         va_start (args, params);
02088 
02089         basef = va_arg (args, cob_field *);
02090         for (i = 1; i < params; ++i) {
02091                 f = va_arg (args, cob_field *);
02092                 if (cob_cmp (f, basef) > 0) {
02093                         basef = f;
02094                         ordmin = i;
02095                 }
02096         }
02097         va_end (args);
02098 
02099         cob_set_int (curr_field, ordmin + 1);
02100         return curr_field;
02101 }
02102 
02103 cob_field *
02104 cob_intr_min (const int params, ...)
02105 {
02106         cob_field       *f, *basef;
02107         va_list         args;
02108         int             i;
02109 
02110         va_start (args, params);
02111 
02112         basef = va_arg (args, cob_field *);
02113         for (i = 1; i < params; ++i) {
02114                 f = va_arg (args, cob_field *);
02115                 if (cob_cmp (f, basef) < 0) {
02116                         basef = f;
02117                 }
02118         }
02119         va_end (args);
02120 
02121         return basef;
02122 }
02123 
02124 cob_field *
02125 cob_intr_max (const int params, ...)
02126 {
02127         cob_field       *f, *basef;
02128         va_list         args;
02129         int             i;
02130 
02131         va_start (args, params);
02132 
02133         basef = va_arg (args, cob_field *);
02134         for (i = 1; i < params; ++i) {
02135                 f = va_arg (args, cob_field *);
02136                 if (cob_cmp (f, basef) > 0) {
02137                         basef = f;
02138                 }
02139         }
02140         va_end (args);
02141 
02142         return basef;
02143 }
02144 
02145 cob_field *
02146 cob_intr_midrange (const int params, ...)
02147 {
02148         cob_field       *f, *basemin, *basemax;
02149         va_list         args;
02150         int             i;
02151 
02152         make_double_entry ();
02153         va_start (args, params);
02154 
02155         basemin = va_arg (args, cob_field *);
02156         basemax = basemin;
02157         for (i = 1; i < params; ++i) {
02158                 f = va_arg (args, cob_field *);
02159                 if (cob_cmp (f, basemin) < 0) {
02160                         basemin = f;
02161                 }
02162                 if (cob_cmp (f, basemax) > 0) {
02163                         basemax = f;
02164                 }
02165         }
02166         va_end (args);
02167 
02168         cob_decimal_set_field (&d1, basemin);
02169         cob_decimal_set_field (&d2, basemax);
02170         cob_decimal_add (&d1, &d2);
02171         mpz_set_ui (d2.value, 2);
02172         d2.scale = 0;
02173         cob_decimal_div (&d1, &d2);
02174         cob_decimal_get_field (&d1, curr_field, 0);
02175         return curr_field;
02176 }
02177 
02178 cob_field *
02179 cob_intr_median (const int params, ...)
02180 {
02181         cob_field       *f;
02182         cob_field       **field_alloc;
02183         va_list         args;
02184         int             i;
02185 
02186         va_start (args, params);
02187 
02188         f = va_arg (args, cob_field *);
02189         if (params == 1) {
02190                 va_end (args);
02191                 return f;
02192         }
02193 
02194         field_alloc = cob_malloc (params * sizeof (cob_field *));
02195         field_alloc[0] = f;
02196 
02197         for (i = 1; i < params; ++i) {
02198                 field_alloc[i] = va_arg (args, cob_field *);
02199         }
02200         va_end (args);
02201 
02202         qsort (field_alloc, (size_t)params, (size_t)sizeof (cob_field *), comp_field);
02203 
02204         i = params / 2;
02205         if (params % 2) {
02206                 f = field_alloc[i];
02207         } else {
02208                 make_double_entry ();
02209                 cob_decimal_set_field (&d1, field_alloc[i-1]);
02210                 cob_decimal_set_field (&d2, field_alloc[i]);
02211                 cob_decimal_add (&d1, &d2);
02212                 mpz_set_ui (d2.value, 2);
02213                 d2.scale = 0;
02214                 cob_decimal_div (&d1, &d2);
02215                 cob_decimal_get_field (&d1, curr_field, 0);
02216                 f = curr_field;
02217         }
02218         
02219         free (field_alloc);
02220         return f;
02221 }
02222 
02223 cob_field *
02224 cob_intr_mean (const int params, ...)
02225 {
02226         cob_field       *f;
02227         va_list         args;
02228         long long       n;
02229         union {
02230                 unsigned char   data[8];
02231                 long long       datall;
02232         } datun;
02233         int             i;
02234         cob_field_attr  attr;
02235         cob_field       field;
02236 
02237 
02238         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
02239         COB_FIELD_INIT (8, NULL, &attr);
02240         mpz_set_ui (d1.value, 0);
02241         d1.scale = 0;
02242 
02243         va_start (args, params);
02244         for (i = 0; i < params; ++i) {
02245                 f = va_arg (args, cob_field *);
02246                 cob_decimal_set_field (&d2, f);
02247                 cob_decimal_add (&d1, &d2);
02248         }
02249         va_end (args);
02250 
02251         mpz_set_ui (d2.value, (unsigned int)params);
02252         d2.scale = 0;
02253         cob_decimal_div (&d1, &d2);
02254         field.data = datun.data;
02255         cob_decimal_get_field (&d1, &field, 0);
02256         n = datun.datall;
02257         for (i = 0; n; n /= 10, ++i) ;
02258         field.data = NULL;
02259         if (i <= 18) {
02260                 attr.scale = 18 - i;
02261         }
02262         make_field_entry (&field);
02263         cob_decimal_get_field (&d1, curr_field, 0);
02264         return curr_field;
02265 }
02266 
02267 cob_field *
02268 cob_intr_mod (cob_field *srcfield1, cob_field *srcfield2)
02269 {
02270         cob_field       *f1;
02271         cob_field_attr  attr;
02272         cob_field       field;
02273 
02274         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
02275         COB_FIELD_INIT (8, NULL, &attr);
02276         make_field_entry (&field);
02277 
02278         f1 = cob_intr_integer (cob_intr_binop (srcfield1, '/', srcfield2));
02279         cob_decimal_set_field (&d1, srcfield2);
02280         cob_decimal_set_field (&d2, f1);
02281         cob_decimal_mul (&d2, &d1);
02282         cob_decimal_set_field (&d1, srcfield1);
02283         cob_decimal_sub (&d1, &d2);
02284         cob_decimal_get_field (&d1, curr_field, 0);
02285         return curr_field;
02286 }
02287 
02288 cob_field *
02289 cob_intr_range (const int params, ...)
02290 {
02291         cob_field       *f, *basemin, *basemax;
02292         va_list         args;
02293         int             i;
02294         cob_field_attr  attr;
02295         cob_field       field;
02296 
02297         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
02298         COB_FIELD_INIT (8, NULL, &attr);
02299         va_start (args, params);
02300 
02301         basemin = va_arg (args, cob_field *);
02302         basemax = basemin;
02303         for (i = 1; i < params; ++i) {
02304                 f = va_arg (args, cob_field *);
02305                 if (cob_cmp (f, basemin) < 0) {
02306                         basemin = f;
02307                 }
02308                 if (cob_cmp (f, basemax) > 0) {
02309                         basemax = f;
02310                 }
02311         }
02312         va_end (args);
02313 
02314         attr.scale = COB_FIELD_SCALE(basemin);
02315         if (COB_FIELD_SCALE(basemax) > attr.scale) {
02316                 attr.scale = COB_FIELD_SCALE(basemax);
02317         }
02318         make_field_entry (&field);
02319         cob_decimal_set_field (&d1, basemax);
02320         cob_decimal_set_field (&d2, basemin);
02321         cob_decimal_sub (&d1, &d2);
02322         cob_decimal_get_field (&d1, curr_field, 0);
02323         return curr_field;
02324 }
02325 
02326 cob_field *
02327 cob_intr_rem (cob_field *srcfield1, cob_field *srcfield2)
02328 {
02329         cob_field       *f1;
02330         cob_field_attr  attr;
02331         cob_field       field;
02332 
02333         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
02334         COB_FIELD_INIT (8, NULL, &attr);
02335         f1 = cob_intr_integer_part (cob_intr_binop (srcfield1, '/', srcfield2));
02336         cob_decimal_set_field (&d1, srcfield2);
02337         cob_decimal_set_field (&d2, f1);
02338         cob_decimal_mul (&d2, &d1);
02339         cob_decimal_set_field (&d1, srcfield1);
02340         cob_decimal_sub (&d1, &d2);
02341 
02342         attr.scale = COB_FIELD_SCALE(srcfield1);
02343         if (COB_FIELD_SCALE(srcfield2) > attr.scale) {
02344                 attr.scale = COB_FIELD_SCALE(srcfield2);
02345         }
02346         make_field_entry (&field);
02347         cob_decimal_get_field (&d1, curr_field, 0);
02348         return curr_field;
02349 }
02350 
02351 cob_field *
02352 cob_intr_random (const int params, ...)
02353 {
02354         cob_field       *f;
02355         va_list         args;
02356         int             seed = 1;
02357         int             randnum;
02358         int             i;
02359         int             exp10;
02360         cob_field_attr  attr;
02361         cob_field       field;
02362 
02363         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 9, COB_FLAG_HAVE_SIGN, NULL);
02364         COB_FIELD_INIT (8, NULL, &attr);
02365         va_start (args, params);
02366 
02367         if (params) {
02368                 f = va_arg (args, cob_field *);
02369                 seed = cob_get_int (f);
02370                 if (seed < 0) {
02371                         seed = 0;
02372                 }
02373 #ifdef  __CYGWIN__
02374                 srandom ((unsigned int)seed);
02375 #else
02376                 srand ((unsigned int)seed);
02377 #endif
02378         }
02379         va_end (args);
02380 
02381 #ifdef  __CYGWIN__
02382         randnum = (int)random ();
02383 #else
02384         randnum = rand ();
02385 #endif
02386         exp10 = 1;
02387         for (i = 0; i < 10; ++i) {
02388                 if ((randnum / exp10) == 0) {
02389                         break;
02390                 }
02391                 exp10 *= 10;
02392         }
02393         if (i == 0) {
02394                 i = 1;
02395         }
02396         attr.scale = i;
02397         make_field_entry (&field);
02398         *(long long *)curr_field->data = (long long)randnum;
02399         return curr_field;
02400 }
02401 
02402 cob_field *
02403 cob_intr_variance (const int params, ...)
02404 {
02405         cob_field       *f;
02406         va_list         args;
02407         long long       n;
02408         union {
02409                 unsigned char   data[8];
02410                 long long       datall;
02411         } datun;
02412         int             i;
02413         cob_field_attr  attr;
02414         cob_field       field;
02415 
02416         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 18, 0, COB_FLAG_HAVE_SIGN, NULL);
02417         COB_FIELD_INIT (8, NULL, &attr);
02418         if (params == 1) {
02419                 make_field_entry (&field);
02420                 cob_set_int (curr_field, 0);
02421                 return curr_field;
02422         }
02423 
02424         /* MEAN for all params */
02425         mpz_set_ui (d1.value, 0);
02426         d1.scale = 0;
02427 
02428         va_start (args, params);
02429         for (i = 0; i < params; ++i) {
02430                 f = va_arg (args, cob_field *);
02431                 cob_decimal_set_field (&d2, f);
02432                 cob_decimal_add (&d1, &d2);
02433         }
02434         va_end (args);
02435         mpz_set_ui (d2.value, (unsigned int)params);
02436         d2.scale = 0;
02437         cob_decimal_div (&d1, &d2);
02438 
02439         /* Got the MEAN in d1, iterate again */
02440 
02441         mpz_set_ui (d4.value, 0);
02442         d4.scale = 0;
02443 
02444         va_start (args, params);
02445 
02446         for (i = 0; i < params; ++i) {
02447                 f = va_arg (args, cob_field *);
02448                 cob_decimal_set_field (&d2, f);
02449                 cob_decimal_sub (&d2, &d1);
02450                 cob_decimal_mul (&d2, &d2);
02451                 cob_decimal_add (&d4, &d2);
02452         }
02453         va_end (args);
02454 
02455         mpz_set_ui (d3.value, (unsigned int)params);
02456         d3.scale = 0;
02457         cob_decimal_div (&d4, &d3);
02458         field.data = datun.data;
02459         cob_decimal_get_field (&d4, &field, 0);
02460         n = datun.datall;
02461         for (i = 0; n; n /= 10, ++i) ;
02462         field.data = NULL;
02463         if (i <= 18) {
02464                 attr.scale = 18 - i;
02465         }
02466         make_field_entry (&field);
02467         cob_decimal_get_field (&d4, curr_field, 0);
02468         return curr_field;
02469 }
02470 
02471 cob_field *
02472 cob_intr_standard_deviation (const int params, ...)
02473 {
02474         cob_field       *f;
02475         va_list         args;
02476         int             i;
02477 
02478         va_start (args, params);
02479         make_double_entry ();
02480 
02481         if (params == 1) {
02482                 va_end (args);
02483                 cob_set_int (curr_field, 0);
02484                 return curr_field;
02485         }
02486 
02487         /* MEAN for all params */
02488         mpz_set_ui (d1.value, 0);
02489         d1.scale = 0;
02490 
02491         for (i = 0; i < params; ++i) {
02492                 f = va_arg (args, cob_field *);
02493                 cob_decimal_set_field (&d2, f);
02494                 cob_decimal_add (&d1, &d2);
02495         }
02496         va_end (args);
02497         mpz_set_ui (d2.value, (unsigned int)params);
02498         d2.scale = 0;
02499         cob_decimal_div (&d1, &d2);
02500 
02501         /* Got the MEAN in d1, iterate again */
02502 
02503         mpz_set_ui (d4.value, 0);
02504         d4.scale = 0;
02505 
02506         va_start (args, params);
02507 
02508         for (i = 0; i < params; ++i) {
02509                 f = va_arg (args, cob_field *);
02510                 cob_decimal_set_field (&d2, f);
02511                 cob_decimal_sub (&d2, &d1);
02512                 cob_decimal_mul (&d2, &d2);
02513                 cob_decimal_add (&d4, &d2);
02514         }
02515         va_end (args);
02516 
02517         mpz_set_ui (d3.value, (unsigned int)params);
02518         d3.scale = 0;
02519         cob_decimal_div (&d4, &d3);
02520         /* We have the VARIANCE in d4, sqrt = STANDARD-DEVIATION */
02521 
02522 /* Do not know why this does not work
02523         d5.scale = d4.scale;
02524         mpz_mul_ui (d5.value, d4.value, 1000000000);
02525         mpz_mul_ui (d4.value, d5.value, 1000000000);
02526         mpz_sqrt (d5.value, d4.value);
02527         mpz_div_ui (d4.value, d5.value, 1000000000);
02528         cob_decimal_get_field (&d4, curr_field, 0);
02529         return curr_field;
02530 */
02531 
02532         cob_decimal_get_field (&d4, curr_field, 0);
02533         f = cob_intr_sqrt (curr_field);
02534         return f;
02535 }
02536 
02537 cob_field *
02538 cob_intr_present_value (const int params, ...)
02539 {
02540         cob_field       *f;
02541         va_list         args;
02542         int             i;
02543 
02544         va_start (args, params);
02545         make_double_entry ();
02546 
02547         if (params < 2) {
02548                 va_end (args);
02549                 fprintf (stderr, "Wrong number of parameters for FUNCTION PRESENT-VALUE\n");
02550                 fflush (stderr);
02551                 cob_set_int (curr_field, 0);
02552                 return curr_field;
02553         }
02554         f = va_arg (args, cob_field *);
02555         cob_decimal_set_field (&d1, f);
02556         mpz_set_ui (d2.value, 1);
02557         d2.scale = 0;
02558         cob_decimal_add (&d1, &d2);
02559 
02560         mpz_set_ui (d4.value, 0);
02561         d4.scale = 0;
02562 
02563         for (i = 1; i < params; ++i) {
02564                 f = va_arg (args, cob_field *);
02565                 cob_decimal_set_field (&d2, f);
02566                 mpz_set (d3.value, d1.value);
02567                 d3.scale = d1.scale;
02568                 if (i > 1) {
02569                         mpz_set_ui (d5.value, (unsigned int)i);
02570                         d5.scale = 0;
02571                         cob_decimal_pow (&d3, &d5);
02572                 }
02573                 cob_decimal_div (&d2, &d3);
02574                 cob_decimal_add (&d4, &d2);
02575         }
02576         va_end (args);
02577 
02578         cob_decimal_get_field (&d4, curr_field, 0);
02579         return curr_field;
02580 }
02581 
02582 cob_field *
02583 cob_intr_year_to_yyyy (const int params, ...)
02584 {
02585         cob_field       *f;
02586         struct tm       *timeptr;
02587         va_list         args;
02588         time_t          t;
02589         int             year;
02590         int             interval;
02591         int             xqtyear;
02592         int             maxyear;
02593         cob_field_attr  attr;
02594         cob_field       field;
02595 
02596         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
02597         COB_FIELD_INIT (4, NULL, &attr);
02598         make_field_entry (&field);
02599 
02600         cob_exception_code = 0;
02601         va_start (args, params);
02602         f = va_arg (args, cob_field *);
02603         year = cob_get_int (f);
02604         if (params > 1) {
02605                 f = va_arg (args, cob_field *);
02606                 interval = cob_get_int (f);
02607         } else {
02608                 interval = 50;
02609         }
02610         if (params > 2) {
02611                 f = va_arg (args, cob_field *);
02612                 xqtyear = cob_get_int (f);
02613         } else {
02614                 t = time (NULL);
02615                 timeptr = localtime (&t);
02616                 xqtyear = 1900 + timeptr->tm_year;
02617         }
02618         va_end (args);
02619 
02620         if (year < 0 || year > 99) {
02621                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02622                 cob_set_int (curr_field, 0);
02623                 return curr_field;
02624         }
02625         if (xqtyear < 1601 || xqtyear > 9999) {
02626                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02627                 cob_set_int (curr_field, 0);
02628                 return curr_field;
02629         }
02630         maxyear = xqtyear + interval;
02631         if (maxyear < 1700 || maxyear > 9999) {
02632                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02633                 cob_set_int (curr_field, 0);
02634                 return curr_field;
02635         }
02636         if (maxyear % 100 >= year) {
02637                 year += 100 * (maxyear / 100);
02638         } else {
02639                 year += 100 * ((maxyear / 100) - 1);
02640         }
02641         cob_set_int (curr_field, year);
02642         return curr_field;
02643 }
02644 
02645 cob_field *
02646 cob_intr_date_to_yyyymmdd (const int params, ...)
02647 {
02648         cob_field       *f;
02649         struct tm       *timeptr;
02650         va_list         args;
02651         time_t          t;
02652         int             year;
02653         int             mmdd;
02654         int             interval;
02655         int             xqtyear;
02656         int             maxyear;
02657         cob_field_attr  attr;
02658         cob_field       field;
02659 
02660         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
02661         COB_FIELD_INIT (4, NULL, &attr);
02662         make_field_entry (&field);
02663 
02664         cob_exception_code = 0;
02665         va_start (args, params);
02666         f = va_arg (args, cob_field *);
02667         year = cob_get_int (f);
02668         mmdd = year % 10000;
02669         year /= 10000;
02670         if (params > 1) {
02671                 f = va_arg (args, cob_field *);
02672                 interval = cob_get_int (f);
02673         } else {
02674                 interval = 50;
02675         }
02676         if (params > 2) {
02677                 f = va_arg (args, cob_field *);
02678                 xqtyear = cob_get_int (f);
02679         } else {
02680                 t = time (NULL);
02681                 timeptr = localtime (&t);
02682                 xqtyear = 1900 + timeptr->tm_year;
02683         }
02684         va_end (args);
02685 
02686         if (year < 0 || year > 999999) {
02687                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02688                 cob_set_int (curr_field, 0);
02689                 return curr_field;
02690         }
02691         if (xqtyear < 1601 || xqtyear > 9999) {
02692                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02693                 cob_set_int (curr_field, 0);
02694                 return curr_field;
02695         }
02696         maxyear = xqtyear + interval;
02697         if (maxyear < 1700 || maxyear > 9999) {
02698                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02699                 cob_set_int (curr_field, 0);
02700                 return curr_field;
02701         }
02702         if (maxyear % 100 >= year) {
02703                 year += 100 * (maxyear / 100);
02704         } else {
02705                 year += 100 * ((maxyear / 100) - 1);
02706         }
02707         year *= 10000;
02708         year += mmdd;
02709         cob_set_int (curr_field, year);
02710         return curr_field;
02711 }
02712 
02713 cob_field *
02714 cob_intr_day_to_yyyyddd (const int params, ...)
02715 {
02716         cob_field       *f;
02717         struct tm       *timeptr;
02718         va_list         args;
02719         time_t          t;
02720         int             year;
02721         int             days;
02722         int             interval;
02723         int             xqtyear;
02724         int             maxyear;
02725         cob_field_attr  attr;
02726         cob_field       field;
02727 
02728         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
02729         COB_FIELD_INIT (4, NULL, &attr);
02730         make_field_entry (&field);
02731 
02732         cob_exception_code = 0;
02733         va_start (args, params);
02734         f = va_arg (args, cob_field *);
02735         year = cob_get_int (f);
02736         days = year % 1000;
02737         year /= 1000;
02738         if (params > 1) {
02739                 f = va_arg (args, cob_field *);
02740                 interval = cob_get_int (f);
02741         } else {
02742                 interval = 50;
02743         }
02744         if (params > 2) {
02745                 f = va_arg (args, cob_field *);
02746                 xqtyear = cob_get_int (f);
02747         } else {
02748                 t = time (NULL);
02749                 timeptr = localtime (&t);
02750                 xqtyear = 1900 + timeptr->tm_year;
02751         }
02752         va_end (args);
02753 
02754         if (year < 0 || year > 999999) {
02755                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02756                 cob_set_int (curr_field, 0);
02757                 return curr_field;
02758         }
02759         if (xqtyear < 1601 || xqtyear > 9999) {
02760                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02761                 cob_set_int (curr_field, 0);
02762                 return curr_field;
02763         }
02764         maxyear = xqtyear + interval;
02765         if (maxyear < 1700 || maxyear > 9999) {
02766                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02767                 cob_set_int (curr_field, 0);
02768                 return curr_field;
02769         }
02770         if (maxyear % 100 >= year) {
02771                 year += 100 * (maxyear / 100);
02772         } else {
02773                 year += 100 * ((maxyear / 100) - 1);
02774         }
02775         year *= 1000;
02776         year += days;
02777         cob_set_int (curr_field, year);
02778         return curr_field;
02779 }
02780 
02781 cob_field *
02782 cob_intr_seconds_past_midnight (void)
02783 {
02784         struct tm       *timeptr;
02785         time_t          t;
02786         int             seconds;
02787         cob_field_attr  attr;
02788         cob_field       field;
02789 
02790         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
02791         COB_FIELD_INIT (4, NULL, &attr);
02792         make_field_entry (&field);
02793 
02794         t = time (NULL);
02795         timeptr = localtime (&t);
02796         seconds = (timeptr->tm_hour * 3600) + (timeptr->tm_min * 60) +
02797                         timeptr->tm_sec;
02798         cob_set_int (curr_field, seconds);
02799         return curr_field;
02800 }
02801 
02802 cob_field *
02803 cob_intr_seconds_from_formatted_time (cob_field *format, cob_field *value)
02804 {
02805         unsigned char   *p1;
02806         unsigned char   *p2;
02807         size_t          n;
02808         int             seconds = 0;
02809         int             minutes = 0;
02810         int             hours = 0;
02811         int             seconds_seen = 0;
02812         int             minutes_seen = 0;
02813         int             hours_seen = 0;
02814         cob_field_attr  attr;
02815         cob_field       field;
02816 
02817         COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 8, 0, 0, NULL);
02818         COB_FIELD_INIT (4, NULL, &attr);
02819         make_field_entry (&field);
02820 
02821         cob_exception_code = 0;
02822         if (value->size < format->size) {
02823                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02824                 cob_set_int (curr_field, 0);
02825                 return curr_field;
02826         }
02827         p1 = format->data;
02828         p2 = value->data;
02829         for (n = 0; n < format->size - 1; ++n, ++p1, ++p2) {
02830                 if (!memcmp (p1, "hh", 2) && !hours_seen) {
02831                         if (*p2 >= '0' && *p2 <= '9' &&
02832                             *(p2 + 1) >= '0' && *(p2 + 1) <= '9') {
02833                                 hours = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
02834                                 hours_seen = 1;
02835                                 continue;
02836                         }
02837                 }
02838                 if (!memcmp (p1, "mm", 2) && !minutes_seen) {
02839                         if (*p2 >= '0' && *p2 <= '9' &&
02840                             *(p2 + 1) >= '0' && *(p2 + 1) <= '9') {
02841                                 minutes = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
02842                                 minutes_seen = 1;
02843                                 continue;
02844                         }
02845                 }
02846                 if (!memcmp (p1, "ss", 2) && !seconds_seen) {
02847                         if (*p2 >= '0' && *p2 <= '9' &&
02848                             *(p2 + 1) >= '0' && *(p2 + 1) <= '9') {
02849                                 seconds = ((*p2 - '0') * 10) + (*(p2 + 1) - '0');
02850                                 seconds_seen = 1;
02851                                 continue;
02852                         }
02853                 }
02854         }
02855         if (hours_seen && minutes_seen && seconds_seen) {
02856                 seconds += (hours * 3600) + (minutes * 60);
02857         } else {
02858                 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
02859                 seconds = 0;
02860         }
02861         cob_set_int (curr_field, seconds);
02862         return curr_field;
02863 }
02864 
02865 cob_field *
02866 cob_intr_locale_date (const int offset, const int length, 
02867                       cob_field *srcfield, cob_field *locale_field)
02868 {
02869         cob_field_attr  attr;
02870         cob_field       field;
02871 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
02872         size_t          len;
02873         int             indate;
02874         int             days;
02875         int             month;
02876         int             year;
02877 #ifdef  HAVE_LANGINFO_CODESET
02878         unsigned char   *p;
02879         char            *deflocale = NULL;
02880         char            *localep = NULL;
02881         char            *localep2;
02882         struct tm       tstruct;
02883         char            buff2[128];
02884 #else
02885         char            *p;
02886         LCID            localeid = LOCALE_USER_DEFAULT;
02887         SYSTEMTIME      syst;
02888 #endif
02889         char            buff[128];
02890 #endif
02891 
02892         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
02893         COB_FIELD_INIT (0, NULL, &attr);
02894         cob_exception_code = 0;
02895 
02896 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
02897         if (COB_FIELD_IS_NUMERIC (srcfield)) {
02898                 indate = cob_get_int (srcfield);
02899         } else {
02900                 if (srcfield->size < 8) {
02901                         goto derror;
02902                 }
02903                 p = srcfield->data;
02904                 indate = 0;
02905                 for (len = 0; len < 8; ++len, ++p) {
02906                         if (isdigit (*p)) {
02907                                 indate *= 10;
02908                                 indate += (*p - '0');
02909                         } else {
02910                                 goto derror;
02911                         }
02912                 }
02913         }
02914         year = indate / 10000;
02915         if (year < 1601 || year > 9999) {
02916                 goto derror;
02917         }
02918         indate %= 10000;
02919         month = indate / 100;
02920         if (month < 1 || month > 12) {
02921                 goto derror;
02922         }
02923         days = indate % 100;
02924         if (days < 1 || days > 31) {
02925                 goto derror;
02926         }
02927         if (leap_year (year)) {
02928                 if (days > leap_month_days[month]) {
02929                         goto derror;
02930                 }
02931         } else {
02932                 if (days > normal_month_days[month]) {
02933                         goto derror;
02934                 }
02935         }
02936 #ifdef  HAVE_LANGINFO_CODESET
02937         month--;
02938 
02939         memset ((void *)&tstruct, 0, sizeof(struct tm));
02940         tstruct.tm_year = year - 1900;
02941         tstruct.tm_mon = month;
02942         tstruct.tm_mday = days;
02943         if (locale_field) {
02944                 if (locale_field->size >= COB_SMALL_BUFF) {
02945                         goto derror;
02946                 }
02947                 cob_field_to_string (locale_field, locale_buff);
02948                 deflocale = locale_buff;
02949                 localep2 = setlocale (LC_TIME, NULL);
02950                 if (localep2) {
02951                         localep = strdup (localep2);
02952                 }
02953                 (void) setlocale (LC_TIME, deflocale);
02954         }
02955         memset (buff2, 0, sizeof(buff2));
02956         snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(D_FMT));
02957         if (deflocale) {
02958                 if (localep) {
02959                         (void) setlocale (LC_TIME, localep);
02960                 }
02961         }
02962         strftime (buff, sizeof(buff), buff2, &tstruct);
02963 #else
02964         memset ((void *)&syst, 0, sizeof(syst));
02965         syst.wYear = year;
02966         syst.wMonth = month;
02967         syst.wDay = days;
02968         if (locale_field) {
02969                 if (locale_field->size >= COB_SMALL_BUFF) {
02970                         goto derror;
02971                 }
02972                 cob_field_to_string (locale_field, locale_buff);
02973                 for (p = locale_buff; *p; ++p) {
02974                         if (isalnum(*p) || *p == '_') {
02975                                 continue;
02976                         }
02977                         break;
02978                 }
02979                 *p = 0;
02980                 for (len = 0; len < WINLOCSIZE; ++len) {
02981                         if (!strcmp(locale_buff, wintable[len].winlocalename)) {
02982                                 localeid = wintable[len].winlocaleid;
02983                                 break;
02984                         }
02985                 }
02986                 if (len == WINLOCSIZE) {
02987                         goto derror;
02988                 }
02989         }
02990         if (!GetDateFormat (localeid, DATE_SHORTDATE, &syst, NULL, buff, sizeof(buff))) {
02991                 goto derror;
02992         }
02993 #endif
02994         len = strlen (buff);
02995         field.size = len;
02996         make_field_entry (&field);
02997         memcpy (curr_field->data, buff, len);
02998         if (unlikely(offset > 0)) {
02999                 calc_ref_mod (curr_field, offset, length);
03000         }
03001         return curr_field;
03002 derror:
03003 #endif
03004         field.size = 10;
03005         make_field_entry (&field);
03006         memset (curr_field->data, ' ', 10);
03007         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
03008         return curr_field;
03009 }
03010 
03011 cob_field *
03012 cob_intr_locale_time (const int offset, const int length,
03013                       cob_field *srcfield, cob_field *locale_field)
03014 {
03015         cob_field_attr  attr;
03016         cob_field       field;
03017 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
03018         size_t          len;
03019         int             indate;
03020         int             hours;
03021         int             minutes;
03022         int             seconds;
03023 #ifdef  HAVE_LANGINFO_CODESET
03024         unsigned char   *p;
03025         char            *deflocale = NULL;
03026         char            *localep = NULL;
03027         char            *localep2;
03028         struct tm       tstruct;
03029         char            buff2[128];
03030 #else
03031         char            *p;
03032         LCID            localeid = LOCALE_USER_DEFAULT;
03033         SYSTEMTIME      syst;
03034 #endif
03035         char            buff[128];
03036 #endif
03037 
03038         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
03039         COB_FIELD_INIT (0, NULL, &attr);
03040         cob_exception_code = 0;
03041 
03042 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
03043         if (COB_FIELD_IS_NUMERIC (srcfield)) {
03044                 indate = cob_get_int (srcfield);
03045         } else {
03046                 if (srcfield->size < 6) {
03047                         goto derror;
03048                 }
03049                 p = srcfield->data;
03050                 indate = 0;
03051                 for (len = 0; len < 6; ++len, ++p) {
03052                         if (isdigit (*p)) {
03053                                 indate *= 10;
03054                                 indate += (*p - '0');
03055                         } else {
03056                                 goto derror;
03057                         }
03058                 }
03059         }
03060         hours = indate / 10000;
03061         if (hours < 0 || hours > 24) {
03062                 goto derror;
03063         }
03064         indate %= 10000;
03065         minutes = indate / 100;
03066         if (minutes < 0 || minutes > 59) {
03067                 goto derror;
03068         }
03069         seconds = indate % 100;
03070         if (seconds < 0 || seconds > 59) {
03071                 goto derror;
03072         }
03073 
03074 #ifdef  HAVE_LANGINFO_CODESET
03075         memset ((void *)&tstruct, 0, sizeof(struct tm));
03076         tstruct.tm_hour = hours;
03077         tstruct.tm_min = minutes;
03078         tstruct.tm_sec = seconds;
03079         if (locale_field) {
03080                 if (locale_field->size >= COB_SMALL_BUFF) {
03081                         goto derror;
03082                 }
03083                 cob_field_to_string (locale_field, locale_buff);
03084                 deflocale = locale_buff;
03085                 localep2 = setlocale (LC_TIME, NULL);
03086                 if (localep2) {
03087                         localep = strdup (localep2);
03088                 }
03089                 (void) setlocale (LC_TIME, deflocale);
03090         }
03091         memset (buff2, 0, sizeof(buff2));
03092         snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
03093         if (deflocale) {
03094                 if (localep) {
03095                         (void) setlocale (LC_TIME, localep);
03096                 }
03097         }
03098         strftime (buff, sizeof(buff), buff2, &tstruct);
03099 #else
03100         memset ((void *)&syst, 0, sizeof(syst));
03101         syst.wHour = hours;
03102         syst.wMinute = minutes;
03103         syst.wSecond = seconds;
03104         if (locale_field) {
03105                 if (locale_field->size >= COB_SMALL_BUFF) {
03106                         goto derror;
03107                 }
03108                 cob_field_to_string (locale_field, locale_buff);
03109                 for (p = locale_buff; *p; ++p) {
03110                         if (isalnum(*p) || *p == '_') {
03111                                 continue;
03112                         }
03113                         break;
03114                 }
03115                 *p = 0;
03116                 for (len = 0; len < WINLOCSIZE; ++len) {
03117                         if (!strcmp(locale_buff, wintable[len].winlocalename)) {
03118                                 localeid = wintable[len].winlocaleid;
03119                                 break;
03120                         }
03121                 }
03122                 if (len == WINLOCSIZE) {
03123                         goto derror;
03124                 }
03125         }
03126         if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {
03127 
03128                 goto derror;
03129         }
03130 #endif
03131         len = strlen (buff);
03132         field.size = len;
03133         make_field_entry (&field);
03134         memcpy (curr_field->data, buff, len);
03135         if (unlikely(offset > 0)) {
03136                 calc_ref_mod (curr_field, offset, length);
03137         }
03138         return curr_field;
03139 derror:
03140 #endif
03141         field.size = 10;
03142         make_field_entry (&field);
03143         memset (curr_field->data, ' ', 10);
03144         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
03145         return curr_field;
03146 }
03147 
03148 cob_field *
03149 cob_intr_lcl_time_from_secs (const int offset, const int length,
03150                              cob_field *srcfield, cob_field *locale_field)
03151 {
03152         cob_field_attr  attr;
03153         cob_field       field;
03154 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
03155         size_t          len;
03156         int             indate;
03157         int             hours;
03158         int             minutes;
03159         int             seconds;
03160 #ifdef  HAVE_LANGINFO_CODESET
03161         char            *deflocale = NULL;
03162         char            *localep = NULL;
03163         char            *localep2;
03164         struct tm       tstruct;
03165         char            buff2[128];
03166 #else
03167         char            *p;
03168         LCID            localeid = LOCALE_USER_DEFAULT;
03169         SYSTEMTIME      syst;
03170 #endif
03171         char            buff[128];
03172 #endif
03173 
03174         COB_ATTR_INIT (COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL);
03175         COB_FIELD_INIT (0, NULL, &attr);
03176         cob_exception_code = 0;
03177 
03178 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
03179         if (COB_FIELD_IS_NUMERIC (srcfield)) {
03180                 indate = cob_get_int (srcfield);
03181         } else {
03182                 goto derror;
03183         }
03184         if (indate > 86400) {
03185                 goto derror;
03186         }
03187         hours = indate / 3600;
03188         indate %= 3600;
03189         minutes = indate / 60;
03190         seconds = indate % 60;
03191 
03192 #ifdef  HAVE_LANGINFO_CODESET
03193         memset ((void *)&tstruct, 0, sizeof(struct tm));
03194         tstruct.tm_hour = hours;
03195         tstruct.tm_min = minutes;
03196         tstruct.tm_sec = seconds;
03197         if (locale_field) {
03198                 if (locale_field->size >= COB_SMALL_BUFF) {
03199                         goto derror;
03200                 }
03201                 cob_field_to_string (locale_field, locale_buff);
03202                 deflocale = locale_buff;
03203                 localep2 = setlocale (LC_TIME, NULL);
03204                 if (localep2) {
03205                         localep = strdup (localep2);
03206                 }
03207                 (void) setlocale (LC_TIME, deflocale);
03208         }
03209         memset (buff2, 0, sizeof(buff2));
03210         snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(T_FMT));
03211         if (deflocale) {
03212                 if (localep) {
03213                         (void) setlocale (LC_TIME, localep);
03214                 }
03215         }
03216         strftime (buff, sizeof(buff), buff2, &tstruct);
03217 #else
03218         memset ((void *)&syst, 0, sizeof(syst));
03219         syst.wHour = hours;
03220         syst.wMinute = minutes;
03221         syst.wSecond = seconds;
03222         if (locale_field) {
03223                 if (locale_field->size >= COB_SMALL_BUFF) {
03224                         goto derror;
03225                 }
03226                 cob_field_to_string (locale_field, locale_buff);
03227                 for (p = locale_buff; *p; ++p) {
03228                         if (isalnum(*p) || *p == '_') {
03229                                 continue;
03230                         }
03231                         break;
03232                 }
03233                 *p = 0;
03234                 for (len = 0; len < WINLOCSIZE; ++len) {
03235                         if (!strcmp(locale_buff, wintable[len].winlocalename)) {
03236                                 localeid = wintable[len].winlocaleid;
03237                                 break;
03238                         }
03239                 }
03240                 if (len == WINLOCSIZE) {
03241                         goto derror;
03242                 }
03243         }
03244         if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff, sizeof(buff))) {
03245 
03246                 goto derror;
03247         }
03248 #endif
03249         len = strlen (buff);
03250         field.size = len;
03251         make_field_entry (&field);
03252         memcpy (curr_field->data, buff, len);
03253         if (unlikely(offset > 0)) {
03254                 calc_ref_mod (curr_field, offset, length);
03255         }
03256         return curr_field;
03257 derror:
03258 #endif
03259         field.size = 10;
03260         make_field_entry (&field);
03261         memset (curr_field->data, ' ', 10);
03262         cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
03263         return curr_field;
03264 }
03265 
03266 /* Initialization routine */
03267 
03268 void
03269 cob_init_intrinsic (void)
03270 {
03271         size_t          i;
03272 
03273         cob_decimal_init (&d1);
03274         cob_decimal_init (&d2);
03275         cob_decimal_init (&d3);
03276         cob_decimal_init (&d4);
03277         cob_decimal_init (&d5);
03278         /* mpz_init2 (mp, 256); */
03279         memset ((char *)&calc_field[0], 0, sizeof (calc_field));
03280         memset ((char *)&calc_attr[0], 0, sizeof (calc_attr));
03281         for (i = 0; i < DEPTH_LEVEL; ++i) {
03282                 calc_field[i].data = cob_malloc (256);
03283                 calc_field[i].size = 256;
03284                 calc_size[i] = 256;
03285         }
03286         locale_buff = cob_malloc (COB_SMALL_BUFF);
03287 }
 All Data Structures Files Functions Variables Typedefs Enumerations Enumerator Defines