diff --git a/.github/workflows/macos.yml b/.github/workflows/macos.yml index 28ccbce6..3e5e2b8e 100644 --- a/.github/workflows/macos.yml +++ b/.github/workflows/macos.yml @@ -27,7 +27,7 @@ jobs: - name: Install packages run: | - brew install pkg-config automake libtool help2man texinfo bison berkeley-db@4 json-c + brew install automake libtool help2man texinfo bison berkeley-db@4 json-c opt="/opt/homebrew/opt" echo "$opt/pkg-config/bin" >> $GITHUB_PATH echo "LDFLAGS=-L$opt/berkeley-db@4/lib ${LDFLAGS}" >> $GITHUB_ENV diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 92f1b255..d50056b9 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,13 @@ +2024-11-22 Chuck Haatvedt + + * move.c (optimized_move_display_to_edited): fixed + Bug #1008: regression in move to numeric edited + items with insertion symbols B, 0 and / + * move.c (optimized_move_display_to_edited): minor refactoring + * system.def, move.c: added definition for COBOL2025 + COB_EC_DATA_NULL + COB_EC_DATA_TRUNCATION (currently not used) + 2024-10-22 Chuck Haatvedt * screenio.c (cob_screen_get_all): fixed Bug #999 diff --git a/libcob/exception.def b/libcob/exception.def index 9cd643ca..9e70c53c 100644 --- a/libcob/exception.def +++ b/libcob/exception.def @@ -122,6 +122,15 @@ COB_EXCEPTION (0305, COB_EC_DATA_OVERFLOW, COB_EXCEPTION (0306, COB_EC_DATA_PTR_NULL, "EC-DATA-PTR-NULL", 1) +/* Attempt to use a null valued data item in a context where not permitted (COBOL2025) */ +COB_EXCEPTION (0307, COB_EC_DATA_NULL, + "EC-DATA-NULL", 1) + +/* A non-space or significant-digit was truncated during MOVE (COBOL2025) */ +COB_EXCEPTION (0308, COB_EC_DATA_TRUNCATION, + "EC-DATA-TRUNCATION", 0) + + /* EXTERNAL item mismatch (COBOL 202x) */ COB_EXCEPTION (1900, COB_EC_EXTERNAL, diff --git a/libcob/move.c b/libcob/move.c index 053bbf24..d895a3c9 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -156,6 +156,19 @@ store_common_region (cob_field *f, const unsigned char *data, const int hf2 = fsize + lf2; const int gcf = cob_min_int (hf1, hf2); +#if 0 /* TODO: globally add support for COB_EC_DATA_TRUNCATION */ + const unsigned char *p = data; + const unsigned char *end = data + hf1 - gcf; + while (p < end) { + if ((COB_FIELD_IS_NUMERIC (f) && (*p != '0')) + || (COB_FIELD_IS_ANY_ALNUM (f) && (*p != ' '))) { + cob_set_exception (COB_EC_DATA_TRUNCATION); + break; + } + ++p; + } +#endif + /* the target may have leading/trailing additional zeroes and in rare cases, we may be out of scale competely; we pre-set all positions as this saves a bunch of @@ -1011,18 +1024,15 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) int suppress_zero = 1; int have_decimal_point = 0; int have_check_protect = 0; - int n; int cntr_currency = 0; - int cntr_sign_neg = 0; - int cntr_sign_pos = 0; + int cntr_sign = 0; unsigned char pad = ' '; unsigned char c; unsigned char float_char = 0x00; - const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' - ? ',' : '.'; + const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' ? ',' : '.'; const unsigned char currency = COB_MODULE_PTR->currency_symbol; -#if 1 /* Sanity check to ensure that the data types of both the fields have the +#if 1 /* Sanity check to ensure that the data types of both the fields have the correct attributes, if not then something is brokend and needs to be fixed */ if (!(COB_FIELD_TYPE (f2) == COB_TYPE_NUMERIC_EDITED && COB_FIELD_DIGITS (f1) == COB_FIELD_DIGITS (f2) @@ -1048,21 +1058,17 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { c = p->symbol; - n = p->times_repeated; if ((c == '9') || (c == 'Z') || (c == '*') || (c == 'C') || (c == 'D')) { break; - } else if (c == '-') { - cntr_sign_neg += n; - if (cntr_sign_neg > 1) break; - } else if (c == '+') { - cntr_sign_pos += n; - if (cntr_sign_pos > 1) break; + } else if ((c == '-') || (c == '+')) { + cntr_sign += p->times_repeated; + if (cntr_sign > 1) break; } else if (c == currency) { - cntr_currency += n; + cntr_currency += p->times_repeated; if (cntr_currency > 1) break; } } @@ -1079,30 +1085,38 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) } /* first check for BLANK WHEN ZERO attribute */ - if (COB_FIELD_BLANK_ZERO(f2)) { - for(; (src <= src_end) ; src++) { + if (COB_FIELD_BLANK_ZERO (f2)) { + for (; (src <= src_end) ; src++) { if (*src != '0') break; } if (src > src_end) { - memset(dst, (int)' ', (size_t)f2->size); + memset (dst, (int)' ', (size_t)f2->size); return; } src = f1->data; } - if (COB_FIELD_HAVE_SIGN(f1)) + if (COB_FIELD_HAVE_SIGN (f1)) { neg = (*src_end == '-') ? 1 : 0; + } for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { + int n; c = p->symbol; - n = p->times_repeated; - if (c == 'P') + if (c == 'P') { continue; - for (; n > 0; n--) { + } + if (c == 'V') { + have_decimal_point = 1; + continue; + } + for (n = p->times_repeated; n > 0; n--) { +#ifndef NDEBUG if (dst >= dst_end) { cob_runtime_error ("optimized_move_display_to_edited: overflow in destination field"); break; } +#endif switch (c) { case '9': @@ -1121,8 +1135,9 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) if (*src != '0') { is_zero = suppress_zero = 0; } else { - if (suppress_zero && (!have_decimal_point)) + if (suppress_zero && (!have_decimal_point)) { *dst = pad; + } } src++; dst++; @@ -1134,8 +1149,9 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) if (*src != '0') { is_zero = suppress_zero = 0; } else { - if (suppress_zero && (!have_decimal_point)) + if (suppress_zero && (!have_decimal_point)) { *dst = pad; + } } src++; dst++; @@ -1184,11 +1200,13 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) *dst = *prev_float_char; *prev_float_char = pad; prev_float_char = dst; - if (*dst == '-' || *dst == '+') + if (*dst == '-' || *dst == '+') { sign_position = dst; + } } - else + else { *dst = pad; + } } else { *dst = c; } @@ -1197,12 +1215,20 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) break; case 'V': - have_decimal_point = 1; break; case '0': case '/': - *dst = c; + if (suppress_zero && prev_float_char) { + *dst = *prev_float_char; + *prev_float_char = pad; + prev_float_char = dst; + if (*dst != currency) { + sign_position = dst; + } + } else { + *dst = c; + } dst++; break; @@ -1211,6 +1237,9 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) *dst = *prev_float_char; *prev_float_char = pad; prev_float_char = dst; + if (*dst != currency) { + sign_position = dst; + } } else if (have_check_protect) { *dst = pad; } else { @@ -1283,36 +1312,36 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) /* if we have not printed any digits set destination to spaces and return */ - if (suppress_zero){ - if (pad == '*'){ - for(dst = f2->data; dst < dst_end; dst++) { - if (*dst != dec_symbol){ + if (suppress_zero) { + if (pad == '*') { + for (dst = f2->data; dst < dst_end; dst++) { + if (*dst != dec_symbol) { *dst = '*'; } } } else { - memset(f2->data, ' ', f2->size); + memset (f2->data, ' ', f2->size); return; } } - if (sign_position == NULL) + if (sign_position == NULL) { return; + } - if ((neg) && (*sign_position == '+')){ + if ((neg) && (*sign_position == '+')) { *sign_position = (is_zero) ? '+' : '-'; return; } - if ((neg) && (*sign_position == '-')){ + if ((neg) && (*sign_position == '-')) { *sign_position = (is_zero) ? ' ' : '-'; return; - } - + } - if ((*sign_position == '-') && (!neg)) + if ((*sign_position == '-') && (!neg)) { *sign_position = ' '; - + } } diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 7d450ef6..db37ca0e 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1980,13 +1980,13 @@ AT_DATA([prog.cob], [ MOVE 10 TO identifier-1 MOVE identifier-1 TO EX-13 - IF EX-13 EQUAL " $//00//10 " + IF EX-13 EQUAL " $00//10 " MOVE "PASS" TO MSG-1 - D DISPLAY " $//00//10 IS WHAT I EXPECTED" + D DISPLAY " $00//10 IS WHAT I EXPECTED" ELSE ADD 1 TO WS-COUNT MOVE "FAIL" TO MSG-1 - DISPLAY "EX-13.02 EXPECTING ==>' $//00//10 ' " + DISPLAY "EX-13.02 EXPECTING ==>' $00//10 ' " "WHAT I GOT WAS ==>'" EX-13 "'<==" D DISPLAY "------------------" MSG-1 @@ -2510,6 +2510,121 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], AT_CLEANUP +AT_SETUP([MOVE to item with +, -, B, 0, / and ,]) +AT_KEYWORDS([fundamental edited editing]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 W-P4 PIC S9 VALUE +4. + 01 W-M4 PIC S9 VALUE -4. + 01 W-M PIC -B- VALUE SPACES. + 01 W-P PIC +B+ VALUE SPACES. + + 01 W-P123 PIC S9(3) VALUE +123. + 01 W-M123 PIC S9(3) VALUE -123. + 01 W-MM PIC ---B--9 VALUE SPACES. + 01 W-PP PIC +++B++9 VALUE SPACES. + + 01 W-X PIC -//00BB,,- VALUE SPACES. + + PROCEDURE DIVISION. + MOVE W-P4 TO W-M. + DISPLAY W-M. + MOVE W-M4 TO W-M. + DISPLAY W-M. + MOVE W-P4 TO W-P. + DISPLAY W-P. + MOVE W-M4 TO W-P. + DISPLAY W-P. + + MOVE W-P123 TO W-MM. + DISPLAY W-MM. + MOVE W-M123 TO W-MM. + DISPLAY W-MM. + MOVE W-P123 TO W-PP. + DISPLAY W-PP. + MOVE W-M123 TO W-PP. + DISPLAY W-PP. + + MOVE W-P4 TO W-X. + DISPLAY W-X. + MOVE W-M4 TO W-X. + DISPLAY W-X. + + MOVE W-P123 TO W-X. + DISPLAY W-X. + MOVE W-M123 TO W-X. + DISPLAY W-X. + + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[ 4 + -4 + +4 + -4 + 123 + -123 + +123 + -123 + 4 + -4 + 3 + -3 +]) + +AT_CLEANUP + + +AT_SETUP([MOVE to shorter edited item (truncation)]) +AT_KEYWORDS([fundamental edited editing]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 W-SRC1 PIC 999V99 VALUE 123.45. + 01 W-SRC2 PIC 9999V9 VALUE 1234.5. + 01 W-SRC3 PIC 99999V VALUE 12345. + 01 W-DST1 PIC ZZZV. + 01 W-DST2 PIC ZZZZZV. + + PROCEDURE DIVISION. + MOVE W-SRC1 TO W-DST1. + DISPLAY W-DST1. + MOVE W-SRC2 TO W-DST1. + DISPLAY W-DST1. + MOVE W-SRC3 TO W-DST1. + DISPLAY W-DST1. + MOVE W-SRC1 TO W-DST2. + DISPLAY W-DST2. + MOVE W-SRC2 TO W-DST2. + DISPLAY W-DST2. + MOVE W-SRC3 TO W-DST2. + DISPLAY W-DST2 WITH NO ADVANCING. + STOP RUN. +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[123 +234 +345 + 123 + 1234 +12345]) + +AT_CLEANUP + + AT_SETUP([MOVE to JUSTIFIED item]) AT_KEYWORDS([fundamental])