1 /*
2 Copyright (C) 2005-2012, 2014-2020 Free Software Foundation, Inc.
3 Written by Roger While, Simon Sobisch, Edward Hart, Brian Tiffin
4
5 This file is part of GnuCOBOL.
6
7 The GnuCOBOL runtime library is free software: you can redistribute it
8 and/or modify it under the terms of the GNU Lesser General Public License
9 as published by the Free Software Foundation, either version 3 of the
10 License, or (at your option) any later version.
11
12 GnuCOBOL is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU Lesser General Public License for more details.
16
17 You should have received a copy of the GNU Lesser General Public License
18 along with GnuCOBOL. If not, see <https://www.gnu.org/licenses/>.
19 */
20
21
22 #include <config.h>
23
24 #include <stdio.h>
25 #include <stdlib.h>
26 #include <stddef.h>
27 #include <stdarg.h>
28 #include <string.h>
29 #include <ctype.h>
30 #include <errno.h>
31 #include <time.h>
32 #ifdef HAVE_SYS_TIME_H
33 #include <sys/time.h>
34 #endif
35 #include <math.h>
36
37 /* Note we include the Cygwin version of windows.h here */
38 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
39 #define LOCTIME_BUFSIZE 128
40
41 #if defined(_WIN32) || defined(__CYGWIN__)
42 #undef HAVE_LANGINFO_CODESET
43 #define WIN32_LEAN_AND_MEAN
44 #include <windows.h>
45 #endif
46
47 #ifdef HAVE_LANGINFO_CODESET
48 #include <langinfo.h>
49 #endif
50 #endif
51
52 #ifdef HAVE_LOCALE_H
53 #include <locale.h>
54 #endif
55
56 /* Force symbol exports, include decimal definitions */
57 #define COB_LIB_EXPIMP
58 #ifdef HAVE_GMP_H
59 #include <gmp.h>
60 #elif defined HAVE_MPIR_H
61 #include <mpir.h>
62 #else
63 #error either HAVE_GMP_H or HAVE_MPIR_H needs to be defined
64 #endif
65 #include "libcob.h"
66 #include "coblocal.h"
67
68 /* Function prototypes */
69 static cob_u32_t integer_of_date (const int, const int, const int);
70 static void get_iso_week (const int, int *, int *);
71
72 /* Local variables */
73
74 static cob_global *cobglobptr;
75
76 static const cob_field_attr const_alpha_attr =
77 {COB_TYPE_ALPHANUMERIC, 0, 0, 0, NULL};
78
79 /* Working fields */
80 static cob_field *move_field;
81
82 static cob_decimal d1;
83 static cob_decimal d2;
84 static cob_decimal d3;
85 static cob_decimal d4;
86 static cob_decimal d5;
87
88 static mpz_t cob_mexp;
89 static mpz_t cob_mpzt;
90
91 static mpf_t cob_mpft;
92 static mpf_t cob_mpft2;
93 static mpf_t cob_mpft_get;
94 static mpf_t cob_log_half;
95 static mpf_t cob_sqrt_two;
96 static mpf_t cob_pi;
97
98
99 /* Stack definitions for created fields */
100
101 struct calc_struct {
102 cob_field calc_field;
103 cob_field_attr calc_attr;
104 size_t calc_size;
105 };
106
107 static struct calc_struct *calc_base;
108 static cob_field *curr_field;
109 static cob_u32_t curr_entry;
110
111 /* Constants for date/day calculations */
112 static const int normal_days[] =
113 {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365};
114 static const int leap_days[] =
115 {0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366};
116 static const int normal_month_days[] =
117 {0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
118 static const int leap_month_days[] =
119 {0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
120
121
122 #define COB_DATESTR_LEN 11
123 #define COB_DATESTR_MAX (COB_DATESTR_LEN - 1)
124
125 #define COB_TIMEDEC_MAX 9
126
127 #define COB_TIMESTR_LEN 26 /* including max decimal places */
128 #define COB_TIMESTR_MAX (COB_TIMESTR_LEN - 1)
129
130 #define COB_DATETIMESTR_LEN 37
131 #define COB_DATETIMESTR_MAX (COB_DATETIMESTR_LEN - 1)
132
133 /* Locale name to Locale ID table */
134 #if defined(_WIN32) || defined(__CYGWIN__)
135
136 struct winlocale {
137 const char *winlocalename;
138 const int winlocaleid;
139 };
140
141 static const struct winlocale wintable[] =
142 {
143 { "af_ZA", 0x0436 },
144 { "am_ET", 0x045e },
145 { "ar_AE", 0x3801 },
146 { "ar_BH", 0x3c01 },
147 { "ar_DZ", 0x1401 },
148 { "ar_EG", 0x0c01 },
149 { "ar_IQ", 0x0801 },
150 { "ar_JO", 0x2c01 },
151 { "ar_KW", 0x3401 },
152 { "ar_LB", 0x3001 },
153 { "ar_LY", 0x1001 },
154 { "ar_MA", 0x1801 },
155 { "ar_OM", 0x2001 },
156 { "ar_QA", 0x4001 },
157 { "ar_SA", 0x0401 },
158 { "ar_SY", 0x2801 },
159 { "ar_TN", 0x1c01 },
160 { "ar_YE", 0x2401 },
161 { "arn_CL", 0x047a },
162 { "as_IN", 0x044d },
163 { "az_Cyrl_AZ", 0x082c },
164 { "az_Latn_AZ", 0x042c },
165 { "ba_RU", 0x046d },
166 { "be_BY", 0x0423 },
167 { "bg_BG", 0x0402 },
168 { "bn_IN", 0x0445 },
169 { "bo_BT", 0x0851 },
170 { "bo_CN", 0x0451 },
171 { "br_FR", 0x047e },
172 { "bs_Cyrl_BA", 0x201a },
173 { "bs_Latn_BA", 0x141a },
174 { "ca_ES", 0x0403 },
175 { "cs_CZ", 0x0405 },
176 { "cy_GB", 0x0452 },
177 { "da_DK", 0x0406 },
178 { "de_AT", 0x0c07 },
179 { "de_CH", 0x0807 },
180 { "de_DE", 0x0407 },
181 { "de_LI", 0x1407 },
182 { "de_LU", 0x1007 },
183 { "dsb_DE", 0x082e },
184 { "dv_MV", 0x0465 },
185 { "el_GR", 0x0408 },
186 { "en_029", 0x2409 },
187 { "en_AU", 0x0c09 },
188 { "en_BZ", 0x2809 },
189 { "en_CA", 0x1009 },
190 { "en_GB", 0x0809 },
191 { "en_IE", 0x1809 },
192 { "en_IN", 0x4009 },
193 { "en_JM", 0x2009 },
194 { "en_MY", 0x4409 },
195 { "en_NZ", 0x1409 },
196 { "en_PH", 0x3409 },
197 { "en_SG", 0x4809 },
198 { "en_TT", 0x2c09 },
199 { "en_US", 0x0409 },
200 { "en_ZA", 0x1c09 },
201 { "en_ZW", 0x3009 },
202 { "es_AR", 0x2c0a },
203 { "es_BO", 0x400a },
204 { "es_CL", 0x340a },
205 { "es_CO", 0x240a },
206 { "es_CR", 0x140a },
207 { "es_DO", 0x1c0a },
208 { "es_EC", 0x300a },
209 { "es_ES", 0x040a },
210 { "es_GT", 0x100a },
211 { "es_HN", 0x480a },
212 { "es_MX", 0x080a },
213 { "es_NI", 0x4c0a },
214 { "es_PA", 0x180a },
215 { "es_PE", 0x280a },
216 { "es_PR", 0x500a },
217 { "es_PY", 0x3c0a },
218 { "es_SV", 0x440a },
219 { "es_US", 0x540a },
220 { "es_UY", 0x380a },
221 { "es_VE", 0x200a },
222 { "et_EE", 0x0425 },
223 { "eu_ES", 0x042d },
224 { "fa_IR", 0x0429 },
225 { "fi_FI", 0x040b },
226 { "fil_PH", 0x0464 },
227 { "fo_FO", 0x0438 },
228 { "fr_BE", 0x080c },
229 { "fr_CA", 0x0c0c },
230 { "fr_CH", 0x100c },
231 { "fr_FR", 0x040c },
232 { "fr_LU", 0x140c },
233 { "fr_MC", 0x180c },
234 { "fy_NL", 0x0462 },
235 { "ga_IE", 0x083c },
236 { "gbz_AF", 0x048c },
237 { "gd", 0x043c },
238 { "gl_ES", 0x0456 },
239 { "gsw_FR", 0x0484 },
240 { "gu_IN", 0x0447 },
241 { "ha_Latn_NG", 0x0468 },
242 { "he_IL", 0x040d },
243 { "hi_IN", 0x0439 },
244 { "hr_BA", 0x101a },
245 { "hr_HR", 0x041a },
246 { "hu_HU", 0x040e },
247 { "hy_AM", 0x042b },
248 { "id_ID", 0x0421 },
249 { "ig_NG", 0x0470 },
250 { "ii_CN", 0x0478 },
251 { "is_IS", 0x040f },
252 { "it_CH", 0x0810 },
253 { "it_IT", 0x0410 },
254 { "iu_Cans_CA", 0x045d },
255 { "iu_Latn_CA", 0x085d },
256 { "ja_JP", 0x0411 },
257 { "ka_GE", 0x0437 },
258 { "kh_KH", 0x0453 },
259 { "kk_KZ", 0x043f },
260 { "kl_GL", 0x046f },
261 { "kn_IN", 0x044b },
262 { "ko_KR", 0x0412 },
263 { "kok_IN", 0x0457 },
264 { "ky_KG", 0x0440 },
265 { "lb_LU", 0x046e },
266 { "lo_LA", 0x0454 },
267 { "lt_LT", 0x0427 },
268 { "lv_LV", 0x0426 },
269 { "mi_NZ", 0x0481 },
270 { "mk_MK", 0x042f },
271 { "ml_IN", 0x044c },
272 { "mn_Cyrl_MN", 0x0450 },
273 { "mn_Mong_CN", 0x0850 },
274 { "moh_CA", 0x047c },
275 { "mr_IN", 0x044e },
276 { "ms_BN", 0x083e },
277 { "ms_MY", 0x043e },
278 { "mt_MT", 0x043a },
279 { "nb_NO", 0x0414 },
280 { "ne_NP", 0x0461 },
281 { "nl_BE", 0x0813 },
282 { "nl_NL", 0x0413 },
283 { "nn_NO", 0x0814 },
284 { "ns_ZA", 0x046c },
285 { "oc_FR", 0x0482 },
286 { "or_IN", 0x0448 },
287 { "pa_IN", 0x0446 },
288 { "pl_PL", 0x0415 },
289 { "ps_AF", 0x0463 },
290 { "pt_BR", 0x0416 },
291 { "pt_PT", 0x0816 },
292 { "qut_GT", 0x0486 },
293 { "quz_BO", 0x046b },
294 { "quz_EC", 0x086b },
295 { "quz_PE", 0x0c6b },
296 { "rm_CH", 0x0417 },
297 { "ro_MO", 0x0818 },
298 { "ro_RO", 0x0418 },
299 { "ru_MO", 0x0819 },
300 { "ru_RU", 0x0419 },
301 { "rw_RW", 0x0487 },
302 { "sa_IN", 0x044f },
303 { "sah_RU", 0x0485 },
304 { "se_FI", 0x0c3b },
305 { "se_NO", 0x043b },
306 { "se_SE", 0x083b },
307 { "si_LK", 0x045b },
308 { "sk_SK", 0x041b },
309 { "sl_SI", 0x0424 },
310 { "sma_NO", 0x183b },
311 { "sma_SE", 0x1c3b },
312 { "smj_NO", 0x103b },
313 { "smj_SE", 0x143b },
314 { "smn_FI", 0x243b },
315 { "sms_FI", 0x203b },
316 { "sq_AL", 0x041c },
317 { "sr_Cyrl_BA", 0x1c1a },
318 { "sr_Cyrl_CS", 0x0c1a },
319 { "sr_Latn_BA", 0x181a },
320 { "sr_Latn_CS", 0x081a },
321 { "st", 0x0430 },
322 { "sv_FI", 0x081d },
323 { "sv_SE", 0x041d },
324 { "sw_KE", 0x0441 },
325 { "syr_SY", 0x045a },
326 { "ta_IN", 0x0449 },
327 { "te_IN", 0x044a },
328 { "tg_Cyrl_TJ", 0x0428 },
329 { "th_TH", 0x041e },
330 { "tk_TM", 0x0442 },
331 { "tmz_Latn_DZ", 0x085f },
332 { "tn_ZA", 0x0432 },
333 { "tr_IN", 0x0820 },
334 { "tr_TR", 0x041f },
335 { "ts", 0x0431 },
336 { "tt_RU", 0x0444 },
337 { "ug_CN", 0x0480 },
338 { "uk_UA", 0x0422 },
339 { "ur_PK", 0x0420 },
340 { "uz_Cyrl_UZ", 0x0843 },
341 { "uz_Latn_UZ", 0x0443 },
342 { "vi_VN", 0x042a },
343 { "wen_DE", 0x042e },
344 { "wo_SN", 0x0488 },
345 { "xh_ZA", 0x0434 },
346 { "yi", 0x043d },
347 { "yo_NG", 0x046a },
348 { "zh_CN", 0x0804 },
349 { "zh_HK", 0x0c04 },
350 { "zh_MO", 0x1404 },
351 { "zh_SG", 0x1004 },
352 { "zh_TW", 0x0404 },
353 { "zu_ZA", 0x0435 }
354 };
355
356 #define WINLOCSIZE sizeof(wintable) / sizeof(struct winlocale)
357
358 #endif
359
360
361 /* Pi - Next 3 digits 000 */
362 static const char cob_pi_str[] =
363 "3.141592653589793238462643383279502884197169399375"
364 "10582097494459230781640628620899862803482534211706"
365 "79821480865132823066470938446095505822317253594081"
366 "28481117450284102701938521105559644622948954930381"
367 "96442881097566593344612847564823378678316527120190"
368 "91456485669234603486104543266482133936072602491412"
369 "73724587006606315588174881520920962829254091715364"
370 "36789259036001133053054882046652138414695194151160"
371 "94330572703657595919530921861173819326117931051185"
372 "48074462379962749567351885752724891227938183011949"
373 "12983367336244065664308602139494639522473719070217"
374 "98609437027705392171762931767523846748184676694051"
375 "32000568127145263560827785771342757789609173637178"
376 "72146844090122495343014654958537105079227968925892"
377 "35420199561121290219608640344181598136297747713099"
378 "60518707211349999998372978049951059731732816096318"
379 "59502445945534690830264252230825334468503526193118"
380 "817101";
381 /* Sqrt 2 - Next 3 digits 001 */
382 static const char cob_sqrt_two_str[] =
383 "1.414213562373095048801688724209698078569671875376"
384 "94807317667973799073247846210703885038753432764157"
385 "27350138462309122970249248360558507372126441214970"
386 "99935831413222665927505592755799950501152782060571"
387 "47010955997160597027453459686201472851741864088919"
388 "86095523292304843087143214508397626036279952514079"
389 "89687253396546331808829640620615258352395054745750"
390 "28775996172983557522033753185701135437460340849884"
391 "71603868999706990048150305440277903164542478230684"
392 "92936918621580578463111596668713013015618568987237"
393 "23528850926486124949771542183342042856860601468247"
394 "20771435854874155657069677653720226485447015858801"
395 "62075847492265722600208558446652145839889394437092"
396 "65918003113882464681570826301005948587040031864803"
397 "42194897278290641045072636881313739855256117322040"
398 "24509122770022694112757362728049573810896750401836"
399 "98683684507257993647290607629969413804756548237289"
400 "97180326802474420629269124859052181004459842150591"
401 "12024944134172853147810580360337107730918286931471"
402 "01711116839165817268894197587165821521282295184884"
403 "72089694633862891562882765952635140542267653239694"
404 "61751129160240871551013515045538128756005263146801"
405 "71274026539694702403005174953188629256313851881634"
406 "78";
407 /* Log 0.5 - Next 3 digits 000 */
408 static const char cob_log_half_str[] =
409 "-0.69314718055994530941723212145817656807550013436"
410 "02552541206800094933936219696947156058633269964186"
411 "87542001481020570685733685520235758130557032670751"
412 "63507596193072757082837143519030703862389167347112"
413 "33501153644979552391204751726815749320651555247341"
414 "39525882950453007095326366642654104239157814952043"
415 "74043038550080194417064167151864471283996817178454"
416 "69570262716310645461502572074024816377733896385506"
417 "95260668341137273873722928956493547025762652098859"
418 "69320196505855476470330679365443254763274495125040"
419 "60694381471046899465062201677204245245296126879465"
420 "46193165174681392672504103802546259656869144192871"
421 "60829380317271436778265487756648508567407764845146"
422 "44399404614226031930967354025744460703080960850474"
423 "86638523138181676751438667476647890881437141985494"
424 "23151997354880375165861275352916610007105355824987"
425 "94147295092931138971559982056543928717";
426
427 /* mpf_init2 length = ceil (log2 (10) * strlen (x)) */
428 #define COB_PI_LEN 2820UL
429 #define COB_SQRT_TWO_LEN 3827UL
430 #define COB_LOG_HALF_LEN 2784UL
431
432 #define RETURN_IF_NOT_ZERO(expr) \
433 do { \
434 int error_pos = (expr); \
435 if (error_pos != 0) { \
436 return error_pos; \
437 } \
438 } ONCE_COB
439
440 /* Local functions */
441
442 static void
make_field_entry(cob_field * f)443 make_field_entry (cob_field *f)
444 {
445 unsigned char *s;
446 struct calc_struct *calc_temp;
447
448 calc_temp = calc_base + curr_entry;
449 curr_field = &calc_temp->calc_field;
450 if (f->size > calc_temp->calc_size) {
451 if (curr_field->data) {
452 cob_free (curr_field->data);
453 }
454 calc_temp->calc_size = f->size + 1;
455 s = cob_malloc (f->size + 1U);
456 } else {
457 s = curr_field->data;
458 memset (s, 0, f->size);
459 }
460
461 *curr_field = *f;
462 calc_temp->calc_attr = *(f->attr);
463 curr_field->attr = &calc_temp->calc_attr;
464
465 curr_field->data = s;
466
467 if (++curr_entry >= COB_DEPTH_LEVEL) {
468 curr_entry = 0;
469 }
470 }
471
472 static int
leap_year(const int year)473 leap_year (const int year)
474 {
475 return ((year % 4 == 0 && year % 100 != 0) || (year % 400 == 0)) ? 1 : 0;
476 }
477
478 static int
comp_field(const void * m1,const void * m2)479 comp_field (const void *m1, const void *m2)
480 {
481 cob_field *f1;
482 cob_field *f2;
483
484 f1 = *(cob_field **) m1;
485 f2 = *(cob_field **) m2;
486 return cob_cmp (f1, f2);
487 }
488
489 /* Reference modification */
490 static void
calc_ref_mod(cob_field * f,const int offset,const int length)491 calc_ref_mod (cob_field *f, const int offset, const int length)
492 {
493 size_t calcoff;
494 size_t size;
495
496 if ((size_t)offset <= f->size) {
497 calcoff = (size_t)offset - 1;
498 size = f->size - calcoff;
499 if (length > 0 && (size_t)length < size) {
500 size = (size_t)length;
501 }
502 f->size = size;
503 if (calcoff > 0) {
504 memmove (f->data, f->data + calcoff, size);
505 }
506 }
507 }
508
509 /* Decimal <-> Decimal */
510
511 static COB_INLINE COB_A_INLINE void
cob_decimal_set(cob_decimal * dst,const cob_decimal * src)512 cob_decimal_set (cob_decimal *dst, const cob_decimal *src)
513 {
514 mpz_set (dst->value, src->value);
515 dst->scale = src->scale;
516 }
517
518 /* Trim trailing zeros in decimal places */
519 static void
cob_trim_decimal(cob_decimal * d)520 cob_trim_decimal (cob_decimal *d)
521 {
522 if (!mpz_sgn (d->value)) {
523 /* Value is zero */
524 d->scale = 0;
525 return;
526 }
527 for ( ; d->scale > 0; d->scale--) {
528 if (!mpz_divisible_ui_p (d->value, 10UL)) {
529 break;
530 }
531 mpz_tdiv_q_ui (d->value, d->value, 10UL);
532 }
533 }
534
535 static void
cob_alloc_set_field_int(const int val)536 cob_alloc_set_field_int (const int val)
537 {
538 cob_u16_t attrsign;
539 cob_field_attr attr;
540 cob_field field;
541
542 if (val < 0) {
543 attrsign = COB_FLAG_HAVE_SIGN;
544 } else {
545 attrsign = 0;
546 }
547 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
548 0, attrsign, NULL);
549 COB_FIELD_INIT (4, NULL, &attr);
550 make_field_entry (&field);
551 memcpy (curr_field->data, &val, sizeof(int));
552 }
553
554 static void
cob_alloc_set_field_uint(const cob_u32_t val)555 cob_alloc_set_field_uint (const cob_u32_t val)
556 {
557 cob_field_attr attr;
558 cob_field field;
559
560 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
561 0, 0, NULL);
562 COB_FIELD_INIT (4, NULL, &attr);
563 make_field_entry (&field);
564 memcpy (curr_field->data, &val, sizeof(cob_u32_t));
565 }
566
567 static void
cob_alloc_field(cob_decimal * d)568 cob_alloc_field (cob_decimal *d)
569 {
570 size_t bitnum;
571 size_t sign;
572 unsigned short attrsign;
573 short size, scale;
574 cob_field_attr attr;
575 cob_field field;
576
577 if (unlikely (d->scale == COB_DECIMAL_NAN)) {
578 /* Check this */
579 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
580 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
581 0, 0, NULL);
582 COB_FIELD_INIT (4, NULL, &attr);
583 make_field_entry (&field);
584 return;
585 }
586
587 if (mpz_sgn (d->value) < 0) {
588 attrsign = COB_FLAG_HAVE_SIGN;
589 sign = 1;
590 } else {
591 attrsign = 0;
592 sign = 0;
593 }
594
595 cob_trim_decimal (d);
596
597 bitnum = mpz_sizeinbase (d->value, 2);
598 if (bitnum < (33 - sign) && d->scale < 10) {
599 /* 4 bytes binary */
600 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 9,
601 (short)d->scale, attrsign, NULL);
602 COB_FIELD_INIT (4, NULL, &attr);
603 make_field_entry (&field);
604 } else if (bitnum < (65 - sign) && d->scale < 19) {
605 /* 8 bytes binary */
606 COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, 20,
607 (short)d->scale, attrsign, NULL);
608 COB_FIELD_INIT (8, NULL, &attr);
609 make_field_entry (&field);
610 } else {
611 /* Display decimal */
612 size = (short)mpz_sizeinbase (d->value, 10);
613 if (d->scale > size) {
614 size = (short)d->scale;
615 }
616 scale = (short)d->scale;
617 COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, size,
618 scale, attrsign, NULL);
619 COB_FIELD_INIT (size, NULL, &attr);
620 make_field_entry (&field);
621 }
622 }
623
624 /* Common function for intrinsics MOD and REM */
625
626 static cob_field *
cob_mod_or_rem(cob_field * f1,cob_field * f2,const int func_is_rem)627 cob_mod_or_rem (cob_field *f1, cob_field *f2, const int func_is_rem)
628 {
629 int sign;
630
631 cobglobptr->cob_exception_code = 0;
632 cob_decimal_set_field (&d2, f1);
633 cob_decimal_set_field (&d3, f2);
634
635 if (!mpz_sgn (d3.value)) {
636 /* function argument violation */
637 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
638 cob_alloc_set_field_uint (0);
639 return curr_field;
640 }
641
642 cob_decimal_div (&d2, &d3);
643
644 /* Calculate integer / integer-part */
645 if (d2.scale < 0) {
646 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d2.scale);
647 mpz_mul (d2.value, d2.value, cob_mexp);
648 } else if (d2.scale > 0) {
649 sign = mpz_sgn (d2.value);
650 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d2.scale);
651 if (func_is_rem) {
652 /* REMAINDER function - INTEGER-PART */
653 mpz_tdiv_q (d2.value, d2.value, cob_mexp);
654 } else {
655 /* MOD function - INTEGER */
656 mpz_tdiv_qr (d2.value, cob_mpzt, d2.value, cob_mexp);
657 /* Check negative and has decimal places */
658 if (sign < 0 && mpz_sgn (cob_mpzt)) {
659 mpz_sub_ui (d2.value, d2.value, 1UL);
660 }
661 }
662 }
663 d2.scale = 0;
664
665 cob_decimal_set_field (&d1, f2);
666 cob_decimal_mul (&d2, &d1);
667 cob_decimal_set_field (&d1, f1);
668 cob_decimal_sub (&d1, &d2);
669
670 cob_alloc_field (&d1);
671 (void)cob_decimal_get_field (&d1, curr_field, 0);
672 return curr_field;
673 }
674
675 /* Validate NUMVAL-F item */
676 /* sp = spaces */
677 /* [sp][+|-][sp]{digits[.[digits]]|.digits}[sp][E[sp]{+|-}[sp]digits[sp]] */
678
679 int
cob_check_numval_f(const cob_field * srcfield)680 cob_check_numval_f (const cob_field *srcfield)
681 {
682 unsigned char *p;
683 size_t plus_minus;
684 size_t digits;
685 size_t dec_seen;
686 size_t space_seen;
687 size_t e_seen;
688 size_t break_needed;
689 size_t exponent;
690 size_t e_plus_minus;
691 int n;
692 unsigned char dec_pt;
693
694 if (!srcfield->size) {
695 return 1;
696 }
697 p = srcfield->data;
698 plus_minus = 0;
699 digits = 0;
700 dec_seen = 0;
701 space_seen = 0;
702 e_seen = 0;
703 break_needed = 0;
704 exponent = 0;
705 e_plus_minus = 0;
706 dec_pt = COB_MODULE_PTR->decimal_point;
707
708 /* Check leading positions */
709 for (n = 0; n < (int)srcfield->size; ++n, ++p) {
710 switch (*p) {
711 case '0':
712 case '1':
713 case '2':
714 case '3':
715 case '4':
716 case '5':
717 case '6':
718 case '7':
719 case '8':
720 case '9':
721 break_needed = 1;
722 break;
723 case ' ':
724 continue;
725 case '+':
726 case '-':
727 if (plus_minus) {
728 return n + 1;
729 }
730 plus_minus = 1;
731 continue;
732 case ',':
733 case '.':
734 if (*p != dec_pt) {
735 return n + 1;
736 }
737 break_needed = 1;
738 break;
739 default:
740 return n + 1;
741 }
742 if (break_needed) {
743 break;
744 }
745 }
746
747 if (n == (int)srcfield->size) {
748 return n + 1;
749 }
750
751 for (; n < (int)srcfield->size; ++n, ++p) {
752 switch (*p) {
753 case '0':
754 case '1':
755 case '2':
756 case '3':
757 case '4':
758 case '5':
759 case '6':
760 case '7':
761 case '8':
762 case '9':
763 if (e_seen) {
764 if (++exponent > 4 || !e_plus_minus) {
765 return n + 1;
766 }
767 } else if (++digits > COB_MAX_DIGITS || space_seen) {
768 return n + 1;
769 }
770 continue;
771 case ',':
772 case '.':
773 if (dec_seen || space_seen || e_seen) {
774 return n + 1;
775 }
776 if (*p == dec_pt) {
777 dec_seen = 1;
778 continue;
779 }
780 return n + 1;
781 case ' ':
782 space_seen = 1;
783 continue;
784 case 'E':
785 if (e_seen) {
786 return n + 1;
787 }
788 e_seen = 1;
789 continue;
790 case '+':
791 case '-':
792 if (e_seen) {
793 if (e_plus_minus) {
794 return n + 1;
795 }
796 e_plus_minus = 1;
797 } else {
798 if (plus_minus) {
799 return n + 1;
800 }
801 plus_minus = 1;
802 }
803 continue;
804 default:
805 return n + 1;
806 }
807 }
808
809 if (!digits || (e_seen && !exponent)) {
810 return n + 1;
811 }
812
813 return 0;
814 }
815
816 /* Decimal <-> GMP float */
817
818 static void
cob_decimal_set_mpf(cob_decimal * d,const mpf_t src)819 cob_decimal_set_mpf (cob_decimal *d, const mpf_t src)
820 {
821 char *p;
822 char *q;
823 cob_sli_t scale;
824 cob_sli_t len;
825
826 if (!mpf_sgn (src)) {
827 mpz_set_ui (d->value, 0UL);
828 d->scale = 0;
829 return;
830 }
831 q = mpf_get_str (NULL, &scale, 10, (size_t)96, src);
832 p = q;
833 mpz_set_str (d->value, p, 10);
834 if (*p == '-') {
835 ++p;
836 }
837 len = (cob_sli_t)strlen (p);
838 cob_gmp_free (q);
839 len -= scale;
840 if (len >= 0) {
841 d->scale = len;
842 } else {
843 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-len);
844 mpz_mul (d->value, d->value, cob_mexp);
845 d->scale = 0;
846 }
847 }
848
849 static void
cob_decimal_get_mpf(mpf_t dst,const cob_decimal * d)850 cob_decimal_get_mpf (mpf_t dst, const cob_decimal *d)
851 {
852 cob_sli_t scale;
853
854 mpf_set_z (dst, d->value);
855 scale = d->scale;
856 if (scale < 0) {
857 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-scale);
858 mpf_set_z (cob_mpft_get, cob_mexp);
859 mpf_mul (dst, dst, cob_mpft_get);
860 } else if (scale > 0) {
861 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)scale);
862 mpf_set_z (cob_mpft_get, cob_mexp);
863 mpf_div (dst, dst, cob_mpft_get);
864 }
865 }
866
867 /* Trigonometric formulae (formulas?) from Wikipedia */
868
869
870 /* Exp function */
871 /* e ^ x = {n = 0, ...} ( (x ^ n) / n! ) */
872
873 static void
cob_mpf_exp(mpf_t dst_val,const mpf_t src_val)874 cob_mpf_exp (mpf_t dst_val, const mpf_t src_val)
875 {
876 mpf_t vf1, vf2, vf3;
877 mpf_t dst_temp;
878 cob_sli_t expon, i;
879 cob_uli_t n;
880 cob_u32_t is_negative;
881
882
883 mpf_init2 (dst_temp, COB_MPF_PREC);
884
885 mpf_init2 (vf1, COB_MPF_PREC);
886 mpf_set (vf1, src_val);
887 mpf_init2 (vf2, COB_MPF_PREC);
888 mpf_set_ui (vf2, 1UL);
889 mpf_init2 (vf3, COB_MPF_PREC);
890
891 mpf_set_ui (dst_temp, 1UL);
892
893 if (mpf_sgn (vf1) < 0) {
894 mpf_neg (vf1, vf1);
895 is_negative = 1;
896 } else {
897 is_negative = 0;
898 }
899
900 mpf_get_d_2exp (&expon, vf1);
901 if (expon > 0) {
902 mpf_div_2exp (vf1, vf1, (cob_uli_t)expon);
903 }
904
905 n = 1;
906 do {
907 mpf_mul (vf2, vf2, vf1);
908 mpf_div_ui (vf2, vf2, (cob_uli_t)n);
909 mpf_set (vf3, dst_temp);
910 mpf_add (dst_temp, dst_temp, vf2);
911 ++n;
912 } while (!mpf_eq (vf3, dst_temp, COB_MPF_CUTOFF));
913
914 for (i = 0; i < expon; ++i) {
915 mpf_mul (dst_temp, dst_temp, dst_temp);
916 }
917
918 if (is_negative) {
919 mpf_ui_div (dst_temp, 1UL, dst_temp);
920 }
921
922 mpf_set (dst_val, dst_temp);
923 mpf_clear (dst_temp);
924
925 mpf_clear (vf3);
926 mpf_clear (vf2);
927 mpf_clear (vf1);
928 }
929
930 /* Log function */
931 /* logn (x) = {n = 1, ...} ( ((1 - x) ^ n) / n ) */
932
933 static void
cob_mpf_log(mpf_t dst_val,const mpf_t src_val)934 cob_mpf_log (mpf_t dst_val, const mpf_t src_val)
935 {
936 mpf_t vf1, vf2, vf3, vf4;
937 mpf_t dst_temp;
938 cob_sli_t expon;
939 cob_uli_t n;
940
941
942
943 if (mpf_sgn (src_val) <= 0 || !mpf_cmp_ui (src_val, 1UL)) {
944 mpf_set_ui (dst_val, 0UL);
945 return;
946 }
947
948 mpf_init2 (dst_temp, COB_MPF_PREC);
949
950 mpf_init2 (vf1, COB_MPF_PREC);
951 mpf_set (vf1, src_val);
952 mpf_init2 (vf2, COB_MPF_PREC);
953 mpf_init2 (vf3, COB_MPF_PREC);
954 mpf_set_si (vf3, -1L);
955 mpf_init2 (vf4, COB_MPF_PREC);
956
957 mpf_set_ui (dst_temp, 0UL);
958 mpf_get_d_2exp (&expon, vf1);
959 if (expon != 0) {
960 mpf_set (dst_temp, cob_log_half);
961 if (expon > 0) {
962 mpf_mul_ui (dst_temp, dst_temp, (cob_uli_t)expon);
963 mpf_neg (dst_temp, dst_temp);
964 mpf_div_2exp (vf1, vf1, (cob_uli_t)expon);
965 } else {
966 mpf_mul_ui (dst_temp, dst_temp, (cob_uli_t)-expon);
967 mpf_mul_2exp (vf1, vf1, (cob_uli_t)-expon);
968 }
969 }
970 mpf_ui_sub (vf1, 1UL, vf1);
971
972 n = 1;
973 do {
974 mpf_mul (vf3, vf3, vf1);
975 mpf_div_ui (vf2, vf3, n);
976 mpf_set (vf4, dst_temp);
977 mpf_add (dst_temp, dst_temp, vf2);
978 ++n;
979 } while (!mpf_eq (vf4, dst_temp, COB_MPF_CUTOFF));
980
981 mpf_set (dst_val, dst_temp);
982 mpf_clear (dst_temp);
983
984 mpf_clear (vf4);
985 mpf_clear (vf3);
986 mpf_clear (vf2);
987 mpf_clear (vf1);
988 }
989
990 /* Log10 function */
991 /* log10 (x) = log (x) / log (10) */
992
993 static void
cob_mpf_log10(mpf_t dst_val,const mpf_t src_val)994 cob_mpf_log10 (mpf_t dst_val, const mpf_t src_val)
995 {
996 mpf_t vf1;
997 mpf_t dst_temp;
998
999 mpf_init2 (dst_temp, COB_MPF_PREC);
1000
1001 mpf_init2 (vf1, COB_MPF_PREC);
1002
1003 cob_mpf_log (dst_temp, src_val);
1004 mpf_set_ui (vf1, 10UL);
1005 cob_mpf_log (vf1, vf1);
1006 mpf_div (dst_temp, dst_temp, vf1);
1007
1008 mpf_set (dst_val, dst_temp);
1009 mpf_clear (dst_temp);
1010
1011 mpf_clear (vf1);
1012 }
1013
1014 /* Sin function */
1015 /* sin (x) = (reduce to pi/2) */
1016 /* {n = 0, ...} ( (-1 ^ n) * ( x ^ (2n + 1)) / (2n + 1) ) */
1017
1018 static void
cob_mpf_sin(mpf_t dst_val,const mpf_t src_val)1019 cob_mpf_sin (mpf_t dst_val, const mpf_t src_val)
1020 {
1021 mpf_t vf1, vf2, vf3, vf4, vf5;
1022 mpf_t dst_temp;
1023 cob_uli_t arcquad;
1024 cob_uli_t n;
1025 int sign;
1026
1027 mpf_init2 (dst_temp, COB_MPF_PREC);
1028
1029 mpf_init2 (vf1, COB_MPF_PREC);
1030 mpf_init2 (vf2, COB_MPF_PREC);
1031 mpf_init2 (vf3, COB_MPF_PREC);
1032 mpf_init2 (vf4, COB_MPF_PREC);
1033 mpf_init2 (vf5, COB_MPF_PREC);
1034 sign = mpf_sgn (src_val);
1035
1036 mpf_abs (vf4, src_val);
1037 mpf_set (vf3, cob_pi);
1038 mpf_div_2exp (vf3, vf3, 1UL);
1039 mpf_div (vf1, vf4, vf3);
1040 mpf_floor (vf4, vf1);
1041
1042 if (mpf_cmp_ui (vf4, 4UL) >= 0) {
1043 mpf_div_2exp (vf2, vf4, 2UL);
1044 mpf_floor (vf2, vf2);
1045 mpf_mul_2exp (vf2, vf2, 2UL);
1046 mpf_sub (vf2, vf4, vf2);
1047 } else {
1048 mpf_set (vf2, vf4);
1049 }
1050
1051 arcquad = mpf_get_ui (vf2);
1052 mpf_sub (vf2, vf1, vf4);
1053 mpf_mul (vf4, vf3, vf2);
1054
1055 if (arcquad > 1) {
1056 sign = -sign;
1057 }
1058 if (arcquad & 1) {
1059 mpf_sub (vf4, vf3, vf4);
1060 }
1061
1062 mpf_mul (vf3, vf4, vf4);
1063 mpf_neg (vf3, vf3);
1064
1065 n = 1;
1066 mpf_set_ui (vf2, 1UL);
1067 mpf_set_ui (dst_temp, 1UL);
1068
1069 do {
1070 ++n;
1071 mpf_div_ui (vf2, vf2, n);
1072 ++n;
1073 mpf_div_ui (vf2, vf2, n);
1074 mpf_mul (vf2, vf2, vf3);
1075 mpf_set (vf5, dst_temp);
1076 mpf_add (dst_temp, dst_temp, vf2);
1077 } while (!mpf_eq (vf5, dst_temp, COB_MPF_PREC));
1078
1079 mpf_mul (dst_temp, dst_temp, vf4);
1080 if (sign < 0) {
1081 mpf_neg (dst_temp, dst_temp);
1082 }
1083
1084 mpf_set (dst_val, dst_temp);
1085 mpf_clear (dst_temp);
1086
1087 mpf_clear (vf5);
1088 mpf_clear (vf4);
1089 mpf_clear (vf3);
1090 mpf_clear (vf2);
1091 mpf_clear (vf1);
1092 }
1093
1094 /* Cos function */
1095 /* cos (x) = sin ((pi / 2) - x) */
1096
1097 static void
cob_mpf_cos(mpf_t dst_val,const mpf_t src_val)1098 cob_mpf_cos (mpf_t dst_val, const mpf_t src_val)
1099 {
1100 mpf_t vf1;
1101
1102 mpf_init2 (vf1, COB_MPF_PREC);
1103
1104 mpf_set (vf1, cob_pi);
1105 mpf_div_2exp (vf1, vf1, 1UL);
1106 mpf_sub (vf1, vf1, src_val);
1107 cob_mpf_sin (dst_val, vf1);
1108
1109 mpf_clear (vf1);
1110 }
1111
1112 /* Tan function */
1113 /* tan (x) = sin(x) / cos(x) */
1114
1115 static void
cob_mpf_tan(mpf_t dst_val,const mpf_t src_val)1116 cob_mpf_tan (mpf_t dst_val, const mpf_t src_val)
1117 {
1118 mpf_t vf1;
1119 mpf_t vf2;
1120
1121 mpf_init2 (vf1, COB_MPF_PREC);
1122 mpf_init2 (vf2, COB_MPF_PREC);
1123
1124 cob_mpf_sin (vf1, src_val);
1125 cob_mpf_cos (vf2, src_val);
1126 mpf_div (dst_val, vf1, vf2);
1127
1128 mpf_clear (vf1);
1129 mpf_clear (vf2);
1130 }
1131
1132 /* Atan function */
1133
1134 static void
cob_mpf_atan(mpf_t dst_val,const mpf_t src_val)1135 cob_mpf_atan (mpf_t dst_val, const mpf_t src_val)
1136 {
1137 mpf_t vf1, vf2, vf3, vf4;
1138 mpf_t dst_temp;
1139 cob_uli_t n;
1140
1141 mpf_init2 (dst_temp, COB_MPF_PREC);
1142
1143 mpf_init2 (vf1, COB_MPF_PREC);
1144 mpf_init2 (vf2, COB_MPF_PREC);
1145 mpf_init2 (vf3, COB_MPF_PREC);
1146 mpf_init2 (vf4, COB_MPF_PREC);
1147
1148 mpf_abs (vf1, src_val);
1149 mpf_add_ui (vf3, cob_sqrt_two, 1UL);
1150
1151 if (mpf_cmp (vf1, vf3) > 0) {
1152 mpf_set (dst_temp, cob_pi);
1153 mpf_div_2exp (dst_temp, dst_temp, 1UL);
1154 mpf_ui_div (vf1, 1UL, vf1);
1155 mpf_neg (vf1, vf1);
1156 } else {
1157 mpf_sub_ui (vf4, cob_sqrt_two, 1UL);
1158 if (mpf_cmp (vf1, vf4) > 0) {
1159 mpf_set (dst_temp, cob_pi);
1160 mpf_div_2exp (dst_temp, dst_temp, 2UL);
1161 mpf_sub_ui (vf3, vf1, 1UL);
1162 mpf_add_ui (vf4, vf1, 1UL);
1163 mpf_div (vf1, vf3, vf4);
1164 } else {
1165 mpf_set_ui (dst_temp, 0UL);
1166 }
1167 }
1168 mpf_mul (vf2, vf1, vf1);
1169 mpf_neg (vf2, vf2);
1170 mpf_add (dst_temp, dst_temp, vf1);
1171
1172 n = 1;
1173
1174 do {
1175 mpf_mul (vf1, vf1, vf2);
1176 mpf_div_ui (vf3, vf1, 2ULL * n + 1);
1177 mpf_set (vf4, dst_temp);
1178 mpf_add (dst_temp, dst_temp, vf3);
1179 ++n;
1180 } while (!mpf_eq (vf4, dst_temp, COB_MPF_PREC));
1181
1182 if (mpf_sgn (src_val) < 0) {
1183 mpf_neg (dst_temp, dst_temp);
1184 }
1185
1186 mpf_set (dst_val, dst_temp);
1187 mpf_clear (dst_temp);
1188
1189 mpf_clear (vf4);
1190 mpf_clear (vf3);
1191 mpf_clear (vf2);
1192 mpf_clear (vf1);
1193 }
1194
1195 /* Asin function */
1196 /* asin (x) = 2 * atan (x / (1 + sqrt (1 - (x ** 2)))) */
1197
1198 static void
cob_mpf_asin(mpf_t dst_val,const mpf_t src_val)1199 cob_mpf_asin (mpf_t dst_val, const mpf_t src_val)
1200 {
1201 mpf_t vf1, vf2;
1202 mpf_t dst_temp;
1203
1204 mpf_init2 (dst_temp, COB_MPF_PREC);
1205
1206 if (!mpf_cmp_ui (src_val, 1UL) || !mpf_cmp_si (src_val, -1L)) {
1207 mpf_set (dst_temp, cob_pi);
1208 mpf_div_ui (dst_temp, dst_temp, 2UL);
1209 if (mpf_sgn (src_val) < 0) {
1210 mpf_neg (dst_temp, dst_temp);
1211 }
1212 mpf_set (dst_val, dst_temp);
1213 mpf_clear (dst_temp);
1214 return;
1215 }
1216 if (!mpz_sgn (src_val)) {
1217 mpf_set_ui (dst_val, 0UL);
1218 mpf_clear (dst_temp);
1219 return;
1220 }
1221
1222 mpf_init2 (vf1, COB_MPF_PREC);
1223 mpf_init2 (vf2, COB_MPF_PREC);
1224
1225 mpf_mul (vf2, src_val, src_val);
1226 mpf_ui_sub (vf2, 1UL, vf2);
1227 mpf_sqrt (vf2, vf2);
1228
1229 mpf_add_ui (vf2, vf2, 1UL);
1230
1231 mpf_div (vf1, src_val, vf2);
1232 cob_mpf_atan (dst_temp, vf1);
1233 mpf_mul_ui (dst_temp, dst_temp, 2UL);
1234
1235 mpf_set (dst_val, dst_temp);
1236 mpf_clear (dst_temp);
1237
1238 mpf_clear (vf2);
1239 mpf_clear (vf1);
1240 }
1241
1242 /* Acos function */
1243 /* acos (x) = 2 * atan (sqrt (1 - (x ** 2)) / (1 + x)) */
1244
1245 static void
cob_mpf_acos(mpf_t dst_val,const mpf_t src_val)1246 cob_mpf_acos (mpf_t dst_val, const mpf_t src_val)
1247 {
1248 mpf_t vf1, vf2;
1249 mpf_t dst_temp;
1250
1251 mpf_init2 (dst_temp, COB_MPF_PREC);
1252
1253 if (!mpf_sgn (src_val)) {
1254 mpf_set (dst_temp, cob_pi);
1255 mpf_div_ui (dst_temp, dst_temp, 2UL);
1256 mpf_set (dst_val, dst_temp);
1257 mpf_clear (dst_temp);
1258 return;
1259 }
1260 if (!mpf_cmp_ui (src_val, 1UL)) {
1261 mpf_set_ui (dst_val, 0UL);
1262 mpf_clear (dst_temp);
1263 return;
1264 }
1265 if (!mpf_cmp_si (src_val, -1L)) {
1266 mpf_set (dst_val, cob_pi);
1267 mpf_clear (dst_temp);
1268 return;
1269 }
1270
1271 mpf_init2 (vf1, COB_MPF_PREC);
1272 mpf_init2 (vf2, COB_MPF_PREC);
1273
1274 mpf_add_ui (vf2, src_val, 1UL);
1275 mpf_mul (vf1, src_val, src_val);
1276 mpf_ui_sub (vf1, 1UL, vf1);
1277 mpf_sqrt (vf1, vf1);
1278 mpf_div (vf1, vf1, vf2);
1279 cob_mpf_atan (dst_temp, vf1);
1280 mpf_mul_ui (dst_temp, dst_temp, 2UL);
1281
1282 mpf_set (dst_val, dst_temp);
1283 mpf_clear (dst_temp);
1284
1285 mpf_clear (vf2);
1286 mpf_clear (vf1);
1287 }
1288
1289 /* SUBSTITUTE(-CASE) functions */
1290
1291 static size_t
get_substituted_size(cob_field * original,cob_field ** matches,cob_field ** reps,const int numreps,int (* cmp_func)(const void *,const void *,size_t))1292 get_substituted_size (cob_field *original, cob_field **matches, cob_field **reps,
1293 const int numreps,
1294 int (*cmp_func)(const void *, const void *, size_t))
1295 {
1296 unsigned char *match_begin = original->data;
1297 size_t orig_size = original->size;
1298 size_t calcsize = 0;
1299 size_t cur_idx;
1300 size_t found = 0;
1301 int i;
1302
1303 for (cur_idx = 0; cur_idx < orig_size; ) {
1304 /* Try to find a match at this point */
1305 for (i = 0; i < numreps; ++i) {
1306 /* If we overflow the string */
1307 if (cur_idx + matches[i]->size > orig_size) {
1308 continue;
1309 }
1310
1311 /* If we find a match */
1312 if (!(*cmp_func) (match_begin, matches[i]->data, matches[i]->size)) {
1313 /* Go past it */
1314 match_begin += matches[i]->size;
1315 cur_idx += matches[i]->size;
1316 /* Keep track how long new string will be */
1317 calcsize += reps[i]->size;
1318
1319 found = 1;
1320 break;
1321 }
1322 }
1323
1324 if (found) {
1325 found = 0;
1326 } else {
1327 /* Move forward one char */
1328 ++cur_idx;
1329 ++match_begin;
1330 ++calcsize;
1331 }
1332 }
1333
1334 return calcsize;
1335 }
1336
1337 static void
substitute_matches(cob_field * original,cob_field ** matches,cob_field ** reps,const int numreps,int (* cmp_func)(const void *,const void *,size_t),unsigned char * replaced_begin)1338 substitute_matches (cob_field *original, cob_field **matches, cob_field **reps,
1339 const int numreps,
1340 int (*cmp_func)(const void *, const void *, size_t),
1341 unsigned char *replaced_begin)
1342 {
1343 unsigned char *match_begin = original->data;
1344 size_t orig_size = original->size;
1345 size_t cur_idx;
1346 size_t found = 0;
1347 int i;
1348
1349 for (cur_idx = 0; cur_idx < orig_size; ) {
1350 /* Try to find a match at this point. */
1351 for (i = 0; i < numreps; ++i) {
1352 /* If we overrun */
1353 if (cur_idx + matches[i]->size > orig_size) {
1354 continue;
1355 }
1356
1357 /* If we find a match */
1358 if (!(*cmp_func) (match_begin, matches[i]->data, matches[i]->size)) {
1359 /* Write the replacement */
1360 memcpy (replaced_begin, reps[i]->data, reps[i]->size);
1361 /* Move past the match/replacement */
1362 match_begin += matches[i]->size;
1363 replaced_begin += reps[i]->size;
1364 cur_idx += matches[i]->size;
1365
1366 found = 1;
1367 break;
1368 }
1369 }
1370
1371 if (found) {
1372 found = 0;
1373 continue;
1374 } else {
1375 /* Add unmatched char to final string and move on one */
1376 ++cur_idx;
1377 *replaced_begin++ = *match_begin++;
1378 }
1379 }
1380 }
1381
1382 static cob_field *
substitute(const int offset,const int length,const int params,int (* cmp_func)(const void *,const void *,size_t),va_list args)1383 substitute (const int offset, const int length, const int params,
1384 int (*cmp_func)(const void *, const void *, size_t),
1385 va_list args)
1386 {
1387
1388 cob_field *original;
1389 cob_field **matches;
1390 cob_field **reps;
1391 int i;
1392 size_t calcsize;
1393 int numreps = params / 2;
1394 cob_field field;
1395
1396 matches = cob_malloc ((size_t)numreps * sizeof (cob_field *));
1397 reps = cob_malloc ((size_t)numreps * sizeof (cob_field *));
1398
1399 /* Extract args */
1400 original = va_arg (args, cob_field *);
1401 for (i = 0; i < params - 1; ++i) {
1402 if ((i % 2) == 0) {
1403 matches[i / 2] = va_arg (args, cob_field *);
1404 } else {
1405 reps[i / 2] = va_arg (args, cob_field *);
1406 }
1407 }
1408
1409 va_end (args);
1410
1411 /* Perform substitution */
1412
1413 calcsize = get_substituted_size (original, matches, reps, numreps, cmp_func);
1414
1415 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
1416 field.size = calcsize;
1417 make_field_entry (&field);
1418
1419 substitute_matches (original, matches, reps, numreps, cmp_func, curr_field->data);
1420
1421 /* Output placed in curr_field */
1422
1423 cob_free (matches);
1424 cob_free (reps);
1425
1426 if (unlikely (offset > 0)) {
1427 calc_ref_mod (curr_field, offset, length);
1428 }
1429 return curr_field;
1430 }
1431
1432 static int
int_strncasecmp(const void * s1,const void * s2,size_t n)1433 int_strncasecmp (const void *s1, const void *s2, size_t n)
1434 {
1435 return (int) strncasecmp (s1, s2, n);
1436 }
1437
1438 /* NUMVAL */
1439
1440 static int
in_last_n_chars(const cob_field * field,const size_t n,const unsigned int i)1441 in_last_n_chars (const cob_field *field, const size_t n, const unsigned int i)
1442 {
1443 return i + n >= field->size;
1444 }
1445
1446 static int
at_cr_or_db(const cob_field * srcfield,const int pos)1447 at_cr_or_db (const cob_field *srcfield, const int pos)
1448 {
1449 return memcmp (&srcfield->data[pos], "CR", (size_t)2) == 0
1450 || memcmp (&srcfield->data[pos], "DB", (size_t)2) == 0;
1451 }
1452
1453 enum numval_type {
1454 NUMVAL,
1455 NUMVAL_C
1456 };
1457
1458 static cob_field *
numval(cob_field * srcfield,cob_field * currency,const enum numval_type type)1459 numval (cob_field *srcfield, cob_field *currency, const enum numval_type type)
1460 {
1461 unsigned char *final_buff = NULL;
1462 unsigned char *currency_data = NULL;
1463 size_t i;
1464 int final_digits = 0;
1465 int decimal_digits = 0;
1466 int sign = 0;
1467 int decimal_seen = 0;
1468 unsigned char dec_pt = COB_MODULE_PTR->decimal_point;
1469 unsigned char cur_symb = COB_MODULE_PTR->currency_symbol;
1470
1471 /* Validate source field */
1472 if (cob_check_numval (srcfield, currency, type == NUMVAL_C, 0)) {
1473 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
1474 cob_alloc_set_field_uint (0);
1475 return curr_field;
1476 }
1477
1478 final_buff = cob_malloc (srcfield->size + 1U);
1479 if (currency && currency->size < srcfield->size) {
1480 currency_data = currency->data;
1481 }
1482
1483 for (i = 0; i < srcfield->size; ++i) {
1484 if (!in_last_n_chars (srcfield, 2, i)
1485 && at_cr_or_db (srcfield, i)) {
1486 sign = 1;
1487 break;
1488 }
1489
1490 if (currency_data) {
1491 /* FIXME: only do so if i has a reasonable size [or at least is < INT_MAX]
1492 otherwise an overflow may occur
1493 */
1494 if (!(in_last_n_chars (srcfield, currency->size, i))
1495 && !memcmp (&srcfield->data[i], currency_data,
1496 currency->size)) {
1497 i += (currency->size - 1);
1498 continue;
1499 }
1500 } else if (type == NUMVAL_C && srcfield->data[i] == cur_symb) {
1501 continue;
1502 }
1503
1504 if (srcfield->data[i] == ' ') {
1505 continue;
1506 }
1507 if (srcfield->data[i] == '+') {
1508 continue;
1509 }
1510 if (srcfield->data[i] == '-') {
1511 sign = 1;
1512 continue;
1513 }
1514 if (srcfield->data[i] == dec_pt) {
1515 decimal_seen = 1;
1516 continue;
1517 }
1518 if (srcfield->data[i] >= (unsigned char)'0' &&
1519 srcfield->data[i] <= (unsigned char)'9') {
1520 if (decimal_seen) {
1521 decimal_digits++;
1522 }
1523 final_buff[final_digits++] = srcfield->data[i];
1524 }
1525 if (final_digits > COB_MAX_DIGITS) {
1526 break;
1527 }
1528 }
1529
1530 /* If srcfield is an empty string */
1531 if (!final_digits) {
1532 final_buff[0] = '0';
1533 }
1534
1535 mpz_set_str (d1.value, (char *)final_buff, 10);
1536 cob_free (final_buff);
1537 if (sign && mpz_sgn (d1.value)) {
1538 mpz_neg (d1.value, d1.value);
1539 }
1540 d1.scale = decimal_digits;
1541 cob_alloc_field (&d1);
1542 (void)cob_decimal_get_field (&d1, curr_field, 0);
1543
1544 return curr_field;
1545 }
1546
1547 /* Numeric functions */
1548
1549 static void
get_min_and_max_of_args(const int num_args,va_list args,cob_field ** min,cob_field ** max)1550 get_min_and_max_of_args (const int num_args, va_list args, cob_field **min, cob_field **max)
1551 {
1552 int i;
1553 cob_field *f;
1554
1555 *min = va_arg (args, cob_field *);
1556 *max = *min;
1557
1558 for (i = 1; i < num_args; ++i) {
1559 f = va_arg (args, cob_field *);
1560 if (cob_cmp (f, *min) < 0) {
1561 *min = f;
1562 }
1563 if (cob_cmp (f, *max) > 0) {
1564 *max = f;
1565 }
1566 }
1567 }
1568
1569 /* Uses d1 and d2. Return value in d1. */
1570 static void
calc_mean_of_args(const int num_args,va_list args)1571 calc_mean_of_args (const int num_args, va_list args)
1572 {
1573 int i;
1574 cob_field *f;
1575
1576 mpz_set_ui (d1.value, 0UL);
1577 d1.scale = 0;
1578
1579 for (i = 0; i < num_args; ++i) {
1580 f = va_arg (args, cob_field *);
1581 cob_decimal_set_field (&d2, f);
1582 cob_decimal_add (&d1, &d2);
1583 }
1584
1585 mpz_set_ui (d2.value, (cob_uli_t)num_args);
1586 d2.scale = 0;
1587 cob_decimal_div (&d1, &d2);
1588 }
1589
1590 /* Return variance in d1. Uses d2, d3 and d4. */
1591 static void
calc_variance_of_args(const int n,va_list numbers,cob_decimal * mean)1592 calc_variance_of_args (const int n, va_list numbers, cob_decimal *mean)
1593 {
1594 cob_field *f;
1595 int i;
1596 cob_decimal *difference = &d2;
1597 cob_decimal *sum = &d3;
1598 cob_decimal *num_numbers = &d4;
1599
1600 if (n == 1) {
1601 mpz_set_ui (d1.value, 0UL);
1602 d1.scale = 0;
1603 return;
1604 }
1605
1606 mpz_set_ui (sum->value, 0UL);
1607 sum->scale = 0;
1608
1609 /* Get the sum of the squares of the differences from the mean */
1610 /* i.e., Sum ((arg - mean)^2) */
1611 for (i = 0; i < n; ++i) {
1612 f = va_arg (numbers, cob_field *);
1613
1614 cob_decimal_set_field (difference, f);
1615 cob_decimal_sub (difference, mean);
1616 cob_decimal_mul (difference, difference);
1617 cob_decimal_add (sum, difference);
1618 }
1619
1620 /* Divide sum by n */
1621 mpz_set_ui (num_numbers->value, (cob_uli_t)n);
1622 num_numbers->scale = 0;
1623 cob_decimal_div (sum, num_numbers);
1624
1625 cob_decimal_set (&d1, sum);
1626 }
1627
1628 /* Date/time functions */
1629
1630 static void
get_interval_and_current_year_from_args(const int num_args,va_list args,int * const interval,int * const current_year)1631 get_interval_and_current_year_from_args (const int num_args, va_list args,
1632 int * const interval, int * const current_year)
1633 {
1634 cob_field *f;
1635 time_t t;
1636 struct tm *timeptr;
1637
1638 if (num_args > 1) {
1639 f = va_arg (args, cob_field *);
1640 *interval = cob_get_int (f);
1641 } else {
1642 *interval = 50;
1643 }
1644
1645 if (num_args > 2) {
1646 f = va_arg (args, cob_field *);
1647 *current_year = cob_get_int (f);
1648 } else {
1649 t = time (NULL);
1650 timeptr = localtime (&t);
1651 *current_year = 1900 + timeptr->tm_year;
1652 }
1653 }
1654
1655 /* Locale time */
1656
1657 #if defined(_WIN32) || defined(__CYGWIN__) || defined (HAVE_LANGINFO_CODESET)
1658 #ifdef HAVE_LANGINFO_CODESET
1659 static int
locale_time(const int hours,const int minutes,const int seconds,cob_field * locale_field,char * buff)1660 locale_time (const int hours, const int minutes, const int seconds,
1661 cob_field *locale_field, char *buff)
1662 {
1663 char *deflocale = NULL;
1664 struct tm tstruct;
1665 char buff2[LOCTIME_BUFSIZE] = { '\0' };
1666 char locale_buff[COB_SMALL_BUFF] = { '\0' };
1667
1668 /* Initialize tstruct to given time */
1669 memset ((void *)&tstruct, 0, sizeof(struct tm));
1670 tstruct.tm_hour = hours;
1671 tstruct.tm_min = minutes;
1672 tstruct.tm_sec = seconds;
1673
1674 if (locale_field) {
1675 if (locale_field->size >= COB_SMALL_BUFF) {
1676 return 1;
1677 }
1678 cob_field_to_string (locale_field, locale_buff,
1679 (size_t)COB_SMALL_MAX);
1680 deflocale = locale_buff;
1681 (void) setlocale (LC_TIME, deflocale);
1682 }
1683
1684 /* Get strftime format string for locale */
1685 memset (buff2, 0, LOCTIME_BUFSIZE);
1686 snprintf(buff2, LOCTIME_BUFSIZE - 1, "%s", nl_langinfo(T_FMT));
1687
1688 /* Set locale if not done yet */
1689 if (deflocale) {
1690 (void) setlocale (LC_ALL, cobglobptr->cob_locale);
1691 }
1692
1693 strftime (buff, LOCTIME_BUFSIZE, buff2, &tstruct);
1694
1695 return 0;
1696 }
1697 #else
1698 static int
locale_time(const int hours,const int minutes,const int seconds,cob_field * locale_field,char * buff)1699 locale_time (const int hours, const int minutes, const int seconds,
1700 cob_field *locale_field, char *buff)
1701 {
1702 size_t len;
1703 unsigned char *p;
1704 LCID localeid = LOCALE_USER_DEFAULT;
1705 SYSTEMTIME syst;
1706 char locale_buff[COB_SMALL_BUFF] = { '\0' };
1707
1708 /* Initialize syst with given time */
1709 memset ((void *)&syst, 0, sizeof(syst));
1710 syst.wHour = (WORD)hours;
1711 syst.wMinute = (WORD)minutes;
1712 syst.wSecond = (WORD)seconds;
1713
1714 /* Get specified locale */
1715 if (locale_field) {
1716 if (locale_field->size >= COB_SMALL_BUFF) {
1717 return 1;
1718 }
1719 cob_field_to_string (locale_field, locale_buff,
1720 COB_SMALL_MAX);
1721
1722 /* Null-terminate last char of the locale string */
1723 for (p = (unsigned char *)locale_buff; *p; ++p) {
1724 if (isalnum((int)*p) || *p == '_') {
1725 continue;
1726 }
1727 break;
1728 }
1729 *p = 0;
1730
1731 /* Find locale ID */
1732 for (len = 0; len < WINLOCSIZE; ++len) {
1733 if (!strcmp(locale_buff, wintable[len].winlocalename)) {
1734 localeid = wintable[len].winlocaleid;
1735 break;
1736 }
1737 }
1738 if (len == WINLOCSIZE) {
1739 return 1;
1740 }
1741 }
1742
1743 /* Get locale time */
1744 if (!GetTimeFormat (localeid, LOCALE_NOUSEROVERRIDE, &syst, NULL, buff,
1745 LOCTIME_BUFSIZE)) {
1746 return 1;
1747 }
1748
1749 return 0;
1750 }
1751 #endif
1752 #endif
1753
1754 /* offset and length are for reference modification */
1755 static void
cob_alloc_set_field_str(char * str,const int offset,const int length)1756 cob_alloc_set_field_str (char *str, const int offset, const int length)
1757 {
1758 const size_t str_len = strlen (str);
1759 cob_field field;
1760
1761 COB_FIELD_INIT (str_len, NULL, &const_alpha_attr);
1762 make_field_entry (&field);
1763 memcpy (curr_field->data, str, str_len);
1764
1765 if (unlikely (offset > 0)) {
1766 calc_ref_mod (curr_field, offset, length);
1767 }
1768 }
1769
1770 static void
cob_alloc_set_field_spaces(const int n)1771 cob_alloc_set_field_spaces (const int n)
1772 {
1773 cob_field field;
1774
1775 COB_FIELD_INIT (n, NULL, &const_alpha_attr);
1776 make_field_entry (&field);
1777 memset (curr_field->data, ' ', (size_t)n);
1778 }
1779
1780 /* Date/time functions */
1781
1782 static int
days_in_year(const int year)1783 days_in_year (const int year)
1784 {
1785 return 365 + leap_year (year);
1786 }
1787
1788 static COB_INLINE COB_A_INLINE int
in_range(const int min,const int max,const int val)1789 in_range (const int min, const int max, const int val)
1790 {
1791 return min <= val && val <= max;
1792 }
1793
1794 static int
valid_integer_date(const int days)1795 valid_integer_date (const int days)
1796 {
1797 return in_range (1, 3067671, days);
1798 }
1799
1800 static int
valid_year(const int year)1801 valid_year (const int year)
1802 {
1803 return in_range (1601, 9999, year);
1804 }
1805
1806 static int
valid_month(const int month)1807 valid_month (const int month)
1808 {
1809 return in_range (1, 12, month);
1810 }
1811
1812 static int
valid_day_of_year(const int year,const int day)1813 valid_day_of_year (const int year, const int day)
1814 {
1815 return in_range (1, days_in_year (year), day);
1816 }
1817
1818 static int
valid_day_of_month(const int year,const int month,const int day)1819 valid_day_of_month (const int year, const int month, const int day)
1820 {
1821 if (leap_year (year)) {
1822 return in_range (1, leap_month_days[month], day);
1823 } else {
1824 return in_range (1, normal_month_days[month], day);
1825 }
1826 }
1827
1828 static int
max_week(int year)1829 max_week (int year)
1830 {
1831 int first_day = integer_of_date (year, 1, 1);
1832 int last_day = first_day + days_in_year (year) - 1;
1833 int week;
1834
1835 get_iso_week (last_day, &year, &week);
1836 return week;
1837 }
1838
1839 /* 86400 = 60 * 60 * 24. We'll ignore leap seconds for now. */
1840 #define SECONDS_IN_DAY 86400
1841
1842 static int
valid_time(const int seconds_from_midnight)1843 valid_time (const int seconds_from_midnight)
1844 {
1845 return in_range (0, SECONDS_IN_DAY, seconds_from_midnight);
1846 }
1847
1848 /* Uses d5. */
1849 static int
valid_decimal_time(cob_decimal * seconds_from_midnight)1850 valid_decimal_time (cob_decimal *seconds_from_midnight)
1851 {
1852 cob_decimal *seconds_in_day = &d5;
1853 mpz_set_ui (seconds_in_day->value, (unsigned long) SECONDS_IN_DAY);
1854 seconds_in_day->scale = 0;
1855
1856 return cob_decimal_cmp (seconds_from_midnight, seconds_in_day) <= 0;
1857 }
1858
1859 #undef SECONDS_IN_DAY
1860
1861 static int
valid_offset_time(const int offset)1862 valid_offset_time (const int offset)
1863 {
1864 const int minutes_in_day = 1440; /* 60 * 24 */
1865 return abs (offset) < minutes_in_day;
1866 }
1867
1868 /* calculate date from days since 1601 */
1869 static void
date_of_integer(const int day_num,int * year,int * month,int * day)1870 date_of_integer (const int day_num, int *year, int *month, int *day)
1871 {
1872 int days = day_num;
1873 int baseyear = 1601;
1874 int leapyear = 365;
1875 int i;
1876
1877 while (days > leapyear) {
1878 days -= leapyear;
1879 ++baseyear;
1880 leapyear = days_in_year (baseyear);
1881 }
1882 for (i = 0; i < 13; ++i) {
1883 if (leap_year (baseyear)) {
1884 if (i && days <= leap_days[i]) {
1885 days -= leap_days[i - 1];
1886 break;
1887 }
1888 } else {
1889 if (i && days <= normal_days[i]) {
1890 days -= normal_days[i - 1];
1891 break;
1892 }
1893 }
1894 }
1895
1896 *year = baseyear;
1897 *month = i;
1898 *day = days;
1899 }
1900
1901 /* set year and day-of-year from integer */
1902 static void
day_of_integer(const int day_num,int * year,int * day)1903 day_of_integer (const int day_num, int *year, int *day)
1904 {
1905 int leapyear = 365;
1906 int days = day_num;
1907
1908 *year = 1601;
1909
1910 while (days > leapyear) {
1911 days -= leapyear;
1912 ++*year;
1913 leapyear = days_in_year (*year);
1914 }
1915
1916 *day = days;
1917 }
1918
1919 /* calculate number of days between 1601 and given year */
1920 static cob_u32_t
days_up_to_year(const int year)1921 days_up_to_year (const int year)
1922 {
1923 cob_u32_t totaldays = 0;
1924 int baseyear = 1601;
1925
1926 while (baseyear != year) {
1927 totaldays += days_in_year (baseyear);
1928 ++baseyear;
1929 }
1930 return totaldays;
1931 }
1932
1933 /* calculate number of days between 1601/01/01 and given date */
1934 static cob_u32_t
integer_of_date(const int year,const int month,const int days)1935 integer_of_date (const int year, const int month, const int days)
1936 {
1937 cob_u32_t totaldays;
1938
1939 totaldays = days_up_to_year (year);
1940
1941 if (leap_year (year)) {
1942 totaldays += leap_days[month - 1];
1943 } else {
1944 totaldays += normal_days[month - 1];
1945 }
1946 totaldays += days;
1947
1948 return totaldays;
1949 }
1950
1951 /* calculate number of days between 1601/01/01 and given year + day-of-year */
1952 static cob_u32_t
integer_of_day(const int year,const int days)1953 integer_of_day (const int year, const int days)
1954 {
1955 cob_u32_t totaldays;
1956
1957 totaldays = days_up_to_year (year);
1958 totaldays += days;
1959
1960 return totaldays;
1961 }
1962
1963 enum formatted_time_extra {
1964 EXTRA_NONE = 0,
1965 EXTRA_Z,
1966 EXTRA_OFFSET_TIME
1967 };
1968
1969 struct time_format {
1970 int with_colons;
1971 int decimal_places;
1972 enum formatted_time_extra extra;
1973 };
1974
1975 /* Uses d2 */
1976 static void
seconds_from_formatted_time(const struct time_format format,const char * str,cob_decimal * seconds_decimal)1977 seconds_from_formatted_time (const struct time_format format, const char *str,
1978 cob_decimal *seconds_decimal)
1979 {
1980 const char *scanf_str = format.with_colons ? "%2d:%2d:%2d" : "%2d%2d%2d";
1981 int hours;
1982 int minutes;
1983 int seconds;
1984 int total_seconds;
1985 int offset;
1986 int end_of_decimal;
1987 int unscaled_fraction = 0;
1988 cob_decimal *fractional_seconds = &d2;
1989
1990 /* LCOV_EXCL_START */
1991 if (unlikely (!sscanf (str, scanf_str, &hours, &minutes, &seconds))) {
1992 cob_fatal_error (COB_FERROR_CODEGEN);
1993 }
1994 /* LCOV_EXCL_STOP */
1995
1996 total_seconds = (hours * 60 * 60) + (minutes * 60) + seconds;
1997
1998 if (format.decimal_places != 0) {
1999 offset = format.with_colons ? 9 : 7;
2000 end_of_decimal = offset + format.decimal_places;
2001 for (; offset != end_of_decimal; ++offset) {
2002 unscaled_fraction = unscaled_fraction * 10 + COB_D2I (str[offset]);
2003 }
2004
2005 mpz_set_ui (fractional_seconds->value, unscaled_fraction);
2006 fractional_seconds->scale = format.decimal_places;
2007
2008 mpz_set_ui (seconds_decimal->value, total_seconds);
2009 cob_decimal_add (seconds_decimal, fractional_seconds);
2010 } else {
2011 mpz_set_ui (seconds_decimal->value, total_seconds);
2012 seconds_decimal->scale = 0;
2013 }
2014 }
2015
2016 static int
valid_day_and_format(const int day,const char * format)2017 valid_day_and_format (const int day, const char *format)
2018 {
2019 return valid_integer_date (day) && cob_valid_date_format (format);
2020 }
2021
2022 static size_t
num_leading_nonspace(const char * str,const size_t str_len)2023 num_leading_nonspace (const char *str, const size_t str_len)
2024 {
2025 size_t i;
2026
2027 for (i = 0; i < str_len && !isspace ((int) str[i]); ++i);
2028 return i;
2029 }
2030
2031 static void
format_as_yyyymmdd(const int day_num,const int with_hyphen,char * buff)2032 format_as_yyyymmdd (const int day_num, const int with_hyphen, char *buff)
2033 {
2034 int day_of_month;
2035 int month;
2036 int year;
2037 const char *format_str;
2038
2039 date_of_integer (day_num, &year, &month, &day_of_month);
2040
2041 format_str = with_hyphen ? "%4.4d-%2.2d-%2.2d" : "%4.4d%2.2d%2.2d";
2042 sprintf (buff, format_str, year, month, day_of_month);
2043 }
2044
2045 static void
format_as_yyyyddd(const int day_num,const int with_hyphen,char * buff)2046 format_as_yyyyddd (const int day_num, const int with_hyphen, char *buff)
2047 {
2048 int day_of_year;
2049 int year;
2050 const char *format_str;
2051
2052 day_of_integer (day_num, &year, &day_of_year);
2053
2054 format_str = with_hyphen ? "%4.4d-%3.3d" : "%4.4d%3.3d";
2055 sprintf (buff, format_str, year, day_of_year);
2056 }
2057
2058 /* 0 = Monday, ..., 6 = Sunday */
2059 static int
get_day_of_week(const int day_num)2060 get_day_of_week (const int day_num)
2061 {
2062 return (day_num - 1) % 7;
2063 }
2064
2065 static int
get_iso_week_one(const int day_num,const int day_of_year)2066 get_iso_week_one (const int day_num, const int day_of_year)
2067 {
2068 int jan_4 = day_num - day_of_year + 4;
2069 int day_of_week = get_day_of_week (jan_4);
2070 int first_monday = jan_4 - day_of_week;
2071 return first_monday;
2072 }
2073
2074 /*
2075 * Derived from "Calculating the ISO week number for a date" by Julian M.
2076 * Bucknall (https://www.boyet.com/articles/publishedarticles/calculatingtheisoweeknumb.html).
2077 */
2078 static void
get_iso_week(const int day_num,int * year,int * week)2079 get_iso_week (const int day_num, int *year, int *week)
2080 {
2081 int day_of_year;
2082 int days_to_dec_29;
2083 int dec_29;
2084 int week_one;
2085
2086 day_of_integer (day_num, year, &day_of_year);
2087
2088 days_to_dec_29 = days_in_year (*year) - 2;
2089 dec_29 = day_num - day_of_year + days_to_dec_29;
2090
2091 if (day_num >= dec_29) {
2092 /* If the day is (after) December 29, it may be in the first
2093 week of the following year
2094 */
2095 week_one = get_iso_week_one (day_num + days_in_year (*year), day_of_year);
2096 if (day_num < week_one) {
2097 week_one = get_iso_week_one (day_num, day_of_year);
2098 } else {
2099 ++*year;
2100 }
2101 } else {
2102 week_one = get_iso_week_one (day_num, day_of_year);
2103
2104 /* If the day is before December 29, it may be in the last week
2105 of the previous year
2106 */
2107 if (day_num < week_one) {
2108 --*year;
2109 week_one = get_iso_week_one (day_num - day_of_year,
2110 days_in_year (*year));
2111 }
2112 }
2113
2114 *week = (day_num - week_one) / 7 + 1;
2115 }
2116
2117 static void
format_as_yyyywwwd(const int day_num,const int with_hyphen,char * buff)2118 format_as_yyyywwwd (const int day_num, const int with_hyphen, char *buff)
2119 {
2120 int ignored_day_of_year;
2121 int week;
2122 int year;
2123 int day_of_week;
2124 const char *format_str;
2125
2126 day_of_integer (day_num, &year, &ignored_day_of_year);
2127 get_iso_week (day_num, &year, &week);
2128 day_of_week = get_day_of_week (day_num);
2129
2130 format_str = with_hyphen ? "%4.4d-W%2.2d-%1.1d" : "%4.4dW%2.2d%1.1d";
2131 sprintf (buff, format_str, year, week, day_of_week + 1);
2132 }
2133
2134 enum days_format {
2135 DAYS_MMDD,
2136 DAYS_DDD,
2137 DAYS_WWWD
2138 };
2139
2140 struct date_format {
2141 enum days_format days;
2142 int with_hyphens;
2143 };
2144
2145 static struct date_format
parse_date_format_string(const char * format_str)2146 parse_date_format_string (const char *format_str)
2147 {
2148 struct date_format format;
2149
2150 if (!strcmp (format_str, "YYYYMMDD") || !strcmp (format_str, "YYYY-MM-DD")) {
2151 format.days = DAYS_MMDD;
2152 } else if (!strcmp (format_str, "YYYYDDD") || !strcmp (format_str, "YYYY-DDD")) {
2153 format.days = DAYS_DDD;
2154 } else { /* YYYYWwwD or YYYY-Www-D */
2155 format.days = DAYS_WWWD;
2156 }
2157
2158 format.with_hyphens = format_str[4] == '-';
2159
2160 return format;
2161 }
2162
2163 static void
format_date(const struct date_format format,const int days,char * buff)2164 format_date (const struct date_format format, const int days, char *buff)
2165 {
2166 void (*formatting_func) (int, int, char *);
2167
2168 if (format.days == DAYS_MMDD) {
2169 formatting_func = &format_as_yyyymmdd;
2170 } else if (format.days == DAYS_DDD) {
2171 formatting_func = &format_as_yyyyddd;
2172 } else { /* DAYS_WWWD */
2173 formatting_func = &format_as_yyyywwwd;
2174 }
2175 (*formatting_func) (days, format.with_hyphens, buff);
2176 }
2177
2178 /* Uses d5. */
2179 static void
get_fractional_seconds(cob_field * time,cob_decimal * fraction)2180 get_fractional_seconds (cob_field *time, cob_decimal *fraction)
2181 {
2182 int seconds;
2183 cob_decimal *whole_seconds;
2184
2185
2186 seconds = cob_get_int (time);
2187 whole_seconds = &d5;
2188 mpz_set_ui (whole_seconds->value, (unsigned long) seconds);
2189 whole_seconds->scale = 0;
2190
2191 cob_decimal_set_field (fraction, time);
2192 cob_decimal_sub (fraction, whole_seconds);
2193 }
2194
2195 static unsigned int
decimal_places_for_seconds(const char * str,const unsigned int point_pos)2196 decimal_places_for_seconds (const char *str, const unsigned int point_pos)
2197 {
2198 unsigned int offset = point_pos;
2199 int decimal_places = 0;
2200
2201 while (str[++offset] == 's') {
2202 ++decimal_places;
2203 }
2204
2205 return decimal_places;
2206 }
2207
2208 static int
rest_is_z(const char * str)2209 rest_is_z (const char *str)
2210 {
2211 return !strcmp (str, "Z");
2212 }
2213
2214 static int
rest_is_offset_format(const char * str,const int with_colon)2215 rest_is_offset_format (const char *str, const int with_colon)
2216 {
2217 if (with_colon) {
2218 return !strcmp (str, "+hh:mm");
2219 } else {
2220 return !strcmp (str, "+hhmm");
2221 }
2222 }
2223
2224 /*
2225 This function is needed because, on MinGW, (int) pow (10, 8) == 9999999, not
2226 10^8. This also occurs with other powers. See http://stackoverflow.com/q/9704195.
2227 */
2228 static unsigned int
int_pow(const unsigned int base,unsigned int power)2229 int_pow (const unsigned int base, unsigned int power)
2230 {
2231 unsigned int ret = 1;
2232
2233 while (power > 0) {
2234 ret *= base;
2235 --power;
2236 }
2237
2238 return ret;
2239 }
2240
2241 static void
add_decimal_digits(int decimal_places,cob_decimal * second_fraction,char * buff,ptrdiff_t * buff_pos)2242 add_decimal_digits (int decimal_places, cob_decimal *second_fraction,
2243 char *buff, ptrdiff_t *buff_pos)
2244 {
2245 unsigned int scale = second_fraction->scale;
2246 unsigned int power_of_ten;
2247 unsigned int fraction = mpz_get_ui (second_fraction->value);
2248
2249 /* Add decimal point */
2250 buff[*buff_pos] = COB_MODULE_PTR->decimal_point;
2251 ++*buff_pos;
2252
2253 /* Append decimal digits from second_fraction from left to right */
2254 while (scale != 0 && decimal_places != 0) {
2255 --scale;
2256 power_of_ten = int_pow (10, scale);
2257 buff[*buff_pos] = (char) ('0' + (fraction / power_of_ten));
2258
2259 fraction %= power_of_ten;
2260 ++*buff_pos;
2261 --decimal_places;
2262 }
2263
2264 /* Set remaining digits to zero */
2265 if (decimal_places != 0) {
2266 memset (buff + *buff_pos, (int)'0', decimal_places);
2267 *buff_pos += decimal_places;
2268 }
2269 }
2270
2271 static void
add_z(const ptrdiff_t buff_pos,char * buff)2272 add_z (const ptrdiff_t buff_pos, char *buff)
2273 {
2274 buff[buff_pos] = 'Z';
2275 }
2276
2277 static void
add_offset_time(const int with_colon,int const * offset_time,const ptrdiff_t buff_pos,char * buff)2278 add_offset_time (const int with_colon, int const *offset_time,
2279 const ptrdiff_t buff_pos, char *buff)
2280 {
2281 int hours;
2282 int minutes;
2283 const char *format_str;
2284 char local_buff[13]; /* 13: make the compiler happy as "(un)signed short" *could*
2285 have more digits than we "assume" */
2286
2287 if (offset_time) {
2288 hours = *offset_time / 60;
2289 minutes = abs (*offset_time) % 60;
2290
2291 format_str = with_colon ? "%+2.2d:%2.2d" : "%+2.2d%2.2d";
2292 snprintf (local_buff, sizeof (local_buff), format_str,
2293 (cob_s16_t) hours,
2294 (cob_u16_t) minutes);
2295 memcpy (buff + buff_pos, local_buff, (size_t)6);
2296 } else {
2297 snprintf (buff + buff_pos, (size_t)6, "00000");
2298 }
2299 }
2300
2301 static struct time_format
parse_time_format_string(const char * str)2302 parse_time_format_string (const char *str)
2303 {
2304 struct time_format format;
2305 unsigned int offset;
2306
2307 if (!strncmp (str, "hhmmss", 6)) {
2308 format.with_colons = 0;
2309 offset = 6;
2310 } else { /* "hh:mm:ss" */
2311 format.with_colons = 1;
2312 offset = 8;
2313 }
2314
2315 if (str[offset] == '.' || str[offset] == ',') {
2316 format.decimal_places = decimal_places_for_seconds (str, offset);
2317 offset += format.decimal_places + 1;
2318 } else {
2319 format.decimal_places = 0;
2320 }
2321
2322 if (strlen (str) > (size_t) offset) {
2323 if (rest_is_z (str + offset)) {
2324 format.extra = EXTRA_Z;
2325 } else { /* the rest is the offset time */
2326 format.extra = EXTRA_OFFSET_TIME;
2327 }
2328 } else {
2329 format.extra = EXTRA_NONE;
2330 }
2331
2332 return format;
2333 }
2334
2335 static int
format_time(const struct time_format format,int time,cob_decimal * second_fraction,int * offset_time,char * buff)2336 format_time (const struct time_format format, int time,
2337 cob_decimal *second_fraction, int *offset_time, char *buff)
2338 {
2339 int hours;
2340 int minutes;
2341 int seconds;
2342 int date_overflow = 0;
2343 ptrdiff_t buff_pos;
2344 const char *format_str;
2345
2346 if (format.with_colons) {
2347 format_str = "%2.2d:%2.2d:%2.2d";
2348 buff_pos = 8;
2349 } else {
2350 format_str = "%2.2d%2.2d%2.2d";
2351 buff_pos = 6;
2352 }
2353
2354 /* Duplication! */
2355 hours = time / 3600;
2356 time %= 3600;
2357 minutes = time / 60;
2358 seconds = time % 60;
2359
2360 if (format.extra == EXTRA_Z) {
2361 if (offset_time == NULL) {
2362 cob_set_exception (COB_EC_IMP_UTC_UNKNOWN);
2363 return 0;
2364 }
2365
2366 hours -= *offset_time / 60;
2367 minutes -= *offset_time % 60;
2368
2369 /* Handle minute and hour overflow */
2370 if (minutes >= 60) {
2371 minutes -= 60;
2372 ++hours;
2373 } else if (minutes < 0) {
2374 minutes += 60;
2375 --hours;
2376 }
2377
2378 if (hours >= 24) {
2379 hours -= 24;
2380 date_overflow = 1;
2381 } else if (hours < 0) {
2382 hours += 24;
2383 date_overflow = -1;
2384 }
2385 }
2386
2387 sprintf (buff, format_str, hours, minutes, seconds);
2388
2389 if (format.decimal_places != 0) {
2390 add_decimal_digits (format.decimal_places, second_fraction,
2391 buff, &buff_pos);
2392 }
2393
2394 if (format.extra == EXTRA_Z) {
2395 add_z (buff_pos, buff);
2396 } else if (format.extra == EXTRA_OFFSET_TIME) {
2397 add_offset_time (format.with_colons, offset_time, buff_pos, buff);
2398 }
2399
2400 return date_overflow;
2401 }
2402
2403 /*
2404 Copies as many character as possible from before the first space
2405 from f->data into out_str and add a null terminator to out_str.
2406 */
2407 static void
copy_data_to_null_terminated_str(cob_field * f,char * const out_str,const size_t out_str_max)2408 copy_data_to_null_terminated_str (cob_field *f, char * const out_str,
2409 const size_t out_str_max)
2410 {
2411 size_t chars_before_space = num_leading_nonspace ((char *)f->data,
2412 f->size);
2413 size_t length = cob_min_int (chars_before_space, out_str_max);
2414
2415 strncpy (out_str, (char *)f->data, length);
2416 out_str[length] = '\0';
2417 }
2418
2419 static void
split_around_t(const char * str,char * first,char * second)2420 split_around_t (const char *str, char *first, char *second)
2421 {
2422 int i;
2423 size_t first_length;
2424 size_t second_length;
2425
2426 /* Find 'T' */
2427 for (i = 0; str[i] != '\0' && str[i] != 'T'; ++i);
2428
2429 /* Copy everything before 'T' into first (if present) */
2430 if (i < COB_DATESTR_MAX) {
2431 first_length = i;
2432 } else {
2433 first_length = COB_DATESTR_MAX;
2434 }
2435 if (first != NULL) {
2436 strncpy (first, str, first_length);
2437 first[first_length] = '\0';
2438 }
2439
2440 /* If there is anything after 'T', copy it into second (if present) */
2441 if (second != NULL) {
2442 if (strlen (str) - i == 0) {
2443 second[0] = '\0';
2444 } else {
2445 second_length = strlen (str) - i - 1U;
2446 if (second_length > COB_TIMESTR_MAX) {
2447 second_length = COB_TIMESTR_MAX;;
2448 }
2449 strncpy (second, str + i + 1U, second_length);
2450 second[second_length] = '\0';
2451 }
2452 }
2453 }
2454
2455 static int
try_get_valid_offset_time(cob_field * offset_time_field,int * offset_time)2456 try_get_valid_offset_time (cob_field *offset_time_field, int *offset_time)
2457 {
2458 if (offset_time_field != NULL) {
2459 *offset_time = cob_get_int (offset_time_field);
2460 if (valid_offset_time (*offset_time)) {
2461 return 0;
2462 }
2463 } else {
2464 *offset_time = 0;
2465 return 0;
2466 }
2467
2468 return 1;
2469 }
2470
2471 static int *
get_system_offset_time_ptr(int * const offset_time)2472 get_system_offset_time_ptr (int * const offset_time)
2473 {
2474 struct cob_time current_time;
2475
2476 current_time = cob_get_current_date_and_time ();
2477 if (current_time.offset_known) {
2478 *offset_time = current_time.utc_offset;
2479 return offset_time;
2480 } else {
2481 return NULL;
2482 }
2483 }
2484
2485 static int
test_char_cond(const int cond,int * offset)2486 test_char_cond (const int cond, int *offset)
2487 {
2488 if (cond) {
2489 ++(*offset);
2490 return 0;
2491 } else {
2492 return *offset + 1;
2493 }
2494 }
2495
2496 static int
test_char(const char wanted,const char * str,int * offset)2497 test_char (const char wanted, const char *str, int *offset)
2498 {
2499 return test_char_cond (wanted == str[*offset], offset);
2500 }
2501
2502 static COB_INLINE COB_A_INLINE int
test_digit(const unsigned char ch,int * offset)2503 test_digit (const unsigned char ch, int *offset)
2504 {
2505 return test_char_cond (isdigit (ch), offset);
2506 }
2507
2508 static COB_INLINE COB_A_INLINE int
test_char_in_range(const char min,const char max,const char ch,int * offset)2509 test_char_in_range (const char min, const char max, const char ch, int *offset)
2510 {
2511 return test_char_cond (min <= ch && ch <= max, offset);
2512 }
2513
test_millenium(const char * date,int * offset,int * millenium)2514 static int test_millenium (const char *date, int *offset, int *millenium)
2515 {
2516 RETURN_IF_NOT_ZERO (test_char_in_range ('1', '9', date[*offset], offset));
2517
2518 *millenium = COB_D2I (date[*offset - 1]);
2519 return 0;
2520 }
2521
2522 static int
test_century(const char * date,int * offset,int * state)2523 test_century (const char *date, int *offset, int *state)
2524 {
2525 if (*state != 1) {
2526 RETURN_IF_NOT_ZERO (test_digit (date[*offset], offset));
2527 } else {
2528 RETURN_IF_NOT_ZERO (test_char_in_range ('6', '9', date[*offset],
2529 offset));
2530 }
2531
2532 *state = *state * 10 + COB_D2I (date[*offset - 1]);
2533 return 0;
2534 }
2535
2536 static int
test_decade(const char * date,int * offset,int * state)2537 test_decade (const char *date, int *offset, int *state)
2538 {
2539 RETURN_IF_NOT_ZERO (test_digit (date[*offset], offset));
2540 *state = *state * 10 + COB_D2I (date[*offset - 1]);
2541 return 0;
2542 }
2543
2544 static int
test_unit_year(const char * date,int * offset,int * state)2545 test_unit_year (const char *date, int *offset, int *state)
2546 {
2547 if (*state != 160) {
2548 RETURN_IF_NOT_ZERO (test_digit (date[*offset], offset));
2549 } else {
2550 RETURN_IF_NOT_ZERO (test_char_in_range ('1', '9', date[*offset],
2551 offset));
2552 }
2553
2554 *state = *state * 10 + COB_D2I (date[*offset - 1]);
2555 return 0;
2556 }
2557
2558 static int
test_year(const char * date,int * offset,int * state)2559 test_year (const char *date, int *offset, int *state)
2560 {
2561 RETURN_IF_NOT_ZERO (test_millenium (date, offset, state));
2562 RETURN_IF_NOT_ZERO (test_century (date, offset, state));
2563 RETURN_IF_NOT_ZERO (test_decade (date, offset, state));
2564 RETURN_IF_NOT_ZERO (test_unit_year (date, offset, state));
2565
2566 return 0;
2567 }
2568
2569 static int
test_hyphen_presence(const int with_hyphens,const char * date,int * offset)2570 test_hyphen_presence (const int with_hyphens, const char *date, int *offset)
2571 {
2572 return with_hyphens ? test_char ('-', date, offset) : 0;
2573 }
2574
2575 static int
test_month(const char * date,int * offset,int * month)2576 test_month (const char *date, int *offset, int *month)
2577 {
2578 int first_digit;
2579
2580 /* Validate first digit */
2581 RETURN_IF_NOT_ZERO (test_char_cond (date[*offset] == '0' || date[*offset] == '1',
2582 offset));
2583 first_digit = COB_D2I (date[*offset - 1]);
2584
2585 /* Validate second digit */
2586 if (first_digit == 0) {
2587 RETURN_IF_NOT_ZERO (test_char_in_range ('1', '9', date[*offset],
2588 offset));
2589 } else { /* first digit == 1 */
2590 RETURN_IF_NOT_ZERO (test_char_in_range ('0', '2', date[*offset],
2591 offset));
2592 }
2593
2594 *month = first_digit * 10 + COB_D2I (date[*offset - 1]);
2595 return 0;
2596 }
2597
2598 static int
test_day_of_month(const char * date,const int year,const int month,int * offset)2599 test_day_of_month (const char *date, const int year, const int month,
2600 int *offset)
2601 {
2602 int days_in_month;
2603 char max_first_digit;
2604 char max_second_digit;
2605 int first_digit;
2606
2607 if (leap_year (year)) {
2608 days_in_month = leap_month_days[month];
2609 } else {
2610 days_in_month = normal_month_days[month];
2611 }
2612 max_first_digit = '0' + (char) (days_in_month / 10);
2613 max_second_digit = '0' + (char) (days_in_month % 10);
2614
2615 /* Validate first digit */
2616 RETURN_IF_NOT_ZERO (test_char_in_range ('0', max_first_digit,
2617 date[*offset], offset));
2618 first_digit = date[*offset - 1];
2619
2620 /* Validate second digit */
2621 if (first_digit == '0') {
2622 RETURN_IF_NOT_ZERO (test_char_in_range ('1', '9', date[*offset],
2623 offset));
2624 } else if (first_digit != max_first_digit) {
2625 RETURN_IF_NOT_ZERO (test_digit (date[*offset], offset));
2626 } else {
2627 RETURN_IF_NOT_ZERO (test_char_in_range ('0', max_second_digit,
2628 date[*offset], offset));
2629 }
2630
2631 return 0;
2632 }
2633
2634 static int
test_day_of_year(const char * date,const int year,int * offset)2635 test_day_of_year (const char *date, const int year, int *offset)
2636 {
2637 char max_last_digit;
2638 int state;
2639
2640 /* Validate first digit */
2641 /* Check day is not greater than 399 */
2642 RETURN_IF_NOT_ZERO (test_char_in_range ('0', '3', date[*offset], offset));
2643 state = COB_D2I (date[*offset - 1]);
2644
2645 /* Validate second digit */
2646 if (state != 3) {
2647 RETURN_IF_NOT_ZERO (test_digit (date[*offset], offset));
2648 } else {
2649 /* Check day is not greater than 369 */
2650 RETURN_IF_NOT_ZERO (test_char_in_range ('0', '6', date[*offset],
2651 offset));
2652 }
2653 state = state * 10 + COB_D2I (date[*offset - 1]);
2654
2655 /* Validate third digit */
2656 if (state == 0) {
2657 RETURN_IF_NOT_ZERO (test_char_in_range ('1', '9', date[*offset],
2658 offset));
2659 } else if (state != 36) {
2660 RETURN_IF_NOT_ZERO (test_digit (date[*offset], offset));
2661 } else {
2662 /* Check day is not greater than 366/365 */
2663 max_last_digit = leap_year (year) ? '6' : '5';
2664 RETURN_IF_NOT_ZERO (test_char_in_range ('0', max_last_digit,
2665 date[*offset], offset));
2666 }
2667
2668 return 0;
2669 }
2670
2671 static int
test_w_presence(const char * date,int * offset)2672 test_w_presence (const char *date, int *offset)
2673 {
2674 return test_char ('W', date, offset);
2675 }
2676
2677 static int
test_week(const char * date,const int year,int * offset)2678 test_week (const char *date, const int year, int *offset)
2679 {
2680 int first_digit;
2681 char max_last_digit;
2682
2683 /* Validate first digit */
2684 RETURN_IF_NOT_ZERO (test_char_in_range ('0', '5', date[*offset], offset));
2685 first_digit = COB_D2I (date[*offset - 1]);
2686
2687 /* Validate second digit */
2688 if (first_digit == 0) {
2689 RETURN_IF_NOT_ZERO (test_char_in_range ('1', '9', date[*offset],
2690 offset));
2691 } else if (first_digit != 5) {
2692 RETURN_IF_NOT_ZERO (test_digit (date[*offset], offset));
2693 } else {
2694 max_last_digit = max_week (year) == 53 ? '3' : '2';
2695 RETURN_IF_NOT_ZERO (test_char_in_range ('0', max_last_digit,
2696 date[*offset], offset));
2697 }
2698
2699 return 0;
2700 }
2701
2702 static int
test_day_of_week(const char * date,int * offset)2703 test_day_of_week (const char *date, int *offset)
2704 {
2705 RETURN_IF_NOT_ZERO (test_char_in_range ('1', '7', date[*offset], offset));
2706 return 0;
2707 }
2708
2709 static int
test_date_end(const struct date_format format,const char * date,const int year,int * offset)2710 test_date_end (const struct date_format format, const char *date, const int year, int *offset)
2711 {
2712 int month;
2713
2714 if (format.days == DAYS_MMDD) {
2715 RETURN_IF_NOT_ZERO (test_month (date, offset, &month));
2716 RETURN_IF_NOT_ZERO (test_hyphen_presence (format.with_hyphens, date, offset));
2717 RETURN_IF_NOT_ZERO (test_day_of_month (date, year, month, offset));
2718 } else if (format.days == DAYS_DDD) {
2719 RETURN_IF_NOT_ZERO (test_day_of_year (date, year, offset));
2720 } else { /* DAYS_WWWD */
2721 RETURN_IF_NOT_ZERO (test_w_presence (date, offset));
2722 RETURN_IF_NOT_ZERO (test_week (date, year, offset));
2723 RETURN_IF_NOT_ZERO (test_hyphen_presence (format.with_hyphens, date, offset));
2724 RETURN_IF_NOT_ZERO (test_day_of_week (date, offset));
2725 }
2726
2727 return 0;
2728 }
2729
2730 static int
test_no_trailing_junk(const char * str,int offset,int end_of_string)2731 test_no_trailing_junk (const char *str, int offset, int end_of_string)
2732 {
2733 if (end_of_string) {
2734 /* Allow trailing spaces at the end of strings */
2735 while (str[offset] != '\0') {
2736 if (str[offset] != ' ') {
2737 return offset + 1;
2738 }
2739 ++offset;
2740 }
2741 return 0;
2742 } else {
2743 return str[offset] == '\0' ? 0 : offset + 1;
2744 }
2745
2746 }
2747
2748 static int
test_formatted_date(const struct date_format format,const char * date,const int end_of_string)2749 test_formatted_date (const struct date_format format, const char *date,
2750 const int end_of_string)
2751 {
2752 int offset = 0;
2753 int year;
2754
2755 RETURN_IF_NOT_ZERO (test_year (date, &offset, &year));
2756 RETURN_IF_NOT_ZERO (test_hyphen_presence (format.with_hyphens, date, &offset));
2757 RETURN_IF_NOT_ZERO (test_date_end (format, date, year, &offset));
2758 RETURN_IF_NOT_ZERO (test_no_trailing_junk (date, offset, end_of_string));
2759 return 0;
2760 }
2761
2762 static int
test_less_than_60(const char * time,int * offset)2763 test_less_than_60 (const char *time, int *offset)
2764 {
2765 RETURN_IF_NOT_ZERO (test_char_in_range ('0', '5', time[*offset], offset));
2766 RETURN_IF_NOT_ZERO (test_digit (time[*offset], offset));
2767 return 0;
2768 }
2769
2770 static int
test_hour(const char * time,int * offset)2771 test_hour (const char *time, int *offset)
2772 {
2773 int first_digit;
2774
2775 RETURN_IF_NOT_ZERO (test_char_in_range ('0', '2', time[*offset], offset));
2776 first_digit = COB_D2I (time[*offset - 1]);
2777
2778 if (first_digit != 2) {
2779 RETURN_IF_NOT_ZERO (test_digit (time[*offset], offset));
2780 } else {
2781 RETURN_IF_NOT_ZERO (test_char_in_range ('0', '3', time[*offset], offset));
2782 }
2783
2784 return 0;
2785 }
2786
2787 static int
test_minute(const char * time,int * offset)2788 test_minute (const char *time, int *offset)
2789 {
2790 RETURN_IF_NOT_ZERO (test_less_than_60 (time, offset));
2791 return 0;
2792 }
2793
2794 static int
test_second(const char * time,int * offset)2795 test_second (const char *time, int *offset)
2796 {
2797 RETURN_IF_NOT_ZERO (test_less_than_60 (time, offset));
2798 return 0;
2799 }
2800
2801 static int
test_colon_presence(const int with_colons,const char * time,int * offset)2802 test_colon_presence (const int with_colons, const char *time,
2803 int *offset)
2804 {
2805 if (with_colons) {
2806 RETURN_IF_NOT_ZERO (test_char (':', time, offset));
2807 }
2808
2809 return 0;
2810 }
2811
2812 static int
test_decimal_places(const int num_decimal_places,const char decimal_point,const char * time,int * offset)2813 test_decimal_places (const int num_decimal_places, const char decimal_point,
2814 const char *time, int *offset)
2815 {
2816 int i;
2817
2818 if (num_decimal_places != 0) {
2819 RETURN_IF_NOT_ZERO (test_char (decimal_point, time, offset));
2820 for (i = 0; i < num_decimal_places; ++i) {
2821 RETURN_IF_NOT_ZERO (test_digit (time[*offset], offset));
2822 }
2823 }
2824
2825 return 0;
2826 }
2827
2828 static int
test_z_presence(const char * time,int * offset)2829 test_z_presence (const char *time, int *offset)
2830 {
2831 return test_char ('Z', time, offset);
2832 }
2833
2834 static int
test_two_zeroes(const char * str,int * offset)2835 test_two_zeroes (const char *str, int *offset)
2836 {
2837 RETURN_IF_NOT_ZERO (test_char ('0', str, offset));
2838 RETURN_IF_NOT_ZERO (test_char ('0', str, offset));
2839 return 0;
2840 }
2841
2842 static int
test_offset_time(const struct time_format format,const char * time,int * offset)2843 test_offset_time (const struct time_format format, const char *time, int *offset)
2844 {
2845 if (time[*offset] == '+' || time[*offset] == '-') {
2846 ++*offset;
2847 RETURN_IF_NOT_ZERO (test_hour (time, offset));
2848 RETURN_IF_NOT_ZERO (test_colon_presence (format.with_colons,
2849 time, offset));
2850 RETURN_IF_NOT_ZERO (test_minute (time, offset));
2851 } else if (time[*offset] == '0') {
2852 ++*offset;
2853 RETURN_IF_NOT_ZERO (test_two_zeroes (time, offset));
2854 RETURN_IF_NOT_ZERO (test_colon_presence (format.with_colons,
2855 time, offset));
2856 RETURN_IF_NOT_ZERO (test_two_zeroes (time, offset));
2857 } else {
2858 return *offset + 1;
2859 }
2860
2861 return 0;
2862 }
2863
2864 static int
test_time_end(const struct time_format format,const char * time,int * offset)2865 test_time_end (const struct time_format format, const char *time,
2866 int *offset)
2867 {
2868 if (format.extra == EXTRA_Z) {
2869 RETURN_IF_NOT_ZERO (test_z_presence (time, offset));
2870 } else if (format.extra == EXTRA_OFFSET_TIME) {
2871 RETURN_IF_NOT_ZERO (test_offset_time (format, time, offset));
2872 }
2873
2874 return 0;
2875 }
2876
2877 static int
test_formatted_time(const struct time_format format,const char * time,const char decimal_point)2878 test_formatted_time (const struct time_format format, const char *time,
2879 const char decimal_point)
2880 {
2881 int offset = 0;
2882
2883 RETURN_IF_NOT_ZERO (test_hour (time, &offset));
2884 RETURN_IF_NOT_ZERO (test_colon_presence (format.with_colons, time, &offset));
2885 RETURN_IF_NOT_ZERO (test_minute (time, &offset));
2886 RETURN_IF_NOT_ZERO (test_colon_presence (format.with_colons, time, &offset));
2887 RETURN_IF_NOT_ZERO (test_second (time, &offset));
2888 RETURN_IF_NOT_ZERO (test_decimal_places (format.decimal_places,
2889 decimal_point, time, &offset));
2890 RETURN_IF_NOT_ZERO (test_time_end (format, time, &offset));
2891 RETURN_IF_NOT_ZERO (test_no_trailing_junk (time, offset, 1));
2892
2893 return 0;
2894 }
2895
2896 #undef RETURN_IF_NOT_ZERO
2897
2898 static cob_u32_t
integer_of_mmdd(const struct date_format format,const int year,const char * final_part)2899 integer_of_mmdd (const struct date_format format, const int year,
2900 const char *final_part)
2901 {
2902 const char *scanf_str = format.with_hyphens ? "%2d-%2d" : "%2d%2d";
2903 int month;
2904 int day;
2905
2906 /* LCOV_EXCL_START */
2907 if (unlikely (!sscanf (final_part, scanf_str, &month, &day))) {
2908 cob_fatal_error (COB_FERROR_CODEGEN);
2909 }
2910 /* LCOV_EXCL_STOP */
2911 return integer_of_date (year, month, day);
2912
2913 }
2914
2915 static cob_u32_t
integer_of_ddd(const int year,const char * final_part)2916 integer_of_ddd (const int year, const char *final_part)
2917 {
2918 int day;
2919
2920 /* LCOV_EXCL_START */
2921 if (unlikely (!sscanf (final_part, "%3d", &day))) {
2922 cob_fatal_error (COB_FERROR_CODEGEN);
2923 }
2924 /* LCOV_EXCL_STOP */
2925 return integer_of_day (year, day);
2926 }
2927
2928 static cob_u32_t
integer_of_wwwd(const struct date_format format,const int year,const char * final_part)2929 integer_of_wwwd (const struct date_format format, const int year,
2930 const char *final_part)
2931 {
2932 int first_week_monday;
2933 const char *scanf_str = format.with_hyphens ? "W%2d-%1d" : "W%2d%1d";
2934 int week;
2935 int day_of_week;
2936 cob_u32_t total_days = 0;
2937
2938 first_week_monday = get_iso_week_one (days_up_to_year (year) + 1, 1);
2939 /* LCOV_EXCL_START */
2940 if (unlikely (!sscanf (final_part, scanf_str, &week, &day_of_week))) {
2941 cob_fatal_error (COB_FERROR_CODEGEN);
2942 }
2943 /* LCOV_EXCL_STOP */
2944 total_days = first_week_monday + ((week - 1) * 7) + day_of_week - 1;
2945
2946 return total_days;
2947 }
2948
2949 static cob_u32_t
integer_of_formatted_date(const struct date_format format,const char * formatted_date)2950 integer_of_formatted_date (const struct date_format format,
2951 const char *formatted_date)
2952 {
2953 int year;
2954 int final_part_start = 4 + format.with_hyphens;
2955
2956 /* LCOV_EXCL_START */
2957 if (unlikely (!sscanf (formatted_date, "%4d", &year))) {
2958 cob_fatal_error (COB_FERROR_CODEGEN);
2959 }
2960 /* LCOV_EXCL_STOP */
2961
2962 if (format.days == DAYS_MMDD) {
2963 return integer_of_mmdd (format, year, formatted_date + final_part_start);
2964 } else if (format.days == DAYS_DDD) {
2965 return integer_of_ddd (year, formatted_date + final_part_start);
2966 } else { /* DAYS_WWWD */
2967 return integer_of_wwwd (format, year, formatted_date + final_part_start);
2968 }
2969
2970 }
2971
2972 static void
format_datetime(const struct date_format date_fmt,const struct time_format time_fmt,const int days,const int whole_seconds,cob_decimal * fractional_seconds,int * offset_time,char * buff)2973 format_datetime (const struct date_format date_fmt,
2974 const struct time_format time_fmt,
2975 const int days,
2976 const int whole_seconds,
2977 cob_decimal *fractional_seconds,
2978 int *offset_time,
2979 char *buff)
2980 {
2981 int overflow;
2982 char formatted_time[COB_TIMESTR_LEN] = { '\0' };
2983 char formatted_date[COB_DATESTR_LEN] = { '\0' };
2984
2985 overflow = format_time (time_fmt, whole_seconds, fractional_seconds,
2986 offset_time, formatted_time);
2987 format_date (date_fmt, days + overflow, formatted_date);
2988
2989 sprintf (buff, "%sT%s", formatted_date, formatted_time);
2990 }
2991
2992 /* Uses d1 */
2993 static void
format_current_date(const struct date_format date_fmt,const struct time_format time_fmt,char * formatted_datetime)2994 format_current_date (const struct date_format date_fmt,
2995 const struct time_format time_fmt,
2996 char *formatted_datetime)
2997 {
2998 struct cob_time time = cob_get_current_date_and_time ();
2999 int days
3000 = integer_of_date (time.year, time.month, time.day_of_month);
3001 int seconds_from_midnight
3002 = time.hour * 60 * 60 + time.minute * 60 + time.second;
3003 cob_decimal *fractional_second = &d1;
3004 int *offset_time;
3005
3006 mpz_set_ui (fractional_second->value, (unsigned long) time.nanosecond);
3007 fractional_second->scale = 9;
3008
3009 if (time.offset_known) {
3010 offset_time = &time.utc_offset;
3011 } else {
3012 offset_time = NULL;
3013 }
3014
3015 format_datetime (date_fmt, time_fmt, days, seconds_from_midnight,
3016 fractional_second, offset_time, formatted_datetime);
3017 }
3018
3019 static DECLNORET COB_A_NORETURN void
error_not_implemented(void)3020 error_not_implemented (void)
3021 {
3022 cob_set_exception (COB_EC_IMP_FEATURE_MISSING);
3023 cob_fatal_error (COB_FERROR_FUNCTION);
3024 }
3025
3026 /* Global functions */
3027
3028 /* Return switch value as field */
3029
3030 cob_field *
cob_switch_value(const int id)3031 cob_switch_value (const int id)
3032 {
3033 cob_alloc_set_field_int (cob_get_switch (id));
3034 return curr_field;
3035 }
3036
3037 /* Decimal exponentiation function */
3038 /* x ^ z = e ^ (z * log(x)) */
3039
3040 void
cob_decimal_pow(cob_decimal * pd1,cob_decimal * pd2)3041 cob_decimal_pow (cob_decimal *pd1, cob_decimal *pd2)
3042 {
3043 cob_uli_t n;
3044 int sign;
3045
3046 if (unlikely (pd1->scale == COB_DECIMAL_NAN)) {
3047 return;
3048 }
3049 if (unlikely (pd2->scale == COB_DECIMAL_NAN)) {
3050 pd1->scale = COB_DECIMAL_NAN;
3051 return;
3052 }
3053
3054 sign = mpz_sgn (pd1->value);
3055
3056 if (!mpz_sgn (pd2->value)) {
3057 /* Exponent is zero */
3058 if (!sign) {
3059 /* 0 ^ 0 */
3060 cob_set_exception (COB_EC_SIZE_EXPONENTIATION);
3061 }
3062 mpz_set_ui (pd1->value, 1UL);
3063 pd1->scale = 0;
3064 return;
3065 }
3066 if (!sign) {
3067 /* Value is zero */
3068 pd1->scale = 0;
3069 return;
3070 }
3071
3072 cob_trim_decimal (pd2);
3073
3074 if (sign < 0 && pd2->scale) {
3075 /* Negative exponent and non-integer power */
3076 pd1->scale = COB_DECIMAL_NAN;
3077 cob_set_exception (COB_EC_SIZE_EXPONENTIATION);
3078 return;
3079 }
3080
3081 cob_trim_decimal (pd1);
3082
3083 if (!pd2->scale) {
3084 /* Integer power */
3085 if (!mpz_cmp_ui (pd2->value, 1UL)) {
3086 /* Power is 1 */
3087 return;
3088 }
3089 if (mpz_sgn (pd2->value) < 0 && mpz_fits_slong_p (pd2->value)) {
3090 /* Negative power */
3091 mpz_abs (pd2->value, pd2->value);
3092 n = mpz_get_ui (pd2->value);
3093 mpz_pow_ui (pd1->value, pd1->value, n);
3094 if (pd1->scale) {
3095 pd1->scale *= n;
3096 cob_trim_decimal (pd1);
3097 }
3098 cob_decimal_set (pd2, pd1);
3099 mpz_set_ui (pd1->value, 1UL),
3100 pd1->scale = 0;
3101 cob_decimal_div (pd1, pd2);
3102 cob_trim_decimal (pd1);
3103 return;
3104 }
3105 if (mpz_fits_ulong_p (pd2->value)) {
3106 /* Positive power */
3107 n = mpz_get_ui (pd2->value);
3108 mpz_pow_ui (pd1->value, pd1->value, n);
3109 if (pd1->scale) {
3110 pd1->scale *= n;
3111 cob_trim_decimal (pd1);
3112 }
3113 return;
3114 }
3115 }
3116
3117 if (sign < 0) {
3118 mpz_abs (pd1->value, pd1->value);
3119 }
3120 cob_decimal_get_mpf (cob_mpft, pd1);
3121 if (pd2->scale == 1 && !mpz_cmp_ui (pd2->value, 5UL)) {
3122 /* Square root short cut */
3123 mpf_sqrt (cob_mpft2, cob_mpft);
3124 } else {
3125 cob_decimal_get_mpf (cob_mpft2, pd2);
3126 cob_mpf_log (cob_mpft, cob_mpft);
3127 mpf_mul (cob_mpft, cob_mpft, cob_mpft2);
3128 cob_mpf_exp (cob_mpft2, cob_mpft);
3129 }
3130 cob_decimal_set_mpf (pd1, cob_mpft2);
3131 if (sign < 0) {
3132 mpz_neg (pd1->value, pd1->value);
3133 }
3134 }
3135
3136 /* Indirect field get/put functions */
3137
3138 void
cob_put_indirect_field(cob_field * f)3139 cob_put_indirect_field (cob_field *f)
3140 {
3141 make_field_entry (f);
3142 memcpy (curr_field->data, f->data, f->size);
3143 move_field = curr_field;
3144 }
3145
3146 void
cob_get_indirect_field(cob_field * f)3147 cob_get_indirect_field (cob_field *f)
3148 {
3149 cob_move (move_field, f);
3150 }
3151
3152 /* Indirect move */
3153
3154 void
cob_decimal_move_temp(cob_field * src,cob_field * dst)3155 cob_decimal_move_temp (cob_field *src, cob_field *dst)
3156 {
3157 short size, scale;
3158 cob_field_attr attr;
3159 cob_field field;
3160
3161 cob_decimal_set_field (&d1, src);
3162 cob_trim_decimal (&d1);
3163
3164 size = (short)mpz_sizeinbase (d1.value, 10);
3165 if (d1.scale > size) {
3166 size = (short)d1.scale;
3167 }
3168 scale = (short)d1.scale;
3169 COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, size,
3170 scale, COB_FLAG_HAVE_SIGN, NULL);
3171 COB_FIELD_INIT (size, NULL, &attr);
3172 make_field_entry (&field);
3173 (void)cob_decimal_get_field (&d1, curr_field, 0);
3174 cob_move (curr_field, dst);
3175 }
3176
3177 /* TEST-NUMVAL implementation */
3178
3179 /* Validate NUMVAL / NUMVAL-C item */
3180 /* [spaces][+|-][spaces]{digits[.[digits]]|.digits}[spaces] */
3181 /* [spaces]{digits[.[digits]]|.digits}[spaces][+|-|CR|DB][spaces] */
3182 int
cob_check_numval(const cob_field * srcfield,const cob_field * currency,const int chkcurr,const int anycase)3183 cob_check_numval (const cob_field *srcfield, const cob_field *currency,
3184 const int chkcurr, const int anycase)
3185 {
3186 unsigned char *p;
3187 unsigned char *begp;
3188 unsigned char *endp;
3189 size_t pos;
3190 size_t plus_minus;
3191 size_t digits;
3192 size_t dec_seen;
3193 size_t space_seen;
3194 size_t break_needed;
3195 size_t currcy_size;
3196 int n;
3197 unsigned char dec_pt;
3198 unsigned char cur_symb;
3199
3200 /* FIXME later: srcfield may be of category national... */
3201
3202 begp = NULL;
3203 currcy_size = 0;
3204 if (currency) {
3205 endp = NULL;
3206 p = currency->data;
3207 for (pos = 0; pos < currency->size; pos++, p++) {
3208 switch (*p) {
3209 case '0':
3210 case '1':
3211 case '2':
3212 case '3':
3213 case '4':
3214 case '5':
3215 case '6':
3216 case '7':
3217 case '8':
3218 case '9':
3219 case '+':
3220 case '-':
3221 case '.':
3222 case ',':
3223 case '*':
3224 return 1;
3225 case ' ':
3226 break;
3227 default:
3228 if (pos < currency->size - 1) {
3229 if (!memcmp (p, "CR", (size_t)2)) {
3230 return 1;
3231 }
3232 if (!memcmp (p, "DB", (size_t)2)) {
3233 return 1;
3234 }
3235 }
3236 if (!begp) {
3237 begp = p;
3238 }
3239 endp = p;
3240 break;
3241 }
3242 }
3243 if (!endp || !begp) {
3244 return 1;
3245 }
3246 currcy_size = endp - begp;
3247 currcy_size++;
3248 if (currcy_size >= srcfield->size) {
3249 begp = NULL;
3250 currcy_size = 0;
3251 }
3252 } else if (chkcurr) {
3253 cur_symb = COB_MODULE_PTR->currency_symbol;
3254 begp = &cur_symb;
3255 currcy_size = 1;
3256 }
3257
3258 if (!srcfield->size) {
3259 return 1;
3260 }
3261
3262 p = srcfield->data;
3263 plus_minus = 0;
3264 digits = 0;
3265 dec_seen = 0;
3266 space_seen = 0;
3267 break_needed = 0;
3268 dec_pt = COB_MODULE_PTR->decimal_point;
3269
3270 /* Check leading positions */
3271 for (n = 0; n < (int)srcfield->size; ++n, ++p) {
3272 switch (*p) {
3273 case '0':
3274 case '1':
3275 case '2':
3276 case '3':
3277 case '4':
3278 case '5':
3279 case '6':
3280 case '7':
3281 case '8':
3282 case '9':
3283 break_needed = 1;
3284 break;
3285 case ' ':
3286 continue;
3287 case '+':
3288 case '-':
3289 if (plus_minus) {
3290 return n + 1;
3291 }
3292 plus_minus = 1;
3293 continue;
3294 case ',':
3295 case '.':
3296 if (*p != dec_pt) {
3297 return n + 1;
3298 }
3299 break_needed = 1;
3300 break;
3301 default:
3302 if (begp && n < (int)(srcfield->size - currcy_size)) {
3303 if (!memcmp (p, begp, currcy_size)) {
3304 break;
3305 }
3306 }
3307 return n + 1;
3308 }
3309 if (break_needed) {
3310 break;
3311 }
3312 }
3313
3314 if (n == (int)srcfield->size) {
3315 return n + 1;
3316 }
3317
3318 for (; n < (int)srcfield->size; ++n, ++p) {
3319 switch (*p) {
3320 case '0':
3321 case '1':
3322 case '2':
3323 case '3':
3324 case '4':
3325 case '5':
3326 case '6':
3327 case '7':
3328 case '8':
3329 case '9':
3330 if (++digits > COB_MAX_DIGITS || space_seen) {
3331 return n + 1;
3332 }
3333 continue;
3334 case ',':
3335 case '.':
3336 if (dec_seen || space_seen) {
3337 return n + 1;
3338 }
3339 if (*p == dec_pt) {
3340 dec_seen = 1;
3341 } else if (!chkcurr) {
3342 return n + 1;
3343 }
3344 continue;
3345 case ' ':
3346 space_seen = 1;
3347 continue;
3348 case '+':
3349 case '-':
3350 if (plus_minus) {
3351 return n + 1;
3352 }
3353 plus_minus = 1;
3354 continue;
3355 case 'c':
3356 if (!anycase) {
3357 return n + 1;
3358 }
3359 /* Fall through */
3360 case 'C':
3361 if (plus_minus) {
3362 return n + 1;
3363 }
3364 if (n < (int)srcfield->size - 1) {
3365 if (*(p + 1) == 'R' ||
3366 (anycase && *(p + 1) == 'r')) {
3367 plus_minus = 1;
3368 p++;
3369 n++;
3370 continue;
3371 }
3372 }
3373 return n + 2;
3374 case 'd':
3375 if (!anycase) {
3376 return n + 1;
3377 }
3378 /* Fall through */
3379 case 'D':
3380 if (plus_minus) {
3381 return n + 1;
3382 }
3383 if (n < (int)srcfield->size - 1) {
3384 if (*(p + 1) == 'B' ||
3385 (anycase && *(p + 1) == 'b')) {
3386 plus_minus = 1;
3387 p++;
3388 n++;
3389 continue;
3390 }
3391 }
3392 return n + 2;
3393 default:
3394 return n + 1;
3395 }
3396 }
3397
3398 if (!digits) {
3399 return n + 1;
3400 }
3401
3402 return 0;
3403 }
3404
3405 /* Date/time format validation */
3406
3407 int
cob_valid_date_format(const char * format)3408 cob_valid_date_format (const char *format)
3409 {
3410 return !strcmp (format, "YYYYMMDD")
3411 || !strcmp (format, "YYYY-MM-DD")
3412 || !strcmp (format, "YYYYDDD")
3413 || !strcmp (format, "YYYY-DDD")
3414 || !strcmp (format, "YYYYWwwD")
3415 || !strcmp (format, "YYYY-Www-D");
3416 }
3417
3418 int
cob_valid_time_format(const char * format,const char decimal_point)3419 cob_valid_time_format (const char *format, const char decimal_point)
3420 {
3421 int with_colons;
3422 unsigned int format_offset;
3423 unsigned int decimal_places = 0;
3424
3425 if (!strncmp (format, "hhmmss", 6)) {
3426 with_colons = 0;
3427 format_offset = 6;
3428 } else if (!strncmp (format, "hh:mm:ss", 8)) {
3429 with_colons = 1;
3430 format_offset = 8;
3431 } else {
3432 return 0;
3433 }
3434
3435 /* Validate number of decimal places */
3436 if (format[format_offset] == decimal_point) {
3437 decimal_places = decimal_places_for_seconds (format, format_offset);
3438 format_offset += decimal_places + 1;
3439 if (decimal_places == 0
3440 || decimal_places > COB_TIMEDEC_MAX) {
3441 return 0;
3442 }
3443 }
3444
3445 /* Check for trailing garbage */
3446 if (strlen (format) > (size_t) format_offset
3447 && !rest_is_z (format + format_offset)
3448 && !rest_is_offset_format (format + format_offset, with_colons)) {
3449 return 0;
3450 }
3451
3452 return 1;
3453 }
3454
3455 int
cob_valid_datetime_format(const char * format,const char decimal_point)3456 cob_valid_datetime_format (const char *format, const char decimal_point)
3457 {
3458 char date_format_str[COB_DATETIMESTR_LEN] = { '\0' };
3459 char time_format_str[COB_DATETIMESTR_LEN] = { '\0' };
3460 struct date_format date_format;
3461 struct time_format time_format;
3462
3463 split_around_t (format, date_format_str, time_format_str);
3464
3465 if (!cob_valid_date_format (date_format_str)
3466 || !cob_valid_time_format (time_format_str, decimal_point)) {
3467 return 0;
3468 }
3469
3470 /* Check time and date formats match */
3471 date_format = parse_date_format_string (date_format_str);
3472 time_format = parse_time_format_string (time_format_str);
3473 if (date_format.with_hyphens != time_format.with_colons) {
3474 return 0;
3475 }
3476
3477 return 1;
3478 }
3479
3480 /* Numeric expressions */
3481
3482 cob_field *
cob_intr_binop(cob_field * f1,const int op,cob_field * f2)3483 cob_intr_binop (cob_field *f1, const int op, cob_field *f2)
3484 {
3485 cob_decimal_set_field (&d1, f1);
3486 cob_decimal_set_field (&d2, f2);
3487 switch (op) {
3488 case '+':
3489 cob_decimal_add (&d1, &d2);
3490 break;
3491 case '-':
3492 cob_decimal_sub (&d1, &d2);
3493 break;
3494 case '*':
3495 cob_decimal_mul (&d1, &d2);
3496 break;
3497 case '/':
3498 cobglobptr->cob_exception_code = 0;
3499 if (!mpz_sgn (d2.value)) {
3500 /* Divide by zero */
3501 cob_set_exception (COB_EC_SIZE_ZERO_DIVIDE);
3502 mpz_set_ui (d1.value, 0UL);
3503 d1.scale = 0;
3504 } else {
3505 cob_decimal_div (&d1, &d2);
3506 }
3507 break;
3508 case '^':
3509 cob_decimal_pow (&d1, &d2);
3510 break;
3511 default:
3512 break;
3513 }
3514
3515 cob_alloc_field (&d1);
3516 (void)cob_decimal_get_field (&d1, curr_field, 0);
3517 return curr_field;
3518 }
3519
3520 /* Intrinsics */
3521
3522 cob_field *
cob_intr_length(cob_field * srcfield)3523 cob_intr_length (cob_field *srcfield)
3524 {
3525 if (COB_FIELD_IS_NATIONAL (srcfield)) {
3526 cob_alloc_set_field_uint ((cob_u32_t)srcfield->size / COB_NATIONAL_SIZE);
3527 } else {
3528 cob_alloc_set_field_uint ((cob_u32_t)srcfield->size);
3529 }
3530 return curr_field;
3531 }
3532
3533 cob_field *
cob_intr_byte_length(cob_field * srcfield)3534 cob_intr_byte_length (cob_field *srcfield)
3535 {
3536 cob_alloc_set_field_uint ((cob_u32_t)srcfield->size);
3537 return curr_field;
3538 }
3539
3540 cob_field *
cob_intr_integer(cob_field * srcfield)3541 cob_intr_integer (cob_field *srcfield)
3542 {
3543 int sign;
3544
3545 cob_decimal_set_field (&d1, srcfield);
3546 /* Check scale */
3547 if (d1.scale < 0) {
3548 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d1.scale);
3549 mpz_mul (d1.value, d1.value, cob_mexp);
3550 } else if (d1.scale > 0) {
3551 sign = mpz_sgn (d1.value);
3552 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
3553 mpz_tdiv_qr (d1.value, cob_mpzt, d1.value, cob_mexp);
3554 /* Check negative and has decimal places */
3555 if (sign < 0 && mpz_sgn (cob_mpzt)) {
3556 mpz_sub_ui (d1.value, d1.value, 1UL);
3557 }
3558 }
3559 d1.scale = 0;
3560
3561 cob_alloc_field (&d1);
3562 (void)cob_decimal_get_field (&d1, curr_field, 0);
3563 return curr_field;
3564 }
3565
3566 cob_field *
cob_intr_integer_part(cob_field * srcfield)3567 cob_intr_integer_part (cob_field *srcfield)
3568 {
3569 cob_decimal_set_field (&d1, srcfield);
3570 /* Check scale */
3571 if (d1.scale < 0) {
3572 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)-d1.scale);
3573 mpz_mul (d1.value, d1.value, cob_mexp);
3574 } else if (d1.scale > 0) {
3575 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
3576 mpz_tdiv_q (d1.value, d1.value, cob_mexp);
3577 }
3578 d1.scale = 0;
3579
3580 cob_alloc_field (&d1);
3581 (void)cob_decimal_get_field (&d1, curr_field, 0);
3582 return curr_field;
3583 }
3584
3585 cob_field *
cob_intr_fraction_part(cob_field * srcfield)3586 cob_intr_fraction_part (cob_field *srcfield)
3587 {
3588 cob_decimal_set_field (&d1, srcfield);
3589 /* Check scale */
3590 if (d1.scale > 0) {
3591 mpz_ui_pow_ui (cob_mexp, 10UL, (cob_uli_t)d1.scale);
3592 mpz_tdiv_r (d1.value, d1.value, cob_mexp);
3593 } else {
3594 /* No decimals */
3595 mpz_set_ui (d1.value, 0UL);
3596 d1.scale = 0;
3597 }
3598
3599 cob_alloc_field (&d1);
3600 (void)cob_decimal_get_field (&d1, curr_field, 0);
3601 return curr_field;
3602 }
3603
3604 cob_field *
cob_intr_sign(cob_field * srcfield)3605 cob_intr_sign (cob_field *srcfield)
3606 {
3607 cob_decimal_set_field (&d1, srcfield);
3608 cob_alloc_set_field_int (mpz_sgn (d1.value));
3609 return curr_field;
3610 }
3611
3612 cob_field *
cob_intr_upper_case(const int offset,const int length,cob_field * srcfield)3613 cob_intr_upper_case (const int offset, const int length, cob_field *srcfield)
3614 {
3615 size_t i, size;
3616
3617 make_field_entry (srcfield);
3618
3619 size = srcfield->size;
3620 for (i = 0; i < size; ++i) {
3621 curr_field->data[i] = (cob_u8_t)toupper (srcfield->data[i]);
3622 }
3623 if (unlikely (offset > 0)) {
3624 calc_ref_mod (curr_field, offset, length);
3625 }
3626 return curr_field;
3627 }
3628
3629 cob_field *
cob_intr_lower_case(const int offset,const int length,cob_field * srcfield)3630 cob_intr_lower_case (const int offset, const int length, cob_field *srcfield)
3631 {
3632 size_t i, size;
3633
3634 make_field_entry (srcfield);
3635
3636 size = srcfield->size;
3637 for (i = 0; i < size; ++i) {
3638 curr_field->data[i] = (cob_u8_t)tolower (srcfield->data[i]);
3639 }
3640 if (unlikely (offset > 0)) {
3641 calc_ref_mod (curr_field, offset, length);
3642 }
3643 return curr_field;
3644 }
3645
3646 cob_field *
cob_intr_reverse(const int offset,const int length,cob_field * srcfield)3647 cob_intr_reverse (const int offset, const int length, cob_field *srcfield)
3648 {
3649 size_t i, size;
3650
3651 make_field_entry (srcfield);
3652
3653 size = srcfield->size;
3654 for (i = 0; i < size; ++i) {
3655 curr_field->data[i] = srcfield->data[size - i - 1];
3656 }
3657 if (unlikely (offset > 0)) {
3658 calc_ref_mod (curr_field, offset, length);
3659 }
3660 return curr_field;
3661 }
3662
3663 cob_field *
cob_intr_module_date(void)3664 cob_intr_module_date (void)
3665 {
3666 cob_field_attr attr;
3667 cob_field field;
3668 char buff[16];
3669
3670 COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
3671 COB_FIELD_INIT (8, NULL, &attr);
3672 make_field_entry (&field);
3673 snprintf (buff, sizeof(buff), "%8.8u", COB_MODULE_PTR->module_date);
3674 memcpy (curr_field->data, buff, (size_t)8);
3675 return curr_field;
3676 }
3677
3678 cob_field *
cob_intr_module_time(void)3679 cob_intr_module_time (void)
3680 {
3681 cob_field_attr attr;
3682 cob_field field;
3683 char buff[8];
3684
3685 COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 6, 0, 0, NULL);
3686 COB_FIELD_INIT (6, NULL, &attr);
3687 make_field_entry (&field);
3688 snprintf (buff, sizeof(buff), "%6.6u", COB_MODULE_PTR->module_time);
3689 memcpy (curr_field->data, buff, (size_t)6);
3690 return curr_field;
3691 }
3692
3693 cob_field *
cob_intr_module_id(void)3694 cob_intr_module_id (void)
3695 {
3696 size_t calcsize;
3697 cob_field field;
3698
3699 calcsize = strlen (COB_MODULE_PTR->module_name);
3700 COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
3701 make_field_entry (&field);
3702 memcpy (curr_field->data, COB_MODULE_PTR->module_name, calcsize);
3703 return curr_field;
3704 }
3705
3706 cob_field *
cob_intr_module_caller_id(void)3707 cob_intr_module_caller_id (void)
3708 {
3709 size_t calcsize;
3710 cob_field field;
3711
3712 if (!COB_MODULE_PTR->next) {
3713 COB_FIELD_INIT (1, NULL, &const_alpha_attr);
3714 make_field_entry (&field);
3715 curr_field->size = 0;
3716 curr_field->data[0] = ' ';
3717 return curr_field;
3718 }
3719 calcsize = strlen (COB_MODULE_PTR->next->module_name);
3720 COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
3721 make_field_entry (&field);
3722 memcpy (curr_field->data, COB_MODULE_PTR->next->module_name,
3723 calcsize);
3724 return curr_field;
3725 }
3726
3727 cob_field *
cob_intr_module_formatted_date(void)3728 cob_intr_module_formatted_date (void)
3729 {
3730 size_t calcsize;
3731 cob_field field;
3732
3733 calcsize = strlen (COB_MODULE_PTR->module_formatted_date);
3734 COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
3735 make_field_entry (&field);
3736 memcpy (curr_field->data, COB_MODULE_PTR->module_formatted_date,
3737 calcsize);
3738 return curr_field;
3739 }
3740
3741 cob_field *
cob_intr_module_source(void)3742 cob_intr_module_source (void)
3743 {
3744 size_t calcsize;
3745 cob_field field;
3746
3747 calcsize = strlen (COB_MODULE_PTR->module_source);
3748 COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
3749 make_field_entry (&field);
3750 memcpy (curr_field->data, COB_MODULE_PTR->module_source, calcsize);
3751 return curr_field;
3752 }
3753
3754 cob_field *
cob_intr_module_path(void)3755 cob_intr_module_path (void)
3756 {
3757 size_t calcsize;
3758 cob_field field;
3759
3760 if (!COB_MODULE_PTR->module_path ||
3761 !*(COB_MODULE_PTR->module_path)) {
3762 COB_FIELD_INIT (1, NULL, &const_alpha_attr);
3763 make_field_entry (&field);
3764 curr_field->size = 0;
3765 curr_field->data[0] = ' ';
3766 return curr_field;
3767 }
3768 calcsize = strlen (*(COB_MODULE_PTR->module_path));
3769 COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
3770 make_field_entry (&field);
3771 memcpy (curr_field->data, *(COB_MODULE_PTR->module_path),
3772 calcsize);
3773 return curr_field;
3774 }
3775
3776 cob_field *
cob_intr_concatenate(const int offset,const int length,const int params,...)3777 cob_intr_concatenate (const int offset, const int length,
3778 const int params, ...)
3779 {
3780 cob_field **f;
3781 unsigned char *p;
3782 size_t calcsize;
3783 int i;
3784 cob_field field;
3785 va_list args;
3786
3787 f = cob_malloc ((size_t)params * sizeof (cob_field *));
3788
3789 va_start (args, params);
3790
3791 /* Extract args / calculate size */
3792 calcsize = 0;
3793 for (i = 0; i < params; ++i) {
3794 f[i] = va_arg (args, cob_field *);
3795 calcsize += f[i]->size;
3796 }
3797 va_end (args);
3798
3799 COB_FIELD_INIT (calcsize, NULL, &const_alpha_attr);
3800 make_field_entry (&field);
3801
3802 p = curr_field->data;
3803 for (i = 0; i < params; ++i) {
3804 memcpy (p, f[i]->data, f[i]->size);
3805 p += f[i]->size;
3806 }
3807
3808 if (unlikely (offset > 0)) {
3809 calc_ref_mod (curr_field, offset, length);
3810 }
3811 cob_free (f);
3812 return curr_field;
3813 }
3814
3815 cob_field *
cob_intr_substitute(const int offset,const int length,const int params,...)3816 cob_intr_substitute (const int offset, const int length,
3817 const int params, ...)
3818 {
3819 cob_field *ret;
3820 va_list args;
3821
3822 va_start (args, params);
3823 ret = substitute (offset, length, params, &memcmp, args);
3824 va_end (args);
3825
3826 return ret;
3827 }
3828
3829 cob_field *
cob_intr_substitute_case(const int offset,const int length,const int params,...)3830 cob_intr_substitute_case (const int offset, const int length,
3831 const int params, ...)
3832 {
3833 cob_field *ret;
3834 va_list args;
3835
3836 va_start (args, params);
3837 ret = substitute (offset, length, params, &int_strncasecmp, args);
3838 va_end (args);
3839
3840 return ret;
3841 }
3842
3843 cob_field *
cob_intr_trim(const int offset,const int length,cob_field * srcfield,const int direction)3844 cob_intr_trim (const int offset, const int length,
3845 cob_field *srcfield, const int direction)
3846 {
3847 unsigned char *begin;
3848 unsigned char *end;
3849 size_t i;
3850 size_t size;
3851
3852 make_field_entry (srcfield);
3853
3854 for (i = 0; i < srcfield->size; ++i) {
3855 if (srcfield->data[i] != ' ') {
3856 break;
3857 }
3858 }
3859 if (i == srcfield->size) {
3860 curr_field->size = 0;
3861 curr_field->data[0] = ' ';
3862 return curr_field;
3863 }
3864
3865 begin = srcfield->data;
3866 if (direction != 2) {
3867 for (; *begin == ' '; ++begin) ;
3868 }
3869 end = srcfield->data + srcfield->size - 1;
3870 if (direction != 1) {
3871 for (; *end == ' '; end--) ;
3872 }
3873
3874 size = 0;
3875 for (i = 0; begin <= end; ++begin, ++i) {
3876 curr_field->data[i] = *begin;
3877 ++size;
3878 }
3879 curr_field->size = size;
3880 if (unlikely (offset > 0)) {
3881 calc_ref_mod (curr_field, offset, length);
3882 }
3883 return curr_field;
3884 }
3885
3886 /* get variable length (at least 2) temporary field containing last file exception status + name */
3887 cob_field *
cob_intr_exception_file(void)3888 cob_intr_exception_file (void)
3889 {
3890 size_t flen;
3891 cob_field field;
3892
3893 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
3894 /* check if last-exception is active and a file-exception */
3895 if (!cobglobptr->cob_error_file ||
3896 (!cob_last_exception_is (COB_EC_I_O))) {
3897 field.size = 2;
3898 make_field_entry (&field);
3899 memcpy (curr_field->data, "00", (size_t)2);
3900 } else {
3901 flen = strlen (cobglobptr->cob_error_file->select_name);
3902 field.size = flen + 2;
3903 make_field_entry (&field);
3904 memcpy (curr_field->data,
3905 cobglobptr->cob_error_file->file_status, (size_t)2);
3906 memcpy (&(curr_field->data[2]),
3907 cobglobptr->cob_error_file->select_name, flen);
3908 }
3909 return curr_field;
3910 }
3911
3912 /* get variable length (at least 1) temporary field containing last exception location */
3913 cob_field *
cob_intr_exception_location(void)3914 cob_intr_exception_location (void)
3915 {
3916 char *buff;
3917 cob_field field;
3918
3919 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
3920 /* check if last-exception is active and if LOCATION is available */
3921 if (!cobglobptr->last_exception_id) {
3922 field.size = 1;
3923 make_field_entry (&field);
3924 *(curr_field->data) = ' ';
3925 return curr_field;
3926 }
3927 buff = cob_malloc ((size_t)COB_SMALL_BUFF);
3928 if (cobglobptr->last_exception_section && cobglobptr->last_exception_paragraph) {
3929 snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s OF %s; %u",
3930 cobglobptr->last_exception_id,
3931 cobglobptr->last_exception_paragraph,
3932 cobglobptr->last_exception_section,
3933 cobglobptr->last_exception_line);
3934 } else if (cobglobptr->last_exception_section) {
3935 snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u",
3936 cobglobptr->last_exception_id,
3937 cobglobptr->last_exception_section,
3938 cobglobptr->last_exception_line);
3939 } else if (cobglobptr->last_exception_paragraph) {
3940 snprintf (buff, (size_t)COB_SMALL_MAX, "%s; %s; %u",
3941 cobglobptr->last_exception_id,
3942 cobglobptr->last_exception_paragraph,
3943 cobglobptr->last_exception_line);
3944 } else {
3945 snprintf (buff, (size_t)COB_SMALL_MAX, "%s; ; %u",
3946 cobglobptr->last_exception_id,
3947 cobglobptr->last_exception_line);
3948 }
3949 buff[COB_SMALL_MAX] = 0; /* silence warnings */
3950 field.size = strlen (buff);
3951 make_field_entry (&field);
3952 memcpy (curr_field->data, buff, field.size);
3953 cob_free (buff);
3954 return curr_field;
3955 }
3956
3957 /* get x(31) temporary field containing last exception name */
3958 cob_field *
cob_intr_exception_status(void)3959 cob_intr_exception_status (void)
3960 {
3961 const char *except_name;
3962 cob_field field;
3963
3964 COB_FIELD_INIT (31, NULL, &const_alpha_attr);
3965 make_field_entry (&field);
3966
3967 memset (curr_field->data, ' ', (size_t)31);
3968 if (cob_get_last_exception_code() != 0) {
3969 except_name = cob_get_last_exception_name ();
3970 if (except_name == NULL) {
3971 except_name = "EXCEPTION-OBJECT";
3972 }
3973 memcpy (curr_field->data, except_name, strlen (except_name));
3974 }
3975 return curr_field;
3976 }
3977
3978 /* get x(31) temporary field containing last exception statement */
3979 cob_field *
cob_intr_exception_statement(void)3980 cob_intr_exception_statement (void)
3981 {
3982 size_t flen;
3983 cob_field field;
3984
3985 COB_FIELD_INIT (31, NULL, &const_alpha_attr);
3986 make_field_entry (&field);
3987
3988 memset (curr_field->data, ' ', (size_t)31);
3989 if (cobglobptr->last_exception_statement) {
3990 flen = strlen (cobglobptr->last_exception_statement);
3991 if (flen > 31) {
3992 flen = 31;
3993 }
3994 memcpy (curr_field->data, cobglobptr->last_exception_statement, flen);
3995 }
3996 return curr_field;
3997 }
3998
3999 cob_field *
cob_intr_when_compiled(const int offset,const int length,cob_field * f)4000 cob_intr_when_compiled (const int offset, const int length, cob_field *f)
4001 {
4002 make_field_entry (f);
4003
4004 memcpy (curr_field->data, f->data, f->size);
4005 if (unlikely (offset > 0)) {
4006 calc_ref_mod (curr_field, offset, length);
4007 }
4008 return curr_field;
4009 }
4010
4011 cob_field *
cob_intr_current_date(const int offset,const int length)4012 cob_intr_current_date (const int offset, const int length)
4013 {
4014 cob_field field;
4015 struct cob_time time;
4016 char buff[22] = { '\0' };
4017
4018 COB_FIELD_INIT (21, NULL, &const_alpha_attr);
4019 make_field_entry (&field);
4020
4021 time = cob_get_current_date_and_time ();
4022
4023 sprintf (buff, "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d",
4024 time.year, time.month, time.day_of_month, time.hour,
4025 time.minute, time.second, (int) time.nanosecond / 10000000);
4026
4027 add_offset_time (0, &time.utc_offset, 16, buff);
4028
4029 memcpy (curr_field->data, buff, (size_t)21);
4030 if (unlikely (offset > 0)) {
4031 calc_ref_mod (curr_field, offset, length);
4032 }
4033 return curr_field;
4034 }
4035
4036 cob_field *
cob_intr_char(cob_field * srcfield)4037 cob_intr_char (cob_field *srcfield)
4038 {
4039 int i;
4040 cob_field field;
4041
4042 COB_FIELD_INIT (1, NULL, &const_alpha_attr);
4043 make_field_entry (&field);
4044
4045 i = cob_get_int (srcfield);
4046 if (i < 1 || i > 256) {
4047 *curr_field->data = 0;
4048 } else {
4049 *curr_field->data = (unsigned char)i - 1;
4050 }
4051 return curr_field;
4052 }
4053
4054 cob_field *
cob_intr_ord(cob_field * srcfield)4055 cob_intr_ord (cob_field *srcfield)
4056 {
4057 cob_alloc_set_field_uint ((cob_u32_t)(*srcfield->data + 1U));
4058 return curr_field;
4059 }
4060
4061 cob_field *
cob_intr_stored_char_length(cob_field * srcfield)4062 cob_intr_stored_char_length (cob_field *srcfield)
4063 {
4064 unsigned char *p;
4065 cob_u32_t count;
4066
4067 count = srcfield->size;
4068 p = srcfield->data + srcfield->size - 1;
4069 for (; count > 0; count--, p--) {
4070 if (*p != ' ') {
4071 break;
4072 }
4073 }
4074
4075 cob_alloc_set_field_uint (count);
4076 return curr_field;
4077 }
4078
4079 cob_field *
cob_intr_combined_datetime(cob_field * srcdays,cob_field * srctime)4080 cob_intr_combined_datetime (cob_field *srcdays, cob_field *srctime)
4081 {
4082 int srdays;
4083 cob_decimal *combined_datetime;
4084 cob_decimal *srtime;
4085 cob_decimal *hundred_thousand;
4086
4087 cobglobptr->cob_exception_code = 0;
4088
4089 /* Validate and extract the value of srcdays */
4090 srdays = cob_get_int (srcdays);
4091 if (!valid_integer_date (srdays)) {
4092 goto invalid_args;
4093 }
4094 combined_datetime = &d1;
4095 mpz_set_ui (combined_datetime->value, (unsigned long) srdays);
4096 combined_datetime->scale = 0;
4097
4098 /* Extract and validate the value of srctime */
4099 srtime = &d2;
4100 cob_decimal_set_field (srtime, srctime);
4101 if (!valid_decimal_time (srtime)) {
4102 goto invalid_args;
4103 }
4104
4105 /* Set a decimal to 100 000. */
4106 hundred_thousand = &d3;
4107 mpz_set_ui (hundred_thousand->value, 100000UL);
4108 hundred_thousand->scale = 0;
4109
4110 /* Combined datetime = date + (time / 100 000) */
4111 cob_decimal_div (srtime, hundred_thousand);
4112 cob_decimal_add (combined_datetime, srtime);
4113
4114 cob_alloc_field (combined_datetime);
4115 (void) cob_decimal_get_field (combined_datetime, curr_field, 0);
4116 goto end_of_func;
4117
4118 invalid_args:
4119 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4120 cob_alloc_set_field_uint (0);
4121
4122 end_of_func:
4123 return curr_field;
4124 }
4125
4126 cob_field *
cob_intr_date_of_integer(cob_field * srcdays)4127 cob_intr_date_of_integer (cob_field *srcdays)
4128 {
4129 int days;
4130 int month;
4131 int year;
4132 cob_field_attr attr;
4133 cob_field field;
4134 char buff[16];
4135
4136 COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 8, 0, 0, NULL);
4137 COB_FIELD_INIT (8, NULL, &attr);
4138 make_field_entry (&field);
4139
4140 cobglobptr->cob_exception_code = 0;
4141 /* Base 1601-01-01 */
4142 days = cob_get_int (srcdays);
4143 if (!valid_integer_date (days)) {
4144 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4145 memset (curr_field->data, (int)'0', (size_t)8);
4146 return curr_field;
4147 }
4148
4149 date_of_integer (days, &year, &month, &days);
4150
4151 snprintf (buff, (size_t)15, "%4.4d%2.2d%2.2d", year, month, days);
4152 memcpy (curr_field->data, buff, (size_t)8);
4153 return curr_field;
4154 }
4155
4156 cob_field *
cob_intr_day_of_integer(cob_field * srcdays)4157 cob_intr_day_of_integer (cob_field *srcdays)
4158 {
4159 int days;
4160 int baseyear;
4161 cob_field_attr attr;
4162 cob_field field;
4163 char buff[13]; /* 13: make the compiler happy as "unsigned short" *could*
4164 have more digits than we "assume" */
4165
4166 COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, 7, 0, 0, NULL);
4167 COB_FIELD_INIT (7, NULL, &attr);
4168 make_field_entry (&field);
4169
4170 cobglobptr->cob_exception_code = 0;
4171 /* Base 1601-01-01 */
4172 days = cob_get_int (srcdays);
4173 if (!valid_integer_date (days)) {
4174 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4175 memset (curr_field->data, (int)'0', (size_t)7);
4176 return curr_field;
4177 }
4178
4179 day_of_integer (days, &baseyear, &days);
4180 snprintf (buff, sizeof (buff), "%4.4d%3.3d",
4181 (cob_u16_t) baseyear,
4182 (cob_u16_t) days);
4183
4184 memcpy (curr_field->data, buff, (size_t)7);
4185 return curr_field;
4186 }
4187
4188 cob_field *
cob_intr_integer_of_date(cob_field * srcfield)4189 cob_intr_integer_of_date (cob_field *srcfield)
4190 {
4191 int indate;
4192 int days;
4193 int month;
4194 int year;
4195
4196 cobglobptr->cob_exception_code = 0;
4197 /* Base 1601-01-01 */
4198 indate = cob_get_int (srcfield);
4199 year = indate / 10000;
4200 if (!valid_year (year)) {
4201 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4202 cob_alloc_set_field_uint (0);
4203 return curr_field;
4204 }
4205 indate %= 10000;
4206 month = indate / 100;
4207 if (!valid_month (month)) {
4208 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4209 cob_alloc_set_field_uint (0);
4210 return curr_field;
4211 }
4212 days = indate % 100;
4213 if (!valid_day_of_month (year, month, days)) {
4214 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4215 cob_alloc_set_field_uint (0);
4216 return curr_field;
4217 }
4218
4219 cob_alloc_set_field_uint (integer_of_date (year, month, days));
4220 return curr_field;
4221 }
4222
4223 cob_field *
cob_intr_integer_of_day(cob_field * srcfield)4224 cob_intr_integer_of_day (cob_field *srcfield)
4225 {
4226 int indate;
4227 int days;
4228 int year;
4229
4230 cobglobptr->cob_exception_code = 0;
4231 /* Base 1601-01-01 */
4232 indate = cob_get_int (srcfield);
4233 year = indate / 1000;
4234 if (!valid_year (year)) {
4235 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4236 cob_alloc_set_field_uint (0);
4237 return curr_field;
4238 }
4239 days = indate % 1000;
4240 if (!valid_day_of_year (year, days)) {
4241 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4242 cob_alloc_set_field_uint (0);
4243 return curr_field;
4244 }
4245
4246 cob_alloc_set_field_uint (integer_of_day (year, days));
4247 return curr_field;
4248 }
4249
4250 cob_field *
cob_intr_test_date_yyyymmdd(cob_field * srcfield)4251 cob_intr_test_date_yyyymmdd (cob_field *srcfield)
4252 {
4253 int indate;
4254 int days;
4255 int month;
4256 int year;
4257
4258 /* Base 1601-01-01 */
4259 indate = cob_get_int (srcfield);
4260 year = indate / 10000;
4261 if (!valid_year (year)) {
4262 cob_alloc_set_field_uint (1);
4263 return curr_field;
4264 }
4265 indate %= 10000;
4266 month = indate / 100;
4267 if (!valid_month (month)) {
4268 cob_alloc_set_field_uint (2);
4269 return curr_field;
4270 }
4271 days = indate % 100;
4272 if (!valid_day_of_month (year, month, days)) {
4273 cob_alloc_set_field_uint (3);
4274 return curr_field;
4275 }
4276 cob_alloc_set_field_uint (0);
4277 return curr_field;
4278 }
4279
4280 cob_field *
cob_intr_test_day_yyyyddd(cob_field * srcfield)4281 cob_intr_test_day_yyyyddd (cob_field *srcfield)
4282 {
4283 int indate;
4284 int days;
4285 int year;
4286
4287 /* Base 1601-01-01 */
4288 indate = cob_get_int (srcfield);
4289 year = indate / 1000;
4290 if (!valid_year (year)) {
4291 cob_alloc_set_field_uint (1);
4292 return curr_field;
4293 }
4294 days = indate % 1000;
4295 if (!valid_day_of_year (year, days)) {
4296 cob_alloc_set_field_uint (2);
4297 return curr_field;
4298 }
4299 cob_alloc_set_field_uint (0);
4300 return curr_field;
4301 }
4302
4303 cob_field *
cob_intr_factorial(cob_field * srcfield)4304 cob_intr_factorial (cob_field *srcfield)
4305 {
4306 int srcval;
4307
4308 cobglobptr->cob_exception_code = 0;
4309 srcval = cob_get_int (srcfield);
4310 d1.scale = 0;
4311 if (srcval < 0) {
4312 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4313 cob_alloc_set_field_uint (0);
4314 return curr_field;
4315 } else {
4316 mpz_fac_ui (d1.value, (cob_uli_t)srcval);
4317 }
4318
4319 cob_alloc_field (&d1);
4320 (void)cob_decimal_get_field (&d1, curr_field, 0);
4321 return curr_field;
4322 }
4323
4324 cob_field *
cob_intr_e(void)4325 cob_intr_e (void)
4326 {
4327 mpf_set_ui (cob_mpft, 1UL);
4328 cob_mpf_exp (cob_mpft, cob_mpft);
4329 cob_decimal_set_mpf (&d1, cob_mpft);
4330 cob_alloc_field (&d1);
4331 (void)cob_decimal_get_field (&d1, curr_field, 0);
4332
4333 return curr_field;
4334 }
4335
4336 cob_field *
cob_intr_pi(void)4337 cob_intr_pi (void)
4338 {
4339 mpf_set (cob_mpft, cob_pi);
4340 cob_decimal_set_mpf (&d1, cob_mpft);
4341 cob_alloc_field (&d1);
4342 (void)cob_decimal_get_field (&d1, curr_field, 0);
4343
4344 return curr_field;
4345 }
4346
4347 cob_field *
cob_intr_exp(cob_field * srcfield)4348 cob_intr_exp (cob_field *srcfield)
4349 {
4350 cob_decimal_set_field (&d1, srcfield);
4351
4352 cobglobptr->cob_exception_code = 0;
4353
4354 if (!mpz_sgn (d1.value)) {
4355 /* Power is zero */
4356 cob_alloc_set_field_uint (1);
4357 return curr_field;
4358 }
4359
4360 cob_decimal_get_mpf (cob_mpft, &d1);
4361 cob_mpf_exp (cob_mpft, cob_mpft);
4362 cob_decimal_set_mpf (&d1, cob_mpft);
4363 cob_alloc_field (&d1);
4364 (void)cob_decimal_get_field (&d1, curr_field, 0);
4365
4366 return curr_field;
4367 }
4368
4369 cob_field *
cob_intr_exp10(cob_field * srcfield)4370 cob_intr_exp10 (cob_field *srcfield)
4371 {
4372 int sign;
4373
4374 cob_decimal_set_field (&d1, srcfield);
4375
4376 cobglobptr->cob_exception_code = 0;
4377
4378 sign = mpz_sgn (d1.value);
4379 if (!sign) {
4380 /* Power is zero */
4381 cob_alloc_set_field_uint (1);
4382 return curr_field;
4383 }
4384
4385 cob_trim_decimal (&d1);
4386
4387 if (!d1.scale) {
4388 /* Integer positive/negative powers */
4389 if (sign < 0 && mpz_fits_sint_p (d1.value)) {
4390 mpz_abs (d1.value, d1.value);
4391 d1.scale = mpz_get_si (d1.value);
4392 mpz_set_ui (d1.value, 1UL);
4393 cob_alloc_field (&d1);
4394 (void)cob_decimal_get_field (&d1, curr_field, 0);
4395 return curr_field;
4396 }
4397 if (sign > 0 && mpz_fits_ulong_p (d1.value)) {
4398 mpz_ui_pow_ui (d1.value, 10UL, mpz_get_ui (d1.value));
4399 cob_alloc_field (&d1);
4400 (void)cob_decimal_get_field (&d1, curr_field, 0);
4401 return curr_field;
4402 }
4403 }
4404
4405 mpz_set_ui (d2.value, 10UL);
4406 d2.scale = 0;
4407 cob_decimal_pow (&d2, &d1);
4408 cob_alloc_field (&d2);
4409 (void)cob_decimal_get_field (&d2, curr_field, 0);
4410
4411 return curr_field;
4412 }
4413
4414 cob_field *
cob_intr_log(cob_field * srcfield)4415 cob_intr_log (cob_field *srcfield)
4416 {
4417 cob_decimal_set_field (&d1, srcfield);
4418
4419 cobglobptr->cob_exception_code = 0;
4420 if (mpz_sgn (d1.value) <= 0) {
4421 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4422 cob_alloc_set_field_uint (0);
4423 return curr_field;
4424 }
4425
4426 if (d1.scale) {
4427 cob_trim_decimal (&d1);
4428 }
4429
4430 if (!d1.scale && !mpz_cmp_ui (d1.value, 1UL)) {
4431 /* Log (1) = 0 */
4432 cob_alloc_set_field_uint (0);
4433 return curr_field;
4434 }
4435
4436 cob_decimal_get_mpf (cob_mpft, &d1);
4437 cob_mpf_log (cob_mpft, cob_mpft);
4438 cob_decimal_set_mpf (&d1, cob_mpft);
4439 cob_alloc_field (&d1);
4440 (void)cob_decimal_get_field (&d1, curr_field, 0);
4441
4442 return curr_field;
4443 }
4444
4445 cob_field *
cob_intr_log10(cob_field * srcfield)4446 cob_intr_log10 (cob_field *srcfield)
4447 {
4448 cob_decimal_set_field (&d1, srcfield);
4449
4450 cobglobptr->cob_exception_code = 0;
4451 if (mpz_sgn (d1.value) <= 0) {
4452 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4453 cob_alloc_set_field_uint (0);
4454 return curr_field;
4455 }
4456
4457 if (d1.scale) {
4458 cob_trim_decimal (&d1);
4459 }
4460
4461 if (!d1.scale && !mpz_cmp_ui (d1.value, 1UL)) {
4462 /* Log10 (1) = 0 */
4463 cob_alloc_set_field_uint (0);
4464 return curr_field;
4465 }
4466
4467 cob_decimal_get_mpf (cob_mpft, &d1);
4468 cob_mpf_log10 (cob_mpft, cob_mpft);
4469 cob_decimal_set_mpf (&d1, cob_mpft);
4470 cob_alloc_field (&d1);
4471 (void)cob_decimal_get_field (&d1, curr_field, 0);
4472
4473 return curr_field;
4474 }
4475
4476 cob_field *
cob_intr_abs(cob_field * srcfield)4477 cob_intr_abs (cob_field *srcfield)
4478 {
4479 cob_decimal_set_field (&d1, srcfield);
4480 mpz_abs (d1.value, d1.value);
4481
4482 make_field_entry (srcfield);
4483 (void)cob_decimal_get_field (&d1, curr_field, 0);
4484 return curr_field;
4485 }
4486
4487 cob_field *
cob_intr_acos(cob_field * srcfield)4488 cob_intr_acos (cob_field *srcfield)
4489 {
4490 cob_decimal_set_field (&d1, srcfield);
4491
4492 mpz_set (d4.value, d1.value);
4493 mpz_set (d5.value, d1.value);
4494 d4.scale = d1.scale;
4495 d5.scale = d1.scale;
4496 mpz_set_si (d2.value, -1L);
4497 d2.scale = 0;
4498 mpz_set_ui (d3.value, 1UL);
4499 d3.scale = 0;
4500
4501 cobglobptr->cob_exception_code = 0;
4502 if (cob_decimal_cmp (&d4, &d2) < 0 || cob_decimal_cmp (&d5, &d3) > 0) {
4503 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4504 cob_alloc_set_field_uint (0);
4505 return curr_field;
4506 }
4507
4508 cob_decimal_get_mpf (cob_mpft, &d1);
4509 cob_mpf_acos (cob_mpft, cob_mpft);
4510 cob_decimal_set_mpf (&d1, cob_mpft);
4511 cob_alloc_field (&d1);
4512 (void)cob_decimal_get_field (&d1, curr_field, 0);
4513
4514 return curr_field;
4515 }
4516
4517 cob_field *
cob_intr_asin(cob_field * srcfield)4518 cob_intr_asin (cob_field *srcfield)
4519 {
4520 cob_decimal_set_field (&d1, srcfield);
4521
4522 mpz_set (d4.value, d1.value);
4523 mpz_set (d5.value, d1.value);
4524 d4.scale = d1.scale;
4525 d5.scale = d1.scale;
4526 mpz_set_si (d2.value, -1L);
4527 d2.scale = 0;
4528 mpz_set_ui (d3.value, 1UL);
4529 d3.scale = 0;
4530
4531 cobglobptr->cob_exception_code = 0;
4532 if (cob_decimal_cmp (&d4, &d2) < 0 || cob_decimal_cmp (&d5, &d3) > 0) {
4533 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4534 cob_alloc_set_field_uint (0);
4535 return curr_field;
4536 }
4537
4538 if (!mpz_sgn (d1.value)) {
4539 /* Asin (0) = 0 */
4540 cob_alloc_set_field_uint (0);
4541 return curr_field;
4542 }
4543
4544 cob_decimal_get_mpf (cob_mpft, &d1);
4545 cob_mpf_asin (cob_mpft, cob_mpft);
4546 cob_decimal_set_mpf (&d1, cob_mpft);
4547 cob_alloc_field (&d1);
4548 (void)cob_decimal_get_field (&d1, curr_field, 0);
4549
4550 return curr_field;
4551 }
4552
4553 cob_field *
cob_intr_atan(cob_field * srcfield)4554 cob_intr_atan (cob_field *srcfield)
4555 {
4556 cob_decimal_set_field (&d1, srcfield);
4557
4558 cobglobptr->cob_exception_code = 0;
4559
4560 if (!mpz_sgn (d1.value)) {
4561 /* Atan (0) = 0 */
4562 cob_alloc_set_field_uint (0);
4563 return curr_field;
4564 }
4565
4566 cob_decimal_get_mpf (cob_mpft, &d1);
4567 cob_mpf_atan (cob_mpft, cob_mpft);
4568 cob_decimal_set_mpf (&d1, cob_mpft);
4569 cob_alloc_field (&d1);
4570 (void)cob_decimal_get_field (&d1, curr_field, 0);
4571
4572 return curr_field;
4573 }
4574
4575 cob_field *
cob_intr_cos(cob_field * srcfield)4576 cob_intr_cos (cob_field *srcfield)
4577 {
4578 cob_decimal_set_field (&d1, srcfield);
4579
4580 cobglobptr->cob_exception_code = 0;
4581
4582 cob_decimal_get_mpf (cob_mpft, &d1);
4583 cob_mpf_cos (cob_mpft, cob_mpft);
4584 cob_decimal_set_mpf (&d1, cob_mpft);
4585 cob_alloc_field (&d1);
4586 (void)cob_decimal_get_field (&d1, curr_field, 0);
4587
4588 return curr_field;
4589 }
4590
4591 cob_field *
cob_intr_sin(cob_field * srcfield)4592 cob_intr_sin (cob_field *srcfield)
4593 {
4594 cob_decimal_set_field (&d1, srcfield);
4595
4596 cobglobptr->cob_exception_code = 0;
4597
4598 cob_decimal_get_mpf (cob_mpft, &d1);
4599 cob_mpf_sin (cob_mpft, cob_mpft);
4600 cob_decimal_set_mpf (&d1, cob_mpft);
4601 cob_alloc_field (&d1);
4602 (void)cob_decimal_get_field (&d1, curr_field, 0);
4603
4604 return curr_field;
4605 }
4606
4607 cob_field *
cob_intr_tan(cob_field * srcfield)4608 cob_intr_tan (cob_field *srcfield)
4609 {
4610 cob_decimal_set_field (&d1, srcfield);
4611
4612 cobglobptr->cob_exception_code = 0;
4613
4614 cob_decimal_get_mpf (cob_mpft, &d1);
4615 cob_mpf_tan (cob_mpft, cob_mpft);
4616 cob_decimal_set_mpf (&d1, cob_mpft);
4617 cob_alloc_field (&d1);
4618 (void)cob_decimal_get_field (&d1, curr_field, 0);
4619
4620 return curr_field;
4621 }
4622
4623 cob_field *
cob_intr_sqrt(cob_field * srcfield)4624 cob_intr_sqrt (cob_field *srcfield)
4625 {
4626 cob_decimal_set_field (&d1, srcfield);
4627
4628 cobglobptr->cob_exception_code = 0;
4629 if (mpz_sgn (d1.value) < 0) {
4630 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4631 cob_alloc_set_field_uint (0);
4632 return curr_field;
4633 }
4634
4635 mpz_set_ui (d2.value, 5UL);
4636 d2.scale = 1;
4637 cob_trim_decimal (&d1);
4638 cob_decimal_pow (&d1, &d2);
4639
4640 cob_alloc_field (&d1);
4641 (void)cob_decimal_get_field (&d1, curr_field, 0);
4642
4643 return curr_field;
4644 }
4645
4646 cob_field *
cob_intr_numval(cob_field * srcfield)4647 cob_intr_numval (cob_field *srcfield)
4648 {
4649 return numval (srcfield, NULL, NUMVAL);
4650 }
4651
4652 cob_field *
cob_intr_numval_c(cob_field * srcfield,cob_field * currency)4653 cob_intr_numval_c (cob_field *srcfield, cob_field *currency)
4654 {
4655 return numval (srcfield, currency, NUMVAL_C);
4656 }
4657
4658 cob_field *
cob_intr_numval_f(cob_field * srcfield)4659 cob_intr_numval_f (cob_field *srcfield)
4660 {
4661 unsigned char *final_buff;
4662 unsigned char *p;
4663 size_t plus_minus;
4664 size_t digits;
4665 size_t decimal_digits;
4666 size_t dec_seen;
4667 size_t e_seen;
4668 size_t exponent;
4669 size_t e_plus_minus;
4670 size_t n;
4671 unsigned char dec_pt;
4672
4673 /* Validate source field */
4674 if (cob_check_numval_f (srcfield)) {
4675 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4676 cob_alloc_set_field_uint (0);
4677 return curr_field;
4678 }
4679
4680 plus_minus = 0;
4681 digits = 0;
4682 decimal_digits = 0;
4683 dec_seen = 0;
4684 e_seen = 0;
4685 exponent = 0;
4686 e_plus_minus = 0;
4687 dec_pt = COB_MODULE_PTR->decimal_point;
4688
4689 final_buff = cob_malloc (srcfield->size + 1U);
4690 p = srcfield->data;
4691 for (n = 0; n < srcfield->size; ++n, ++p) {
4692 switch (*p) {
4693 case '0':
4694 case '1':
4695 case '2':
4696 case '3':
4697 case '4':
4698 case '5':
4699 case '6':
4700 case '7':
4701 case '8':
4702 case '9':
4703 if (e_seen) {
4704 exponent *= 10;
4705 exponent += (*p & 0x0F);
4706 } else {
4707 if (dec_seen) {
4708 decimal_digits++;
4709 }
4710 final_buff[digits++] = *p;
4711 }
4712 continue;
4713 case 'E':
4714 e_seen = 1;
4715 continue;
4716 case '-':
4717 if (e_seen) {
4718 e_plus_minus = 1;
4719 } else {
4720 plus_minus = 1;
4721 }
4722 continue;
4723 default:
4724 if (*p == dec_pt) {
4725 dec_seen = 1;
4726 }
4727 continue;
4728 }
4729 }
4730
4731 if (!digits) {
4732 final_buff[0] = '0';
4733 }
4734
4735 mpz_set_str (d1.value, (char *)final_buff, 10);
4736 cob_free (final_buff);
4737 if (!mpz_sgn (d1.value)) {
4738 /* Value is zero ; sign and exponent irrelevant */
4739 d1.scale = 0;
4740 cob_alloc_field (&d1);
4741 (void)cob_decimal_get_field (&d1, curr_field, 0);
4742 return curr_field;
4743 }
4744 if (plus_minus) {
4745 mpz_neg (d1.value, d1.value);
4746 }
4747 if (exponent) {
4748 if (e_plus_minus) {
4749 /* Negative exponent */
4750 d1.scale = decimal_digits + exponent;
4751 } else {
4752 /* Positive exponent */
4753 if (decimal_digits >= exponent) {
4754 d1.scale = decimal_digits - exponent;
4755 } else {
4756 exponent -= decimal_digits;
4757 mpz_ui_pow_ui (cob_mexp, 10UL,
4758 (cob_uli_t)exponent);
4759 mpz_mul (d1.value, d1.value, cob_mexp);
4760 d1.scale = 0;
4761 }
4762 }
4763 } else {
4764 /* No exponent */
4765 d1.scale = decimal_digits;
4766 }
4767
4768 cob_alloc_field (&d1);
4769 (void)cob_decimal_get_field (&d1, curr_field, 0);
4770
4771 return curr_field;
4772 }
4773
4774 cob_field *
cob_intr_annuity(cob_field * srcfield1,cob_field * srcfield2)4775 cob_intr_annuity (cob_field *srcfield1, cob_field *srcfield2)
4776 {
4777 int sign;
4778
4779 cob_decimal_set_field (&d1, srcfield1);
4780 cob_decimal_set_field (&d2, srcfield2);
4781
4782 /* P1 >= 0, P2 > 0 and integer */
4783 sign = mpz_sgn (d1.value);
4784 if (sign < 0 || mpz_sgn (d2.value) <= 0 || d2.scale != 0) {
4785 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
4786 cob_alloc_set_field_uint (0);
4787 return curr_field;
4788 }
4789
4790 if (!sign) {
4791 mpz_set_ui (d1.value, 1UL);
4792 d1.scale = 0;
4793 cob_decimal_div (&d1, &d2);
4794 cob_alloc_field (&d1);
4795 (void)cob_decimal_get_field (&d1, curr_field, 0);
4796 return curr_field;
4797 }
4798
4799 /* x = P1 / (1 - (1 + P1) ^ (-P2)) */
4800 mpz_neg (d2.value, d2.value);
4801
4802 mpz_set (d3.value, d1.value);
4803 d3.scale = d1.scale;
4804 mpz_set_ui (d4.value, 1UL);
4805 d4.scale = 0;
4806 cob_decimal_add (&d3, &d4);
4807 cob_trim_decimal (&d3);
4808 cob_trim_decimal (&d2);
4809 cob_decimal_pow (&d3, &d2);
4810 mpz_set_ui (d4.value, 1UL);
4811 d4.scale = 0;
4812 cob_decimal_sub (&d4, &d3);
4813 cob_trim_decimal (&d4);
4814 cob_trim_decimal (&d1);
4815 cob_decimal_div (&d1, &d4);
4816 cob_alloc_field (&d1);
4817 (void)cob_decimal_get_field (&d1, curr_field, 0);
4818 return curr_field;
4819 }
4820
4821 cob_field *
cob_intr_sum(const int params,...)4822 cob_intr_sum (const int params, ...)
4823 {
4824 cob_field *f;
4825 va_list args;
4826 int i;
4827
4828 mpz_set_ui (d1.value, 0UL);
4829 d1.scale = 0;
4830
4831 va_start (args, params);
4832
4833 for (i = 0; i < params; ++i) {
4834 f = va_arg (args, cob_field *);
4835 cob_decimal_set_field (&d2, f);
4836 cob_decimal_add (&d1, &d2);
4837 }
4838 va_end (args);
4839
4840 cob_alloc_field (&d1);
4841 (void)cob_decimal_get_field (&d1, curr_field, 0);
4842 return curr_field;
4843 }
4844
4845 cob_field *
cob_intr_ord_min(const int params,...)4846 cob_intr_ord_min (const int params, ...)
4847 {
4848 cob_field *f;
4849 cob_field *basef;
4850 int i;
4851 cob_u32_t ordmin;
4852 va_list args;
4853
4854 va_start (args, params);
4855
4856 ordmin = 1;
4857 basef = va_arg (args, cob_field *);
4858 for (i = 1; i < params; ++i) {
4859 f = va_arg (args, cob_field *);
4860 if (cob_cmp (f, basef) < 0) {
4861 basef = f;
4862 ordmin = i + 1;
4863 }
4864 }
4865 va_end (args);
4866
4867 cob_alloc_set_field_uint (ordmin);
4868 return curr_field;
4869 }
4870
4871 cob_field *
cob_intr_ord_max(const int params,...)4872 cob_intr_ord_max (const int params, ...)
4873 {
4874 cob_field *f;
4875 cob_field *basef;
4876 cob_u32_t ordmax;
4877 int i;
4878 va_list args;
4879
4880 va_start (args, params);
4881
4882 ordmax = 1;
4883 basef = va_arg (args, cob_field *);
4884 for (i = 1; i < params; ++i) {
4885 f = va_arg (args, cob_field *);
4886 if (cob_cmp (f, basef) > 0) {
4887 basef = f;
4888 ordmax = i + 1;
4889 }
4890 }
4891 va_end (args);
4892
4893 cob_alloc_set_field_uint (ordmax);
4894 return curr_field;
4895 }
4896
4897 cob_field *
cob_intr_min(const int params,...)4898 cob_intr_min (const int params, ...)
4899 {
4900 cob_field *f;
4901 cob_field *basef;
4902 va_list args;
4903 int i;
4904
4905 va_start (args, params);
4906
4907 basef = va_arg (args, cob_field *);
4908 for (i = 1; i < params; ++i) {
4909 f = va_arg (args, cob_field *);
4910 if (cob_cmp (f, basef) < 0) {
4911 basef = f;
4912 }
4913 }
4914 va_end (args);
4915
4916 make_field_entry (basef);
4917 memcpy (curr_field->data, basef->data, basef->size);
4918 return curr_field;
4919 }
4920
4921 cob_field *
cob_intr_max(const int params,...)4922 cob_intr_max (const int params, ...)
4923 {
4924 cob_field *f;
4925 cob_field *basef;
4926 va_list args;
4927 int i;
4928
4929 va_start (args, params);
4930
4931 basef = va_arg (args, cob_field *);
4932 for (i = 1; i < params; ++i) {
4933 f = va_arg (args, cob_field *);
4934 if (cob_cmp (f, basef) > 0) {
4935 basef = f;
4936 }
4937 }
4938 va_end (args);
4939
4940 make_field_entry (basef);
4941 memcpy (curr_field->data, basef->data, basef->size);
4942 return curr_field;
4943 }
4944
4945 cob_field *
cob_intr_midrange(const int params,...)4946 cob_intr_midrange (const int params, ...)
4947 {
4948 cob_field *basemin;
4949 cob_field *basemax;
4950 va_list args;
4951
4952 va_start (args, params);
4953 get_min_and_max_of_args (params, args, &basemin, &basemax);
4954 va_end (args);
4955
4956 /* Return (max + min) / 2 */
4957 cob_decimal_set_field (&d1, basemin);
4958 cob_decimal_set_field (&d2, basemax);
4959 cob_decimal_add (&d1, &d2);
4960 mpz_set_ui (d2.value, 2UL);
4961 d2.scale = 0;
4962 cob_decimal_div (&d1, &d2);
4963
4964 cob_alloc_field (&d1);
4965 (void)cob_decimal_get_field (&d1, curr_field, 0);
4966 return curr_field;
4967 }
4968
4969 cob_field *
cob_intr_median(const int params,...)4970 cob_intr_median (const int params, ...)
4971 {
4972 cob_field *f;
4973 cob_field **field_alloc;
4974 va_list args;
4975 int i;
4976
4977 va_start (args, params);
4978
4979 f = va_arg (args, cob_field *);
4980 if (params == 1) {
4981 va_end (args);
4982 make_field_entry (f);
4983 memcpy (curr_field->data, f->data, f->size);
4984 return curr_field;
4985 }
4986
4987 field_alloc = cob_malloc ((size_t)params * sizeof (cob_field *));
4988 field_alloc[0] = f;
4989
4990 for (i = 1; i < params; ++i) {
4991 field_alloc[i] = va_arg (args, cob_field *);
4992 }
4993 va_end (args);
4994
4995 qsort (field_alloc, (size_t)params, (size_t)sizeof (cob_field *),
4996 comp_field);
4997
4998 i = params / 2;
4999 if (params % 2) {
5000 f = field_alloc[i];
5001 make_field_entry (f);
5002 memcpy (curr_field->data, f->data, f->size);
5003 } else {
5004 cob_decimal_set_field (&d1, field_alloc[i-1]);
5005 cob_decimal_set_field (&d2, field_alloc[i]);
5006 cob_decimal_add (&d1, &d2);
5007 mpz_set_ui (d2.value, 2UL);
5008 d2.scale = 0;
5009 cob_decimal_div (&d1, &d2);
5010 cob_alloc_field (&d1);
5011 (void)cob_decimal_get_field (&d1, curr_field, 0);
5012 }
5013 cob_free (field_alloc);
5014 return curr_field;
5015 }
5016
5017 cob_field *
cob_intr_mean(const int params,...)5018 cob_intr_mean (const int params, ...)
5019 {
5020 cob_field *f;
5021 va_list args;
5022 int i;
5023
5024 va_start (args, params);
5025
5026 if (params == 1) {
5027 f = va_arg (args, cob_field *);
5028 va_end (args);
5029 make_field_entry (f);
5030 memcpy (curr_field->data, f->data, f->size);
5031 return curr_field;
5032 }
5033
5034 mpz_set_ui (d1.value, 0UL);
5035 d1.scale = 0;
5036
5037 for (i = 0; i < params; ++i) {
5038 f = va_arg (args, cob_field *);
5039 cob_decimal_set_field (&d2, f);
5040 cob_decimal_add (&d1, &d2);
5041 }
5042 va_end (args);
5043
5044 mpz_set_ui (d2.value, (cob_uli_t)params);
5045 d2.scale = 0;
5046 cob_decimal_div (&d1, &d2);
5047
5048 cob_alloc_field (&d1);
5049 (void)cob_decimal_get_field (&d1, curr_field, 0);
5050
5051 return curr_field;
5052 }
5053
5054 cob_field *
cob_intr_mod(cob_field * srcfield1,cob_field * srcfield2)5055 cob_intr_mod (cob_field *srcfield1, cob_field *srcfield2)
5056 {
5057 return cob_mod_or_rem (srcfield1, srcfield2, 0);
5058 }
5059
5060 cob_field *
cob_intr_range(const int params,...)5061 cob_intr_range (const int params, ...)
5062 {
5063 cob_field *basemin, *basemax;
5064 va_list args;
5065
5066 va_start (args, params);
5067 get_min_and_max_of_args (params, args, &basemin, &basemax);
5068 va_end (args);
5069
5070 cob_decimal_set_field (&d1, basemax);
5071 cob_decimal_set_field (&d2, basemin);
5072 cob_decimal_sub (&d1, &d2);
5073
5074 cob_alloc_field (&d1);
5075 (void)cob_decimal_get_field (&d1, curr_field, 0);
5076 return curr_field;
5077 }
5078
5079 cob_field *
cob_intr_rem(cob_field * srcfield1,cob_field * srcfield2)5080 cob_intr_rem (cob_field *srcfield1, cob_field *srcfield2)
5081 {
5082 return cob_mod_or_rem (srcfield1, srcfield2, 1);
5083 }
5084
5085 cob_field *
cob_intr_random(const int params,...)5086 cob_intr_random (const int params, ...)
5087 {
5088 cob_field *f;
5089 va_list args;
5090 double val;
5091 int seed;
5092 int randnum;
5093 cob_field_attr attr;
5094 cob_field field;
5095
5096 COB_ATTR_INIT (COB_TYPE_NUMERIC_DOUBLE, 20, 9, COB_FLAG_HAVE_SIGN, NULL);
5097 COB_FIELD_INIT (sizeof(double), NULL, &attr);
5098 va_start (args, params);
5099
5100 if (params) {
5101 f = va_arg (args, cob_field *);
5102 seed = cob_get_int (f);
5103 if (seed < 0) {
5104 seed = 0;
5105 }
5106 #ifdef __CYGWIN__
5107 srandom ((unsigned int)seed);
5108 #else
5109 srand ((unsigned int)seed);
5110 #endif
5111 }
5112 va_end (args);
5113
5114 #ifdef __CYGWIN__
5115 randnum = (int)random ();
5116 #else
5117 randnum = rand ();
5118 #endif
5119 make_field_entry (&field);
5120 val = (double)randnum / (double)RAND_MAX;
5121 memcpy (curr_field->data, &val, sizeof(val));
5122 return curr_field;
5123 }
5124
5125 #define GET_VARIANCE(num_args, args) \
5126 do { \
5127 /* Get mean in d1 */ \
5128 va_start (args, num_args); \
5129 calc_mean_of_args (num_args, args); \
5130 va_end (args); \
5131 \
5132 cob_decimal_set (&d5, &d1); \
5133 \
5134 /* Get variance in d1 */ \
5135 va_start (args, num_args); \
5136 calc_variance_of_args (num_args, args, &d5); \
5137 va_end (args); \
5138 } ONCE_COB
5139
5140 cob_field *
cob_intr_variance(const int num_args,...)5141 cob_intr_variance (const int num_args, ...)
5142 {
5143 va_list args;
5144
5145 GET_VARIANCE (num_args, args);
5146
5147 cob_alloc_field (&d1);
5148 (void)cob_decimal_get_field (&d1, curr_field, 0);
5149 return curr_field;
5150 }
5151
5152 cob_field *
cob_intr_standard_deviation(const int num_args,...)5153 cob_intr_standard_deviation (const int num_args, ...)
5154 {
5155 va_list args;
5156
5157 GET_VARIANCE (num_args, args);
5158 cob_trim_decimal (&d1);
5159
5160 cobglobptr->cob_exception_code = 0;
5161
5162 /* Take square root of variance */
5163 mpz_set_ui (d3.value, 5UL);
5164 d3.scale = 1;
5165
5166 cob_decimal_pow (&d1, &d3);
5167
5168 cob_alloc_field (&d1);
5169 (void)cob_decimal_get_field (&d1, curr_field, 0);
5170 return curr_field;
5171 }
5172
5173 #undef GET_VARIANCE
5174
5175 cob_field *
cob_intr_present_value(const int params,...)5176 cob_intr_present_value (const int params, ...)
5177 {
5178 cob_field *f;
5179 va_list args;
5180 int i;
5181
5182 va_start (args, params);
5183
5184 f = va_arg (args, cob_field *);
5185
5186 cob_decimal_set_field (&d1, f);
5187 mpz_set_ui (d2.value, 1UL);
5188 d2.scale = 0;
5189 cob_decimal_add (&d1, &d2);
5190
5191 mpz_set_ui (d4.value, 0UL);
5192 d4.scale = 0;
5193
5194 for (i = 1; i < params; ++i) {
5195 f = va_arg (args, cob_field *);
5196 cob_decimal_set_field (&d2, f);
5197 mpz_set (d3.value, d1.value);
5198 d3.scale = d1.scale;
5199 if (i > 1) {
5200 mpz_pow_ui (d3.value, d3.value, (cob_uli_t)i);
5201 d3.scale *= i;
5202 }
5203 cob_decimal_div (&d2, &d3);
5204 cob_decimal_add (&d4, &d2);
5205 }
5206 va_end (args);
5207
5208 cob_alloc_field (&d4);
5209 (void)cob_decimal_get_field (&d4, curr_field, 0);
5210 return curr_field;
5211 }
5212
5213 cob_field *
cob_intr_year_to_yyyy(const int params,...)5214 cob_intr_year_to_yyyy (const int params, ...)
5215 {
5216 cob_field *f;
5217 struct tm *timeptr;
5218 va_list args;
5219 time_t t;
5220 int year;
5221 int interval;
5222 int current_year;
5223 int maxyear;
5224
5225 cobglobptr->cob_exception_code = 0;
5226 va_start (args, params);
5227 f = va_arg (args, cob_field *);
5228 year = cob_get_int (f);
5229 if (params > 1) {
5230 f = va_arg (args, cob_field *);
5231 interval = cob_get_int (f);
5232 } else {
5233 interval = 50;
5234 }
5235 if (params > 2) {
5236 f = va_arg (args, cob_field *);
5237 current_year = cob_get_int (f);
5238 } else {
5239 t = time (NULL);
5240 timeptr = localtime (&t);
5241 current_year = 1900 + timeptr->tm_year;
5242 }
5243 va_end (args);
5244
5245 if (year < 0 || year > 99) {
5246 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5247 cob_alloc_set_field_uint (0);
5248 return curr_field;
5249 }
5250 if (!valid_year (current_year)) {
5251 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5252 cob_alloc_set_field_uint (0);
5253 return curr_field;
5254 }
5255 maxyear = current_year + interval;
5256 if (maxyear < 1700 || maxyear > 9999) {
5257 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5258 cob_alloc_set_field_uint (0);
5259 return curr_field;
5260 }
5261 if (maxyear % 100 >= year) {
5262 year += 100 * (maxyear / 100);
5263 } else {
5264 year += 100 * ((maxyear / 100) - 1);
5265 }
5266 cob_alloc_set_field_int (year);
5267 return curr_field;
5268 }
5269
5270 cob_field *
cob_intr_date_to_yyyymmdd(const int params,...)5271 cob_intr_date_to_yyyymmdd (const int params, ...)
5272 {
5273 cob_field *f;
5274 va_list args;
5275 int year;
5276 int mmdd;
5277 int interval;
5278 int current_year;
5279 int maxyear;
5280
5281 cobglobptr->cob_exception_code = 0;
5282
5283 va_start (args, params);
5284
5285 f = va_arg (args, cob_field *);
5286 year = cob_get_int (f);
5287 mmdd = year % 10000;
5288 year /= 10000;
5289
5290 get_interval_and_current_year_from_args (params, args, &interval,
5291 ¤t_year);
5292
5293 va_end (args);
5294
5295 maxyear = current_year + interval;
5296 /* The unusual year checks are as specified in the standard */
5297 if (year < 0 || year > 999999
5298 || !valid_year (current_year)
5299 || (maxyear < 1700 || maxyear > 9999)) {
5300 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5301 cob_alloc_set_field_uint (0);
5302 return curr_field;
5303 }
5304
5305 if (maxyear % 100 >= year) {
5306 year += 100 * (maxyear / 100);
5307 } else {
5308 year += 100 * ((maxyear / 100) - 1);
5309 }
5310 year *= 10000;
5311 year += mmdd;
5312 cob_alloc_set_field_int (year);
5313 return curr_field;
5314 }
5315
5316 cob_field *
cob_intr_day_to_yyyyddd(const int params,...)5317 cob_intr_day_to_yyyyddd (const int params, ...)
5318 {
5319 cob_field *f;
5320 va_list args;
5321 int year;
5322 int days;
5323 int interval;
5324 int current_year;
5325 int maxyear;
5326
5327 cobglobptr->cob_exception_code = 0;
5328
5329 va_start (args, params);
5330
5331 f = va_arg (args, cob_field *);
5332 year = cob_get_int (f);
5333 days = year % 1000;
5334 year /= 1000;
5335
5336 get_interval_and_current_year_from_args (params, args, &interval,
5337 ¤t_year);
5338
5339 va_end (args);
5340
5341 if (year < 0 || year > 999999) {
5342 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5343 cob_alloc_set_field_uint (0);
5344 return curr_field;
5345 }
5346 if (!valid_year (current_year)) {
5347 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5348 cob_alloc_set_field_uint (0);
5349 return curr_field;
5350 }
5351 maxyear = current_year + interval;
5352 if (maxyear < 1700 || maxyear > 9999) {
5353 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5354 cob_alloc_set_field_uint (0);
5355 return curr_field;
5356 }
5357 if (maxyear % 100 >= year) {
5358 year += 100 * (maxyear / 100);
5359 } else {
5360 year += 100 * ((maxyear / 100) - 1);
5361 }
5362 year *= 1000;
5363 year += days;
5364 cob_alloc_set_field_int (year);
5365 return curr_field;
5366 }
5367
5368 cob_field *
cob_intr_seconds_past_midnight(void)5369 cob_intr_seconds_past_midnight (void)
5370 {
5371 struct tm *timeptr;
5372 time_t t;
5373 int seconds;
5374
5375 t = time (NULL);
5376 timeptr = localtime (&t);
5377 /* Leap seconds ? */
5378 if (timeptr->tm_sec >= 60) {
5379 timeptr->tm_sec = 59;
5380 }
5381 seconds = (timeptr->tm_hour * 3600) + (timeptr->tm_min * 60) +
5382 timeptr->tm_sec;
5383 cob_alloc_set_field_int (seconds);
5384 return curr_field;
5385 }
5386
5387 cob_field *
cob_intr_seconds_from_formatted_time(cob_field * format_field,cob_field * time_field)5388 cob_intr_seconds_from_formatted_time (cob_field *format_field, cob_field *time_field)
5389 {
5390 size_t str_length;
5391 char format_str[2 * COB_DATETIMESTR_LEN] = { '\0' };
5392 char * time_format_str = format_str;
5393 const char decimal_point = COB_MODULE_PTR->decimal_point;
5394 int is_datetime = 0;
5395 char time_str[COB_DATETIMESTR_LEN] = { '\0' };
5396 struct time_format time_fmt;
5397 cob_decimal *seconds = &d1;
5398
5399 str_length = num_leading_nonspace ((char *) format_field->data,
5400 format_field->size);
5401 memcpy (format_str, format_field->data, str_length);
5402
5403 cobglobptr->cob_exception_code = 0;
5404
5405 /* Validate the format string */
5406 if (cob_valid_datetime_format (format_str, decimal_point)) {
5407 is_datetime = 1;
5408 } else if (!cob_valid_time_format (format_str, decimal_point)) {
5409 goto invalid_args;
5410 }
5411
5412 /* Extract the time part of the strings */
5413 if (is_datetime) {
5414 time_format_str = format_str + sizeof(format_str) / 2;
5415 split_around_t (format_str, NULL, time_format_str);
5416 split_around_t ((char *) time_field->data, NULL, time_str);
5417 } else {
5418 memcpy (time_str, time_field->data, str_length);
5419 }
5420
5421 /* Validate the formatted time */
5422 time_fmt = parse_time_format_string (time_format_str);
5423 if (test_formatted_time (time_fmt, time_str, decimal_point) != 0) {
5424 goto invalid_args;
5425 }
5426
5427 seconds_from_formatted_time (time_fmt, time_str, seconds);
5428
5429 cob_alloc_field (seconds);
5430 (void) cob_decimal_get_field (seconds, curr_field, 0);
5431
5432 return curr_field;
5433
5434 invalid_args:
5435 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5436 cob_alloc_set_field_uint (0);
5437 return curr_field;
5438 }
5439
5440 cob_field *
cob_intr_locale_date(const int offset,const int length,cob_field * srcfield,cob_field * locale_field)5441 cob_intr_locale_date (const int offset, const int length,
5442 cob_field *srcfield, cob_field *locale_field)
5443 {
5444 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
5445 size_t len;
5446 int indate;
5447 int days;
5448 int month;
5449 int year;
5450 #ifdef HAVE_LANGINFO_CODESET
5451 unsigned char *p;
5452 char *deflocale = NULL;
5453 struct tm tstruct;
5454 char buff2[128];
5455 #else
5456 unsigned char *p;
5457 LCID localeid = LOCALE_USER_DEFAULT;
5458 SYSTEMTIME syst;
5459 #endif
5460 char buff[128];
5461 char locale_buff[COB_SMALL_BUFF];
5462 #endif
5463
5464 cobglobptr->cob_exception_code = 0;
5465
5466 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
5467 if (COB_FIELD_IS_NUMERIC (srcfield)) {
5468 indate = cob_get_int (srcfield);
5469 } else {
5470 if (srcfield->size < 8) {
5471 goto derror;
5472 }
5473 p = srcfield->data;
5474 indate = 0;
5475 for (len = 0; len < 8; ++len, ++p) {
5476 if (isdigit (*p)) {
5477 indate *= 10;
5478 indate += (*p - '0');
5479 } else {
5480 goto derror;
5481 }
5482 }
5483 }
5484 year = indate / 10000;
5485 if (!valid_year (year)) {
5486 goto derror;
5487 }
5488 indate %= 10000;
5489 month = indate / 100;
5490 if (!valid_month (month)) {
5491 goto derror;
5492 }
5493 days = indate % 100;
5494 if (!valid_day_of_month (year, month, days)) {
5495 goto derror;
5496 }
5497 #ifdef HAVE_LANGINFO_CODESET
5498 month--;
5499
5500 memset ((void *)&tstruct, 0, sizeof(struct tm));
5501 tstruct.tm_year = year - 1900;
5502 tstruct.tm_mon = month;
5503 tstruct.tm_mday = days;
5504 if (locale_field) {
5505 if (locale_field->size >= COB_SMALL_BUFF) {
5506 goto derror;
5507 }
5508 cob_field_to_string (locale_field, locale_buff,
5509 (size_t)COB_SMALL_MAX);
5510 deflocale = locale_buff;
5511 (void) setlocale (LC_TIME, deflocale);
5512 }
5513 memset (buff2, 0, sizeof(buff2));
5514 snprintf(buff2, sizeof(buff2) - 1, "%s", nl_langinfo(D_FMT));
5515 if (deflocale) {
5516 (void) setlocale (LC_ALL, cobglobptr->cob_locale);
5517 }
5518 strftime (buff, sizeof(buff), buff2, &tstruct);
5519 #else
5520 memset ((void *)&syst, 0, sizeof(syst));
5521 syst.wYear = (WORD)year;
5522 syst.wMonth = (WORD)month;
5523 syst.wDay = (WORD)days;
5524 if (locale_field) {
5525 if (locale_field->size >= COB_SMALL_BUFF) {
5526 goto derror;
5527 }
5528 cob_field_to_string (locale_field, locale_buff,
5529 COB_SMALL_MAX);
5530 locale_buff[COB_SMALL_MAX] = 0; /* silence warnings */
5531 for (p = (unsigned char *)locale_buff; *p; ++p) {
5532 if (isalnum(*p) || *p == '_') {
5533 continue;
5534 }
5535 break;
5536 }
5537 *p = 0;
5538 for (len = 0; len < WINLOCSIZE; ++len) {
5539 if (!strcmp(locale_buff, wintable[len].winlocalename)) {
5540 localeid = wintable[len].winlocaleid;
5541 break;
5542 }
5543 }
5544 if (len == WINLOCSIZE) {
5545 goto derror;
5546 }
5547 }
5548 if (!GetDateFormat (localeid, DATE_SHORTDATE, &syst, NULL, buff, sizeof(buff))) {
5549 goto derror;
5550 }
5551 #endif
5552 cob_alloc_set_field_str (buff, offset, length);
5553 return curr_field;
5554 derror:
5555 #endif
5556 cob_alloc_set_field_spaces (10);
5557 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5558 return curr_field;
5559 }
5560
5561 cob_field *
cob_intr_locale_time(const int offset,const int length,cob_field * srcfield,cob_field * locale_field)5562 cob_intr_locale_time (const int offset, const int length,
5563 cob_field *srcfield, cob_field *locale_field)
5564 {
5565 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
5566 unsigned char *p;
5567 size_t len;
5568 int indate;
5569 int hours;
5570 int minutes;
5571 int seconds;
5572 char buff[LOCTIME_BUFSIZE] = { '\0' };
5573 #endif
5574
5575 cobglobptr->cob_exception_code = 0;
5576
5577 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
5578 if (COB_FIELD_IS_NUMERIC (srcfield)) {
5579 indate = cob_get_int (srcfield);
5580 } else {
5581 if (srcfield->size < 6) {
5582 goto derror;
5583 }
5584 p = srcfield->data;
5585 indate = 0;
5586 for (len = 0; len < 6; ++len, ++p) {
5587 if (isdigit (*p)) {
5588 indate *= 10;
5589 indate += (*p - '0');
5590 } else {
5591 goto derror;
5592 }
5593 }
5594 }
5595 hours = indate / 10000;
5596 if (hours < 0 || hours > 24) {
5597 goto derror;
5598 }
5599 indate %= 10000;
5600 minutes = indate / 100;
5601 if (minutes < 0 || minutes > 59) {
5602 goto derror;
5603 }
5604 seconds = indate % 100;
5605 if (seconds < 0 || seconds > 59) {
5606 goto derror;
5607 }
5608
5609 if (locale_time (hours, minutes, seconds, locale_field, buff)) {
5610 goto derror;
5611 }
5612
5613 cob_alloc_set_field_str (buff, offset, length);
5614 return curr_field;
5615 derror:
5616 #endif
5617 cob_alloc_set_field_spaces (10);
5618 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5619 return curr_field;
5620 }
5621
5622 cob_field *
cob_intr_lcl_time_from_secs(const int offset,const int length,cob_field * srcfield,cob_field * locale_field)5623 cob_intr_lcl_time_from_secs (const int offset, const int length,
5624 cob_field *srcfield, cob_field *locale_field)
5625 {
5626 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
5627 int indate;
5628 int hours;
5629 int minutes;
5630 int seconds;
5631 char buff[LOCTIME_BUFSIZE] = { '\0' };
5632 #endif
5633
5634 cobglobptr->cob_exception_code = 0;
5635
5636 #if defined(_WIN32) || defined(__CYGWIN__) || defined(HAVE_LANGINFO_CODESET)
5637 if (COB_FIELD_IS_NUMERIC (srcfield)) {
5638 indate = cob_get_int (srcfield);
5639 } else {
5640 goto derror;
5641 }
5642 if (!valid_time (indate)) {
5643 goto derror;
5644 }
5645 hours = indate / 3600;
5646 indate %= 3600;
5647 minutes = indate / 60;
5648 seconds = indate % 60;
5649
5650 if (locale_time (hours, minutes, seconds, locale_field, buff)) {
5651 goto derror;
5652 }
5653
5654 cob_alloc_set_field_str (buff, offset, length);
5655 return curr_field;
5656 derror:
5657 #endif
5658 cob_alloc_set_field_spaces (10);
5659 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5660 return curr_field;
5661 }
5662
5663 cob_field *
cob_intr_mon_decimal_point(void)5664 cob_intr_mon_decimal_point (void)
5665 {
5666 #ifdef HAVE_LOCALECONV
5667 struct lconv *p;
5668 size_t size;
5669 #endif
5670 cob_field field;
5671
5672 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5673 cobglobptr->cob_exception_code = 0;
5674
5675 #ifdef HAVE_LOCALECONV
5676 p = localeconv ();
5677 size = strlen (p->mon_decimal_point);
5678 if (size) {
5679 field.size = size;
5680 } else {
5681 field.size = 1;
5682 }
5683 make_field_entry (&field);
5684 if (size) {
5685 memcpy (curr_field->data, p->mon_decimal_point, size);
5686 } else {
5687 curr_field->size = 0;
5688 curr_field->data[0] = 0;
5689 }
5690 #else
5691 field.size = 1;
5692 make_field_entry (&field);
5693 curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5694 #endif
5695 return curr_field;
5696 }
5697
5698 cob_field *
cob_intr_num_decimal_point(void)5699 cob_intr_num_decimal_point (void)
5700 {
5701 #ifdef HAVE_LOCALECONV
5702 struct lconv *p;
5703 size_t size;
5704 #endif
5705 cob_field field;
5706
5707 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5708 cobglobptr->cob_exception_code = 0;
5709
5710 #ifdef HAVE_LOCALECONV
5711 p = localeconv ();
5712 size = strlen (p->decimal_point);
5713 if (size) {
5714 field.size = size;
5715 } else {
5716 field.size = 1;
5717 }
5718 make_field_entry (&field);
5719 if (size) {
5720 memcpy (curr_field->data, p->decimal_point, size);
5721 } else {
5722 curr_field->size = 0;
5723 curr_field->data[0] = 0;
5724 }
5725 #else
5726 field.size = 1;
5727 make_field_entry (&field);
5728 curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5729 #endif
5730 return curr_field;
5731 }
5732
5733 cob_field *
cob_intr_mon_thousands_sep(void)5734 cob_intr_mon_thousands_sep (void)
5735 {
5736 #ifdef HAVE_LOCALECONV
5737 struct lconv *p;
5738 size_t size;
5739 #endif
5740 cob_field field;
5741
5742 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5743 cobglobptr->cob_exception_code = 0;
5744
5745 #ifdef HAVE_LOCALECONV
5746 p = localeconv ();
5747 size = strlen (p->mon_thousands_sep);
5748 if (size) {
5749 field.size = size;
5750 } else {
5751 field.size = 1;
5752 }
5753 make_field_entry (&field);
5754 if (size) {
5755 memcpy (curr_field->data, p->mon_thousands_sep, size);
5756 } else {
5757 curr_field->size = 0;
5758 curr_field->data[0] = 0;
5759 }
5760 #else
5761 field.size = 1;
5762 make_field_entry (&field);
5763 curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5764 #endif
5765 return curr_field;
5766 }
5767
5768 cob_field *
cob_intr_num_thousands_sep(void)5769 cob_intr_num_thousands_sep (void)
5770 {
5771 #ifdef HAVE_LOCALECONV
5772 struct lconv *p;
5773 size_t size;
5774 #endif
5775 cob_field field;
5776
5777 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5778 cobglobptr->cob_exception_code = 0;
5779
5780 #ifdef HAVE_LOCALECONV
5781 p = localeconv ();
5782 size = strlen (p->thousands_sep);
5783 if (size) {
5784 field.size = size;
5785 } else {
5786 field.size = 1;
5787 }
5788 make_field_entry (&field);
5789 if (size) {
5790 memcpy (curr_field->data, p->thousands_sep, size);
5791 } else {
5792 curr_field->size = 0;
5793 curr_field->data[0] = 0;
5794 }
5795 #else
5796 field.size = 1;
5797 make_field_entry (&field);
5798 curr_field->data[0] = COB_MODULE_PTR->decimal_point;
5799 #endif
5800 return curr_field;
5801 }
5802
5803 cob_field *
cob_intr_currency_symbol(void)5804 cob_intr_currency_symbol (void)
5805 {
5806 #ifdef HAVE_LOCALECONV
5807 struct lconv *p;
5808 size_t size;
5809 #endif
5810 cob_field field;
5811
5812 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
5813 cobglobptr->cob_exception_code = 0;
5814
5815 #ifdef HAVE_LOCALECONV
5816 p = localeconv ();
5817 size = strlen (p->currency_symbol);
5818 if (size) {
5819 field.size = size;
5820 } else {
5821 field.size = 1;
5822 }
5823 make_field_entry (&field);
5824 if (size) {
5825 memcpy (curr_field->data, p->currency_symbol, size);
5826 } else {
5827 curr_field->size = 0;
5828 curr_field->data[0] = 0;
5829 }
5830 #else
5831 field.size = 1;
5832 make_field_entry (&field);
5833 curr_field->data[0] = COB_MODULE_PTR->currency_symbol;
5834 #endif
5835 return curr_field;
5836 }
5837
5838 cob_field *
cob_intr_test_numval(cob_field * srcfield)5839 cob_intr_test_numval (cob_field *srcfield)
5840 {
5841 cob_alloc_set_field_int (cob_check_numval (srcfield, NULL, 0, 0));
5842 return curr_field;
5843 }
5844
5845 cob_field *
cob_intr_test_numval_c(cob_field * srcfield,cob_field * currency)5846 cob_intr_test_numval_c (cob_field *srcfield, cob_field *currency)
5847 {
5848 cob_alloc_set_field_int (cob_check_numval (srcfield, currency, 1, 0));
5849 return curr_field;
5850 }
5851
5852 cob_field *
cob_intr_test_numval_f(cob_field * srcfield)5853 cob_intr_test_numval_f (cob_field *srcfield)
5854 {
5855 cob_alloc_set_field_int (cob_check_numval_f (srcfield));
5856 return curr_field;
5857 }
5858
5859 cob_field *
cob_intr_lowest_algebraic(cob_field * srcfield)5860 cob_intr_lowest_algebraic (cob_field *srcfield)
5861 {
5862 cob_uli_t expo;
5863 cob_field field;
5864
5865 switch (COB_FIELD_TYPE (srcfield)) {
5866 case COB_TYPE_ALPHANUMERIC:
5867 case COB_TYPE_NATIONAL:
5868 COB_FIELD_INIT (COB_FIELD_SIZE (srcfield), NULL, &const_alpha_attr);
5869 make_field_entry (&field);
5870 break;
5871
5872 case COB_TYPE_ALPHANUMERIC_EDITED:
5873 case COB_TYPE_NATIONAL_EDITED:
5874 COB_FIELD_INIT (COB_FIELD_DIGITS (srcfield), NULL, &const_alpha_attr);
5875 make_field_entry (&field);
5876 break;
5877
5878 case COB_TYPE_NUMERIC_BINARY:
5879 case COB_TYPE_NUMERIC_COMP5:
5880 if (!COB_FIELD_HAVE_SIGN (srcfield)) {
5881 cob_alloc_set_field_uint (0);
5882 break;
5883 }
5884 if (COB_FIELD_REAL_BINARY (srcfield)
5885 || !COB_FIELD_BINARY_TRUNC (srcfield)) {
5886 expo = (cob_uli_t)((COB_FIELD_SIZE (srcfield) * 8U) - 1U);
5887 mpz_ui_pow_ui (d1.value, 2UL, expo);
5888 mpz_neg (d1.value, d1.value);
5889 d1.scale = COB_FIELD_SCALE (srcfield);
5890 cob_alloc_field (&d1);
5891 (void)cob_decimal_get_field (&d1, curr_field, 0);
5892 break;
5893 }
5894 expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5895 mpz_ui_pow_ui (d1.value, 10UL, expo);
5896 mpz_sub_ui (d1.value, d1.value, 1UL);
5897 mpz_neg (d1.value, d1.value);
5898 d1.scale = COB_FIELD_SCALE (srcfield);
5899 cob_alloc_field (&d1);
5900 (void)cob_decimal_get_field (&d1, curr_field, 0);
5901 break;
5902
5903 case COB_TYPE_NUMERIC_FLOAT:
5904 case COB_TYPE_NUMERIC_DOUBLE:
5905 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5906 cob_alloc_set_field_uint (0);
5907 break;
5908
5909 case COB_TYPE_NUMERIC_DISPLAY:
5910 case COB_TYPE_NUMERIC_PACKED:
5911 case COB_TYPE_NUMERIC_EDITED:
5912 if (!COB_FIELD_HAVE_SIGN (srcfield)) {
5913 cob_alloc_set_field_uint (0);
5914 break;
5915 }
5916 expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5917 mpz_ui_pow_ui (d1.value, 10UL, expo);
5918 mpz_sub_ui (d1.value, d1.value, 1UL);
5919 mpz_neg (d1.value, d1.value);
5920 d1.scale = COB_FIELD_SCALE (srcfield);
5921 cob_alloc_field (&d1);
5922 (void)cob_decimal_get_field (&d1, curr_field, 0);
5923 break;
5924 default:
5925 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5926 cob_alloc_set_field_uint (0);
5927 break;
5928 }
5929 return curr_field;
5930 }
5931
5932 cob_field *
cob_intr_highest_algebraic(cob_field * srcfield)5933 cob_intr_highest_algebraic (cob_field *srcfield)
5934 {
5935 cob_uli_t expo;
5936 size_t size;
5937 cob_field field;
5938
5939 switch (COB_FIELD_TYPE (srcfield)) {
5940 case COB_TYPE_ALPHANUMERIC:
5941 case COB_TYPE_NATIONAL:
5942 size = COB_FIELD_SIZE (srcfield);
5943 COB_FIELD_INIT (size, NULL, &const_alpha_attr);
5944 make_field_entry (&field);
5945 memset (curr_field->data, 255, size);
5946 break;
5947
5948 case COB_TYPE_ALPHANUMERIC_EDITED:
5949 case COB_TYPE_NATIONAL_EDITED:
5950 size = COB_FIELD_DIGITS (srcfield);
5951 COB_FIELD_INIT (size, NULL, &const_alpha_attr);
5952 make_field_entry (&field);
5953 memset (curr_field->data, 255, size);
5954 break;
5955
5956 case COB_TYPE_NUMERIC_BINARY:
5957 case COB_TYPE_NUMERIC_COMP5:
5958 if (COB_FIELD_REAL_BINARY (srcfield)
5959 || !COB_FIELD_BINARY_TRUNC (srcfield)) {
5960 expo = COB_FIELD_SIZE (srcfield) * 8U;
5961 if (COB_FIELD_HAVE_SIGN (srcfield)) {
5962 expo--;
5963 }
5964 mpz_ui_pow_ui (d1.value, 2UL, expo);
5965 mpz_sub_ui (d1.value, d1.value, 1UL);
5966 d1.scale = COB_FIELD_SCALE (srcfield);
5967 cob_alloc_field (&d1);
5968 (void)cob_decimal_get_field (&d1, curr_field, 0);
5969 break;
5970 }
5971 expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5972 mpz_ui_pow_ui (d1.value, 10UL, expo);
5973 mpz_sub_ui (d1.value, d1.value, 1UL);
5974 d1.scale = COB_FIELD_SCALE (srcfield);
5975 cob_alloc_field (&d1);
5976 (void)cob_decimal_get_field (&d1, curr_field, 0);
5977 break;
5978
5979 case COB_TYPE_NUMERIC_FLOAT:
5980 case COB_TYPE_NUMERIC_DOUBLE:
5981 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5982 cob_alloc_set_field_uint (0);
5983 break;
5984
5985 case COB_TYPE_NUMERIC_DISPLAY:
5986 case COB_TYPE_NUMERIC_PACKED:
5987 case COB_TYPE_NUMERIC_EDITED:
5988 expo = (cob_uli_t)COB_FIELD_DIGITS (srcfield);
5989 mpz_ui_pow_ui (d1.value, 10UL, expo);
5990 mpz_sub_ui (d1.value, d1.value, 1UL);
5991 d1.scale = COB_FIELD_SCALE (srcfield);
5992 cob_alloc_field (&d1);
5993 (void)cob_decimal_get_field (&d1, curr_field, 0);
5994 break;
5995 default:
5996 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
5997 cob_alloc_set_field_uint (0);
5998 break;
5999 }
6000 return curr_field;
6001 }
6002
6003 cob_field *
cob_intr_locale_compare(const int params,...)6004 cob_intr_locale_compare (const int params, ...)
6005 {
6006 cob_field *f1;
6007 cob_field *f2;
6008 cob_field *locale_field;
6009 #ifdef HAVE_STRCOLL
6010 unsigned char *p;
6011 unsigned char *p1;
6012 unsigned char *p2;
6013 char *deflocale;
6014 size_t size;
6015 size_t size2;
6016 int ret;
6017 #endif
6018 cob_field field;
6019 va_list args;
6020
6021 cobglobptr->cob_exception_code = 0;
6022 va_start (args, params);
6023 f1 = va_arg (args, cob_field *);
6024 f2 = va_arg (args, cob_field *);
6025 if (params > 2) {
6026 locale_field = va_arg (args, cob_field *);
6027 } else {
6028 locale_field = NULL;
6029 }
6030 va_end (args);
6031
6032 COB_FIELD_INIT (1, NULL, &const_alpha_attr);
6033 make_field_entry (&field);
6034
6035 #ifdef HAVE_STRCOLL
6036 deflocale = NULL;
6037
6038 size = f1->size;
6039 size2 = size;
6040 for (p = f1->data + size - 1U; p != f1->data; --p) {
6041 if (*p != ' ') {
6042 break;
6043 }
6044 size2--;
6045 }
6046 p1 = cob_malloc (size2 + 1U);
6047 memcpy (p1, f1->data, size2);
6048
6049 size = f2->size;
6050 size2 = size;
6051 for (p = f2->data + size - 1U; p != f2->data; --p) {
6052 if (*p != ' ') {
6053 break;
6054 }
6055 size2--;
6056 }
6057 p2 = cob_malloc (size2 + 1U);
6058 memcpy (p2, f2->data, size2);
6059
6060 if (locale_field) {
6061 if (!locale_field->size) {
6062 goto derror;
6063 }
6064 #ifdef HAVE_SETLOCALE
6065 deflocale = cob_malloc (locale_field->size + 1U);
6066 cob_field_to_string (locale_field, deflocale,
6067 (size_t)(locale_field->size + 1U));
6068 (void) setlocale (LC_COLLATE, deflocale);
6069 #else
6070 goto derror;
6071 #endif
6072 }
6073
6074 ret = strcoll ((char *)p1, (char *)p2);
6075 if (ret < 0) {
6076 curr_field->data[0] = '<';
6077 } else if (ret > 0) {
6078 curr_field->data[0] = '>';
6079 } else {
6080 curr_field->data[0] = '=';
6081 }
6082 cob_free (p1);
6083 cob_free (p2);
6084
6085 #ifdef HAVE_SETLOCALE
6086 if (deflocale) {
6087 (void) setlocale (LC_ALL, cobglobptr->cob_locale);
6088 cob_free (deflocale);
6089 }
6090 #endif
6091
6092 return curr_field;
6093
6094 derror:
6095 cob_free (p1);
6096 cob_free (p2);
6097 #endif
6098 curr_field->data[0] = ' ';
6099 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
6100
6101 return curr_field;
6102 }
6103
6104 cob_field *
cob_intr_formatted_date(const int offset,const int length,cob_field * format_field,cob_field * days_field)6105 cob_intr_formatted_date (const int offset, const int length,
6106 cob_field *format_field, cob_field *days_field)
6107 {
6108 cob_field field;
6109 size_t field_length;
6110 char format_str[COB_DATESTR_LEN] = { '\0' };
6111 int days;
6112 struct date_format format;
6113 char buff[COB_DATESTR_LEN] = { '\0' };
6114
6115 copy_data_to_null_terminated_str (format_field, format_str,
6116 COB_DATESTR_MAX);
6117 field_length = strlen (format_str);
6118
6119 COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
6120 make_field_entry (&field);
6121
6122 cobglobptr->cob_exception_code = 0;
6123 days = cob_get_int (days_field);
6124
6125 if (!valid_day_and_format (days, format_str)) {
6126 goto invalid_args;
6127 }
6128
6129 format = parse_date_format_string (format_str);
6130 format_date (format, days, buff);
6131
6132 memcpy (curr_field->data, buff, field_length);
6133 goto end_of_func;
6134
6135 invalid_args:
6136 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
6137 memset (curr_field->data, ' ', strlen (format_str));
6138
6139 end_of_func:
6140 if (unlikely (offset > 0)) {
6141 calc_ref_mod (curr_field, offset, length);
6142 }
6143 return curr_field;
6144 }
6145
6146 cob_field *
cob_intr_formatted_time(const int offset,const int length,const int params,...)6147 cob_intr_formatted_time (const int offset, const int length,
6148 const int params, ...)
6149 {
6150 va_list args;
6151 cob_field *format_field;
6152 cob_field *time_field;
6153 cob_field *offset_time_field;
6154 cob_field field;
6155 size_t field_length;
6156 char buff[COB_TIMESTR_LEN] = { '\0' };
6157 char format_str[COB_TIMESTR_LEN] = { '\0' };
6158 int whole_seconds;
6159 cob_decimal *fractional_seconds;
6160 int use_system_offset;
6161 int offset_time;
6162 int *offset_time_ptr;
6163 struct time_format format;
6164
6165 if (!(params == 3 || params == 4)) {
6166 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
6167 make_field_entry (&field);
6168 goto invalid_args;
6169 }
6170
6171 /* Get args */
6172 va_start (args, params);
6173
6174 format_field = va_arg (args, cob_field *);
6175 time_field = va_arg (args, cob_field *);
6176 if (params == 4) {
6177 offset_time_field = va_arg (args, cob_field *);
6178 } else {
6179 offset_time_field = NULL;
6180 }
6181 use_system_offset = va_arg (args, int);
6182
6183 va_end (args);
6184
6185 /* Initialise buffers */
6186 copy_data_to_null_terminated_str (format_field, format_str,
6187 COB_TIMESTR_MAX);
6188 field_length = strlen (format_str);
6189
6190 COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
6191 make_field_entry (&field);
6192
6193 cobglobptr->cob_exception_code = 0;
6194
6195 /* Extract and validate the times and time format */
6196
6197 whole_seconds = cob_get_int (time_field);
6198 if (!valid_time (whole_seconds)) {
6199 goto invalid_args;
6200 }
6201
6202 fractional_seconds = &d2;
6203 get_fractional_seconds (time_field, fractional_seconds);
6204
6205 if (!cob_valid_time_format (format_str, COB_MODULE_PTR->decimal_point)) {
6206 goto invalid_args;
6207 }
6208 format = parse_time_format_string (format_str);
6209
6210 if (use_system_offset) {
6211 offset_time_ptr = get_system_offset_time_ptr (&offset_time);
6212 } else {
6213 if (try_get_valid_offset_time (offset_time_field,
6214 &offset_time)) {
6215 goto invalid_args;
6216 } else {
6217 offset_time_ptr = &offset_time;
6218 }
6219 }
6220
6221 format_time (format, whole_seconds, fractional_seconds, offset_time_ptr,
6222 buff);
6223
6224 memcpy (curr_field->data, buff, field_length);
6225 goto end_of_func;
6226
6227 invalid_args:
6228 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
6229 memset (curr_field->data, ' ', strlen (format_str));
6230
6231 end_of_func:
6232 if (unlikely (offset > 0)) {
6233 calc_ref_mod (curr_field, offset, length);
6234 }
6235 return curr_field;
6236 }
6237
6238 cob_field *
cob_intr_formatted_datetime(const int offset,const int length,const int params,...)6239 cob_intr_formatted_datetime (const int offset, const int length,
6240 const int params, ...)
6241 {
6242 va_list args;
6243 cob_field *fmt_field;
6244 cob_field *days_field;
6245 cob_field *time_field;
6246 cob_field *offset_time_field;
6247 cob_field field;
6248 size_t field_length;
6249 char fmt_str[COB_DATETIMESTR_LEN] = { '\0' };
6250 char date_fmt_str[COB_DATESTR_LEN] = { '\0' };
6251 char time_fmt_str[COB_TIMESTR_LEN] = { '\0' };
6252 struct date_format date_fmt;
6253 struct time_format time_fmt;
6254 int days;
6255 int whole_seconds;
6256 cob_decimal *fractional_seconds;
6257 int use_system_offset;
6258 int offset_time;
6259 int *offset_time_ptr;
6260 char buff[COB_DATETIMESTR_LEN] = { '\0' };
6261
6262 if (!(params == 4 || params == 5)) {
6263 COB_FIELD_INIT (0, NULL, &const_alpha_attr);
6264 make_field_entry (&field);
6265 goto invalid_args;
6266 }
6267
6268 /* Get arguments */
6269 va_start (args, params);
6270
6271 fmt_field = va_arg (args, cob_field *);
6272 days_field = va_arg (args, cob_field *);
6273 time_field = va_arg (args, cob_field *);
6274 if (params == 5) {
6275 offset_time_field = va_arg (args, cob_field *);
6276 } else {
6277 offset_time_field = NULL;
6278 }
6279 use_system_offset = va_arg (args, int);
6280
6281 va_end (args);
6282
6283 copy_data_to_null_terminated_str (fmt_field, fmt_str,
6284 COB_DATETIMESTR_MAX);
6285 field_length = strlen (fmt_str);
6286
6287 COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
6288 make_field_entry (&field);
6289
6290 cobglobptr->cob_exception_code = 0;
6291
6292 /* Validate the formats, dates and times */
6293 if (!cob_valid_datetime_format (fmt_str, COB_MODULE_PTR->decimal_point)) {
6294 goto invalid_args;
6295 }
6296
6297 days = cob_get_int (days_field);
6298 whole_seconds = cob_get_int (time_field);
6299
6300 if (!valid_integer_date (days) || !valid_time (whole_seconds)) {
6301 goto invalid_args;
6302 }
6303
6304 split_around_t (fmt_str, date_fmt_str, time_fmt_str);
6305
6306 time_fmt = parse_time_format_string (time_fmt_str);
6307 if (use_system_offset) {
6308 offset_time_ptr = get_system_offset_time_ptr (&offset_time);
6309 } else {
6310 if (try_get_valid_offset_time (offset_time_field,
6311 &offset_time)) {
6312 goto invalid_args;
6313 } else {
6314 offset_time_ptr = &offset_time;
6315 }
6316 }
6317 date_fmt = parse_date_format_string (date_fmt_str);
6318
6319 /* Format */
6320
6321 fractional_seconds = &d1;
6322 get_fractional_seconds (time_field, fractional_seconds);
6323
6324 format_datetime (date_fmt, time_fmt, days, whole_seconds,
6325 fractional_seconds, offset_time_ptr, buff);
6326
6327 memcpy (curr_field->data, buff, (size_t) field_length);
6328 goto end_of_func;
6329
6330 invalid_args:
6331 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
6332 memset (curr_field->data, ' ', strlen (fmt_str));
6333
6334 end_of_func:
6335 if (unlikely (offset > 0)) {
6336 calc_ref_mod (curr_field, offset, length);
6337 }
6338 return curr_field;
6339 }
6340
6341
6342 cob_field *
cob_intr_test_formatted_datetime(cob_field * format_field,cob_field * datetime_field)6343 cob_intr_test_formatted_datetime (cob_field *format_field,
6344 cob_field *datetime_field)
6345 {
6346 char datetime_format_str[COB_DATETIMESTR_LEN] = { '\0' };
6347 char date_format_str[COB_DATESTR_LEN] = { '\0' };
6348 char time_format_str[COB_TIMESTR_LEN] = { '\0' };
6349 int date_present;
6350 int time_present;
6351 char formatted_datetime[COB_DATETIMESTR_LEN] = { '\0' };
6352 char formatted_date[COB_DATESTR_LEN] = { '\0' };
6353 char formatted_time[COB_TIMESTR_LEN] = { '\0' };
6354 int time_part_offset;
6355 int error_pos;
6356
6357 cobglobptr->cob_exception_code = 0;
6358
6359 /* Copy to null-terminated strings */
6360 copy_data_to_null_terminated_str (format_field, datetime_format_str,
6361 COB_DATETIMESTR_MAX);
6362 copy_data_to_null_terminated_str (datetime_field, formatted_datetime,
6363 COB_DATETIMESTR_MAX);
6364
6365 /* Check whether date or time is present. */
6366 if (cob_valid_date_format (datetime_format_str)) {
6367 date_present = 1;
6368 time_present = 0;
6369 } else if (cob_valid_time_format (datetime_format_str,
6370 COB_MODULE_PTR->decimal_point)) {
6371 date_present = 0;
6372 time_present = 1;
6373 } else if (cob_valid_datetime_format (datetime_format_str,
6374 COB_MODULE_PTR->decimal_point)) {
6375 date_present = 1;
6376 time_present = 1;
6377 } else {
6378 goto invalid_args;
6379 }
6380
6381 /* Move date/time to respective variables */
6382 if (date_present && time_present) {
6383 split_around_t (datetime_format_str, date_format_str, time_format_str);
6384 } else if (date_present) {
6385 strncpy (date_format_str, datetime_format_str, COB_DATESTR_MAX);
6386 } else { /* time_present */
6387 strncpy (time_format_str, datetime_format_str, COB_TIMESTR_MAX);
6388 }
6389
6390 if (date_present && time_present) {
6391 split_around_t (formatted_datetime, formatted_date, formatted_time);
6392 } else if (date_present) {
6393 strncpy (formatted_date, formatted_datetime, COB_DATESTR_MAX);
6394 } else { /* time_present */
6395 strncpy (formatted_time, formatted_datetime, COB_TIMESTR_MAX);
6396 }
6397 /* silence warnings */
6398 formatted_date[COB_DATESTR_MAX] = formatted_time[COB_TIMESTR_MAX] = 0;
6399
6400 /* Set time offset */
6401 if (date_present) {
6402 time_part_offset = (int)strlen (formatted_date) + 1;
6403 } else {
6404 time_part_offset = 0;
6405 }
6406
6407 /* Parse and validate the formatted date/time */
6408 if (date_present) {
6409 error_pos = test_formatted_date (parse_date_format_string (date_format_str),
6410 formatted_date, !time_present);
6411 if (error_pos != 0) {
6412 cob_alloc_set_field_uint (error_pos);
6413 goto end_of_func;
6414 }
6415 }
6416 if (date_present && time_present
6417 && formatted_datetime[strlen (formatted_date)] != 'T') {
6418 cob_alloc_set_field_uint ((unsigned int)strlen (formatted_date) + 1U);
6419 goto end_of_func;
6420 }
6421 if (time_present) {
6422 error_pos = test_formatted_time (parse_time_format_string (time_format_str),
6423 formatted_time, COB_MODULE_PTR->decimal_point);
6424 if (error_pos != 0) {
6425 cob_alloc_set_field_uint (time_part_offset + error_pos);
6426 goto end_of_func;
6427 }
6428 }
6429
6430 cob_alloc_set_field_uint (0);
6431 goto end_of_func;
6432
6433 invalid_args:
6434 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
6435 cob_alloc_set_field_uint (0);
6436
6437 end_of_func:
6438 return curr_field;
6439 }
6440
6441 cob_field *
cob_intr_integer_of_formatted_date(cob_field * format_field,cob_field * date_field)6442 cob_intr_integer_of_formatted_date (cob_field *format_field,
6443 cob_field *date_field)
6444 {
6445 char original_format_str[COB_DATETIMESTR_LEN] = { '\0' };
6446 char original_date_str[COB_DATETIMESTR_LEN] = { '\0' };
6447 char format_str[COB_DATESTR_LEN] = { '\0' };
6448 char date_str[COB_DATESTR_LEN] = { '\0' };
6449 int is_date;
6450 struct date_format date_fmt;
6451
6452 cobglobptr->cob_exception_code = 0;
6453
6454 copy_data_to_null_terminated_str (format_field, original_format_str,
6455 COB_DATETIMESTR_MAX);
6456 copy_data_to_null_terminated_str (date_field, original_date_str,
6457 COB_DATETIMESTR_MAX);
6458
6459 /* Get date format string and parse it */
6460 is_date = cob_valid_date_format (original_format_str);
6461 if (is_date) {
6462 strcpy (format_str, original_format_str);
6463 } else if (cob_valid_datetime_format (original_format_str,
6464 COB_MODULE_PTR->decimal_point)) { /* Datetime */
6465 split_around_t (original_format_str, format_str, NULL);
6466 } else { /* Invalid format string */
6467 goto invalid_args;
6468 }
6469 date_fmt = parse_date_format_string (format_str);
6470
6471 /* Get formatted date and validate it */
6472 if (is_date) {
6473 strcpy (date_str, original_date_str);
6474 } else { /* Datetime */
6475 split_around_t (original_date_str, date_str, NULL);
6476 }
6477 if (test_formatted_date (date_fmt, date_str, 1) != 0) {
6478 goto invalid_args;
6479 }
6480
6481 cob_alloc_set_field_uint (integer_of_formatted_date (date_fmt, date_str));
6482 goto end_of_func;
6483
6484 invalid_args:
6485 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
6486 cob_alloc_set_field_uint (0);
6487
6488 end_of_func:
6489 return curr_field;
6490 }
6491
6492 cob_field *
cob_intr_formatted_current_date(const int offset,const int length,cob_field * format_field)6493 cob_intr_formatted_current_date (const int offset, const int length,
6494 cob_field *format_field)
6495 {
6496 cob_field field;
6497 char format_str[COB_DATETIMESTR_LEN] = { '\0' };
6498 size_t field_length;
6499 char date_format_str[COB_DATESTR_LEN] = { '\0' };
6500 char time_format_str[COB_TIMESTR_LEN] = { '\0' };
6501 struct date_format date_fmt;
6502 struct time_format time_fmt;
6503 char formatted_date[COB_DATETIMESTR_LEN] = { '\0' };
6504
6505 copy_data_to_null_terminated_str (format_field, format_str,
6506 COB_DATETIMESTR_MAX);
6507 field_length = strlen (format_str);
6508
6509 COB_FIELD_INIT (field_length, NULL, &const_alpha_attr);
6510 make_field_entry (&field);
6511
6512 cobglobptr->cob_exception_code = 0;
6513
6514 /* Validate format */
6515 if (!cob_valid_datetime_format (format_str, COB_MODULE_PTR->decimal_point)) {
6516 cob_set_exception (COB_EC_ARGUMENT_FUNCTION);
6517 memset (curr_field->data, ' ', field_length);
6518 goto end_of_func;
6519 }
6520
6521 /* Parse format */
6522 split_around_t (format_str, date_format_str, time_format_str);
6523 date_fmt = parse_date_format_string (date_format_str);
6524 time_fmt = parse_time_format_string (time_format_str);
6525
6526 /* Format current date */
6527 format_current_date (date_fmt, time_fmt, formatted_date);
6528 memcpy (curr_field->data, formatted_date, field_length);
6529
6530 end_of_func:
6531 if (unlikely (offset > 0)) {
6532 calc_ref_mod (curr_field, offset, length);
6533 }
6534 return curr_field;
6535 }
6536
6537 /**
6538 FUNCTION CONTENT-LENGTH(pointer). NUMERIC.
6539
6540 Return the nul byte terminated "string" length of data
6541 addressed by the given pointer.
6542 **/
6543 cob_field *
cob_intr_content_length(cob_field * srcfield)6544 cob_intr_content_length (cob_field *srcfield)
6545 {
6546 unsigned char *pointed;
6547 cob_u32_t val = 0;
6548
6549 cob_set_exception (0);
6550 if (srcfield) {
6551 pointed = *((unsigned char **)srcfield->data);
6552 } else {
6553 pointed = NULL;
6554 }
6555 /* check if the pointer is set and does not point to NULL */
6556 if (pointed && *pointed) {
6557 val = (cob_u32_t)strlen ((char *)pointed);
6558 } else {
6559 cob_set_exception (COB_EC_DATA_PTR_NULL);
6560 }
6561 cob_alloc_set_field_uint (val);
6562 return curr_field;
6563 }
6564
6565 /**
6566 FUNCTION CONTENT-OF (pointer, [len]). ALPHANUMERIC, ref-mod allowed.
6567
6568 Retrieve the content of a pointer indirection.
6569 Either for given length, or if omitted or 0, by NUL terminator scan.
6570 If the source pointer is null, points to null or an empty string,
6571 return a zero length space.
6572 **/
6573 cob_field *
cob_intr_content_of(const int offset,const int length,const int params,...)6574 cob_intr_content_of (const int offset, const int length, const int params, ...)
6575 {
6576 size_t size = 0;
6577 unsigned char *pointed;
6578 unsigned int request_len;
6579 va_list args;
6580 cob_field field;
6581 cob_field *srcfield;
6582 cob_field *lenfield;
6583
6584 cob_set_exception (0);
6585
6586 va_start (args, params);
6587 srcfield = va_arg(args, cob_field *);
6588 if (params > 1) {
6589 lenfield = va_arg (args, cob_field *);
6590 request_len = cob_get_int (lenfield);
6591 } else {
6592 request_len = 0;
6593 }
6594 va_end (args);
6595
6596 if (srcfield) {
6597 pointed = *((unsigned char **)srcfield->data);
6598 } else {
6599 pointed = NULL;
6600 }
6601 /* check if the pointer is set and does not point to NULL */
6602 if (pointed && *pointed) {
6603 /* Fixed length (may include NUL) or C NUL terminated string */
6604 if (request_len != 0) {
6605 size = request_len;
6606 } else {
6607 size = strlen ((char *)pointed);
6608 }
6609 if (size > COB_MAX_UNBOUNDED_SIZE) {
6610 cob_set_exception (COB_EC_SIZE_TRUNCATION);
6611 size = COB_MAX_UNBOUNDED_SIZE;
6612 }
6613 } else {
6614 cob_set_exception (COB_EC_DATA_PTR_NULL);
6615 size = 0;
6616 }
6617 if (size != 0) {
6618 COB_FIELD_INIT (size, NULL, &const_alpha_attr);
6619 make_field_entry (&field);
6620 /* Testing for memory access permissions is canonically: */
6621 /* open fake pipe, use write and test for -1 and EFAULT */
6622 /* Not used here, performance hit versus programmer error */
6623 memcpy (curr_field->data, pointed, size);
6624 } else {
6625 COB_FIELD_INIT (1, NULL, &const_alpha_attr);
6626 make_field_entry (&field);
6627 curr_field->data[0] = ' ';
6628 curr_field->size = 0;
6629 }
6630 if (unlikely(offset > 0)) {
6631 calc_ref_mod (curr_field, offset, length);
6632 }
6633 return curr_field;
6634 }
6635
6636 /* RXWRXW - To be implemented */
6637
6638 cob_field *
cob_intr_boolean_of_integer(cob_field * f1,cob_field * f2)6639 cob_intr_boolean_of_integer (cob_field *f1, cob_field *f2)
6640 {
6641 COB_UNUSED (f1);
6642 COB_UNUSED (f2);
6643
6644 error_not_implemented ();
6645 }
6646
6647 cob_field *
cob_intr_char_national(cob_field * srcfield)6648 cob_intr_char_national (cob_field *srcfield)
6649 {
6650 COB_UNUSED (srcfield);
6651
6652 error_not_implemented ();
6653 }
6654
6655 cob_field *
cob_intr_display_of(const int offset,const int length,const int params,...)6656 cob_intr_display_of (const int offset, const int length,
6657 const int params, ...)
6658 {
6659 COB_UNUSED (offset);
6660 COB_UNUSED (length);
6661 COB_UNUSED (params);
6662
6663 error_not_implemented ();
6664 }
6665
6666 cob_field *
cob_intr_exception_file_n(void)6667 cob_intr_exception_file_n (void)
6668 {
6669 error_not_implemented ();
6670 }
6671
6672 cob_field *
cob_intr_exception_location_n(void)6673 cob_intr_exception_location_n (void)
6674 {
6675 error_not_implemented ();
6676 }
6677
6678 cob_field *
cob_intr_integer_of_boolean(cob_field * srcfield)6679 cob_intr_integer_of_boolean (cob_field *srcfield)
6680 {
6681 COB_UNUSED (srcfield);
6682
6683 error_not_implemented ();
6684 }
6685
6686 cob_field *
cob_intr_national_of(const int offset,const int length,const int params,...)6687 cob_intr_national_of (const int offset, const int length, const int params, ...)
6688 {
6689 COB_UNUSED (offset);
6690 COB_UNUSED (length);
6691 COB_UNUSED (params);
6692
6693 error_not_implemented ();
6694 }
6695
6696 cob_field *
cob_intr_standard_compare(const int params,...)6697 cob_intr_standard_compare (const int params, ...)
6698 {
6699 COB_UNUSED (params);
6700
6701 error_not_implemented ();
6702 }
6703
6704 /* Initialization/exit routines */
6705
6706 void
cob_exit_intrinsic(void)6707 cob_exit_intrinsic (void)
6708 {
6709 struct calc_struct *calc_temp;
6710 cob_u32_t i;
6711
6712 mpf_clear (cob_log_half);
6713 mpf_clear (cob_sqrt_two);
6714 mpf_clear (cob_pi);
6715
6716 mpf_clear (cob_mpft_get);
6717 mpf_clear (cob_mpft2);
6718 mpf_clear (cob_mpft);
6719
6720 mpz_clear (d5.value);
6721 mpz_clear (d4.value);
6722 mpz_clear (d3.value);
6723 mpz_clear (d2.value);
6724 mpz_clear (d1.value);
6725
6726 mpz_clear (cob_mpzt);
6727 mpz_clear (cob_mexp);
6728
6729 if (calc_base) {
6730 calc_temp = calc_base;
6731 for (i = 0; i < COB_DEPTH_LEVEL; ++i, ++calc_temp) {
6732 if (calc_temp->calc_field.data) {
6733 cob_free (calc_temp->calc_field.data);
6734 }
6735 }
6736 cob_free (calc_base);
6737 }
6738 }
6739
6740 void
cob_init_intrinsic(cob_global * lptr)6741 cob_init_intrinsic (cob_global *lptr)
6742 {
6743 struct calc_struct *calc_temp;
6744 cob_u32_t i;
6745
6746 cobglobptr = lptr;
6747
6748 move_field = NULL;
6749 curr_entry = 0;
6750 curr_field = NULL;
6751 calc_base = cob_malloc (COB_DEPTH_LEVEL * sizeof(struct calc_struct));
6752 calc_temp = calc_base;
6753 for (i = 0; i < COB_DEPTH_LEVEL; ++i, ++calc_temp) {
6754 calc_temp->calc_field.data = cob_malloc ((size_t)256);
6755 calc_temp->calc_field.size = 256;
6756 calc_temp->calc_size = 256;
6757 }
6758
6759 mpz_init2 (cob_mexp, COB_MPZ_DEF);
6760 mpz_init2 (cob_mpzt, COB_MPZ_DEF);
6761 cob_decimal_init2 (&d1, 1536UL);
6762 cob_decimal_init2 (&d2, 1536UL);
6763 cob_decimal_init2 (&d3, 1536UL);
6764 cob_decimal_init2 (&d4, 1536UL);
6765 cob_decimal_init2 (&d5, 1536UL);
6766
6767 mpf_init2 (cob_mpft, COB_MPF_PREC);
6768 mpf_init2 (cob_mpft2, COB_MPF_PREC);
6769 mpf_init2 (cob_mpft_get, COB_MPF_PREC);
6770
6771 mpf_init2 (cob_pi, COB_PI_LEN);
6772 mpf_set_str (cob_pi, cob_pi_str, 10);
6773
6774 mpf_init2 (cob_sqrt_two, COB_SQRT_TWO_LEN);
6775 mpf_set_str (cob_sqrt_two, cob_sqrt_two_str, 10);
6776
6777 mpf_init2 (cob_log_half, COB_LOG_HALF_LEN);
6778 mpf_set_str (cob_log_half, cob_log_half_str, 10);
6779 }
6780
6781 #undef COB_DATETIMESTR_LEN
6782 #undef COB_TIMESTR_LEN
6783 #undef COB_DATESTR_LEN
6784