diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 29ba7a811..8b228426c 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -195,6 +195,12 @@ from copy_children, copy_into_field_recursive * tree.c (build_sum_counter): fix reference to sum counter +2022-10-01 Simon Sobisch + + * parser.y (function): attach ref-mod to all kind of functions to consume + them here and to pass invalid ref-mod for all numeric intrinsics to + cb_build_intrinsic enable us to create a nice diagnostic + 2022-09-30 Nicolas Berthier * codegen.c, cconv.h, cconv.c: extract EBCDIC & ASCII conversion tables @@ -1254,6 +1260,13 @@ Also, section/paragraph/verb names are now set via pointers in cob_module +2021-03-18 Ron Norman + + * codegen.c (output_section_info, output_trace_info): current name of + section/paragraph/verb are now set via pointers in cob_module instead + of executing trace functions, which are now only generated if trace + is requested + 2021-03-07 Simon Sobisch * Makefile.am: honor COBC_CPPFLAGS passed to configure diff --git a/cobc/parser.y b/cobc/parser.y index 29969d821..e82e8b558 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -19163,18 +19163,19 @@ function: { $$ = cb_build_intrinsic ($1, $3, $5, 0); } -| LENGTH_FUNC TOK_OPEN_PAREN length_arg TOK_CLOSE_PAREN +| LENGTH_FUNC TOK_OPEN_PAREN length_arg TOK_CLOSE_PAREN func_refmod { $$ = cb_build_intrinsic ($1, $3, NULL, 0); } -| LENGTH_FUNC TOK_OPEN_PAREN length_arg PHYSICAL TOK_CLOSE_PAREN +| LENGTH_FUNC TOK_OPEN_PAREN length_arg PHYSICAL TOK_CLOSE_PAREN func_refmod { CB_PENDING (_("PHYSICAL argument for LENGTH functions")); $$ = cb_build_intrinsic ($1, $3, NULL, 0); } -| NUMVALC_FUNC TOK_OPEN_PAREN numvalc_args TOK_CLOSE_PAREN +| NUMVALC_FUNC TOK_OPEN_PAREN numvalc_args TOK_CLOSE_PAREN func_refmod { - $$ = cb_build_intrinsic ($1, $3, NULL, 0); + /* note: no ref-mod allowed, parsing here to error in the following function */ + $$ = cb_build_intrinsic ($1, $3, $5, 0); } | LOCALE_DATE_FUNC TOK_OPEN_PAREN locale_dt_args TOK_CLOSE_PAREN func_refmod { @@ -19196,13 +19197,13 @@ function: { $$ = cb_build_intrinsic ($1, $3, $5, 0); } -| FUNCTION_NAME func_args +| FUNCTION_NAME func_args func_refmod { - $$ = cb_build_intrinsic ($1, $2, NULL, 0); + $$ = cb_build_intrinsic ($1, $2, $3, 0); } -| USER_FUNCTION_NAME func_args +| USER_FUNCTION_NAME func_args func_refmod { - $$ = cb_build_intrinsic ($1, $2, NULL, 1); + $$ = cb_build_intrinsic ($1, $2, $3, 1); } ; diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 3c601ccf8..56c1193f6 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -194,6 +194,15 @@ * intrinsic.c: extend internal docs * fileio.c: add some guards against bad function calls +2022-10-01 Simon Sobisch + + * intrinsic.c (numval, cob_intr_numval_f): rewritten for improved + performance (and creating smaller temporary fields); + changed to just skip invalid data instead of doing pre-validation + (which can be re-enabled by defining [INVALID_NUMVAL_IS_ZERO]) + * intrinsic.c (cob_check_numval_f, cob_intr_numval_f): correctly + recognize lowercase E + 2022-09-30 Simon Sobisch * common.h (cob_frame_ext): new variant of cob_frame storing the @@ -988,7 +997,7 @@ 2021-06-26 Ron Norman - * common.h: Add COB_DIALECT_xxx + * common.h: Add COB_DIALECT_xxx * fileio.c: Preparing for dialect specific status codes 2021-06-11 Ron Norman and Christian Lademann @@ -1002,7 +1011,7 @@ 2021-05-04 Ron Norman - * common.c: Make a few variables 'static' to better + * common.c: Make a few variables 'static' to better handle when there is an abort during dumping 2021-04-30 Ron Norman @@ -1049,11 +1058,11 @@ * common.h: Add to cob_symbol values for 'is_indirect' Changed 'data' to 'adrs', 'indexes' to 'subscripts' * common.c: Adjusted for new field names, handle ANY LENGTH/NUMERIC - + 2021-03-20 Ron Norman - * common.h: Add 'indexes' to cob_symbol - + * common.h: Add 'indexes' to cob_symbol + 2021-03-18 Ron Norman * common.h: New cob_symbol defined for a table of all module symbols @@ -1061,6 +1070,11 @@ * common.c: New routines added to dump a module using the symbol table instead of a bunch in generated code to do it +2021-03-18 Ron Norman + + * common.h (cob_module): fields for section/paragraph/statement names + * common.c: adjusted to use new fields in cob_module + 2021-03-05 Ron Norman * common.h: Add flag_isnodat diff --git a/libcob/intrinsic.c b/libcob/intrinsic.c index b305f253a..2205819c2 100644 --- a/libcob/intrinsic.c +++ b/libcob/intrinsic.c @@ -717,6 +717,8 @@ cob_mod_or_rem (cob_field *f1, cob_field *f2, const int func_is_rem) return curr_field; } +/* TEST-NUMVAL-F implementation */ + /* Validate NUMVAL-F item */ /* sp = spaces */ /* [sp][+|-][sp]{digits[.[digits]]|.digits}[sp][E[sp]{+|-}[sp]digits[sp]] */ @@ -724,31 +726,32 @@ cob_mod_or_rem (cob_field *f1, cob_field *f2, const int func_is_rem) int cob_check_numval_f (const cob_field *srcfield) { - unsigned char *p; + unsigned char *p = srcfield->data; size_t plus_minus; size_t digits; - size_t dec_seen; + size_t decimal_seen; size_t space_seen; size_t e_seen; size_t break_needed; size_t exponent; size_t e_plus_minus; int n; - unsigned char dec_pt; + const unsigned char dec_pt = COB_MODULE_PTR->decimal_point; if (!srcfield->size) { return 1; } - p = srcfield->data; + + /* FIXME later: srcfield may be of category national... */ + plus_minus = 0; digits = 0; - dec_seen = 0; + decimal_seen = 0; space_seen = 0; e_seen = 0; break_needed = 0; exponent = 0; e_plus_minus = 0; - dec_pt = COB_MODULE_PTR->decimal_point; /* Check leading positions */ for (n = 0; n < (int)srcfield->size; ++n, ++p) { @@ -815,11 +818,11 @@ cob_check_numval_f (const cob_field *srcfield) continue; case ',': case '.': - if (dec_seen || space_seen || e_seen) { + if (decimal_seen || space_seen || e_seen) { return n + 1; } if (*p == dec_pt) { - dec_seen = 1; + decimal_seen = 1; continue; } return n + 1; @@ -827,6 +830,7 @@ cob_check_numval_f (const cob_field *srcfield) space_seen = 1; continue; case 'E': + case 'e': if (e_seen) { return n + 1; } @@ -1481,19 +1485,51 @@ int_strncasecmp (const void *s1, const void *s2, size_t n) return (int) strncasecmp (s1, s2, n); } -/* NUMVAL */ +/* NUMVAL + NUMVAL-C implementation */ -static int -in_last_n_chars (const cob_field *field, const size_t n, const unsigned int i) +static COB_INLINE COB_A_INLINE int +space_left (unsigned char * p, unsigned char *p_end) { - return i + n >= field->size; + return p_end - p + 1; } -static int -at_cr_or_db (const cob_field *srcfield, const int pos) +static COB_INLINE COB_A_INLINE int +at_cr_or_db (const unsigned char *p) { - return memcmp (&srcfield->data[pos], "CR", (size_t)2) == 0 - || memcmp (&srcfield->data[pos], "DB", (size_t)2) == 0; + return memcmp (p, "CR", 2) == 0 + || memcmp (p, "DB", 2) == 0; +} + +/* get first and last position of possible numeric data */ +static size_t +calculate_start_end_for_numval (cob_field *srcfield, + unsigned char **pp, unsigned char **pp_end) +{ + unsigned char *p = srcfield->data; + unsigned char *p_end; + + if (srcfield->size == 0 + || p == NULL) { + return 0; + } + + /* skip trailing space and low-value */ + p_end = p + srcfield->size - 1; + while (p != p_end) { + if (*p_end != ' ' && *p_end != 0) break; + p_end--; + } + + /* skip leading space and zero */ + while (p != p_end) { + if (*p != ' ' && *p != '0') break; + p++; + } + + *pp = p; + *pp_end = p_end; + + return p_end - p + 1; } enum numval_type { @@ -1505,82 +1541,177 @@ static cob_field * numval (cob_field *srcfield, cob_field *currency, const enum numval_type type) { unsigned char *final_buff = NULL; + unsigned char *p, *p_end; unsigned char *currency_data = NULL; - size_t i; - int final_digits = 0; - int decimal_digits = 0; - int sign = 0; - int decimal_seen = 0; - unsigned char dec_pt = COB_MODULE_PTR->decimal_point; - unsigned char cur_symb = COB_MODULE_PTR->currency_symbol; - + size_t datasize; + int digits, decimal_digits; + int sign, decimal_seen, currency_seen, exception; + const unsigned char dec_pt = COB_MODULE_PTR->decimal_point; + const unsigned char num_sep = COB_MODULE_PTR->numeric_separator; + const unsigned char cur_symb = COB_MODULE_PTR->currency_symbol; + + /* note: versions before 3.2 did a pre-validation here, + we now parse "as valid as possible" by default + (the testsuite checks both variants) */ +#ifdef INVALID_NUMVAL_IS_ZERO /* Validate source field */ if (cob_check_numval (srcfield, currency, type == NUMVAL_C, 0)) { cob_set_exception (COB_EC_ARGUMENT_FUNCTION); cob_alloc_set_field_uint (0); return curr_field; } +#endif + + /* FIXME later: srcfield may be of category national... */ + + /* get size along with first/last relevant position */ + datasize = calculate_start_end_for_numval (srcfield, &p, &p_end); + + /* no data -> zero */ + if (datasize == 0) { + cob_alloc_set_field_uint (0); + return curr_field; + } + /* not wasting buffer space (COBOL2022: 35/34 max)... */ + if (datasize > COB_MAX_DIGITS) { + datasize = COB_MAX_DIGITS; + } + + /* acquire temp buffer long enugh */ + final_buff = cob_malloc (datasize + 1U); + + sign = 0; + digits = 0; + decimal_digits = 0; + decimal_seen = 0; + currency_seen = 0; + exception = 0; - final_buff = cob_malloc (srcfield->size + 1U); - if (currency && currency->size < srcfield->size) { + if (type == NUMVAL_C && currency && currency->size < datasize) { currency_data = currency->data; } - for (i = 0; i < srcfield->size; ++i) { - if (!in_last_n_chars (srcfield, 2, i) - && at_cr_or_db (srcfield, i)) { - sign = 1; - break; + for ( /* start value for p set above */ ; p <= p_end ; ++p) { + if (space_left (p, p_end) >= 2 + && at_cr_or_db (p)) { + /* CR / DB always wins in GnuCOBOL, sets the sign and ends */ + if (sign) { + /* that's an error, no need to check further */ + exception = 1; + } else { + /* post validation - only spaces allowed */ + p += 2; + while (p <= p_end) { + if (*p != ' ') { + exception = 1; + break; + } + p++; + } + } + sign = -1; + goto game_over; } if (currency_data) { - /* FIXME: only do so if i has a reasonable size [or at least is < INT_MAX] - otherwise an overflow may occur - */ - if (!(in_last_n_chars (srcfield, currency->size, i)) - && !memcmp (&srcfield->data[i], currency_data, - currency->size)) { - i += (currency->size - 1); + if (space_left (p, p_end) >= currency->size + && !memcmp (p, currency_data, currency->size)) { + if (currency_seen) { + exception = 1; + } else { + if (digits != 0 || decimal_seen) { + exception = 1; + } + currency_seen = 1; + } + p += (currency->size - 1); continue; } - } else if (type == NUMVAL_C && srcfield->data[i] == cur_symb) { + } else if (type == NUMVAL_C && *p == cur_symb) { + if (currency_seen) { + exception = 1; + } else { + currency_seen = 1; + } continue; } - if (srcfield->data[i] == ' ') { + switch (*p) { + case '0': + if (digits == 0 && !decimal_seen) { + /* no data yet, so just skip */ + continue; + } + /* Fall through */ + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (decimal_seen) { + decimal_digits++; + } + final_buff[digits++] = *p; + if (digits > COB_MAX_DIGITS) { + exception = 1; + goto game_over; + } continue; - } - if (srcfield->data[i] == '+') { + case '+': + if (sign) { + exception = 1; + } else { + sign = 1; + } continue; - } - if (srcfield->data[i] == '-') { - sign = 1; + case '-': + if (sign) { + exception = 1; + } else { + sign = -1; + } continue; - } - if (srcfield->data[i] == dec_pt) { - decimal_seen = 1; + case ' ': + /* note: we don't check for bad embedded spaces + because of performance reasons */ continue; - } - if (srcfield->data[i] >= (unsigned char)'0' && - srcfield->data[i] <= (unsigned char)'9') { - if (decimal_seen) { - decimal_digits++; + default: + if (*p == dec_pt) { + if (decimal_seen) { + exception = 1; + } + decimal_seen = 1; + } else + if (*p == num_sep && type == NUMVAL_C) { + /* note: we don't check for bad numeric seperator places + because of performance reasons */ + } else { + /* must be invalid data, set exception and go on */ + exception = 1; } - final_buff[final_digits++] = srcfield->data[i]; - } - if (final_digits > COB_MAX_DIGITS) { - break; + continue; } } - /* If srcfield is an empty string */ - if (!final_digits) { +game_over: + + if (!digits) { + /* srcfield is an empty / all zero string */ final_buff[0] = '0'; } mpz_set_str (d1.value, (char *)final_buff, 10); cob_free (final_buff); - if (sign && mpz_sgn (d1.value)) { + + if (exception) { + cob_set_exception (COB_EC_ARGUMENT_FUNCTION); + } + + if (sign == -1 && mpz_sgn (d1.value)) { mpz_neg (d1.value, d1.value); } d1.scale = decimal_digits; @@ -3210,7 +3341,7 @@ cob_decimal_move_temp (cob_field *src, cob_field *dst) cob_move (curr_field, dst); } -/* TEST-NUMVAL implementation */ +/* TEST-NUMVAL + TEST-NUMVAL-C implementation */ /* Validate NUMVAL / NUMVAL-C item */ /* [spaces][+|-][spaces]{digits[.[digits]]|.digits}[spaces] */ @@ -3226,12 +3357,12 @@ cob_check_numval (const cob_field *srcfield, const cob_field *currency, size_t pos; size_t plus_minus; size_t digits; - size_t dec_seen; + size_t decimal_seen; size_t space_seen; size_t break_needed; size_t currcy_size; int n; - unsigned char dec_pt; + const unsigned char dec_pt = COB_MODULE_PTR->decimal_point; unsigned char cur_symb; /* variabe-length zero-size field -> error */ @@ -3301,7 +3432,6 @@ cob_check_numval (const cob_field *srcfield, const cob_field *currency, p = srcfield->data; plus_minus = 0; break_needed = 0; - dec_pt = COB_MODULE_PTR->decimal_point; /* check leading positions */ for (n = 0; n < (int)max_pos; ++n, ++p) { switch (*p) { @@ -3354,7 +3484,7 @@ cob_check_numval (const cob_field *srcfield, const cob_field *currency, /* check actual data */ break_needed = 0; digits = 0; - dec_seen = 0; + decimal_seen = 0; space_seen = 0; for (; n < (int)max_pos; ++n, ++p) { @@ -3375,11 +3505,11 @@ cob_check_numval (const cob_field *srcfield, const cob_field *currency, continue; case ',': case '.': - if (dec_seen || space_seen) { + if (decimal_seen || space_seen) { return n + 1; } if (*p == dec_pt) { - dec_seen = 1; + decimal_seen = 1; } else if (!chkcurr) { return n + 1; } @@ -4909,42 +5039,67 @@ cob_intr_numval_c (cob_field *srcfield, cob_field *currency) return numval (srcfield, currency, NUMVAL_C); } +/* NUMVAL-F implementation */ + cob_field * cob_intr_numval_f (cob_field *srcfield) { unsigned char *final_buff; - unsigned char *p; - size_t plus_minus; + unsigned char *p, *p_end; size_t digits; size_t decimal_digits; - size_t dec_seen; - size_t e_seen; size_t exponent; - size_t e_plus_minus; - size_t n; - unsigned char dec_pt; - + size_t datasize; + int decimal_seen, e_seen, plus_minus, e_plus_minus, exception; + const unsigned char dec_pt = COB_MODULE_PTR->decimal_point; + + /* note: versions before 3.2 did a pre-validation here, + we now parse "as valid as possible" by default + (the testsuite checks both variants) */ +#ifdef INVALID_NUMVAL_IS_ZERO /* Validate source field */ if (cob_check_numval_f (srcfield)) { cob_set_exception (COB_EC_ARGUMENT_FUNCTION); cob_alloc_set_field_uint (0); return curr_field; } +#endif + + /* FIXME later: srcfield may be of category national... */ + + /* get size along with first/last relevant position */ + datasize = calculate_start_end_for_numval (srcfield, &p, &p_end); + + /* no data -> zero */ + if (datasize == 0) { + cob_alloc_set_field_uint (0); + return curr_field; + } + /* not wasting buffer space (COBOL2022: 35/34 max)... */ + if (datasize > COB_MAX_DIGITS) { + datasize = COB_MAX_DIGITS; + } + + /* acquire temp buffer long enuogh */ + final_buff = cob_malloc (datasize + 1U); plus_minus = 0; digits = 0; decimal_digits = 0; - dec_seen = 0; + decimal_seen = 0; e_seen = 0; exponent = 0; e_plus_minus = 0; - dec_pt = COB_MODULE_PTR->decimal_point; + exception = 0; - final_buff = cob_malloc (srcfield->size + 1U); - p = srcfield->data; - for (n = 0; n < srcfield->size; ++n, ++p) { + for ( /* start value for p set above */; p <= p_end; ++p) { switch (*p) { case '0': + if (digits == 0 && !decimal_seen && exponent == 0) { + /* no data yet, so just skip */ + continue; + } + /* Fall through */ case '1': case '2': case '3': @@ -4958,48 +5113,108 @@ cob_intr_numval_f (cob_field *srcfield) exponent *= 10; exponent += COB_D2I (*p); } else { - if (dec_seen) { + if (decimal_seen) { decimal_digits++; } final_buff[digits++] = *p; + if (digits > COB_MAX_DIGITS) { + exception = 1; + goto game_over; + } } continue; - case 'E': - e_seen = 1; + case '+': + if (e_seen) { + if (e_plus_minus) { + exception = 1; + } else { + e_plus_minus = 1; + } + } else { + if (plus_minus) { + exception = 1; + } else { + plus_minus = 1; + } + } continue; case '-': if (e_seen) { - e_plus_minus = 1; + if (e_plus_minus) { + exception = 1; + } else { + e_plus_minus = -1; + } } else { - plus_minus = 1; + if (plus_minus) { + exception = 1; + } else { + plus_minus = -1; + } } continue; + case 'e': + case 'E': + if (e_seen) { + exception = 1; + } else { + if (digits == 0 && decimal_digits == 0) { + exception = 1; + goto game_over; + } + e_seen = 1; + } + continue; + case ' ': + /* note: we don't check for bad embedded spaces + because of performance reasons */ + continue; default: if (*p == dec_pt) { - dec_seen = 1; + if (decimal_seen) { + exception = 1; + } else { + decimal_seen = 1; + } + } else { + /* must be invalid data, set exception and go on */ + exception = 1; } continue; } } +game_over: + if (!digits) { + /* srcfield is an empty / all zero string */ final_buff[0] = '0'; } mpz_set_str (d1.value, (char *)final_buff, 10); cob_free (final_buff); - if (!mpz_sgn (d1.value)) { + + if (exponent > 9999) { + exponent = 9999; + exception = 1; + } + + if (exception) { + cob_set_exception (COB_EC_ARGUMENT_FUNCTION); + } + + if (mpz_sgn (d1.value) == 0) { /* Value is zero ; sign and exponent irrelevant */ d1.scale = 0; cob_alloc_field (&d1); (void)cob_decimal_get_field (&d1, curr_field, 0); return curr_field; } - if (plus_minus) { + if (plus_minus == -1) { mpz_neg (d1.value, d1.value); } if (exponent) { - if (e_plus_minus) { + if (e_plus_minus == -1) { /* Negative exponent */ d1.scale = decimal_digits + exponent; } else { diff --git a/tests/testsuite.src/run_functions.at b/tests/testsuite.src/run_functions.at index d77fcdd8b..7a0ae114a 100644 --- a/tests/testsuite.src/run_functions.at +++ b/tests/testsuite.src/run_functions.at @@ -2561,20 +2561,52 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 X1 PIC X(12) VALUE " -9876.1234 ". - 01 X2 PIC X(18) VALUE " 19876.1234 CR". - 01 N PIC s9(5)v9(5). + 01 X1 PIC X(12) VALUE " -9876.1234 ". + 01 X2 PIC X(18) VALUE " 19876.1234 CR". + 01 X3 PIC X(09) VALUE "-042.3240". + 01 X4 PIC X(09) VALUE "+04232400". + 01 X5 PIC X(09) VALUE " 00.00430". + 01 BAD1 PIC X(18) VALUE " 1. A-0B4.5". + 01 BAD2 PIC X(20) VALUE "+0@0%0=0*0!0&0^0)10-". + 01 EMPT PIC X(20) VALUE SPACE. + 77 CSZE PIC 9 VALUE 0. + 01 VSIZED. + 03 FILLER PIC X OCCURS 0 TO 10 DEPENDING ON CSZE. + 01 N PIC s9(8)v9(5). PROCEDURE DIVISION. MOVE FUNCTION NUMVAL ( X1 ) TO N - IF N NOT = -9876.1234 - DISPLAY N - END-DISPLAY - END-IF + IF N <> -9876.1234 + DISPLAY "X1 '" X1 "' : " N. MOVE FUNCTION NUMVAL ( X2 ) TO N - IF N NOT = -19876.1234 - DISPLAY N - END-DISPLAY - END-IF + IF N <> -19876.1234 + DISPLAY "X2 '" X2 "' : " N. + MOVE FUNCTION NUMVAL ( X3 ) TO N + IF N <> -42.324 + DISPLAY "X3 '" X3 "' : " N. + MOVE FUNCTION NUMVAL ( X4 ) TO N + IF N <> 4232400 + DISPLAY "X4 '" X4 "' : " N. + MOVE FUNCTION NUMVAL ( X5 ) TO N + IF N <> .0043 + DISPLAY "X5 '" X5 "' : " N. + + * Note: the following are "empty" tests + MOVE FUNCTION NUMVAL ( EMPT ) TO N + IF N <> 0 + DISPLAY "EMPT '" EMPT "' : " N. + MOVE FUNCTION NUMVAL ( VSIZED ) TO N + IF N <> 0 + DISPLAY "VSIZED '" VSIZED "' : " N. + + * Note: the following tests with invalid data, pre 3.2 + * return zero, 3.2+ get "whatever is valid there + * (which seem to be what MF is doing) + MOVE FUNCTION NUMVAL ( BAD1 ) TO N + IF N <> 0 AND N <> -1.045 + DISPLAY "BAD1 '" BAD1 "' : " N. + MOVE FUNCTION NUMVAL ( BAD2 ) TO N + IF N <> 0 AND N <> 10 + DISPLAY "BAD2 '" BAD2 "' : " N. STOP RUN. ]) @@ -2592,20 +2624,40 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 X1 PIC X(14) VALUE " % -9876.1234 ". - 01 X2 PIC X(20) VALUE " % 19,876.1234 DB". - 01 X3 PIC X(12) VALUE "% -9876.1234". - 01 N PIC s9(5)v9(5). + 01 X1 PIC X(14) VALUE " % -9876.1234 ". + 01 X2 PIC X(18) VALUE " % 19,876.1234 DB". + 01 X3 PIC X(12) VALUE "% -9876.1234". + 01 X4 PIC X(12) VALUE "019,876.1234". + 01 BAD1 PIC X(18) VALUE " -19,876.1234 %". + 01 BAD2 PIC X(18) VALUE "19,87,56.12.34 ". + 01 BAD3 PIC X(18) VALUE "+19,8756CR1234". + 01 N PIC s9(8)v9(5). PROCEDURE DIVISION. MOVE FUNCTION NUMVAL-C ( X1 , "%" ) TO N IF N NOT = -9876.1234 - DISPLAY X1 " - " N. + DISPLAY "X1 '" X1 "' : " N. MOVE FUNCTION NUMVAL-C ( X2 , "%" ) TO N IF N NOT = -19876.1234 - DISPLAY X2 " - " N. + DISPLAY "X2 '" X2 "' : " N. MOVE FUNCTION NUMVAL-C ( X3 , "%" ) TO N IF N NOT = -9876.1234 - DISPLAY X3 " - " N. + DISPLAY "X3 '" X3 "' : " N. + MOVE FUNCTION NUMVAL-C ( X4 , "%" ) TO N + IF N NOT = 19876.1234 + DISPLAY "X4 '" X4 "' : " N. + + * Note: the following tests with invalid data, pre 3.2 + * return zero, 3.2+ get "whatever is valid there + * (which seem to be what MF is doing) + MOVE FUNCTION NUMVAL ( BAD1 ) TO N + IF N <> 0 AND N <> -19876.1234 + DISPLAY "BAD1 '" BAD1 "' : " N. + MOVE FUNCTION NUMVAL ( BAD2 ) TO N + IF N <> 0 AND N <> 198756.1234 + DISPLAY "BAD2 '" BAD2 "' : " N. + MOVE FUNCTION NUMVAL ( BAD3 ) TO N + IF N <> 0 AND N <> -198756 + DISPLAY "BAD3 '" BAD3 "' : " N. STOP RUN. ]) @@ -2628,12 +2680,12 @@ AT_DATA([prog.cob], [ . DATA DIVISION. WORKING-STORAGE SECTION. - 01 X1 PIC X(20) VALUE " % 19.876,1234 DB". - 01 N PIC s9(5)v9(5). + 01 X1 PIC X(20) VALUE " % 19.876,1234 DB". + 01 N PIC s9(5)v9(5). PROCEDURE DIVISION. MOVE FUNCTION NUMVAL-C ( X1 , "%" ) TO N IF N NOT = -19876,1234 - DISPLAY X1 " - " N. + DISPLAY "X1 '" X1 "' : " N. STOP RUN. ]) @@ -2651,17 +2703,29 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 X PIC X(12) VALUE " -0.1234E+4 ". + 01 X1 PIC X(12) VALUE " -0.1234E+4 ". + 01 X2 PIC X(12) VALUE " .1234e-2 ". + 01 BAD1 PIC X(18) VALUE " -000E-12". + 01 N PIC s9(8)v9(10). PROCEDURE DIVISION. - DISPLAY FUNCTION NUMVAL-F ( X ) - END-DISPLAY. + MOVE FUNCTION NUMVAL-F ( X1 ) TO N + IF N NOT = -1234 + DISPLAY "X1 '" X1 "' : " N. + MOVE FUNCTION NUMVAL-F ( X2 ) TO N + IF N NOT = .001234 + DISPLAY "X2 '" X2 "' : " N. + + * Note: the following tests with invalid data, pre 3.2 + * return zero, 3.2+ get "whatever is valid there + * (which seem to be what MF is doing) + MOVE FUNCTION NUMVAL-F ( BAD1 ) TO N + IF N <> 0 + DISPLAY "BAD1 '" BAD1 "' : " N. STOP RUN. ]) AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], -[-000001234 -]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP diff --git a/tests/testsuite.src/syn_functions.at b/tests/testsuite.src/syn_functions.at index 43198afdb..a2507cc37 100644 --- a/tests/testsuite.src/syn_functions.at +++ b/tests/testsuite.src/syn_functions.at @@ -1,4 +1,4 @@ -## Copyright (C) 2007-2012, 2014-2018, 2020-2021 Free Software Foundation, Inc. +## Copyright (C) 2007-2012, 2014-2018, 2020-2022 Free Software Foundation, Inc. ## Written by Roger While, Simon Sobisch, Edward Hart ## ## This file is part of GnuCOBOL. @@ -365,30 +365,6 @@ AT_SETUP([Intrinsic functions: reference modification]) AT_KEYWORDS([functions refmod]) # the following should be checked, currently doesn't work -#AT_DATA([prog.cob], [ -# IDENTIFICATION DIVISION. -# PROGRAM-ID. prog. -# ENVIRONMENT DIVISION. -# DATA DIVISION. -# WORKING-STORAGE SECTION. -# PROCEDURE DIVISION. -# DISPLAY FUNCTION CHAR (66)(1:2). -# DISPLAY FUNCTION NUMVAL-C (123)(1:2). -# DISPLAY FUNCTION REVERSE ("TESTME")(20:1). -# DISPLAY FUNCTION REVERSE ("TESTME")(-1:1). -# DISPLAY FUNCTION REVERSE ("TESTME")(1:0). -# STOP RUN. -#]) -# -#AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], -#[prog.cob:8: error: FUNCTION 'PI' can not have reference modification -#prog.cob:9: error: FUNCTION 'NUMVAL-C' can not have reference modification -#prog.cob:10: error: FUNCTION 'REVERSE' has invalid reference modification -#prog.cob:11: error: FUNCTION 'REVERSE' has invalid reference modification -#prog.cob:12: error: FUNCTION 'REVERSE' has invalid reference modification -#]) - -# test what is in already... AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. @@ -396,16 +372,38 @@ AT_DATA([prog.cob], [ DATA DIVISION. WORKING-STORAGE SECTION. PROCEDURE DIVISION. + DISPLAY FUNCTION CHAR (66)(1:2). + DISPLAY FUNCTION NUMVAL-C (123)(1:2). DISPLAY FUNCTION REVERSE ("TESTME")(-1:1). DISPLAY FUNCTION REVERSE ("TESTME")(1:0). STOP RUN. ]) AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], -[prog.cob:8: error: FUNCTION 'REVERSE' has invalid reference modification -prog.cob:9: error: FUNCTION 'REVERSE' has invalid reference modification +[prog.cob:8: error: FUNCTION 'CHAR' cannot have reference modification +prog.cob:9: error: FUNCTION 'NUMVAL-C' cannot have reference modification +prog.cob:10: error: FUNCTION 'REVERSE' has invalid reference modification +prog.cob:11: error: FUNCTION 'REVERSE' has invalid reference modification ]) +# missing: resolving constant values at compile-time, allowing us to +# catch bad ref-mods +#AT_DATA([prog2.cob], [ +# IDENTIFICATION DIVISION. +# PROGRAM-ID. prog2. +# ENVIRONMENT DIVISION. +# DATA DIVISION. +# WORKING-STORAGE SECTION. +# PROCEDURE DIVISION. +# DISPLAY FUNCTION REVERSE ("TESTME")(20:1). +# STOP RUN. +#]) +# +#AT_CHECK([$COMPILE_ONLY prog3.cob], [1], [], +#[prog.cob:8: error: FUNCTION 'REVERSE' has invalid reference modification +#prog.cob:8: error: reference modification out of bounds +#]) + AT_CLEANUP