|
OpenCOBOL 1.1pre-rel
|
|
OpenCOBOL 1.1pre-rel
|
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 }
1.7.4
