diff --git a/cobc/ChangeLog b/cobc/ChangeLog index fea626e9a..3e644a35b 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -3,6 +3,11 @@ * cobc.c (process_command_line): fix leak for --copy and -include parsing +2024-12-05 David Declerck + + * config.def: new normalize-bcd dialect option + * codegen.c (output_module_init_function): initialize flag_normalize_bcd + 2024-10-30 Chuck Haatvedt * typeck.c: define [WITH_EXTENDED_SCREENIO] for any curses headers diff --git a/cobc/codegen.c b/cobc/codegen.c index c46d67f24..a29f8f1ff 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -11391,6 +11391,7 @@ output_module_init_function (struct cb_program *prog) } else { output_line ("module->module_sources = NULL;"); } + output_line ("module->flag_normalize_bcd = %d;", cb_normalize_bcd); output_block_close (); output_newline (); diff --git a/cobc/config.def b/cobc/config.def index ce587c5a4..b1097abe6 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -203,6 +203,9 @@ CB_CONFIG_BOOLEAN (cb_areacheck, "areacheck", " * statements must not start in Area A; and\n" " * separator periods must not be within Area A")) +CB_CONFIG_BOOLEAN (cb_normalize_bcd, "normalize-bcd", + _("normalize BCD on-the-fly")) + /* Support flags */ CB_CONFIG_SUPPORT (cb_comment_paragraphs, "comment-paragraphs", diff --git a/config/ChangeLog b/config/ChangeLog index a23c513bb..bb9ae5a9b 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,4 +1,8 @@ +2024-12-05 David Declerck + + * general: add the normalize-bcd dialect option (active only for GCOS) + 2024-08-17 Ammar Almoris FR #474: add runtime configuration to hide cursor for extended screenio diff --git a/config/acu-strict.conf b/config/acu-strict.conf index 2b9e45b17..287c69bd6 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -202,6 +202,9 @@ subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 2c0a1fae8..be6ede0e3 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -200,6 +200,9 @@ subscript-check: max # not verified, may need "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 6548f790c..bbaa339e4 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -199,6 +199,9 @@ subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 7f1492468..c26b8b347 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -199,6 +199,9 @@ subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/cobol85.conf b/config/cobol85.conf index f05669281..d10e26ce5 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -199,6 +199,9 @@ subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/default.conf b/config/default.conf index c4510e71c..f3dc2df26 100644 --- a/config/default.conf +++ b/config/default.conf @@ -219,6 +219,9 @@ subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 558e673a0..0df7f50fc 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -198,6 +198,9 @@ subscript-check: max # not verified, may need "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: yes # TODO: verify +# Normalize BCD on-the-fly +normalize-bcd: yes + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 41c6b4727..75c373681 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -198,6 +198,9 @@ subscript-check: max # TODO: "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: yes +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/mf-strict.conf b/config/mf-strict.conf index ee5d8b8fb..b1e1274b1 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -201,6 +201,9 @@ subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index fe928cb75..d977e2d39 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -198,6 +198,9 @@ subscript-check: max # TODO: "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: yes +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 1e40d19e1..4d06b0285 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -202,6 +202,9 @@ subscript-check: full # not verified yet # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 0af678a73..bb9966c84 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -205,6 +205,9 @@ subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/config/xopen.conf b/config/xopen.conf index 8bb576113..020bc9365 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -212,6 +212,9 @@ subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage init-justify: no +# Normalize BCD on-the-fly +normalize-bcd: no + # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' diff --git a/libcob/ChangeLog b/libcob/ChangeLog index b03c08cb8..4e71f22d4 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -9,6 +9,15 @@ * screenio.c [WITH_PANELS]: replace use of ncurses extension ceiling_panel() with X/Open Curses function panel_below() +2024-12-05 David Declerck + + * common.h: new flag_normalize_bcd field in cob_module + * common.c, coblocal.h (cob_get_sign_from_alnum): new function + to retrieve the "sign" of an ALPHANUMERIC field + * move.c (cob_move_alphanum_to_display), + numeric.c (cob_decimal_set_display): perform BCD + normalization when flag_normalize_bcd is set + 2024-11-22 David Declerck * move.c (optimized_move_display_to_edited): minor refactoring diff --git a/libcob/coblocal.h b/libcob/coblocal.h index a8b8e2c6c..573f2be2d 100644 --- a/libcob/coblocal.h +++ b/libcob/coblocal.h @@ -483,6 +483,7 @@ COB_HIDDEN FILE *cob_create_tmpfile (const char *); COB_HIDDEN int cob_check_numval_f (const cob_field *); COB_HIDDEN int cob_real_get_sign (cob_field *, const int); +COB_HIDDEN int cob_get_sign_from_alnum (cob_field *); COB_HIDDEN void cob_real_put_sign (cob_field *, const int); #ifndef COB_WITHOUT_DECIMAL diff --git a/libcob/common.c b/libcob/common.c index 00c5d9a40..ccaf6886d 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -3843,6 +3843,25 @@ cob_real_get_sign (cob_field *f, const int adjust_ebcdic) return 0; } +/* get the "sign" from an alphanumeric field, as if the field + was numeric display with non-separate trailing sign */ +int +cob_get_sign_from_alnum (cob_field *f) +{ + int sign; + cob_field_attr attr; + cob_field field; + COB_FIELD_INIT (COB_FIELD_SIZE (f), COB_FIELD_DATA (f), &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, COB_FIELD_SIZE (f), 0, COB_FLAG_HAVE_SIGN, NULL); + sign = cob_real_get_sign (&field, 0); + if (sign < 0) { + return -1; + } else if (sign > 0) { + return 1; + } + return 0; +} + /* store sign to DISPLAY/PACKED fields */ void cob_real_put_sign (cob_field *f, const int sign) diff --git a/libcob/common.h b/libcob/common.h index 18512d7a0..d00d430f5 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1337,6 +1337,8 @@ typedef struct __cob_module { const char *paragraph_name; /* name of current active pagagraph */ enum cob_statement statement; /* statement currently executed */ + unsigned char flag_normalize_bcd; /* Should BCD be normalized on-the-fly ? */ + } cob_module; diff --git a/libcob/move.c b/libcob/move.c index b96667b28..bbcb7b00d 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -309,6 +309,7 @@ cob_move_alphanum_to_display (cob_field *f1, cob_field *f2) const unsigned char *e2 = s2 + COB_FIELD_SIZE (f2); const unsigned char dec_pt = COB_MODULE_PTR->decimal_point; const unsigned char num_sep = COB_MODULE_PTR->numeric_separator; + unsigned char last; int sign; int count; int size; @@ -325,21 +326,34 @@ cob_move_alphanum_to_display (cob_field *f1, cob_field *f2) /* Check for sign */ sign = 0; - if (s1 != e1) { - if (*s1 == '+' || *s1 == '-') { - sign = (*s1++ == '+') ? 1 : -1; + if (!COB_MODULE_PTR->flag_normalize_bcd) { + if (s1 != e1) { + if (*s1 == '+' || *s1 == '-') { + sign = (*s1++ == '+') ? 1 : -1; + } } + } else { + last = f1->data[f1->size - 1]; + sign = cob_get_sign_from_alnum (f1); } /* Count the number of digits before decimal point */ count = 0; { register unsigned char *p; - for (p = s1; p < e1 && *p != dec_pt; ++p) { + if (!COB_MODULE_PTR->flag_normalize_bcd) { + for (p = s1; p < e1 && *p != dec_pt; ++p) { /* note: as isdigit is locale-aware (slower and not what we want), we use a range check instead */ - if (*p >= '0' && *p <= '9') { - ++count; + if (*p >= '0' && *p <= '9') { + ++count; + } + } + } else { + for (p = s1; p < e1 && *p != dec_pt; ++p) { + if (COB_D2I (*p) >= 0 && COB_D2I (*p) <= 9) { + ++count; + } } } } @@ -349,34 +363,69 @@ cob_move_alphanum_to_display (cob_field *f1, cob_field *f2) if (count < size) { s2 += size - count; } else { - while (count-- > size) { - while (*s1 < '0' || *s1 > '9') { + if (!COB_MODULE_PTR->flag_normalize_bcd) { + while (count-- > size) { + while (*s1 < '0' || *s1 > '9') { + s1++; + } + s1++; + } + } else { + while (count-- > size) { + while (COB_D2I (*s1) < 0 || COB_D2I (*s1) > 9) { + s1++; + } s1++; } - s1++; } } /* Move */ count = 0; - for (; s1 < e1 && s2 < e2; ++s1) { - if (*s1 >= '0' && *s1 <= '9') { - *s2++ = *s1; - } else if (*s1 == dec_pt) { - if (count++ > 0) { + if (!COB_MODULE_PTR->flag_normalize_bcd) { + for (; s1 < e1 && s2 < e2; ++s1) { + if (*s1 >= '0' && *s1 <= '9') { + *s2++ = *s1; + } else if (*s1 == dec_pt) { + if (count++ > 0) { + goto error; + } + } else if (!(isspace (*s1) || *s1 == num_sep)) { + goto error; + } + } + } else { + for (; s1 < e1 && s2 < e2; ++s1) { + if (COB_D2I (*s1) >= 0 && COB_D2I (*s1) <= 9) { +#ifndef COB_EBCDIC_MACHINE + *s2++ = (COB_D2I (*s1) | 0x30); +#else + *s2++ = (COB_D2I (*s1) | 0xF0); +#endif + } else if (*s1 == dec_pt) { + if (count++ > 0) { + goto error; + } + } else if (!(isspace (*s1) || *s1 == num_sep)) { goto error; } - } else if (!(isspace (*s1) || *s1 == num_sep)) { - goto error; } } COB_PUT_SIGN (f2, sign); + if (COB_MODULE_PTR->flag_normalize_bcd + && !COB_FIELD_CONSTANT (f1)) { + f1->data[f1->size - 1] = last; + } return; error: memset (f2->data, '0', f2->size); COB_PUT_SIGN (f2, 0); + if (COB_MODULE_PTR->flag_normalize_bcd + && !COB_FIELD_CONSTANT (f1)) { + f1->data[f1->size - 1] = last; + } } static void diff --git a/libcob/numeric.c b/libcob/numeric.c index bd76526bc..65cf4f720 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -1446,7 +1446,16 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f) register unsigned char *data = COB_FIELD_DATA (f); register unsigned int size = (unsigned int) COB_FIELD_SIZE (f); - const int sign = COB_GET_SIGN_ADJUST (f); + unsigned char last; + int sign; + + if (COB_MODULE_PTR->flag_normalize_bcd + && COB_FIELD_IS_ANY_ALNUM (f)) { + last = f->data[f->size - 1]; + sign = cob_get_sign_from_alnum (f); + } else { + sign = COB_GET_SIGN_ADJUST (f); + } /* TODO: document special cases here */ if (unlikely (*data == 255)) { @@ -1540,7 +1549,12 @@ cob_decimal_set_display (cob_decimal *d, cob_field *f) } d->scale = COB_FIELD_SCALE (f); - COB_PUT_SIGN_ADJUSTED (f, sign); + if (COB_MODULE_PTR->flag_normalize_bcd + && COB_FIELD_IS_ANY_ALNUM (f)) { + f->data[f->size - 1] = last; + } else { + COB_PUT_SIGN_ADJUSTED (f, sign); + } } /* store value from decimal into field of type numeric DISPLAY */ diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index 9a417b0f5..35a40e34b 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -460,6 +460,7 @@ test.conf: missing definitions: no definition of 'device-mnemonics' no definition of 'xml-parse-xmlss' no definition of 'areacheck' + no definition of 'normalize-bcd' no definition of 'comment-paragraphs' no definition of 'control-division' no definition of 'partial-replace-when-literal-src' diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 10df40949..a5865f896 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -15132,3 +15132,106 @@ AT_CHECK([COB_PROF_ENABLE=1 COB_PROF_FILE=prof.csv $COBCRUN_DIRECT ./caller], [0 ]) AT_CLEANUP + + +AT_SETUP([On-the-fly BCD normalization on MOVE from ALPHANUMERIC]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC-ALNUM PIC X(10) VALUE "ABC456789}". + 01 DST-NUMDISP PIC S9(10). + 01 DST-NUMEDIT PIC +9B999B999B999. + 01 DST-PACK PIC S9(10) PACKED-DECIMAL. + 01 DST-BIN PIC S9(10) BINARY. + 01 DST-BINC BINARY-CHAR SIGNED. + 01 DST-BINS BINARY-SHORT SIGNED. + 01 DST-BINL BINARY-LONG SIGNED. + 01 DST-BIND BINARY-DOUBLE SIGNED. + 01 DST-COMP5 PIC S9(10) COMP-5. + 01 DST-COMP6 PIC 9(10) COMP-6. + 01 DST-COMPX PIC 9(10) COMP-X. + 01 DST-COMPN PIC 9(10) COMP-N. + 01 DST-FLTSHORT FLOAT-SHORT. + 01 DST-FLTLONG FLOAT-LONG. + 01 DST-INDEX INDEX. + 01 FILLER BINARY-INT VALUE 0. + 88 DO-DISP VALUE 0. + 88 NO-DISP VALUE 1. + REPLACE ==DISPLAY== BY ==IF DO-DISP DISPLAY==. + + PROCEDURE DIVISION. + MAIN. + PERFORM DO-CHECK. + >> IF CHECK-PERF IS DEFINED + SET NO-DISP TO TRUE + PERFORM DO-CHECK 20000 TIMES. + >> END-IF + GOBACK. + + DO-CHECK. + IF SRC-ALNUM NOT NUMERIC DISPLAY "NOT NUMERIC". + + DISPLAY "SRC-ALNUM : '" SRC-ALNUM "'". + + MOVE SRC-ALNUM TO DST-NUMDISP. + DISPLAY " -> DST-NUMDISP : '" DST-NUMDISP "'". + MOVE SRC-ALNUM TO DST-NUMEDIT. + DISPLAY " -> DST-NUMEDIT : '" DST-NUMEDIT "'". + MOVE SRC-ALNUM TO DST-PACK. + DISPLAY " -> DST-PACK : '" DST-PACK "'". + MOVE SRC-ALNUM TO DST-BIN. + DISPLAY " -> DST-BIN : '" DST-BIN "'". + + MOVE SRC-ALNUM TO DST-BINC. + DISPLAY " -> DST-BINC : '" DST-BINC "'". + MOVE SRC-ALNUM TO DST-BINS. + DISPLAY " -> DST-BINS : '" DST-BINS "'". + MOVE SRC-ALNUM TO DST-BINL. + DISPLAY " -> DST-BINL : '" DST-BINL "'". + MOVE SRC-ALNUM TO DST-BIND. + DISPLAY " -> DST-BIND : '" DST-BIND "'". + + MOVE SRC-ALNUM TO DST-COMP5. + DISPLAY " -> DST-COMP5 : '" DST-COMP5 "'". + MOVE SRC-ALNUM TO DST-COMP6. + DISPLAY " -> DST-COMP6 : '" DST-COMP6 "'". + MOVE SRC-ALNUM TO DST-COMPX. + DISPLAY " -> DST-COMPX : '" DST-COMPX "'". + MOVE SRC-ALNUM TO DST-COMPN. + DISPLAY " -> DST-COMPN : '" DST-COMPN "'". + + MOVE SRC-ALNUM TO DST-FLTSHORT. + DISPLAY " -> DST-FLTSHORT : '" DST-FLTSHORT "'". + MOVE SRC-ALNUM TO DST-FLTLONG. + DISPLAY " -> DST-FLTLONG : '" DST-FLTLONG "'". + + MOVE SRC-ALNUM TO DST-INDEX. + DISPLAY " -> DST-INDEX : '" DST-INDEX "'". +]) + +AT_CHECK([$COMPILE -fsign=EBCDIC -fnormalize-bcd prog.cob]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[NOT NUMERIC +SRC-ALNUM : 'ABC456789}' + -> DST-NUMDISP : '-1234567890' + -> DST-NUMEDIT : '-1 234 567 890' + -> DST-PACK : '-1234567890' + -> DST-BIN : '-1234567890' + -> DST-BINC : '+046' + -> DST-BINS : '-00722' + -> DST-BINL : '-1234567890' + -> DST-BIND : '-00000000001234567890' + -> DST-COMP5 : '-00000000001234567890' + -> DST-COMP6 : '1234567890' + -> DST-COMPX : '1234567890' + -> DST-COMPN : '1234567890' + -> DST-FLTSHORT : '-1.2345679E+9' + -> DST-FLTLONG : '-1234567890' + -> DST-INDEX : '-1234567890' +]) + +AT_CLEANUP +