From 7c7b55b9311b7edf3bdab5e3c630995f28249958 Mon Sep 17 00:00:00 2001 From: chaat Date: Fri, 5 Jul 2024 20:06:18 +0000 Subject: [PATCH 1/9] Adjustment for move to edited numeric Fix errors in cob_move_display_to_edited and simplify the code. This was done by cloning the function to an optimized version and making the changes to the calling functions to support it. Basically this involves changing the intermediate cob_field to match the attributes of the target edited field instead of the sending field. libcob: * move.c (cob_optimized_move_display_to_edited): added new function (cob_move): when move numeric-display to numeric-edited added logic to check if an indirect move is needed (indirect_move): when the destination field is numeric-edited and the function source is binary, packed or display then the attributes need to generated to match destination attributes instead of the source attributes * termio.c (pretty_display_numeric), mlio.c (get_num): changed to use the attributes of the receiving field cobc: * tree.c (cb_build_picture): fixed currency digit counting logic --- cobc/ChangeLog | 4 + cobc/tree.c | 3 +- libcob/ChangeLog | 19 + libcob/mlio.c | 19 +- libcob/move.c | 635 +++++---- libcob/termio.c | 19 +- tests/testsuite.src/run_fundamental.at | 1729 ++++++++++++++++++++++- tests/testsuite.src/run_reportwriter.at | 11 +- 8 files changed, 2100 insertions(+), 339 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index bab8121b3..404956b17 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -3,6 +3,10 @@ * cobc.c (process_compile): fix MSVC build command +2024-06-11 Chuck Haatvedt + + * tree.c (cb_build_picture): fixed currency digit counting logic + 2024-05-15 Simon Sobisch * replace.c: fix compile warnings and formatting diff --git a/cobc/tree.c b/cobc/tree.c index a49d8aaf0..0fab97a3c 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -3797,11 +3797,10 @@ cb_build_picture (const char *str) category |= PIC_NUMERIC_EDITED; if (c_count == 0) { digits += n - 1; - c_count = n - 1; } else { digits += n; - c_count += n; } + c_count += n; break; } diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 00cd916fe..aff94ae59 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,23 @@ +2024-05-30 Chuck Haatvedt + + fix errors in cob_move_display_to_edited and simplify the code + this was done by cloning the function to an optimized version + and making the changes to the calling functions to support it + Basically this involves changing the intermediate cob_field to + match the attributes of the target edited field instead of the + sending field. + + * move.c (cob_optimized_move_display_to_edited): added new function + (cob_move): when move numeric-display to numeric-edited added logic + to check if an indirect move is needed + (indirect_move): when the destination field is numeric-edited and + the function source is binary, packed or display then the attributes + need to generated to match destination attributes instead of the + source attributes + * termio.c (pretty_display_numeric), mlio.c (get_num): + changed to use the attributes of the receiving field + 2024-05-15 Simon Sobisch * profiling.c: fix compile warnings diff --git a/libcob/mlio.c b/libcob/mlio.c index f6a657b46..67c52e443 100644 --- a/libcob/mlio.c +++ b/libcob/mlio.c @@ -1,5 +1,5 @@ /* - Copyright (C) 2018-2020, 2022-2023 Free Software Foundation, Inc. + Copyright (C) 2018-2020, 2022-2024 Free Software Foundation, Inc. Written by Edward Hart, Simon Sobisch This file is part of GnuCOBOL. @@ -229,7 +229,7 @@ is_empty (const cob_field * const f) } /* strdup-like wrapper for get_trimmed_data, returns a pointer to - fresh allocated memory pointing to a copy of the specified + fresh allocated memory pointing to a copy of the specified data with specified size as string (+ trailing NULL) */ static void * copy_data_as_string (const char* data, const size_t size) @@ -354,9 +354,9 @@ static void * get_num (cob_field * const f, void * (*strndup_func)(const char *, size_t), const char decimal_point) { - size_t num_integer_digits + const size_t num_integer_digits = cob_max_int (0, COB_FIELD_DIGITS (f) - COB_FIELD_SCALE (f)); - size_t num_decimal_digits + const size_t num_decimal_digits = cob_max_int (0, COB_FIELD_SCALE (f)); cob_field_attr attr; cob_field edited_field; @@ -367,9 +367,14 @@ get_num (cob_field * const f, void * (*strndup_func)(const char *, size_t), /* Initialize attribute for nicely edited version of f */ attr.type = COB_TYPE_NUMERIC_EDITED; - attr.flags = COB_FLAG_JUSTIFIED; - attr.scale = COB_FIELD_SCALE (f); - attr.digits = COB_FIELD_DIGITS (f); + attr.flags = COB_FIELD_HAVE_SIGN (f) ? + (COB_FLAG_JUSTIFIED | COB_FLAG_HAVE_SIGN) : + (COB_FLAG_JUSTIFIED); + attr.scale = (COB_FIELD_SCALE (f) < 0) ? 0 : COB_FIELD_SCALE (f); + attr.digits = (unsigned short)(num_integer_digits + num_decimal_digits); + if (num_integer_digits == 0) + attr.digits++; + attr.pic = get_pic_for_num_field (num_integer_digits, num_decimal_digits); diff --git a/libcob/move.c b/libcob/move.c index da157583f..8aa342ece 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -1,22 +1,22 @@ /* - Copyright (C) 2002-2012, 2014-2020, 2022-2024 Free Software Foundation, Inc. - Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, - Edwart Hard + Copyright (C) 2002-2012, 2014-2020, 2022-2024 Free Software Foundation, Inc. + Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman, + Edwart Hard - This file is part of GnuCOBOL. + This file is part of GnuCOBOL. - The GnuCOBOL runtime library is free software: you can redistribute it - and/or modify it under the terms of the GNU Lesser General Public License - as published by the Free Software Foundation, either version 3 of the - License, or (at your option) any later version. + The GnuCOBOL runtime library is free software: you can redistribute it + and/or modify it under the terms of the GNU Lesser General Public License + as published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. - GnuCOBOL is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + GnuCOBOL is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License - along with GnuCOBOL. If not, see . + You should have received a copy of the GNU Lesser General Public License + along with GnuCOBOL. If not, see . */ @@ -102,42 +102,42 @@ static const cob_s64_t cob_exp10_ll[19] = { /* translation table for BCD byte (2 digits) to integer; - identical defined in numeric.c */ + identical defined in numeric.c */ static const unsigned char pack_to_bin [] = { #if 0 /* invalid BCD nibbles as zero */ - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, - 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, - 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, - 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, - 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, - 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, - 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, - 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, - 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, - 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 0, 0, 0, 0, 0, 0, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 0, 0, 0, 0, 0, 0, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 0, 0, 0, 0, 0, 0, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0, 0, 0, 0, 0, 0, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 0, 0, 0, 0, 0, 0, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 0, 0, 0, 0, 0, 0, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 0, 0, 0, 0, 0, 0, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 0, 0, 0, 0, 0, 0, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 #else /* invalid BCD nibbles as translated since at least OC 1.1 */ - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, - 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, - 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 25, - 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, - 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, - 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, - 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, - 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, - 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, - 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, - 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, - 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, - 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, - 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, - 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, - 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165 + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 25, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, + 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, + 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, + 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, + 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, + 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165 #endif }; @@ -474,11 +474,11 @@ cob_move_alphanum_to_alphanum (cob_field *f1, cob_field *f2) void cob_move_display_to_packed (cob_field *f1, cob_field *f2) { - unsigned char *data1 = COB_FIELD_DATA (f1); - const int sign = COB_GET_SIGN_ADJUST (f1); - const short scale1 = COB_FIELD_SCALE (f1); - const short scale2 = COB_FIELD_SCALE (f2); - const int target_no_sign_nibble = COB_FIELD_NO_SIGN_NIBBLE (f2); + unsigned char *data1 = COB_FIELD_DATA (f1); + const int sign = COB_GET_SIGN_ADJUST (f1); + const short scale1 = COB_FIELD_SCALE (f1); + const short scale2 = COB_FIELD_SCALE (f2); + const int target_no_sign_nibble = COB_FIELD_NO_SIGN_NIBBLE (f2); unsigned short digits1; unsigned short digits2; register unsigned int i; @@ -540,7 +540,7 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) while (i < i_end) { *q = ((*p << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ + COB_D2I (*(p + 1)); - q++; + q++; i++; p += 2; } @@ -555,13 +555,13 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) /* clean bottom nibble if we packed one extra digit past the end of the input */ if (p > p_end) { *(q - 1) &= 0xf0; - } + } } COB_PUT_SIGN_ADJUSTED (f1, sign); if (target_no_sign_nibble) { - return; + return; } /* note: for zero-fill like MOVE 2.1 TO C3-9v9999 we only go to the second position and @@ -703,7 +703,7 @@ cob_move_fp_to_fp (cob_field *src, cob_field *dst) /* move from one to the other binary field ignoring the scale - --> these must match */ + --> these must match */ static void cob_move_binary_to_binary (cob_field *f1, cob_field *f2) { @@ -871,187 +871,185 @@ cob_move_binary_to_display (cob_field *f1, cob_field *f2) /* create numeric edited field, note: non-display fields get "unpacked" first via indirect_move, then be edited - from display using this function */ + from display using this function */ static void -cob_move_display_to_edited (cob_field *f1, cob_field *f2) +optimized_move_display_to_edited (cob_field *f1, cob_field *f2) { - register unsigned char *dst = f2->data; - register unsigned char *src; - const cob_pic_symbol *p; - unsigned char *min = COB_FIELD_DATA (f1); - unsigned char *max = min + COB_FIELD_SIZE (f1); - unsigned char *end = f2->data + f2->size; - unsigned char *decimal_point = NULL; - /* note: can't use the "adjust" variant here as we don't convert to digit - to explicit keep invalid data "as is"; - CHECKME for using a buffer instead of original data */ - const int sign = COB_GET_SIGN (f1); - int neg = (sign < 0) ? 1 : 0; - int count = 0; - int count_sign = 1; - int count_curr = 1; - int trailing_sign = 0; - int trailing_curr = 0; - int is_zero = 1; - int suppress_zero = 1; - int sign_first = 0; - int p_is_left = 0; - int has_b = 0; - int repeat; - int n; - unsigned char pad = ' '; - unsigned char x; - unsigned char c; - unsigned char sign_symbol = 0; - unsigned char curr_symbol = 0; - const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' - ? ',' : '.'; - const unsigned char currency = COB_MODULE_PTR->currency_symbol; - int floating_insertion = 0; - unsigned char *last_fixed_insertion_pos = NULL; - unsigned char last_fixed_insertion_char = '\0'; - - /* Setup counters (only before decimal point) */ - /* - TO-DO: This is computed in cb_build_picture; add computed results to - cb_field / new overlay cb_field_edited and use those. - */ - for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { - c = p->symbol; - repeat = p->times_repeated; - if (c == '9' || c == 'Z' || c == '*') { - count += repeat; - count_sign = 0; - count_curr = 0; - } else if (count_curr && c == currency) { - count += repeat; - } else if (count_sign && (c == '+' || c == '-')) { - count += repeat; - } else if (c == 'P') { - if (count == 0) { - p_is_left = 1; - break; - } else { - count += repeat; - count_sign = 0; - count_curr = 0; - } - } else if (c == 'V' || c == dec_symbol) { - break; + /************************************************************/ + /* this is a special "optimized" version of the */ + /* cob_move_display_to_edited function. The scale and */ + /* digits of the f2 field must be the same as the f1 */ + /* field. */ + /* */ + /* it is only called from the indirect_move function when */ + /* the destination field is type */ + /* COB_TYPE_NUMERIC_EDITED */ + /* */ + /* create numeric edited field, note: non-display fields */ + /* get "unpacked" first via indirect_move, then be edited */ + /* from display using this function */ + /* */ + /* This requires that the input field MUST be signed */ + /* separate (which is trailing). Also the source field */ + /* must contain the exact same number of digits as the */ + /* destination.. */ + /* */ + /* This ensures that we can make a single pass thru the */ + /* picture symbols and not have to worry about padding or */ + /* insertation after the loop thru the picture symbols. */ + /* */ + /* The reason for this change has more to do with */ + /* reducing the complexity of the code than performance. */ + /* Although it may result in a slight performance gain as */ + /* well. */ + /* */ + /************************************************************/ + + register unsigned char *dst = f2->data; + register unsigned char *src = f1->data; + const cob_pic_symbol *p; + unsigned char *src_end = src + f1->size - 1; + unsigned char *dst_end = f2->data + f2->size; + + unsigned char *prev_float_char = NULL; + unsigned char *sign_position = NULL; + int neg = 0; + int is_zero = 1; + int suppress_zero = 1; + int n; + unsigned char pad = ' '; + unsigned char c; + 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 + 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) + && COB_FIELD_SCALE (f1) == COB_FIELD_SCALE (f2) + && COB_FIELD_HAVE_SIGN (f1) == COB_FIELD_HAVE_SIGN (f2) + && ((COB_FIELD_HAVE_SIGN (f1) && (!COB_FIELD_SIGN_LEADING (f1) && COB_FIELD_SIGN_SEPARATE (f1))) + || !COB_FIELD_HAVE_SIGN (f1)))) { + cob_runtime_error ("optimized_move_display_to_edited: invalid argument"); + } +#endif + + /* first check for BLANK WHEN ZERO attribute */ + 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); + return; } + src = f1->data; } - /* now insert data to destination */ - src = max - COB_FIELD_SCALE (f1) - count; + if (COB_FIELD_HAVE_SIGN(f1)) + neg = (*src_end == '-') ? 1 : 0; + for (p = COB_FIELD_PIC (f2); p->symbol; ++p) { c = p->symbol; n = p->times_repeated; - for (; n > 0; n--, ++dst) { + if (c == 'P') + continue; + for (; n > 0; n--) { + if (dst >= dst_end) { + cob_runtime_error ("optimized_move_display_to_edited: overflow in destination field"); + break; + } switch (c) { case '9': - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { + suppress_zero = 0; + *dst = *src; + if (*src != '0') { is_zero = 0; } - suppress_zero = 0; - trailing_sign = 1; - trailing_curr = 1; - *dst = x; + src++; + dst++; break; case 'Z': case '*': - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { + *dst = *src; + if (*src != '0') { is_zero = suppress_zero = 0; + } else { + if (suppress_zero) + *dst = pad = (c == '*') ? '*' : ' '; } - trailing_sign = 1; - trailing_curr = 1; - pad = (c == '*') ? '*' : ' '; - *dst = suppress_zero ? pad : x; + src++; + dst++; break; case '+': case '-': - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { - is_zero = suppress_zero = 0; - } - if (trailing_sign) { - /* Check negative and not zero */ - if (neg && !is_zero) { - *dst = '-'; - } else if (c == '+') { - *dst = '+'; - } else { - *dst = ' '; - } - --end; - } else if (dst == f2->data || suppress_zero) { - *dst = pad; - sign_symbol = c; - if (!curr_symbol) { - ++sign_first; - } + if ((prev_float_char == NULL) || (c != *prev_float_char)) { + *dst = c; + prev_float_char = dst; + sign_position = dst; + dst++; + break; + } else if ((*src == '0') && (suppress_zero)) { + *prev_float_char = ' '; + prev_float_char = dst; + sign_position = dst; + *dst = c; + dst++; + src++; + break; } else { - *dst = x; - } - - if (n > 1 || last_fixed_insertion_char == c) { - floating_insertion = 1; - } else if (!trailing_sign) { - if (last_fixed_insertion_pos) { - *last_fixed_insertion_pos = last_fixed_insertion_char; - } - last_fixed_insertion_pos = dst; - last_fixed_insertion_char = c; + *dst = *src; + is_zero = suppress_zero = 0; + dst++; + src++; + break; } - break; case '.': case ',': if (c == dec_symbol) { *dst = dec_symbol; - decimal_point = dst; } else { if (suppress_zero) { - *dst = pad; + if (prev_float_char) { + *dst = *prev_float_char; + *prev_float_char = pad; + prev_float_char = dst; + if (*dst == '-' || *dst == '+') + sign_position = dst; + } + else + *dst = pad; } else { *dst = c; } } + dst++; break; case 'V': - --dst; - decimal_point = dst; break; case '0': case '/': *dst = c; + dst++; break; case 'B': - if (suppress_zero) { - *dst = pad; - } else { - *dst = 'B'; - has_b = 1; - } + *dst = pad; + dst++; break; case 'P': - if (p_is_left) { - ++src; - --dst; - } break; case 'C': case 'D': - end = dst; /* Check negative and not zero */ if (neg && !is_zero) { if (c == 'C') { @@ -1062,152 +1060,75 @@ cob_move_display_to_edited (cob_field *f1, cob_field *f2) } else { memset (dst, ' ', (size_t)2); } - dst++; + dst += 2; break; default: /* LCOV_EXCL_START */ if (c != currency) { /* should never happen, consider remove [also the reason for not translating that] */ - cob_runtime_error ("cob_move_display_to_edited: invalid PIC character %c", c); - *dst = '?'; /* Invalid PIC */ + cob_runtime_error ("optimized_move_display_to_edited: invalid PIC character %c", c); + *dst = '?'; /* Invalid PIC */ break; - } - /* LCOV_EXCL_STOP */ - - x = (min <= src && src < max) ? *src++ : (src++, '0'); - if (x != '0') { - is_zero = suppress_zero = 0; - } - if (trailing_curr) { - *dst = currency; - --end; - } else if (dst == f2->data || suppress_zero) { - *dst = pad; - curr_symbol = currency; } else { - *dst = x; - } - if (n > 1 || last_fixed_insertion_char == c) { - floating_insertion = 1; - } else if (!trailing_curr) { - if (last_fixed_insertion_pos) { - *last_fixed_insertion_pos = last_fixed_insertion_char; + if ((prev_float_char == NULL) || (c != *prev_float_char)) { + *dst = c; + prev_float_char = dst; + dst++; + break; + } else if ((*src == '0') && (suppress_zero)) { + *prev_float_char = ' '; + prev_float_char = dst; + *dst = c; + dst++; + src++; + break; + } else { + *dst = *src; + is_zero = suppress_zero = 0; + dst++; + src++; + break; } - last_fixed_insertion_pos = dst; - last_fixed_insertion_char = c; } - break; - } - } - } + /* LCOV_EXCL_STOP */ + } /* END OF SWITCH STATEMENT */ + } /* END OF INNER FOR LOOP */ + } /* END OF OUTER FOR LOOP */ - if (sign_symbol) { - /* Check negative and not zero */ - if (neg && !is_zero) { - sign_symbol = '-'; - } else if (sign_symbol != '+') { - sign_symbol = ' '; - } + /************************************************************/ + /* after the edited string is built from the mask */ + /* then the sign mask has to be adjusted according to */ + /* the actual sign of the data. */ + /************************************************************/ + + if (sign_position == NULL) + return; + + /* if we have not printed any digits set sign to space and return */ + + if (suppress_zero){ + *sign_position = ' '; + return; +} + + if ((neg) && (*sign_position == '+')){ + *sign_position = (is_zero) ? '+' : '-'; + return; } - if (suppress_zero || (is_zero && COB_FIELD_BLANK_ZERO (f2))) { - /* All digits are zeros */ - if (pad == ' ' || COB_FIELD_BLANK_ZERO (f2)) { - memset (f2->data, ' ', f2->size); - } else { - for (dst = f2->data; dst < f2->data + f2->size; ++dst) { - if (*dst != dec_symbol) { - *dst = pad; - } - } - } - } else { - /* Put zero after the decimal point if necessary */ - if (decimal_point) { - for (dst = decimal_point + 1; dst < end; ++dst) { - switch (*dst) { - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': -#if 1 /* CHECKME: Why should we have a comma in here, necessary as shown in NIST NC, - (TODO: add this to the internal testsuite, must fail if commented out) - but not skip a period? */ - case ',': - case '.': -#endif - case '+': - case '-': - case '/': - case 'B': - break; - default: - *dst = '0'; + if ((neg) && (*sign_position == '-')){ + *sign_position = (is_zero) ? ' ' : '-'; + return; } - } - } - /* Put sign or currency symbol at the beginning */ - if (sign_symbol || curr_symbol) { - if (floating_insertion) { - /* use memrchr here as soon as gnulib is used */ - for (dst = end - 1; dst > f2->data; --dst) { - if (*dst == ' ') { - break; - } - } - if (sign_symbol && curr_symbol) { - /* - Only one of $ and +/- can be floating - in any given picture, so the symbol - which comes after the other must be - the one which floats. - */ - if (sign_first) { - *dst = curr_symbol; - } else { - *dst = sign_symbol; - } - } else if (sign_symbol) { - *dst = sign_symbol; - } else { - *dst = curr_symbol; - } - } else { - if (last_fixed_insertion_char == currency) { - *last_fixed_insertion_pos = curr_symbol; - } else { /* + or - */ - *last_fixed_insertion_pos = sign_symbol; - } - } - } - /* Replace all leading 'B's by pad, others by space */ - if (has_b) { - for (dst = f2->data; dst < end; ++dst) { - if (*dst == 'B') { - if (has_b) { - *dst = pad; - } else { - *dst = ' '; - } - } else { - has_b = 0; /* non-starting characters seen */ - } - } - } - } + if ((*sign_position == '-') && (!neg)) + *sign_position = ' '; - COB_PUT_SIGN (f1, sign); } + static void cob_move_edited_to_display (cob_field *f1, cob_field *f2) { @@ -1331,10 +1252,58 @@ indirect_move (void (*func) (cob_field *src, cob_field *dst), cob_field *src, cob_field *dst, const size_t size, const int scale) { + /************************************************************/ + /* */ + /* this function was modified to call a new version of */ + /* the optimized_move_display_to_edited function */ + /* which is much simpler. However it requires the */ + /* intermediate numeric_display field created below to be */ + /* signed separate with the scale and number of digits to */ + /* match the final destination field. */ + /* */ + /* Note that this function requires that the sign flag on */ + /* the final destination field be set correctly. This */ + /* required changes to the pretty_display_numeric */ + /* function in termio.c, Also the get_num function in */ + /* mlio.c had to change as well. Both of these changes */ + /* involved setting the sign flag correctly on the */ + /* destination field. */ + /* */ + /************************************************************/ + cob_field field; cob_field_attr attr; - - if (size <= 2 * COB_MAX_DIGITS) { + size_t temp_size; + unsigned short digits; + + if ( (COB_FIELD_TYPE(dst) == COB_TYPE_NUMERIC_EDITED) + && ( (func == cob_move_binary_to_display) + || (func == cob_move_packed_to_display) + || (func == cob_move_display_to_display) ) ) { + if (COB_FIELD_SCALE(dst) < 0) + temp_size = COB_FIELD_DIGITS(dst) + COB_FIELD_SCALE(dst) + 1; + else + temp_size = COB_FIELD_DIGITS(dst) + 1; + digits = (unsigned short)temp_size - 1; + unsigned char buff[COB_MAX_DIGITS + 1] = { 0 }; + if (COB_FIELD_HAVE_SIGN(dst)) { + COB_FIELD_INIT (temp_size, buff, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, + digits, + COB_FIELD_SCALE(dst), + (COB_FLAG_HAVE_SIGN | COB_FLAG_SIGN_SEPARATE), + NULL); + } else { + COB_FIELD_INIT (temp_size - 1, buff, &attr); + COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, + digits, + COB_FIELD_SCALE(dst), + 0, + NULL); + } + func (src, &field); + optimized_move_display_to_edited (&field, dst); + } else if (size <= 2 * COB_MAX_DIGITS) { unsigned char buff[2 * COB_MAX_DIGITS] = { 0 }; COB_FIELD_INIT (size, buff, &attr); COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, (unsigned short) size, (short) scale, @@ -1507,7 +1476,17 @@ cob_move (cob_field *src, cob_field *dst) cob_move_display_to_binary (src, dst); return; case COB_TYPE_NUMERIC_EDITED: - cob_move_display_to_edited (src, dst); + if (COB_FIELD_DIGITS(src) == COB_FIELD_DIGITS(dst) + && COB_FIELD_SCALE(src) == COB_FIELD_SCALE(dst) + && COB_FIELD_HAVE_SIGN(src) == COB_FIELD_HAVE_SIGN(dst) + && ((COB_FIELD_HAVE_SIGN(src) && (!COB_FIELD_SIGN_LEADING(src) && COB_FIELD_SIGN_SEPARATE (src))) + || COB_FIELD_HAVE_SIGN(src) == 0)) { + optimized_move_display_to_edited(src, dst); + } else { + indirect_move (cob_move_display_to_display, src, dst, + (size_t)(COB_FIELD_DIGITS(src)), + COB_FIELD_SCALE (src)); + } return; case COB_TYPE_ALPHANUMERIC_EDITED: if (COB_FIELD_SCALE (src) < 0 @@ -1928,12 +1907,27 @@ packed_get_long_long (cob_field *field) if (COB_FIELD_NO_SIGN_NIBBLE (field)) { /* Unpack COMP-6 to integer */ + /************************************************************/ + /* if the scale is negative we need to determine if the */ + /* number of digits in the data plus the number of P's is */ + /* greater than the number of digits in the field. */ + /************************************************************/ + if (scale < 0) + { + if (((field->size * 2) - scale) > COB_FIELD_DIGITS (field)) + val = *d++ & 0x0F; + else + val = 0; + } + else + { const size_t offset = COB_FIELD_DIGITS (field) % 2; if (offset == 1) { val = *d++ & 0x0F; } else { val = 0; } + } if (val == 0) { /* Skip leading ZEROs */ while (d <= d_end @@ -1945,6 +1939,20 @@ packed_get_long_long (cob_field *field) val = val * 100 + pack_to_bin[*d++]; } } else { + /************************************************************/ + /* if the scale is negative we need to determine if the */ + /* number of digits in the data plus the number of P's is */ + /* greater than the number of digits in the field. */ + /************************************************************/ + if (scale < 0) + { + if (((field->size * 2) - 1 - scale) > COB_FIELD_DIGITS (field)) + val = *d++ & 0x0F; + else + val = 0; + } + else + { /* Unpack PACKED-DECIMAL / COMP-3 to integer */ const size_t offset = 1 - COB_FIELD_DIGITS (field) % 2; if (offset == 1) { @@ -1952,6 +1960,7 @@ packed_get_long_long (cob_field *field) } else { val = 0; } + } if (val == 0) { /* Skip leading ZEROs */ while (d < d_end diff --git a/libcob/termio.c b/libcob/termio.c index bbb5e9cf9..c44d31ce4 100644 --- a/libcob/termio.c +++ b/libcob/termio.c @@ -109,7 +109,7 @@ static void pretty_display_numeric (cob_field *f, FILE *fp) { unsigned short digits; - const signed short scale = COB_FIELD_SCALE (f); + signed short scale = COB_FIELD_SCALE (f); const int has_sign = COB_FIELD_HAVE_SIGN (f) ? 1 : 0; int size; /* Note: while we only need one pair, the double one works around a bug in @@ -161,17 +161,17 @@ pretty_display_numeric (cob_field *f, FILE *fp) p->times_repeated = scale; ++p; } else { + scale = 0; p->symbol = '9'; p->times_repeated = digits; ++p; } - if (has_sign) { - if (COB_FIELD_SIGN_SEPARATE (f) - && !COB_FIELD_SIGN_LEADING (f)) { - p->symbol = '+'; - p->times_repeated = 1; - ++p; - } + if (has_sign + && COB_FIELD_SIGN_SEPARATE (f) + && !COB_FIELD_SIGN_LEADING (f)) { + p->symbol = '+'; + p->times_repeated = 1; + ++p; } p->symbol = '\0'; @@ -181,7 +181,8 @@ pretty_display_numeric (cob_field *f, FILE *fp) cob_field field; cob_field_attr attr; COB_FIELD_INIT (size, COB_TERM_BUFF, &attr); - COB_ATTR_INIT (COB_TYPE_NUMERIC_EDITED, digits, scale, 0, + COB_ATTR_INIT (COB_TYPE_NUMERIC_EDITED, digits, scale, + has_sign ? (COB_FLAG_HAVE_SIGN | COB_FLAG_SIGN_SEPARATE): 0, (const cob_pic_symbol*)pic); cob_move (f, &field); diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index 53ec55967..69d7cd99c 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -447,6 +447,1684 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], []) AT_CLEANUP +AT_SETUP([MOVE to edited item (4)]) +AT_KEYWORDS([fundamental editing]) + +AT_DATA([prog.cob], [ + *@OPTIONS MAIN(MAIN) + IDENTIFICATION DIVISION. + + PROGRAM-ID. NUM-EDIT. + ****************************************************************** + *AUTHOR. MICHAEL F GLEASON. * + * TESTING RESULTS OF NUMERIC EDIT * + ****************************************************************** + + ENVIRONMENT DIVISION. + + CONFIGURATION SECTION. + + ****************************************************************** + * * + * THIS PROGRAM WILL ONLY DISPLAY MESSAGES IF THE * + * COMPILER IS GENERATING AN INCORRECT RESULT. * + * * + * IF YOU WISH TO SEE ALL THE DISPLAYS, THEN * + * UNCOMMENT THE SOURCE-COMPUTER LINE BELOW. * + * * + ****************************************************************** + + ****************************************************************** + *SOURCE-COMPUTER. IBM-PC WITH DEBUGGING MODE. + ****************************************************************** + OBJECT-COMPUTER. IBM-PC. + + ****************************************************************** + *REPOSITORY. * + *FUNCTION ALL INTRINSIC. * + ****************************************************************** + + DATA DIVISION. + + WORKING-STORAGE SECTION. + + 01 MISC-WORKING-STORAGE. + 05 WS-COUNT PIC 9(03) VALUE 0. + 05 PIC9V99 PIC S9(09)V99 COMP-3. + 05 MSG PIC X(50). + 05 MSG-1 PIC X(50). + 05 WS-CARDS-BANK-TOT PIC S9(9) COMP-3 VALUE 100. + 05 WS-CARDS-BANK PIC --,---,--9. + 05 EX-1 PIC ---,---,--9. + 05 EX-2 PIC $,$$$,$$9.99CR. + 05 EX-3 PIC ZZ,ZZZ,ZZ9DB. + 05 EX-4 PIC ZZ,ZZZ,ZZ9CR. + 05 EX-5 PIC $,$$$,$$9.99-. + 05 EX-6 PIC +$$$,$$$,$$9. + 05 EX-7 PIC -$,$$$,$$9.99. + 05 EX-8 PIC +$,$$$,$$9.99. + 05 EX-9 PIC +$ZZZZ9.99. *> PROG GUIDE EXMPL + 05 EX-10 PIC -$ZZZZ9.99. + 05 EX-11 PIC ++++,+++,++9. + 05 EX-12 PIC 9BB999BB999B9999. + 05 EX-13 PIC $$$$$//99//99CR. + 05 EX-13-2 PIC $$$$$/B/90/B/90CR. + 05 identifier-1 PIC S9(09) COMP-3. + 05 identifier-2 PIC ----,---,--9. + 05 A-PHONE-NUMBER PIC 9(11) VALUE 15128006789. + 05 Year-Month-Day PIC 9(4)/9(2)/9(2). + 05 YYYY-MM-DD PIC 9(10) VALUE 20240401. + 05 EX-14 PIC +$Z,,B0B,,9.909. + 05 EX-15 PIC ****,***,***.**. + + PROCEDURE DIVISION. + + 000-BEGIN-TEST. + + ****************************************************************** + *TEST-1 * + ****************************************************************** + D DISPLAY "Results for Year-Month-Day " + D "when input is an identifier" + D DISPLAY "PIC 9(4)/9(2)/9(2)." + MOVE YYYY-MM-DD TO Year-Month-Day + IF Year-Month-Day EQUAL "2024/04/01" + MOVE "PASS" TO MSG-1 + D DISPLAY "2024/04/01 IS WHAT I EXPECTED" + ELSE + MOVE "FAIL" TO MSG-1 + ADD 1 TO WS-COUNT + DISPLAY "TEST-1 EXPECTING 2024/04/01. WHAT I GOT WAS " + Year-Month-Day "." + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *TEST-2 * + ****************************************************************** + D DISPLAY "Results identifier-2 for WS-CARDS-BANK" + D DISPLAY "PIC --,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO WS-CARDS-BANK-TOT + MOVE WS-CARDS-BANK-TOT TO WS-CARDS-BANK + IF WS-CARDS-BANK = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " WS-CARDS-BANK MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-2 -10 " WS-CARDS-BANK MSG + END-IF + ****************************************************************** + *TEST-3 * + ****************************************************************** + MOVE -100 TO WS-CARDS-BANK-TOT + MOVE WS-CARDS-BANK-TOT TO WS-CARDS-BANK + IF WS-CARDS-BANK = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " WS-CARDS-BANK MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-3 -100 " WS-CARDS-BANK MSG + END-IF + ****************************************************************** + *TEST-4 * + ****************************************************************** + MOVE -1000 TO WS-CARDS-BANK-TOT + MOVE WS-CARDS-BANK-TOT TO WS-CARDS-BANK + IF WS-CARDS-BANK = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " WS-CARDS-BANK + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-4 -1000 " WS-CARDS-BANK MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *TEST-5 * + ****************************************************************** + D DISPLAY "MOVE identifier-1 TO identifier-2" + D DISPLAY "PIC ----,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -123456789 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = "-123,456,789" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 -123456789 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING '-123,456,789'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-5 identifier-1 -123456789 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-6 * + ****************************************************************** + MOVE -123 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " -123" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 -123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-6 identifier-1 -123 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-7 * + ****************************************************************** + MOVE -1234 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " -1,234" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 -1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-7 identifier-1 -1234 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-8 * + ****************************************************************** + MOVE -123 TO identifier-2 + IF identifier-2 = " -123" + MOVE SPACE TO MSG + D DISPLAY "literal-1 -123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-8 literal-1 -123 identifier-2 " + identifier-2 MSG + END-IF + D DISPLAY "literal-1 -123 identifier-2 " + ****************************************************************** + *TEST-9 * + ****************************************************************** + MOVE -1234 TO identifier-2 + IF identifier-2 = " -1,234" + MOVE SPACE TO MSG + D DISPLAY "literal-1 -1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-9 literal-1 -1234 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-10 * + ****************************************************************** + MOVE 123456789 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 123,456,789" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 123456789 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 123,456,789'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-10 identifier-1 123456789 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-11 * + ****************************************************************** + MOVE 12 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 12" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 12 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 12'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-11 identifier-1 12 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-12 * + ****************************************************************** + MOVE 123 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 123" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-12 identifier-1 123 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-13 * + ****************************************************************** + MOVE 1234 TO identifier-1 + MOVE identifier-1 TO identifier-2 + IF identifier-2 = " 1,234" + MOVE SPACE TO MSG + D DISPLAY "identifier-1 1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-13 identifier-1 1234 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-14 * + ****************************************************************** + MOVE 123 TO identifier-2 + IF identifier-2 = " 123" + MOVE SPACE TO MSG + D DISPLAY "literal-1 123 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 123'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-14 literal-1 123 identifier-2 " + identifier-2 MSG + END-IF + ****************************************************************** + *TEST-15 * + ****************************************************************** + MOVE 1234 TO identifier-2 + IF identifier-2 = " 1,234" + MOVE SPACE TO MSG + D DISPLAY "literal-1 1234 identifier-2 " + D identifier-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,234'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "TEST-15 literal-1 1234 identifier-2 " + identifier-2 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-1A * + ****************************************************************** + D DISPLAY "Results for EX-1 when input is a literal" + D DISPLAY "PIC ---,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO EX-1 + IF EX-1 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.01 -10 " EX-1 MSG + END-IF + + MOVE -100 TO EX-1 + IF EX-1 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.02 -100 " EX-1 MSG + END-IF + + MOVE -1000 TO EX-1 + IF EX-1 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.03 -1000 " EX-1 MSG + END-IF + + MOVE -10000 TO EX-1 + IF EX-1 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.04 -10000 " EX-1 MSG + END-IF + + MOVE 10 TO EX-1 + IF EX-1 = " 10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.05 10 " EX-1 MSG + END-IF + + MOVE 100 TO EX-1 + IF EX-1 = " 100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.06 100 " EX-1 MSG + END-IF + + MOVE 1000 TO EX-1 + IF EX-1 = " 1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.07 1000 " EX-1 MSG + END-IF + + MOVE 10000 TO EX-1 + IF EX-1 = " 10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.08 10000 " EX-1 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-1B * + ****************************************************************** + D DISPLAY "Results for EX-1 when input is an identifier" + D DISPLAY "PIC ---,---,--9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.09 -10 " EX-1 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.10 -100 " EX-1 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.11 -1000 " EX-1 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.12 -10000 " EX-1 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.13 10 " EX-1 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.14 100 " EX-1 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.15 1000 " EX-1 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-1 + IF EX-1 = " 10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-1 MSG + ELSE + MOVE " <---<<< EXPECTING ' 10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-1.16 10000 " EX-1 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-2 * + ****************************************************************** + D DISPLAY "Results for EX-2 when input is a literal" + D DISPLAY "PIC $,$$$,$$9.99CR." + MOVE "PASS" TO MSG-1 + MOVE 100 TO EX-2 + IF EX-2 = " $100.00 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.01 100 " EX-2 MSG + END-IF + + MOVE -100 TO EX-2 + IF EX-2 = " $100.00CR" + MOVE SPACE TO MSG + D DISPLAY " -100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.02 -100 " EX-2 MSG + END-IF + + MOVE 1000 TO EX-2 + IF EX-2 = " $1,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.03 1000 " EX-2 MSG + END-IF + + MOVE -1000 TO EX-2 + IF EX-2 = " $1,000.00CR" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.04 -1000 " EX-2 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + D DISPLAY "Results for EX-2 when input is an identifier " + D DISPLAY "PIC $,$$$,$$9.99CR." + MOVE "PASS" TO MSG-1 + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $100.00 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.05 100 " EX-2 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $100.00CR" + MOVE SPACE TO MSG + D DISPLAY " -100 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.06 -100 " EX-2 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $1,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.07 1000 " EX-2 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-2 + IF EX-2 = " $1,000.00CR" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-2 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-2.08 -1000 " EX-2 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-3 * + ****************************************************************** + D DISPLAY "Results for EX-3 when input is a literal" + D DISPLAY "PIC ZZ,ZZZ,ZZ9DB." + MOVE "PASS" TO MSG-1 + MOVE 100 TO EX-3 + IF EX-3 = " 100 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-3 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-3.01 100 " EX-3 MSG + END-IF + + MOVE -100 TO EX-3 + IF EX-3 = " 100DB" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-3 MSG + ELSE + MOVE " <---<<< EXPECTING ' 100DB'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-3.02 -100 " EX-3 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-4 * + ****************************************************************** + D DISPLAY "Results for EX-4 when input is a literal" + D DISPLAY "PIC ZZ,ZZZ,ZZ9CR." + MOVE "PASS" TO MSG-1 + MOVE 1000 TO EX-4 + IF EX-4 = " 1,000 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-4 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-4.01 1000 " EX-4 MSG + END-IF + + MOVE -1000 TO EX-4 + IF EX-4 = " 1,000CR" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-4 MSG + ELSE + MOVE " <---<<< EXPECTING ' 1,000CR'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-4.02 -1000 " EX-4 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-5 * + ****************************************************************** + D DISPLAY "Results for EX-5 when input is an identifier " + D DISPLAY "PIC $,$$$,$$9.99-." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10.00-" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.01 -10 " EX-5 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $100.00-" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.02 -100 " EX-5 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $1,000.00-" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.03 -1000 " EX-5 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10,000.00-" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10,000.00-'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.04 -10000 " EX-5 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10.00 " + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.05 10 " EX-5 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $100.00 " + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.06 100 " EX-5 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $1,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.07 1000 " EX-5 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-5 + IF EX-5 = " $10,000.00 " + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-5 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10,000.00 '" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-5.08 10000 " EX-5 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-6 * + ****************************************************************** + D DISPLAY "Results for EX-6 when input is an identifier" + D DISPLAY "PIC +$$$,$$$,$$9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.01 -10 " EX-6 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.02 -100 " EX-6 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.03 -1000 " EX-6 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "- $10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.04 -10000 " EX-6 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.05 10 " EX-6 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.06 100 " EX-6 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.07 1000 " EX-6 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-6 + IF EX-6 = "+ $10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-6 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-6.08 10000 " EX-6 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-7 * + ****************************************************************** + D DISPLAY "Results for EX-7 when input is an identifier" + D DISPLAY "PIC -$,$$$,$$9.99." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.01 -10 " EX-7 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.02 -100 " EX-7 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $1,000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.03 -1000 " EX-7 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = "- $10,000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.04 -10000 " EX-7 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.05 10 " EX-7 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.06 100 " EX-7 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $1,000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.07 1000 " EX-7 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-7 + IF EX-7 = " $10,000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-7 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-7.08 10000 " EX-7 MSG + END-IF + D DISPLAY "------------------"MSG-1 + ****************************************************************** + *EX-8 * + ****************************************************************** + D DISPLAY "Results for EX-8 when input is an identifier" + D DISPLAY "PIC +$,$$$,$$9.99." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.01 -10 " EX-8 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.02 -100 " EX-8 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $1,000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.03 -1000 " EX-8 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "- $10,000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '- $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.04 -10000 " EX-8 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.05 10 " EX-8 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.06 100 " EX-8 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $1,000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $1,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.07 1000 " EX-8 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-8 + IF EX-8 = "+ $10,000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-8 MSG + ELSE + MOVE " <---<<< EXPECTING '+ $10,000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-8.08 10000 " EX-8 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-9 * + ****************************************************************** + D DISPLAY "Results for EX-9 when input is an identifier" + D " and a literal" + D DISPLAY "PIC +$ZZZZ9.99. *> PROG GUIDE EXMPL" + D DISPLAY " The -$ signs don't float is correct" + D DISPLAY "According to P.G. the sign and $ should float" + D DISPLAY "In reality and by the COBOL STANDARDS, it doesn't" + MOVE "PASS" TO MSG-1 + MOVE 1 TO EX-9 + D DISPLAY "literal-1 1 " EX-9 + MOVE -1 TO EX-9 + D DISPLAY "literal-1 -1 " EX-9 + D " <---<<< Should be -$ when negative" + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$ 10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.01 -10 " EX-9 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$ 100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.02 -100 " EX-9 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$ 1000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.03 -1000 " EX-9 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "-$10000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '-$10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.04 -10000 " EX-9 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$ 10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.05 10 " EX-9 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$ 100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.06 100 " EX-9 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$ 1000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.07 1000 " EX-9 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-9 + IF EX-9 = "+$10000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-9 MSG + ELSE + MOVE " <---<<< EXPECTING '+$10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-9.08 10000 " EX-9 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-10 * + ****************************************************************** + D DISPLAY "Results for EX-10 when input is an identifier" + D " and a literal" + D DISPLAY "PIC -$ZZZZ9.99." + D DISPLAY " The -$ signs don't float is correct" + D DISPLAY "According to P.G. the sign and $ should float" + D DISPLAY "In reality and by the COBOL STANDARDS, it doesn't" + MOVE "PASS" TO MSG-1 + MOVE 1 TO EX-10 + D DISPLAY "literal-1 1 " EX-10 + D " <---<<< Should be just $ not -$ when positive" + MOVE -1 TO EX-10 + D DISPLAY "literal-1 -1 " EX-10 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$ 10.00" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.01 -10 " EX-10 MSG + END-IF + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$ 100.00" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.02 -100 " EX-10 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$ 1000.00" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.03 -1000 " EX-10 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = "-$10000.00" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING '-$10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.04 -10000 " EX-10 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $ 10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $ 10.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.05 10 " EX-10 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $ 100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $ 100.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.06 100 " EX-10 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $ 1000.00" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $ 1000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.07 1000 " EX-10 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-10 + IF EX-10 = " $10000.00" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-10 MSG + ELSE + MOVE " <---<<< EXPECTING ' $10000.00'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-10.08 10000 " EX-10 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-11A * + ****************************************************************** + D DISPLAY "Results for EX-11 when input is a literal" + D DISPLAY "PIC ++++,+++,++9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO EX-11 + IF EX-11 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.01 -10 " EX-11 MSG + END-IF + + MOVE -100 TO EX-11 + IF EX-11 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.02 -100 " EX-11 MSG + END-IF + + MOVE -1000 TO EX-11 + IF EX-11 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.03 -1000 " EX-11 MSG + END-IF + + MOVE -10000 TO EX-11 + IF EX-11 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.04 -10000 " EX-11 MSG + END-IF + + MOVE 10 TO EX-11 + IF EX-11 = " +10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.05 10 " EX-11 MSG + END-IF + + MOVE 100 TO EX-11 + IF EX-11 = " +100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.06 100 " EX-11 MSG + END-IF + + MOVE 1000 TO EX-11 + IF EX-11 = " +1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.07 1000 " EX-11 MSG + END-IF + + MOVE 10000 TO EX-11 + IF EX-11 = " +10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.08 10000 " EX-11 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-11B * + ****************************************************************** + D DISPLAY "Results for EX-11 when input is an identifier" + D DISPLAY "PIC ++++,+++,++9." + MOVE "PASS" TO MSG-1 + MOVE -10 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -10" + MOVE SPACE TO MSG + D DISPLAY "-10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.09 -10 " EX-11 MSG + END-IF + D DISPLAY "-10 " EX-11 MSG + + MOVE -100 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -100" + MOVE SPACE TO MSG + D DISPLAY "-100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.10 -100 " EX-11 MSG + END-IF + + MOVE -1000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -1,000" + MOVE SPACE TO MSG + D DISPLAY "-1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.11 -1000 " EX-11 MSG + END-IF + + MOVE -10000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " -10,000" + MOVE SPACE TO MSG + D DISPLAY "-10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' -10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.12 -10000 " EX-11 MSG + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +10" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.13 10 " EX-11 MSG + END-IF + + MOVE 100 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +100" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +100'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.14 100 " EX-11 MSG + END-IF + + MOVE 1000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +1,000" + MOVE SPACE TO MSG + D DISPLAY " 1000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +1,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.15 1000 " EX-11 MSG + END-IF + + MOVE 10000 TO identifier-1 + MOVE identifier-1 TO EX-11 + IF EX-11 = " +10,000" + MOVE SPACE TO MSG + D DISPLAY " 10000 " EX-11 MSG + ELSE + MOVE " <---<<< EXPECTING ' +10,000'" TO MSG + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-11.16 10000 " EX-11 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-12 * + ****************************************************************** + D DISPLAY "Results for EX-12 when input is an identifier" + D DISPLAY "PIC 9BB999BB999B9999." + MOVE A-PHONE-NUMBER TO EX-12 + MOVE "(" TO EX-12 (3:1) + MOVE ")" TO EX-12 (7:1) + IF EX-12 EQUAL "1 (512) 800 6789" + MOVE "PASS" TO MSG-1 + D DISPLAY "HURAH, '" EX-12 "' IS WHAT I WANTED." + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-12.01 EXPECTING '1 (512) 800 6789' NOT '" + EX-12 "'" + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-13 * + ****************************************************************** + D DISPLAY "Results for EX-13 when input is an identifier" + D DISPLAY "PIC $$$$$//99//99CR" + MOVE -123456 TO identifier-1 + MOVE identifier-1 TO EX-13 + IF EX-13 EQUAL " $12//34//56CR" + MOVE "PASS" TO MSG-1 + D DISPLAY " $12//34//56CR IS WHAT I EXPECTED" + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-13.01 EXPECTING ==> '$12//34//56CR' <==" + " WHAT I GOT WAS ==>'" + EX-13 "'<==" + END-IF + + MOVE 10 TO identifier-1 + MOVE identifier-1 TO EX-13 + IF EX-13 EQUAL " $//00//10 " + MOVE "PASS" TO MSG-1 + 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 ' " + "WHAT I GOT WAS ==>'" + EX-13 "'<==" + D DISPLAY "------------------" MSG-1 + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + *EX-13-2 * + ****************************************************************** + D DISPLAY "Results for EX-13-2 when input is an identifier" + D DISPLAY "PIC $$$$$/B/90/B/90CR" + MOVE -12345 TO identifier-1 + MOVE identifier-1 TO EX-13-2 + IF EX-13-2 EQUAL " $123/ /40/ /50CR" + MOVE "PASS" TO MSG-1 + D DISPLAY " $123/ /40/ /50CR IS WHAT I EXPECTED" + D DISPLAY "------------------" MSG-1 + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-13-2.1 EXPECTING $123/ /40/ /50CR " + "WHAT I GOT WAS ==>'" + EX-13-2(1:) "'<==" + D DISPLAY "------------------" MSG-1 + END-IF + ****************************************************************** + *EX-14 * + ****************************************************************** + MOVE -123456.7895 TO EX-14. + IF EX-14(1:) EQUAL "-$5,, 0 ,,6.708" + MOVE "PASS" TO MSG-1 + D DISPLAY "EX-14 ==> IS WHAT I EXPECTED '" EX-14(1:) "'" + D DISPLAY "------------------" MSG-1 + ELSE + ADD 1 TO WS-COUNT + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-14 ==> WHAT I EXPECTED '-$5,, 0 ,,6.708'" + DISPLAY "EX-14 ==> WHAT I GOT '" EX-14(1:) "'" + D DISPLAY "------------------" MSG-1 + END-IF + + ****************************************************************** + *EX-15 * + * It does not matter if a + or - amount is moved to this edit, * + * the result will be the same. * + ****************************************************************** + D DISPLAY "Results for EX-15 when input is an identifier" + D DISPLAY "PIC ****,***,***.**." + MOVE "PASS" TO MSG-1 + MOVE -123.45 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*********123.45" + MOVE SPACE TO MSG + D DISPLAY "-123.45 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*********123.45'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.1 -123.45 " EX-15 MSG + END-IF + + MOVE -1234.56 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*******1,234.56" + MOVE SPACE TO MSG + D DISPLAY "-1234.56 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*******1,234.56'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.2 -1234.56 " EX-15 MSG + END-IF + + MOVE -12345.67 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "******12,345.67" + MOVE SPACE TO MSG + D DISPLAY "-12345.67 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '******12,345.67'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.3 -12345.67 " EX-15 MSG + END-IF + + MOVE 10 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "**********10.00" + MOVE SPACE TO MSG + D DISPLAY " 10 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '**********10.00'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.4 10 " EX-15 MSG + END-IF + + MOVE 100 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*********100.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*********100.00'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.5 100 " EX-15 MSG + END-IF + + MOVE 100000000 TO PIC9V99 + MOVE PIC9V99 TO EX-15 + IF EX-15 = "*100,000,000.00" + MOVE SPACE TO MSG + D DISPLAY " 100 " EX-15 MSG + ELSE + ADD 1 TO WS-COUNT + MOVE " <---<<< EXPECTING '*100,000,000.00'" TO MSG + MOVE "FAIL" TO MSG-1 + DISPLAY "EX-15.6 100 " EX-15 MSG + END-IF + D DISPLAY "------------------" MSG-1 + ****************************************************************** + * End of process. Display error total if not zero * + ****************************************************************** + IF WS-COUNT > ZERO + MOVE "TESTS FAILED" TO MSG-1 + DISPLAY "------------------" WS-COUNT SPACE MSG-1(1 : 12) + "------------------" + END-IF + + GOBACK. +]) + +AT_CHECK([$COMPILE -Wno-truncate prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], []) + +AT_CLEANUP + + AT_SETUP([MOVE to item with simple and floating insertion]) AT_KEYWORDS([fundamental edited editing]) @@ -459,6 +2137,9 @@ AT_DATA([prog.cob], [ 01 num-1 PIC -*B*99. 01 num-2 PIC $BB**,***.**. 01 num-3 PIC $BB--,---.--. + 01 num-4 PIC $,$$$,$$9.99CR. + 01 num-5 PIC --,---,--9. + 01 num-packed-1 PIC S9(9)V999 COMP-3. PROCEDURE DIVISION. MOVE -123 TO num-1 @@ -469,6 +2150,39 @@ AT_DATA([prog.cob], [ MOVE 1234.56 TO num-3 DISPLAY ">" num-3 "<" + + MOVE 456789 to num-4 + DISPLAY ">" num-4 "<" + + MOVE -100 to num-5 + DISPLAY ">" num-5 "<" + + MOVE -1000 to num-5 + DISPLAY ">" num-5 "<" + + MOVE -123 TO num-packed-1 + MOVE num-packed-1 TO num-1 + DISPLAY ">" num-1 "<" + + MOVE 1234.56 TO num-packed-1 + MOVE num-packed-1 TO num-2 + DISPLAY ">" num-2 "<" + + MOVE 1234.56 TO num-packed-1 + MOVE num-packed-1 TO num-3 + DISPLAY ">" num-3 "<" + + MOVE 123456789 to num-packed-1 + MOVE num-packed-1 TO num-4 + DISPLAY ">" num-4 "<" + + MOVE -100 to num-packed-1 + MOVE num-packed-1 TO num-5 + DISPLAY ">" num-5 "<" + + MOVE -1000 to num-packed-1 + MOVE num-packed-1 TO num-5 + DISPLAY ">" num-5 "<" . ]) @@ -477,6 +2191,15 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [>-**123< >$ *1,234.56< >$ 1,234.56< +> $456,789.00 < +> -100< +> -1,000< +>-**123< +>$ *1,234.56< +>$ 1,234.56< +> $456,789.00 < +> -100< +> -1,000< ]) AT_CLEANUP @@ -7133,7 +8856,7 @@ AT_DATA([prog.cob], [ *> MOVE -12345 TO SRC-FIELD-100 . MOVE SRC-FIELD-100 TO DST-FIELD-2 . - IF DST-FIELD-2 NOT = 1234005 + IF DST-FIELD-2 NOT = -1234005 DISPLAY '5: DST-FIELD-2 <' DST-FIELD-2 '> != 1234005' . *> MOVE -23456 TO SRC-FIELD-101 . @@ -7175,7 +8898,7 @@ AT_DATA([prog.cob], [ *> MOVE -12345 TO SRC-FIELD-400 . MOVE SRC-FIELD-400 TO DST-FIELD-2 . - IF DST-FIELD-2 NOT = 1234005 + IF DST-FIELD-2 NOT = -1234005 DISPLAY '13: DST-FIELD-2 <' DST-FIELD-2 '> != 1234005' . *> MOVE -23456 TO SRC-FIELD-401 . @@ -7280,7 +9003,7 @@ AT_SETUP([MOVE between USAGEs]) AT_KEYWORDS([fundamental COMP-1 COMP-2 COMP-3 COMP-4 COMP-5 COMP-6 DISPLAY BINARY PACKED-DECIMAL BINARY-C-LONG BINARY-CHAR BINARY-DOUBLE BINARY-INT -BINARY-LONG SIGNED UNSIGNED BINARY-LONG-LONG +BINARY-LONG SIGNED UNSIGNED BINARY-LONG-LONG BINARY-SHORT FLOAT-DECIMAL-16 FLOAT-DECIMAL-34 FLOAT-SHORT SIGNED-INT SIGNED-LONG SIGNED-SHORT UNSIGNED-INT UNSIGNED-LONG UNSIGNED-SHORT]) diff --git a/tests/testsuite.src/run_reportwriter.at b/tests/testsuite.src/run_reportwriter.at index 2ff781a44..78d781e23 100644 --- a/tests/testsuite.src/run_reportwriter.at +++ b/tests/testsuite.src/run_reportwriter.at @@ -1,4 +1,4 @@ -## Copyright (C) 2014-2021 Free Software Foundation, Inc. +## Copyright (C) 2014-2021, 2024 Free Software Foundation, Inc. ## Written by Ron Norman, Simon Sobisch ## ## This file is part of GnuCOBOL. @@ -3792,10 +3792,11 @@ AT_CLEANUP AT_SETUP([Sample Inventory Report]) AT_KEYWORDS([report runfile]) -AT_DATA([inp_data],[01Data Processing 02000500012388 -02Cow Milking 02000600054398 -03Grass Cutting 03000600054397 -03Lawn mowing 03000600054397 +AT_DATA([inp_data], +[01Data Processing 020005000123880 +02Cow Milking 020006000543980 +03Grass Cutting 030006000543970 +03Lawn mowing 030006000543970 ]) AT_DATA([prog.cob], [ From b33a87961f0d11b2d9d371374efae94d97c7b557 Mon Sep 17 00:00:00 2001 From: chaat Date: Fri, 5 Jul 2024 21:16:50 +0000 Subject: [PATCH 2/9] Adjustment to READ PREVIOUS for VBISAM / VISAM fix errors in filio.c when building with VISAM 2.2. This issue occurred when using a partial key with a sequential read previous. fileio.c: (indexed_start_internal), (indexed_start) and (indexed_read_next): added a new field, partial_key_length, to the indexfile structure for use in these functions. This will allow the saved partial key to be used in the positioning logic. --- libcob/ChangeLog | 13 +++ libcob/fileio.c | 150 ++++++++++++++++++-------------- tests/testsuite.src/run_file.at | 2 +- 3 files changed, 99 insertions(+), 66 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index aff94ae59..82a0a90e9 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,17 @@ +2024-05-30 Chuck Haatvedt + + fix errors in filio.c when building with VISAM 2.2. This issue + occurred when using a partial key with a sequential read previous. + + * fileio.c (indexed_start_internal), (indexed_start) + and (indexed_read_next): added a new field, partial_key_length, + to the indexfile structure for use in these functions. + This will allow the saved partial key to be used in the + positioning logic. + Also the BDB logic was changed to return a status code of "35" + when encountering a missing directory for OUTPUT on INDEXED file. + 2024-05-30 Chuck Haatvedt fix errors in cob_move_display_to_edited and simplify the code diff --git a/libcob/fileio.c b/libcob/fileio.c index ec8dcb88e..870a4de42 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -1,21 +1,21 @@ /* - Copyright (C) 2002-2012, 2014-2024 Free Software Foundation, Inc. - Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman + Copyright (C) 2002-2012, 2014-2024 Free Software Foundation, Inc. + Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman - This file is part of GnuCOBOL. + This file is part of GnuCOBOL. - The GnuCOBOL runtime library is free software: you can redistribute it - and/or modify it under the terms of the GNU Lesser General Public License - as published by the Free Software Foundation, either version 3 of the - License, or (at your option) any later version. + The GnuCOBOL runtime library is free software: you can redistribute it + and/or modify it under the terms of the GNU Lesser General Public License + as published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. - GnuCOBOL is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + GnuCOBOL is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License - along with GnuCOBOL. If not, see . + You should have received a copy of the GNU Lesser General Public License + along with GnuCOBOL. If not, see . */ @@ -185,6 +185,7 @@ struct indexfile { int readdone; /* A 'read' has been successfully done */ int startiscur; /* The 'start' record is current */ int wrkhasrec; /* 'recwrk' holds the next|prev record */ + int partial_key_length; /* new field for partial key on START verb */ struct keydesc key[1]; /* Table of key information */ /* keydesc is defined in (d|c|vb)isam.h */ }; @@ -202,7 +203,7 @@ indexed_keylen (const struct keydesc *key) } /* Save key for given index into 'savekey' - Return total length of the key */ + Return total length of the key */ static int indexed_savekey (struct indexfile *fh, unsigned char *data, int idx) { @@ -221,7 +222,7 @@ indexed_savekey (struct indexfile *fh, unsigned char *data, int idx) } /* Copy key for given index from 'savekey' back to recwrk - Return total length of the key */ + Return total length of the key */ static int indexed_restorekey (struct indexfile *fh, unsigned char *data, int idx) { @@ -240,7 +241,7 @@ indexed_restorekey (struct indexfile *fh, unsigned char *data, int idx) } /* Compare key for given index 'savekey' to recwrk - Return compare status */ + Return compare status */ static int indexed_cmpkey (struct indexfile *fh, unsigned char *data, int idx, int partlen) { @@ -264,7 +265,7 @@ indexed_cmpkey (struct indexfile *fh, unsigned char *data, int idx, int partlen) } /* Build 'keydesc' from 'cob_file_key' - Return total length of the key */ + Return total length of the key */ static int indexed_keydesc (cob_file *f, struct keydesc *kd, cob_file_key *key) { @@ -328,7 +329,7 @@ indexed_keydesc (cob_file *f, struct keydesc *kd, cob_file_key *key) } /* Compare 'keydesc' to 'keydesc' - Return 0 if equal, else 1 */ + Return 0 if equal, else 1 */ static int indexed_keycmp (struct keydesc *k1, struct keydesc *k2) { @@ -726,7 +727,7 @@ struct indexed_file { }; /* collation aware key comparision, - currently only used for BDB, likely used in general later */ + currently only used for BDB, likely used in general later */ static int indexed_key_compare (const unsigned char *k1, const unsigned char *k2, size_t sz, const unsigned char *col) @@ -757,7 +758,7 @@ bdb_keylen (cob_file *f, int idx) } /* Save key for given index from 'record' into 'keyarea', - returns total length of the key */ + returns total length of the key */ static int bdb_savekey (cob_file *f, unsigned char *keyarea, unsigned char *record, int idx) { @@ -798,7 +799,7 @@ bdb_setkey (cob_file *f, int idx) } /* Compare key for given index 'keyarea' to 'record'. - returns compare status */ + returns compare status */ static int bdb_cmpkey (cob_file *f, unsigned char *keyarea, unsigned char *record, int idx, int partlen) { @@ -834,7 +835,7 @@ bdb_cmpkey (cob_file *f, unsigned char *keyarea, unsigned char *record, int idx, } /* Is given key data all SUPPRESS char, - returns 1 if key has all SUPPRESS char */ + returns 1 if key has all SUPPRESS char */ static int bdb_suppresskey (cob_file *f, int idx) { @@ -914,7 +915,7 @@ bdb_close_index (cob_file *f, int index) static int bdb_bt_compare (DB *db, const DBT *k1, const DBT *k2 #if DB_VERSION_MAJOR >= 6 /* ABI break in DB_VERSION_FAMILY 12 ... */ - , size_t *locp + , size_t *locp #endif ) { @@ -980,9 +981,9 @@ dummy_start (cob_file *f, const int cond, cob_field *key) } /* Check for DD_xx, dd_xx, xx environment variables for a filename - or a part specified with 'src'; - returns either the value or NULL if not found in the environment - Note: MF only checks for xx if the variable started with a $, + or a part specified with 'src'; + returns either the value or NULL if not found in the environment + Note: MF only checks for xx if the variable started with a $, ACUCOBOL only checks for xx in general ... */ static char * cob_chk_file_env (const char *src) @@ -1096,7 +1097,7 @@ looks_absolute (char *src) } /* checks for special ACUCOBOL-case: file that start with hyphen [note: -P not supported] - no translation at all, name starts after first non-space */ + no translation at all, name starts after first non-space */ static int has_acu_hyphen (char *src) { @@ -1436,7 +1437,7 @@ save_status (cob_file *f, cob_field *fnstatus, const int status) cobglobptr->cob_exception_code = 0; } else { #if 0 /* correct thing to do, but then also needs to have codegen adjusted - --> module-incompatibility --> 4.x */ + --> module-incompatibility --> 4.x */ cob_set_exception (eop_status); #else cob_set_exception (COB_EC_I_O_EOP); @@ -1459,7 +1460,7 @@ save_status (cob_file *f, cob_field *fnstatus, const int status) /* Regular file */ /* Translate errno status to COBOL status, - Note: always sets either an error or the given default value */ + Note: always sets either an error or the given default value */ static int errno_cob_sts (const int default_status) { @@ -2204,7 +2205,7 @@ open_next (cob_file *f) int fmode = O_BINARY; /* without this ftell does not work on some systems */ #ifdef _WIN32 /* win32 seems to resolve the file descriptor from the file handler - on fclose - and then aborts because it was closed directly before */ + on fclose - and then aborts because it was closed directly before */ if (f->file) { fclose (f->file); } else { @@ -2262,8 +2263,8 @@ open_next (cob_file *f) /* Read record size into f->record->size - returns -1 if no data was read, zero for success and - and an io status otherwise */ + returns -1 if no data was read, zero for success and + and an io status otherwise */ static int set_sequential_variable_length (cob_file *f) { int bytesread; @@ -2628,7 +2629,7 @@ lineseq_read (cob_file *f, const int read_opts) } } #if 0 /* From trunk - CHECKME: When should this be done? - Only for LS_VALIDATE / LS_NULLS? */ + Only for LS_VALIDATE / LS_NULLS? */ /* Skip NEW PAGE on reading */ if (n == '\f') { continue; @@ -3750,7 +3751,7 @@ get_dupno (cob_file *f, const cob_u32_t i) } /* read file with all alternate keys that don't allow duplicates - to check if records exist already, returns 1 if true */ + to check if records exist already, returns 1 if true */ static int check_alt_keys (cob_file *f, const int rewrite) { @@ -4707,13 +4708,14 @@ indexed_open (cob_file *f, char *filename, case DB_LOCK_NOTGRANTED: return COB_STATUS_61_FILE_SHARING; case ENOENT: + case ENOTDIR: if (mode == COB_OPEN_EXTEND || mode == COB_OPEN_OUTPUT) { - return COB_STATUS_30_PERMANENT_ERROR; + return COB_STATUS_35_NOT_EXISTS; } if (f->flag_optional) { if (mode == COB_OPEN_I_O) { - return COB_STATUS_30_PERMANENT_ERROR; + return COB_STATUS_35_NOT_EXISTS; } f->open_mode = mode; f->flag_nonexistent = 1; @@ -4905,6 +4907,24 @@ indexed_start (cob_file *f, const int cond, cob_field *key) return COB_STATUS_23_KEY_NOT_EXISTS; } k = cob_findkey_attr (f, key, &fullkeylen, &partlen); + + /************************************************************/ + /* */ + /* here we are storing the partial key length in the */ + /* indexfile structure so that the indexed read next */ + /* functions can position the file based on the partial */ + /* key length. */ + /* */ + /* note the indexed_cmpkey function expects a partial key */ + /* length of zero if it is to use the full key length. */ + /* */ + /************************************************************/ + + if (fullkeylen == partlen) + fh->partial_key_length = 0; + else + fh->partial_key_length = partlen; + if (k < 0) { return COB_STATUS_23_KEY_NOT_EXISTS; } @@ -5198,7 +5218,7 @@ indexed_read_next (cob_file *f, const int read_opts) case COB_GE: domoveback = 0; while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) == 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) == 0) { isread (fh->isfd, (void *)f->record->data, ISPREV); domoveback = 1; } @@ -5209,7 +5229,7 @@ indexed_read_next (cob_file *f, const int read_opts) case COB_LE: domoveback = 0; while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) == 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) == 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); domoveback = 1; } @@ -5222,13 +5242,13 @@ indexed_read_next (cob_file *f, const int read_opts) isread (fh->isfd, (void *)f->record->data, ISPREV); #endif while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) >= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) >= 0) { isread (fh->isfd, (void *)f->record->data, ISPREV); } break; case COB_GT: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) <= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) <= 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); } break; @@ -5278,12 +5298,12 @@ indexed_read_next (cob_file *f, const int read_opts) } else { switch (fh->startcond) { case COB_LE: - if (indexed_cmpkey (fh, f->record->data, f->curkey, 0) > 0) + if(indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) > 0) domoveback = 1; else domoveback = 0; while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) == 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) == 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); domoveback = 1; } @@ -5293,19 +5313,19 @@ indexed_read_next (cob_file *f, const int read_opts) break; case COB_LT: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) >= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) >= 0) { isread (fh->isfd, (void *)f->record->data, ISPREV); } break; case COB_GT: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) <= 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) <= 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); } break; case COB_GE: while (ISERRNO == 0 - && indexed_cmpkey (fh, f->record->data, f->curkey, 0) < 0) { + && indexed_cmpkey(fh, f->record->data, f->curkey, fh->partial_key_length) < 0) { isread (fh->isfd, (void *)f->record->data, ISNEXT); } break; @@ -7006,7 +7026,7 @@ cob_delete_file (cob_file *f, cob_field *fnstatus) } /* Return index number for given key and set length attributes, - storing resulting key field in file's last_key */ + storing resulting key field in file's last_key */ int cob_findkey (cob_file *f, cob_field *kf, int *fullkeylen, int *partlen) { @@ -7044,7 +7064,7 @@ cob_savekey (cob_file *f, int idx, unsigned char *data) /* System routines */ /* stores the field's rtrimmed string content into a fresh allocated - string, which later needs to be passed to cob_free */ + string, which later needs to be passed to cob_free */ static void * cob_str_from_fld (const cob_field *f) { @@ -7311,7 +7331,7 @@ cob_sys_close_file (unsigned char *file_handle) } /* entry point and processing for library routine CBL_FLUSH_FILE - (flush bytestream file handle, got from CBL_OPEN_FILE) */ + (flush bytestream file handle, got from CBL_OPEN_FILE) */ int cob_sys_flush_file (unsigned char *file_handle) { @@ -7353,7 +7373,7 @@ cob_sys_delete_file (unsigned char *file_name) } /* entry point and processing for library routine CBL_COPY_FILE, - does a direct read + write of the complete file */ + does a direct read + write of the complete file */ int cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) { @@ -8389,7 +8409,7 @@ cob_file_sort_using (cob_file *sort_file, cob_file *data_file) } /* SORT/MERGE: add all records from GIVING file 'data_file' to 'sort_file', - with optional external file handler 'callfh' */ + with optional external file handler 'callfh' */ void cob_file_sort_using_extfh (cob_file *sort_file, cob_file *data_file, int (*callfh)(unsigned char *opcode, FCD3 *fcd)) @@ -8439,7 +8459,7 @@ cob_file_sort_using_extfh (cob_file *sort_file, cob_file *data_file, /* SORT/MERGE: WRITE all records from 'sort_file' to all USING files 'fbase', - with using their optional external file handlers 'callfh' */ + with using their optional external file handlers 'callfh' */ static void cob_file_sort_giving_internal (cob_file *sort_file, const size_t giving_cnt, cob_file **fbase, int (**callfh)(unsigned char *opcode, FCD3 *fcd)) @@ -8588,7 +8608,7 @@ cob_file_sort_giving (cob_file *sort_file, const size_t varcnt, ...) } /* SORT: WRITE all records from 'sort_file' to all passed USING files, - with using their optional external file handlers */ + with using their optional external file handlers */ void cob_file_sort_giving_extfh (cob_file *sort_file, const size_t varcnt, ...) { @@ -8610,7 +8630,7 @@ cob_file_sort_giving_extfh (cob_file *sort_file, const size_t varcnt, ...) } /* SORT: close of internal sort file 'f' and deallocation - of temporary storage */ + of temporary storage */ void cob_file_sort_close (cob_file *f) { @@ -8725,8 +8745,8 @@ cob_get_filename_print (cob_file* file, const int show_resolved_name) } /* Initialization/Termination - cobsetpr-values with type ENV_PATH or ENV_STR - like bdb_home and cob_file_path are taken care in cob_exit_common()! + cobsetpr-values with type ENV_PATH or ENV_STR + like bdb_home and cob_file_path are taken care in cob_exit_common()! */ const char *implicit_close_of_msgid = NULL; @@ -9535,7 +9555,7 @@ free_fcd2 (FCD2 *fcd2) } /* Convert FCD2 into FCD3 format, note: explicit no checks here - as those have to be in EXTFH3 / fileio later */ + as those have to be in EXTFH3 / fileio later */ static FCD3 * fcd2_to_fcd3 (FCD2 *fcd2) { @@ -10042,7 +10062,7 @@ cob_extfh_delete ( } /* COBOL wrapper for EXTFH call to prevent warnings about FCD3 structure - with additional checks */ + with additional checks */ int cob_sys_extfh (const void *opcode_ptr, void *fcd_ptr) { @@ -10421,8 +10441,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) STCOMPX4(f->record_max,fcd->curRecLen); update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); @@ -10439,8 +10459,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) } update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); @@ -10458,8 +10478,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) } update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); @@ -10475,8 +10495,8 @@ EXTFH3 (unsigned char *opcode, FCD3 *fcd) } update_file_to_fcd (f, fcd, fnstatus); #if 0 /* Simon: general mapping needed, depending - on a compile time switch (also for other dialects) - --> no "single place extension" here */ + on a compile time switch (also for other dialects) + --> no "single place extension" here */ if (f->organization == COB_ORG_INDEXED && memcmp (f->file_status, "61", 2) == 0) {/* 61 --> 9A for MF */ memcpy (fcd->fileStatus,"9A", 2); diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index ae8dc8e43..2fc93cadf 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -580,7 +580,7 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION. * OPEN OUTPUT FILE0 - IF WSFS NOT = "30" + IF WSFS NOT = "35" DISPLAY "STATUS OPENO " WSFS. * STOP RUN. From 026a651ee4063b380eaccc07f54aa585d5c86924 Mon Sep 17 00:00:00 2001 From: chaat Date: Sat, 6 Jul 2024 02:55:58 +0000 Subject: [PATCH 3/9] Fix errors caught by the Sanitizer functionality of GCC. fix errors caught by the Sanitizer functionality of GCC. This change did not resolve all of the issues found as some of them were in Berkeley DB and some were intentional in the memory corruption logic which has been implemented in the runtime. libcob: * move.c: (cob_move_display_to_packed) function was rewritten to fix the out of bounds memory addressing issues and also to make the code simpler. * numeric.c (count_leading_zeros) was changed to fix an out of bounds memory addressing issue --- libcob/ChangeLog | 13 +++ libcob/move.c | 245 ++++++++++++++++++++++++++++++++--------------- libcob/numeric.c | 8 +- 3 files changed, 188 insertions(+), 78 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 82a0a90e9..516ea2978 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,17 @@ +2024-05-30 Chuck Haatvedt + + fix errors caught by the Sanitizer functionality of GCC. This + change did not resolve all of the issues found as some of them + were in Berkeley DB and some were intentional in the memory + corruption logic which has been implemented in the runtime. + + * move.c (the cob_move_display_to_packed function was rewritten to + fix the out of bounds memory addressing issues and also to make + the code simpler. + * numeric.c (the function count_leading_zeros was changed to fix + an out of bounds memory addressing issue + 2024-05-30 Chuck Haatvedt fix errors in filio.c when building with VISAM 2.2. This issue diff --git a/libcob/move.c b/libcob/move.c index 8aa342ece..c60f08422 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -474,106 +474,199 @@ cob_move_alphanum_to_alphanum (cob_field *f1, cob_field *f2) void cob_move_display_to_packed (cob_field *f1, cob_field *f2) { - unsigned char *data1 = COB_FIELD_DATA (f1); + + /************************************************************/ + /* */ + /* The logic used by this function is to find the offset */ + /* from the decimal point for first position in both the */ + /* sending and receiving fields. Note that NO special */ + /* logic is required to handle the presence of a "p" in */ + /* the PICTURE clause. */ + /* */ + /* Once the offsets are found we can use the difference */ + /* in the offsets to position the pointers in each of the */ + /* fields. */ + /* */ + /* If the offsets are the same then we can start packing */ + /* starting at the beginning of both fields. */ + /* */ + /* If the offset of the sending field is greater than */ + /* that of the receiving field then we need to adjust the */ + /* position of the sending field point to the right by */ + /* the difference in the offsets. */ + /* */ + /* If the offset of the receiving field is greater than */ + /* that of the sending field then the logic is a bit more */ + /* complicated in that each time thru the packing loop we */ + /* pack TWO DIGITS. So we divide the offset by 2 to */ + /* adjust the position of the pointer to the packed field */ + /* to the correct byte where the digit will be placed. */ + /* Also we need to determine if the first digit to be */ + /* packed will go into the HIGH ORDER nibble or the LOW */ + /* ORDER nibble. If the difference in the offsets is ODD, */ + /* then the first digit will need to go into the LOW */ + /* ORDER nibble, so we set a switch for that. */ + /* */ + /* Before starting the packing loop we need to check if */ + /* the first digit has to go into the LOW ORDER nibble, */ + /* if so we need to do that first. */ + /* */ + /* Also after completing the packing loop, we need to */ + /* check if there is a digit left to be packed, if so we */ + /* need to put it into the HIGH ORDER nibble of the next */ + /* location in the receiving field. */ + /* */ + /* Then we need to clear the PAD nibble if present and */ + /* set the sign nibble if the receiving field is signed. */ + /* */ + /************************************************************/ + const int sign = COB_GET_SIGN_ADJUST (f1); const short scale1 = COB_FIELD_SCALE (f1); const short scale2 = COB_FIELD_SCALE (f2); const int target_no_sign_nibble = COB_FIELD_NO_SIGN_NIBBLE (f2); - unsigned short digits1; - unsigned short digits2; - register unsigned int i; - - register unsigned char *p; - - /* 99P -> 3 digits, scale -1 --> real digits are less */ - if (scale1 >= 0) { - digits1 = COB_FIELD_DIGITS (f1); - } else { - digits1 = COB_FIELD_DIGITS (f1) + scale1; - } - if (scale2 >= 0) { - digits2 = COB_FIELD_DIGITS (f2); - } else { - digits2 = COB_FIELD_DIGITS (f2) + scale2; - } - - if (target_no_sign_nibble) { - i = digits2 % 2; - } else { - i = 1 - digits2 % 2; - } - - /* note: the overhead of checking for leading ZERO and zero-like data - is higher than just setting it below - so not done here */ - - /* skip not available positions */ - p = data1 + (digits1 - scale1) - (digits2 - scale2); - while (p < data1) { - p++; i++; /* note: both p and i are about digits */ - } - + unsigned int f1_digits, f2_digits; + unsigned int start_in_low_nibble = 0; + int f1_offset, f2_offset; + + register unsigned char *p, *p_end, *q, *q_end; + + + /************************************************************/ + /* */ + /* Note that when calculating the offsets of the first */ + /* position in each field we need to use the number of */ + /* digits in the actual data field not the number of */ + /* digits returned by the COB_FIELD_DIGITS function. */ + /* */ + /* Note that this logic works whether or not there is a */ + /* "P" any where in the PICTURE clause. */ + /* */ + /************************************************************/ + + if (COB_FIELD_SIGN_SEPARATE (f1)) + f1_digits = f1->size - 1; + else + f1_digits = f1->size; + + p = COB_FIELD_DATA (f1); + p_end = p + f1_digits - 1; + + f1_offset = f1_digits - scale1 - 1; + + + if (target_no_sign_nibble) + f2_digits = f2->size << 1; + else + f2_digits = (f2->size << 1) - 1; + + q = f2->data; + q_end = q + f2->size - 1; + + f2_offset = f2_digits - scale2 - 1; + + /************************************************************/ + /* */ + /* if the packed field has a sign nibble then the offset */ + /* has to be one greater than the number of digits in */ + /* both fields since the offset is the position in */ + /* the receiving field */ + /* */ + /************************************************************/ + + /************************************************************/ + /* */ + /* At this point we are ready to position the pointers to */ + /* the sending and receiving fields. Note that if the */ + /* offsets are equal then no positioning is needed and we */ + /* can just start packing data */ + /* */ /* zero out target, then transfer data */ + /* */ + /************************************************************/ + memset (f2->data, 0, f2->size); + + if (f1_offset > f2_offset) + p = p + (f1_offset - f2_offset); + else if (f1_offset < f2_offset) { - register unsigned char *q = f2->data + i / 2; - const unsigned int i_end = (unsigned int)f2->size; /* a packed field always has small size */ - /* FIXME: get rid of that, adjust i_end to handle both truncation of the source to the right - and zero-fill because of scale differences (zero-fill wa s already done) */ - const unsigned char *p_end = data1 + digits1; - - if (i % 2 == 1) { - *q++ = COB_D2I (*p++); - i++; - } - - /* note: from this point on the variable "i" represents the target bytes, - not the digits any more (therefore we divide by 2) */ - i = i / 2; - - /* note: for performance reasons we write "full bytes" only, this means that for COMP-3 - we'll read 1 byte "too much = after" from the DISPLAY data; - it is believed that this won't raise a SIGBUS anywhere, but we will need to "clean" - the half-byte before setting the sign */ - - /* check for necessary loop (until we not need the p_end check) */ - if (i_end - i < (unsigned int)(p_end - p + 1) / 2) { - while (i < i_end) { - *q = ((*p << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ - + COB_D2I (*(p + 1)); + /************************************************************/ + /* if the difference in offsets is odd then the first */ + /* digit will need to pack into the low order nibble */ + /* otherwise it can start packing into the high order */ + /* nibble */ + /************************************************************/ + if ((f2_offset - f1_offset) & 1) + start_in_low_nibble = 1; + q = q + ((f2_offset - f1_offset ) >> 1); + } + + /************************************************************/ + /* */ + /* Now both pointers have been set to start the packing */ + /* of digits. Note that first we have to check to see if */ + /* the first digit to be packed has to be positioned in */ + /* the lower order nibble before we can start the packing */ + /* loop */ + /* */ + /************************************************************/ + + if (start_in_low_nibble && (p <= p_end) && (q <= q_end)) + { + *q = (*p) & 0x0F; q++; - i++; - p += 2; + p++; } - } else { - while (p < p_end) { - *q = ((*p << 4) & 0xFF) /* -> dropping the higher bits = no use in COB_D2I */ + + /************************************************************/ + /* */ + /* Now we can start the packing loop !! */ + /* */ + /* Note that we exit when the display pointer NOT LESS */ + /* than the last digit in the sending field. */ + /* */ + /************************************************************/ + + while ((p < p_end) && (q <= q_end)) + { + *q = (unsigned char) (*p << 4) /* -> dropping the higher bits = no use in COB_D2I */ + COB_D2I (*(p + 1)); + p = p + 2; q++; - p += 2; - } - } - /* clean bottom nibble if we packed one extra digit past the end of the input */ - if (p > p_end) { - *(q - 1) &= 0xf0; } + + /************************************************************/ + /* */ + /* Now we need to check if there is 1 digit left to pack */ + /* */ + /************************************************************/ + + if ((p == p_end) && (q <= q_end)) + { + *q = (unsigned char) (*p << 4) & 0xF0; } COB_PUT_SIGN_ADJUSTED (f1, sign); + if (COB_FIELD_DIGITS(f2) < f2_digits) + { + *(f2->data) &= 0x0f; + } + if (target_no_sign_nibble) { return; } - /* note: for zero-fill like MOVE 2.1 TO C3-9v9999 we only go to the second position and - therefore have to set 'p' to the most-right place in the target field*/ - p = f2->data + f2->size - 1; if (!COB_FIELD_HAVE_SIGN (f2)) { - *p |= 0x0F; + *q_end |= 0x0F; } else if (sign < 0) { - *p = (*p & 0xF0) | 0x0D; + *q_end = (*q_end & 0xF0) | 0x0D; } else { - *p = (*p & 0xF0) | 0x0C; + *q_end = (*q_end & 0xF0) | 0x0C; } + + return; } void diff --git a/libcob/numeric.c b/libcob/numeric.c index 0f4b0dfc9..b1cd169d0 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -2683,7 +2683,7 @@ cob_move_bcd (cob_field *f1, cob_field *f2) } } else { memcpy (fld2, fld1 + fld1_size - llen, llen); - if (fld1_sign) { + if (fld1_sign && llen) { *(fld2 + llen - 1) &= 0xF0; } } @@ -2919,7 +2919,11 @@ static COB_INLINE COB_A_INLINE int count_leading_zeros (unsigned char *ptr_char, int len) { int cntr = 0; - while (*ptr_char++ == 0x00 && cntr++ < len); + while (cntr < len && *ptr_char == 0x00) + { + cntr++; + ptr_char++; + } return cntr; } From d33f2ec97d726b9578cf5ef55f8acd89ec64e777 Mon Sep 17 00:00:00 2001 From: chaat Date: Sat, 6 Jul 2024 03:24:19 +0000 Subject: [PATCH 4/9] Added two new functions CBL_GC_SCR_DUMP and CBL_GC_SCR_RESTORE Added new functions to allow CURSES to dump and restore the screen. * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) added new functions * common.h added exports for the two new functions * system.def: added as system library call CBL_GC_SCR_DUMP, CBL_GC_SCR_RESTORE --- libcob/ChangeLog | 7 +++++++ libcob/common.h | 2 ++ libcob/screenio.c | 42 ++++++++++++++++++++++++++++++++++++++++++ libcob/system.def | 2 ++ 4 files changed, 53 insertions(+) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 516ea2978..4a27e4214 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,11 @@ +2024-06-10 Chuck Haatvedt + + * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) added new functions + * common.h added exports for the two new functions + * system.def: added as system library call CBL_GC_SCR_DUMP, + CBL_GC_SCR_RESTORE + 2024-05-30 Chuck Haatvedt fix errors caught by the Sanitizer functionality of GCC. This diff --git a/libcob/common.h b/libcob/common.h index eb7ed2e88..b24458ac8 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -2174,6 +2174,8 @@ COB_EXPIMP int cob_sys_clear_screen (void); COB_EXPIMP int cob_sys_sound_bell (void); COB_EXPIMP int cob_sys_get_scr_size (unsigned char *, unsigned char *); COB_EXPIMP int cob_sys_set_scr_size (unsigned char *, unsigned char *); +COB_EXPIMP int cob_sys_scr_dump (unsigned char *); +COB_EXPIMP int cob_sys_scr_restore (unsigned char *); COB_EXPIMP int cob_sys_get_char (unsigned char *); COB_EXPIMP int cob_get_text (char *, int); COB_EXPIMP int cob_get_scr_cols (void); diff --git a/libcob/screenio.c b/libcob/screenio.c index 8f743bbd8..e3e519f8d 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -4917,6 +4917,48 @@ cob_sys_set_scr_size (unsigned char *line, unsigned char *col) #endif } + /* save the current stdscr screen to a file */ +int +cob_sys_scr_dump(unsigned char *parm) +{ + const char *filename = cob_get_param_str_buffered (1); + FILE *filep; + + if (filename && (filep = fopen(filename, "wb")) != NULL) + { + refresh(); + int result = putwin(stdscr, filep); + fclose(filep); + return result; + } + + return ERR; +} + + + /* restore the current stdscr screen from a file */ +int cob_sys_scr_restore(unsigned char *parm) +{ + const char *filename = cob_get_param_str_buffered (1); + FILE *filep; + + if (filename && (filep = fopen(filename, "rb")) != NULL) + { + WINDOW *replacement = getwin(filep); + fclose(filep); + + if (replacement) + { + int result = overwrite(replacement, stdscr); + refresh(); + delwin(replacement); + return result; + } + } + + return ERR; +} + int cob_get_scr_cols (void) { diff --git a/libcob/system.def b/libcob/system.def index 201f7e676..969dd2b78 100644 --- a/libcob/system.def +++ b/libcob/system.def @@ -42,6 +42,8 @@ COB_SYSTEM_GEN ("CBL_FLUSH_FILE", 1, 1, cob_sys_flush_file) COB_SYSTEM_GEN ("CBL_GET_CSR_POS", 1, 1, cob_sys_get_csr_pos) COB_SYSTEM_GEN ("CBL_GET_CURRENT_DIR", 3, 3, cob_sys_get_current_dir) COB_SYSTEM_GEN ("CBL_GET_SCR_SIZE", 2, 2, cob_sys_get_scr_size) +COB_SYSTEM_GEN ("CBL_GC_SCR_DUMP", 1, 1, cob_sys_scr_dump) +COB_SYSTEM_GEN ("CBL_GC_SCR_RESTORE", 1, 1, cob_sys_scr_restore) COB_SYSTEM_GEN ("CBL_IMP", 3, 3, cob_sys_imp) COB_SYSTEM_GEN ("CBL_NIMP", 3, 3, cob_sys_nimp) COB_SYSTEM_GEN ("CBL_NOR", 3, 3, cob_sys_nor) From e51b091b99211fc8a99f446156e90b4fdf9754c2 Mon Sep 17 00:00:00 2001 From: chaat Date: Sat, 6 Jul 2024 03:54:15 +0000 Subject: [PATCH 5/9] Fix for bug 934 - default ROUNDED option Fixed rounding when ROUNDED phrase is present on an ADD or SUBTRACT * numeric.c (cob_add_bcd) fixed check for default ROUNDED option to resolve bug 934 --- libcob/ChangeLog | 5 ++++ libcob/numeric.c | 2 +- tests/testsuite.src/data_packed.at | 39 ++++++++++++++++++++++++++++++ 3 files changed, 45 insertions(+), 1 deletion(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 4a27e4214..227d5c360 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2024-07-02 Chuck Haatvedt + + * numeric.c (cob_add_bcd) fixed check for default ROUNDED option + to resolve bug 934 + 2024-06-10 Chuck Haatvedt * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) added new functions diff --git a/libcob/numeric.c b/libcob/numeric.c index b1cd169d0..fe1425429 100644 --- a/libcob/numeric.c +++ b/libcob/numeric.c @@ -3088,7 +3088,7 @@ cob_add_bcd (cob_field *fdst, if ((used_original_scale <= dst_scale) || (used_scale < dest_scale) || (opt & COB_STORE_TRUNCATION) - || !(opt & ~COB_STORE_MASK)) { + || !(opt & (~COB_STORE_MASK | COB_STORE_ROUND))) { check_rounding = 0; check_all_zeros = 0; all_zeros = 0; diff --git a/tests/testsuite.src/data_packed.at b/tests/testsuite.src/data_packed.at index 2c8f3e415..9ebc95d4e 100644 --- a/tests/testsuite.src/data_packed.at +++ b/tests/testsuite.src/data_packed.at @@ -28743,6 +28743,45 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) AT_CLEANUP +AT_SETUP([BCD ADD and SUBTRACT, DEFAULT ROUNDING MODE]) +AT_KEYWORDS([fundamental arithmetic PACKED-DECIMAL ROUNDED]) + +# This test was created to test the default rounding mode + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. GAG1. + * + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SOURCE-COMPUTER. VAX-11. + OBJECT-COMPUTER. VAX-11. + SPECIAL-NAMES. + * DECIMAL-POINT IS COMMA. + * + DATA DIVISION. + WORKING-STORAGE SECTION. + 1 TOTO. + 2 RESULT PIC S9(13)V9(2) COMP-3. + 2 RESULT-5 PIC S9(13)V9(5) COMP-3. + + PROCEDURE DIVISION. + DEBUT. + MOVE 3.14659 TO RESULT-5. + MOVE ZERO TO RESULT. + ADD RESULT-5 TO RESULT ROUNDED. + IF RESULT NOT EQUAL 3.15 + DISPLAY "RESULT " RESULT. + GOBACK. +]) + + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + AT_SETUP([BCD ADD and SUBTRACT, all ROUNDED MODEs]) AT_KEYWORDS([fundamental arithmetic SUBTRACT MODE COMP-3 COMP-6 PACKED-DECIMAL AWAY-FROM-ZERO NEAREST-AWAY-FROM-ZERO From 435454f8df3808669bfe75ea985446c409877a53 Mon Sep 17 00:00:00 2001 From: chaat Date: Wed, 10 Jul 2024 17:27:40 +0000 Subject: [PATCH 6/9] Adjustment for move to edited numeric Fix errors in optimized_move_display_to_edited introduced with change at R5285. Also fixed cb_build_picture to calculate the scale correctly. libcob: * move.c (optimized_move_display_to_edited): fixed errors (indirect_move): fixed calculation scale of intermediate field cobc: * tree.c (cb_build_picture): fixed currency scale counting logic --- cobc/ChangeLog | 4 ++ cobc/tree.c | 7 +++ libcob/ChangeLog | 13 ++++- libcob/move.c | 134 ++++++++++++++++++++++++++++++++++++++--------- 4 files changed, 132 insertions(+), 26 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 404956b17..50fbd7507 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,8 @@ +2024-07-10 Chuck Haatvedt + + * tree.c (cb_build_picture): fixed currency scale counting logic + 2024-06-19 David Declerck * cobc.c (process_compile): fix MSVC build command diff --git a/cobc/tree.c b/cobc/tree.c index 0fab97a3c..c4df8cdf0 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -3800,6 +3800,13 @@ cb_build_picture (const char *str) } else { digits += n; } + if (v_count) { + if (c_count == 0) { + scale += n - 1; + } else { + scale += n; + } + } c_count += n; break; } diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 227d5c360..a577f46c3 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,15 @@ +2024-07-10 Chuck Haatvedt + + fix errors in cob_optimized_move_display_to_edited introduced + with changes at revision R5285. The errors showed up in the + NIST tests in group NC. + + * move.c (optimized_move_display_to_edited): fixed bugs + (indirect_move): fixed bug when calculating scale of + the intermediate cob field + + 2024-07-02 Chuck Haatvedt * numeric.c (cob_add_bcd) fixed check for default ROUNDED option @@ -46,7 +57,7 @@ match the attributes of the target edited field instead of the sending field. - * move.c (cob_optimized_move_display_to_edited): added new function + * move.c (optimized_move_display_to_edited): added new function (cob_move): when move numeric-display to numeric-edited added logic to check if an indirect move is needed (indirect_move): when the destination field is numeric-edited and diff --git a/libcob/move.c b/libcob/move.c index c60f08422..c6b92dfd5 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -1009,9 +1009,15 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) int neg = 0; int is_zero = 1; 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; unsigned char pad = ' '; unsigned char c; + unsigned char float_char = 0x00; const unsigned char dec_symbol = COB_MODULE_PTR->decimal_point == ',' ? ',' : '.'; const unsigned char currency = COB_MODULE_PTR->currency_symbol; @@ -1028,6 +1034,50 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) } #endif + + /************************************************************/ + /* Currently this will require two passes of the symbol */ + /* table to find the float char.... */ + /* */ + /* this logic to find the floating char if one exits */ + /* should be moved to COBC in GC40. This would require */ + /* some structure changes so for now it is needed here. */ + /************************************************************/ + + c = 0x00; + + 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 == currency) { + cntr_currency += n; + if (cntr_currency > 1) break; + } + } + + switch (c) { + case '-' : float_char = c; break; + case '+' : float_char = c; break; + case '*' : pad = c; break; + default: + if (c == currency) { + float_char = c; + break; + } + } + /* first check for BLANK WHEN ZERO attribute */ if (COB_FIELD_BLANK_ZERO(f2)) { for(; (src <= src_end) ; src++) { @@ -1066,13 +1116,26 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) break; case 'Z': + *dst = *src; + pad = ' '; + if (*src != '0') { + is_zero = suppress_zero = 0; + } else { + if (suppress_zero && (!have_decimal_point)) + *dst = pad; + } + src++; + dst++; + break; + case '*': *dst = *src; + have_check_protect = 1; if (*src != '0') { is_zero = suppress_zero = 0; } else { - if (suppress_zero) - *dst = pad = (c == '*') ? '*' : ' '; + if (suppress_zero && (!have_decimal_point)) + *dst = pad; } src++; dst++; @@ -1080,7 +1143,12 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) case '+': case '-': - if ((prev_float_char == NULL) || (c != *prev_float_char)) { + if (c != float_char) { + *dst = c; + sign_position = dst; + dst++; + break; + } else if (prev_float_char == NULL) { *dst = c; prev_float_char = dst; sign_position = dst; @@ -1106,6 +1174,7 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) case ',': if (c == dec_symbol) { *dst = dec_symbol; + have_decimal_point = 1; } else { if (suppress_zero) { if (prev_float_char) { @@ -1134,7 +1203,15 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) break; case 'B': - *dst = pad; + if (suppress_zero && prev_float_char) { + *dst = *prev_float_char; + *prev_float_char = pad; + prev_float_char = dst; + } else if (have_check_protect) { + *dst = pad; + } else { + *dst = ' '; + } dst++; break; @@ -1161,28 +1238,33 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) if (c != currency) { /* should never happen, consider remove [also the reason for not translating that] */ cob_runtime_error ("optimized_move_display_to_edited: invalid PIC character %c", c); - *dst = '?'; /* Invalid PIC */ + *dst = '?'; /* Invalid PIC */ break; - } else { - if ((prev_float_char == NULL) || (c != *prev_float_char)) { + } else if (c != float_char) { + *dst = c; + dst++; + break; + } else if (prev_float_char == NULL) { *dst = c; prev_float_char = dst; dst++; break; - } else if ((*src == '0') && (suppress_zero)) { + } else if ((*src == '0') && (suppress_zero) && (!have_decimal_point)) { *prev_float_char = ' '; prev_float_char = dst; *dst = c; dst++; src++; break; - } else { + } else { *dst = *src; - is_zero = suppress_zero = 0; + if (*src != '0') { + is_zero = 0; + suppress_zero = 0; + } dst++; src++; break; - } } /* LCOV_EXCL_STOP */ } /* END OF SWITCH STATEMENT */ @@ -1195,15 +1277,23 @@ optimized_move_display_to_edited (cob_field *f1, cob_field *f2) /* the actual sign of the data. */ /************************************************************/ - if (sign_position == NULL) - return; - - /* if we have not printed any digits set sign to space and return */ + /* if we have not printed any digits set destination to spaces and return */ if (suppress_zero){ - *sign_position = ' '; + if (pad == '*'){ + for(dst = f2->data; dst < dst_end; dst++) { + if (*dst != dec_symbol){ + *dst = '*'; + } + } + } else { + memset(f2->data, ' ', f2->size); + return; + } + } + + if (sign_position == NULL) return; -} if ((neg) && (*sign_position == '+')){ *sign_position = (is_zero) ? '+' : '-'; @@ -1369,14 +1459,8 @@ indirect_move (void (*func) (cob_field *src, cob_field *dst), size_t temp_size; unsigned short digits; - if ( (COB_FIELD_TYPE(dst) == COB_TYPE_NUMERIC_EDITED) - && ( (func == cob_move_binary_to_display) - || (func == cob_move_packed_to_display) - || (func == cob_move_display_to_display) ) ) { - if (COB_FIELD_SCALE(dst) < 0) - temp_size = COB_FIELD_DIGITS(dst) + COB_FIELD_SCALE(dst) + 1; - else - temp_size = COB_FIELD_DIGITS(dst) + 1; + if (COB_FIELD_TYPE(dst) == COB_TYPE_NUMERIC_EDITED) { + temp_size = COB_FIELD_DIGITS(dst) + 1; digits = (unsigned short)temp_size - 1; unsigned char buff[COB_MAX_DIGITS + 1] = { 0 }; if (COB_FIELD_HAVE_SIGN(dst)) { From 1fa8db0d0e6bd4411f0db864511fd3d9bb6963a5 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Thu, 11 Jul 2024 21:49:15 +0000 Subject: [PATCH 7/9] Fix minor alignment / tab issues in config/*.conf --- config/ChangeLog | 4 ++ config/acu-strict.conf | 70 +++++++++++++++++------------------ config/bs2000-strict.conf | 36 +++++++++--------- config/cobol2002.conf | 30 +++++++-------- config/cobol2014.conf | 30 +++++++-------- config/cobol85.conf | 36 +++++++++--------- config/default.conf | 28 +++++++------- config/gcos-strict.conf | 16 ++++---- config/ibm-strict.conf | 34 ++++++++--------- config/lax.conf-inc | 6 +-- config/mf-strict.conf | 42 ++++++++++----------- config/mvs-strict.conf | 46 +++++++++++------------ config/realia-strict.conf | 78 +++++++++++++++++++-------------------- config/rm-strict.conf | 54 +++++++++++++-------------- config/xopen.conf | 34 ++++++++--------- 15 files changed, 274 insertions(+), 270 deletions(-) diff --git a/config/ChangeLog b/config/ChangeLog index 89dab2d0d..e31460947 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,4 +1,8 @@ +2024-07-11 David Declerck + + * general: fix minor alignment / tab issues + 2024-05-02 Simon Sobisch fixing bug #965 diff --git a/config/acu-strict.conf b/config/acu-strict.conf index f1f521602..2b9e45b17 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -34,11 +34,11 @@ tab-width: 8 text-column: 72 word-length: 60 literal-length: 4096 -numeric-literal-length: 31 # default in ACUCOBOL is 18 with the possibility to switch to 31 -pic-length: 100 +numeric-literal-length: 31 # default in ACUCOBOL is 18 with the possibility to switch to 31 +pic-length: 100 # Enable AREACHECK by default, for reference formats other than {fixed,free} -areacheck: no #not verified yet +areacheck: no # not verified yet # Default assign type # Value: 'dynamic', 'external' @@ -88,7 +88,7 @@ indirect-redefines: yes # 15 - 16 15 - 16 7 # 17 - 18 17 - 18 8 # -binary-size: 1-2-4-8 # not verified yet +binary-size: 1-2-4-8 # not verified yet # Numeric truncation according to ANSI binary-truncate: yes @@ -98,7 +98,7 @@ binary-truncate: yes binary-byteorder: big-endian # Allow larger REDEFINES items other than 01 non-external -larger-redefines: ok # not verified yet +larger-redefines: ok # not verified yet # Allow certain syntax variations (eg. REDEFINES position) relax-syntax-checks: yes @@ -121,28 +121,28 @@ move-ibm: no select-working: yes # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. sticky-linkage: no # If yes, allow non-matching level numbers -relax-level-hierarchy: no # not verified yet +relax-level-hierarchy: no # not verified yet # If yes, evaluate constant expressions at compile time constant-folding: no # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field -hostsign: no # not verified yet +hostsign: no # not verified yet # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -194,59 +194,59 @@ xml-parse-xmlss: no # always in COMPAT screen-section-rules: acu # Whether DECIMAL-POINT IS COMMA has effect in XML/JSON GENERATE -dpc-in-data: xml # verify +dpc-in-data: xml # verify # Bounds against which to check subscripts (full, max, record) subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', # 'unconformable' alter-statement: obsolete -comment-paragraphs: obsolete # not verified yet +comment-paragraphs: obsolete # not verified yet partial-replace-when-literal-src: ok control-division: unconformable call-overflow: ok -data-records-clause: obsolete # not verified yet +data-records-clause: obsolete # not verified yet debugging-mode: ok use-for-debugging: unconformable -listing-statements: skip # only available in IBM mode -title-statement: skip # not available but a reserved word in acu +listing-statements: skip # only available in IBM mode +title-statement: skip # not available but a reserved word in acu entry-statement: ok -goto-statement-without-name: obsolete # not verified yet -label-records-clause: obsolete # not verified yet -memory-size-clause: obsolete # not verified yet -move-noninteger-to-alphanumeric: error # not verified yet +goto-statement-without-name: obsolete # not verified yet +label-records-clause: obsolete # not verified yet +memory-size-clause: obsolete # not verified yet +move-noninteger-to-alphanumeric: error # not verified yet move-figurative-constant-to-numeric: ok move-figurative-space-to-numeric: ok move-figurative-quote-to-numeric: ok -multiple-file-tape-clause: obsolete # not verified yet +multiple-file-tape-clause: obsolete # not verified yet next-sentence-phrase: ok -odo-without-to: ok # not verified yet -padding-character-clause: obsolete # not verified yet -section-segments: ignore # not verified yet -stop-literal-statement: obsolete # not verified yet +odo-without-to: ok # not verified yet +padding-character-clause: obsolete # not verified yet +section-segments: ignore # not verified yet +stop-literal-statement: obsolete # not verified yet stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: skip special-names-clause: ok top-level-occurs-clause: ok -value-of-clause: obsolete # not verified yet +value-of-clause: obsolete # not verified yet numeric-boolean: unconformable hexadecimal-boolean: unconformable national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric,non-numeric(acu) -acu-literals: ok +acu-literals: ok hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -258,7 +258,7 @@ constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable program-prototypes: unconformable -numeric-value-for-edited-item: error # not verified yet +numeric-value-for-edited-item: error # not verified yet reference-out-of-declaratives: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable @@ -266,13 +266,13 @@ using-optional: unconformable incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause error # not verified yet +records-mismatch-record-clause: error # not verified yet record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: ok -missing-statement: ok # gets a warning in some places but not in PERFORM -missing-period: warning #when format not in {fixed,free} -zero-length-literals: unconformable # not verified yet +missing-statement: ok # gets a warning in some places but not in PERFORM +missing-period: warning # when format not in {fixed,free} +zero-length-literals: unconformable # not verified yet xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable @@ -281,9 +281,9 @@ assign-using-variable: unconformable assign-ext-dyn: ok assign-disk-from: unconformable vsam-status: ignore -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: " " +defaultbyte: " " picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 4db799012..2c0a1fae8 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -35,8 +35,8 @@ format: cobol85 tab-width: 8 text-column: 72 word-length: 31 -literal-length: 180 # TO-DO: Check max hex string length is 360. -numeric-literal-length: 31 # TO-DO: Different rules for exponent-format floating-point literals. +literal-length: 180 # TO-DO: Check max hex string length is 360. +numeric-literal-length: 31 # TO-DO: Different rules for exponent-format floating-point literals. pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} @@ -55,7 +55,7 @@ assign-clause: external # 4. the literal "DATAFILE" # If no, the value of the assign clause is the file name. # -filename-mapping: yes # probably +filename-mapping: yes # probably # Alternate formatting of numeric fields pretty-display: no @@ -93,7 +93,7 @@ indirect-redefines: no binary-size: 2-4-8 # Numeric truncation according to ANSI -binary-truncate: yes # TO-DO: For BINARY, *not* for COMP or COMP-5! +binary-truncate: yes # TO-DO: For BINARY, *not* for COMP or COMP-5! # Binary byte order # Value: 'native', 'big-endian' @@ -114,7 +114,7 @@ ref-mod-zero-length: no perform-osvs: no # Compute intermediate decimal results like IBM OSVS -arithmetic-osvs: no # TO-DO: Maybe, but if intermediate item has more than 31 places, floating-point arithmetic is used. +arithmetic-osvs: no # TO-DO: Maybe, but if intermediate item has more than 31 places, floating-point arithmetic is used. # MOVE like IBM (mvc); left to right, byte by byte move-ibm: no @@ -123,11 +123,11 @@ move-ibm: no select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no # not verified yet +local-implies-recursive: no # not verified yet # If yes, LINKAGE SECTION items remain allocated # between invocations. -sticky-linkage: no # TO-DO: Check! +sticky-linkage: no # TO-DO: Check! # If yes, allow non-matching level numbers relax-level-hierarchy: no @@ -186,7 +186,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # only XMLPARSE"COMPAT" way +xml-parse-xmlss: no # only XMLPARSE"COMPAT" way # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -195,10 +195,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # not verified, may need "record" +subscript-check: max # not verified, may need "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -207,7 +207,7 @@ init-justify: no alter-statement: obsolete comment-paragraphs: unconformable control-division: unconformable -partial-replace-when-literal-src: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -232,10 +232,10 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # TYPEDEF is reserved but unused -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: skip -special-names-clause: error # not verified yet +special-names-clause: error # not verified yet top-level-occurs-clause: unconformable value-of-clause: obsolete numeric-boolean: unconformable @@ -258,17 +258,17 @@ reference-out-of-declaratives: error program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause error # not verified yet +records-mismatch-record-clause: error # not verified yet record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: unconformable missing-statement: warning # not verified yet -missing-period: error #when format not in {fixed,free}, not verified yet +missing-period: error # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -278,9 +278,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 # not verified yet, but likely to be as IBM +defaultbyte: 0 # not verified yet, but likely to be as IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 1943f9218..6548f790c 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -34,8 +34,8 @@ tab-width: 8 text-column: 72 word-length: 31 literal-length: 160 -numeric-literal-length: 31 -pic-length: 50 +numeric-literal-length: 31 +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: no @@ -119,10 +119,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -185,7 +185,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -197,7 +197,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -211,8 +211,8 @@ call-overflow: archaic data-records-clause: unconformable debugging-mode: obsolete use-for-debugging: unconformable -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: unconformable label-records-clause: unconformable @@ -231,7 +231,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: ok special-names-clause: error @@ -242,7 +242,7 @@ hexadecimal-boolean: ok national-literals: ok hexadecimal-national-literals: ok national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: archaic @@ -257,17 +257,17 @@ reference-out-of-declaratives: error program-prototypes: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: ok +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error +records-mismatch-record-clause: error record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -277,9 +277,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # initial storage is undefined +defaultbyte: none # initial storage is undefined picture-l: unconformable # archaic in COBOL2002 and currently not available as dialect features: diff --git a/config/cobol2014.conf b/config/cobol2014.conf index c24530200..7f1492468 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -34,8 +34,8 @@ tab-width: 8 text-column: 72 word-length: 31 literal-length: 8191 -numeric-literal-length: 31 -pic-length: 63 +numeric-literal-length: 31 +pic-length: 63 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: no @@ -119,10 +119,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -185,7 +185,7 @@ implicit-assign-dynamic-var: yes device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -197,7 +197,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -211,8 +211,8 @@ call-overflow: archaic data-records-clause: unconformable debugging-mode: unconformable use-for-debugging: unconformable -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: unconformable label-records-clause: unconformable @@ -232,7 +232,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: ok special-names-clause: error @@ -243,7 +243,7 @@ hexadecimal-boolean: ok national-literals: ok hexadecimal-national-literals: ok national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable word-continuation: archaic ebcdic-symbolic-characters: no @@ -257,17 +257,17 @@ reference-out-of-declaratives: error program-prototypes: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: ok +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error +records-mismatch-record-clause: error record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: ok xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -277,9 +277,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # initial storage is undefined +defaultbyte: none # initial storage is undefined picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/cobol85.conf b/config/cobol85.conf index dd9ed5e66..f05669281 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -34,8 +34,8 @@ tab-width: 8 text-column: 72 word-length: 30 literal-length: 160 -numeric-literal-length: 18 -pic-length: 30 +numeric-literal-length: 18 +pic-length: 30 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -119,10 +119,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -132,7 +132,7 @@ sticky-linkage: no relax-level-hierarchy: no # If yes, evaluate constant expressions at compile time -constant-folding: yes # we may set this to "no" for "old compilers" +constant-folding: yes # we may set this to "no" for "old compilers" # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: no @@ -185,7 +185,7 @@ implicit-assign-dynamic-var: yes device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -197,7 +197,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -211,8 +211,8 @@ call-overflow: ok data-records-clause: obsolete debugging-mode: ok use-for-debugging: obsolete -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: obsolete label-records-clause: obsolete @@ -231,9 +231,9 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: skip -sync-left-right: ok # TODO: verify +sync-left-right: ok # TODO: verify special-names-clause: error top-level-occurs-clause: unconformable value-of-clause: obsolete @@ -242,7 +242,7 @@ hexadecimal-boolean: unconformable national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -253,21 +253,21 @@ symbolic-constant: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error +records-mismatch-record-clause: error record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -277,9 +277,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: none # initial storage is undefined +defaultbyte: none # initial storage is undefined picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: diff --git a/config/default.conf b/config/default.conf index 2bb1f985c..c4510e71c 100644 --- a/config/default.conf +++ b/config/default.conf @@ -139,10 +139,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -202,7 +202,7 @@ move-non-numeric-lit-to-numeric-is-zero: no implicit-assign-dynamic-var: yes # If yes, ACCEPT and DISPLAY statements accept device names using mnemonics -device-mnemonics: no +device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs xml-parse-xmlss: yes @@ -217,7 +217,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -231,8 +231,8 @@ call-overflow: archaic data-records-clause: obsolete debugging-mode: ok use-for-debugging: ok -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: ok goto-statement-without-name: obsolete label-records-clause: obsolete @@ -251,9 +251,9 @@ stop-identifier-statement: obsolete stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok -usage-type: ok +usage-type: ok synchronized-clause: ok -sync-left-right: ok # TODO: implement, now raises PENDING warning +sync-left-right: ok # TODO: implement, now raises PENDING warning special-names-clause: ok top-level-occurs-clause: ok value-of-clause: obsolete @@ -278,17 +278,17 @@ reference-out-of-declaratives: warning program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: ok -using-optional: ok +using-optional: ok numeric-value-for-edited-item: ok incorrect-conf-sec-order: ok define-constant-directive: archaic free-redefines-position: warning -records-mismatch-record-clause warning +records-mismatch-record-clause: warning record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: ok missing-statement: warning -missing-period: warning #when format not in {fixed,free} +missing-period: warning # when format not in {fixed,free} zero-length-literals: ok xml-generate-extra-phrases: ok continue-after: ok @@ -298,10 +298,10 @@ assign-using-variable: ok assign-ext-dyn: ok assign-disk-from: ok vsam-status: ignore -self-call-recursive: warning +self-call-recursive: warning record-contains-depending-clause: unconformable -defaultbyte: init # GC inits as INITIALIZE ALL TO VALUE THEN TO DEFAULT, - # with INDEXED BY variables initialized to 1 +defaultbyte: init # GC inits as INITIALIZE ALL TO VALUE THEN TO DEFAULT, + # with INDEXED BY variables initialized to 1 picture-l: ok # use complete word list; synonyms and exceptions are specified below diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 82acacf1c..558e673a0 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -22,7 +22,7 @@ name: "GCOS" # Value: enum (see default.conf and cobc/cobc.h for details) -standard-define 7 # Builds on COBOL-85 +standard-define 7 # Builds on COBOL-85 # Default source reference-format (see default.conf for details) format: cobol85 @@ -184,7 +184,7 @@ implicit-assign-dynamic-var: no device-mnemonics: yes # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -193,10 +193,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # not verified, may need "record" +subscript-check: max # not verified, may need "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: yes # TODO: verify +init-justify: yes # TODO: verify # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -205,7 +205,7 @@ init-justify: yes # TODO: verify alter-statement: obsolete comment-paragraphs: obsolete control-division: ok -partial-replace-when-literal-src: skip # i.e, do not replace if results in spaces only +partial-replace-when-literal-src: skip # i.e, do not replace if results in spaces only call-overflow: archaic data-records-clause: obsolete debugging-mode: ok @@ -256,7 +256,7 @@ reference-out-of-declaratives: error program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error @@ -266,7 +266,7 @@ record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error # when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -278,7 +278,7 @@ assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip record-contains-depending-clause: obsolete -defaultbyte: 0 +defaultbyte: 0 picture-l: ok # use fixed word list, synonyms and exceptions specified there diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 0d664d768..41c6b4727 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -27,15 +27,15 @@ name: "IBM COBOL" standard-define 2 # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # Value: int tab-width: 8 text-column: 72 word-length: 30 literal-length: 160 -numeric-literal-length: 31 # for ARITH(EXTENDED), otherwise 18 -pic-length: 50 +numeric-literal-length: 31 # for ARITH(EXTENDED), otherwise 18 +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -121,7 +121,7 @@ move-ibm: yes select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -131,18 +131,18 @@ sticky-linkage: yes relax-level-hierarchy: yes # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: yes # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -193,10 +193,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # TODO: "record" +subscript-check: max # TODO: "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: yes +init-justify: yes # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -231,7 +231,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: ok sync-left-right: skip special-names-clause: error @@ -242,7 +242,7 @@ hexadecimal-boolean: unconformable national-literals: ok hexadecimal-national-literals: unconformable national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -252,21 +252,21 @@ renames-uncommon-levels: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause ok # IBM: "if not matching use the record size" +records-mismatch-record-clause: ok # IBM: "if not matching use the record size" record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: unconformable missing-statement: warning # not verified yet -missing-period: warning #when format not in {fixed,free}, not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: ok continue-after: unconformable @@ -276,9 +276,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 +defaultbyte: 0 picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/lax.conf-inc b/config/lax.conf-inc index b9475b27c..6f473d08d 100644 --- a/config/lax.conf-inc +++ b/config/lax.conf-inc @@ -88,9 +88,9 @@ stop-literal-statement: +obsolete stop-identifier-statement: ok same-as-clause: ok type-to-clause: ok -usage-type: ok +usage-type: ok synchronized-clause: +ignore -sync-left-right: +ignore # better use "skip" here? +sync-left-right: +ignore # better use "skip" here? special-names-clause: +warning top-level-occurs-clause: ok value-of-clause: +obsolete @@ -113,7 +113,7 @@ reference-out-of-declaratives: +warning program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: ok -using-optional: +warning +using-optional: +warning numeric-value-for-edited-item: +warning incorrect-conf-sec-order: +warning define-constant-directive: +obsolete diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 4c0000f89..ee5d8b8fb 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -34,11 +34,11 @@ tab-width: 8 text-column: 72 # Maximum word-length for COBOL words / Programmer defined words # current max (COB_MAX_WORDLEN): 63 -#word-length: 127 +# word-length: 127 word-length: 63 literal-length: 8192 -numeric-literal-length: 18 -pic-length: 50 +numeric-literal-length: 18 +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: no @@ -124,7 +124,7 @@ move-ibm: no select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: yes +local-implies-recursive: yes # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -134,18 +134,18 @@ sticky-linkage: no relax-level-hierarchy: yes # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: no # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -199,7 +199,7 @@ dpc-in-data: xml subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -233,19 +233,19 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # only supports USAGE type-name -usage-type: ok -synchronized-clause: skip # only active with IBMCOMP=OK (active with dialects IBM + RM) -sync-left-right: skip # commentary only +usage-type: ok +synchronized-clause: skip # only active with IBMCOMP=OK (active with dialects IBM + RM) +sync-left-right: skip # commentary only special-names-clause: error top-level-occurs-clause: ok value-of-clause: obsolete -numeric-boolean: ok # this can be changed by the BINLINT directive (default is NUMERIC=OK) -hexadecimal-boolean: unconformable +numeric-boolean: ok # this can be changed by the BINLINT directive (default is NUMERIC=OK) +hexadecimal-boolean: unconformable national-literals: ok hexadecimal-national-literals: ok national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric(rm/mf),non-numeric -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -256,21 +256,21 @@ symbolic-constant: unconformable constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: warning # not verified yet +reference-out-of-declaratives: warning # not verified yet program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: unconformable -using-optional: ok +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: ok define-constant-directive: unconformable free-redefines-position: ok -records-mismatch-record-clause ok # follows IBM "if not matching use the record size" +records-mismatch-record-clause: ok # follows IBM "if not matching use the record size" record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: ok -missing-statement: ok # according to tests, documentation partially disagrees -missing-period: warning # when format not in {fixed,free} +missing-statement: ok # according to tests, documentation partially disagrees +missing-period: warning # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: ok continue-after: unconformable @@ -280,9 +280,9 @@ assign-using-variable: unconformable assign-ext-dyn: ok assign-disk-from: ok vsam-status: ignore -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: " " +defaultbyte: " " picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index 4f6034575..fe928cb75 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -27,15 +27,15 @@ name: "IBM COBOL for MVS & VM" standard-define 3 # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # Value: int tab-width: 8 text-column: 72 -word-length: 30 # not verified yet -literal-length: 160 # not verified yet -numeric-literal-length: 18 # not verified yet -pic-length: 50 +word-length: 30 # not verified yet +literal-length: 160 # not verified yet +numeric-literal-length: 18 # not verified yet +pic-length: 50 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -121,7 +121,7 @@ move-ibm: yes select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -131,18 +131,18 @@ sticky-linkage: yes relax-level-hierarchy: yes # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: yes # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used -accept-update: no # not verified yet +accept-update: no # not verified yet # If yes, set WITH AUTO clause as default for ACCEPT dest-item, # except if WITH TAB clause is used -accept-auto: no # not verified yet +accept-auto: no # not verified yet # If yes, DISPLAYs and ACCEPTs are, by default, done on the CRT (i.e., using # curses). @@ -184,7 +184,7 @@ implicit-assign-dynamic-var: no device-mnemonics: yes # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -193,10 +193,10 @@ screen-section-rules: std dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: max # TODO: "record" +subscript-check: max # TODO: "record" # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: yes +init-justify: yes # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -206,7 +206,7 @@ alter-statement: obsolete comment-paragraphs: obsolete partial-replace-when-literal-src: unconformable control-division: unconformable -call-overflow: ok # not verified yet +call-overflow: ok # not verified yet data-records-clause: obsolete debugging-mode: ok use-for-debugging: obsolete @@ -217,7 +217,7 @@ goto-statement-without-name: obsolete label-records-clause: obsolete memory-size-clause: obsolete move-noninteger-to-alphanumeric: error -move-figurative-constant-to-numeric: error # not verified yet +move-figurative-constant-to-numeric: error # not verified yet move-figurative-space-to-numeric: error # not verified yet move-figurative-quote-to-numeric: error # not verified yet multiple-file-tape-clause: obsolete @@ -230,18 +230,18 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable special-names-clause: error synchronized-clause: ok sync-left-right: skip top-level-occurs-clause: unconformable value-of-clause: obsolete numeric-boolean: unconformable -hexadecimal-boolean: unconformable +hexadecimal-boolean: unconformable national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -252,21 +252,21 @@ symbolic-constant: unconformable constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause ok # not verified but IBM has "if not matching use the record size" +records-mismatch-record-clause: ok # not verified but IBM has "if not matching use the record size" record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: unconformable missing-statement: warning # not verified yet -missing-period: warning #when format not in {fixed,free}, not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -276,9 +276,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 # not verified yet, but likely to be as IBM +defaultbyte: 0 # not verified yet, but likely to be as IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 6f4dfb901..1e40d19e1 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -24,25 +24,25 @@ name: "CA Realia II" # Value: enum (see default.conf and cobc/cobc.h for details) -standard-define 7 # Uses COBOL-85 currently +standard-define 7 # Uses COBOL-85 currently # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # Value: int tab-width: 8 text-column: 72 -word-length: 60 # to check +word-length: 60 # to check literal-length: 160 -numeric-literal-length: 18 # to check -pic-length: 100 # to check +numeric-literal-length: 18 # to check +pic-length: 100 # to check # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes # Default assign type # Value: 'dynamic', 'external' -assign-clause: dynamic # to check +assign-clause: dynamic # to check # If yes, file names are resolved at run time using # environment variables. @@ -53,7 +53,7 @@ assign-clause: dynamic # to check # 4. the literal "DATAFILE" # If no, the value of the assign clause is the file name. # -filename-mapping: yes # to check +filename-mapping: yes # to check # Alternate formatting of numeric fields pretty-display: yes @@ -91,17 +91,17 @@ indirect-redefines: no binary-size: 2-4-8 # Numeric truncation according to ANSI -binary-truncate: no # to check +binary-truncate: no # to check # Binary byte order # Value: 'native', 'big-endian' -binary-byteorder: big-endian # to check +binary-byteorder: big-endian # to check # Allow larger REDEFINES items other than 01 non-external -larger-redefines: error # not verified yet +larger-redefines: error # not verified yet # Allow certain syntax variations (eg. REDEFINES position) -relax-syntax-checks: no # to check +relax-syntax-checks: no # to check # Allow zero length reference-modification # (only checked with active EC-BOUND-REF-MOD) @@ -109,32 +109,32 @@ ref-mod-zero-length: no # Perform type OSVS - If yes, the exit point of any currently # executing perform is recognized if reached. -perform-osvs: no # to check +perform-osvs: no # to check # Compute intermediate decimal results like IBM OSVS -arithmetic-osvs: no # to check +arithmetic-osvs: no # to check # MOVE like IBM (mvc); left to right, byte by byte -move-ibm: no # to check +move-ibm: no # to check # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: yes # yes for ASSIGN, to check for RELATIVE KEY +select-working: yes # yes for ASSIGN, to check for RELATIVE KEY # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. sticky-linkage: no # If yes, allow non-matching level numbers -relax-level-hierarchy: no # not verified yet +relax-level-hierarchy: no # not verified yet # If yes, evaluate constant expressions at compile time constant-folding: no # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field -hostsign: no # not verified yet +hostsign: no # not verified yet # If yes, set WITH UPDATE clause as default for ACCEPT dest-item, # except if WITH NO UPDATE clause is used @@ -188,7 +188,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -197,10 +197,10 @@ screen-section-rules: xopen dpc-in-data: xml # Bounds against which to check subscripts (full, max, record) -subscript-check: full # not verified yet +subscript-check: full # not verified yet # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -208,8 +208,8 @@ init-justify: no alter-statement: obsolete comment-paragraphs: ok -control-division: unconformable # not verified yet -partial-replace-when-literal-src: unconformable # not verified yet +control-division: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: ignore debugging-mode: unconformable @@ -220,12 +220,12 @@ entry-statement: ok goto-statement-without-name: ok label-records-clause: ok memory-size-clause: ignore -move-noninteger-to-alphanumeric: error # not verified yet -move-figurative-constant-to-numeric: ok # not verified yet -move-figurative-space-to-numeric: ok # not verified yte -move-figurative-quote-to-numeric: ok # not verified yet +move-noninteger-to-alphanumeric: error # not verified yet +move-figurative-constant-to-numeric: ok # not verified yet +move-figurative-space-to-numeric: ok # not verified yte +move-figurative-quote-to-numeric: ok # not verified yet multiple-file-tape-clause: ignore -next-sentence-phrase: archaic # not verified yet +next-sentence-phrase: archaic # not verified yet odo-without-to: unconformable padding-character-clause: ignore section-segments: unconformable @@ -234,10 +234,10 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable -special-names-clause: error # not verified yet +usage-type: unconformable +special-names-clause: error # not verified yet synchronized-clause: ok -sync-left-right: ignore # can raise a warning upon request +sync-left-right: ignore # can raise a warning upon request top-level-occurs-clause: unconformable value-of-clause: ignore numeric-boolean: unconformable @@ -257,22 +257,22 @@ symbolic-constant: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: ok # not verified yet +reference-out-of-declaratives: ok # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable -numeric-value-for-edited-item: error # not verified yet +using-optional: unconformable +numeric-value-for-edited-item: error # not verified yet incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable -records-mismatch-record-clause: error # not verified yet +records-mismatch-record-clause: error # not verified yet record-delimiter: ignore sequential-delimiters: unconformable record-delim-with-fixed-recs: error missing-statement: warning -missing-period: warning #when format not in {fixed,free}, not verified yet -zero-length-literals: unconformable # not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet +zero-length-literals: unconformable # not verified yet xml-generate-extra-phrases: unconformable continue-after: unconformable goto-entry: unconformable @@ -281,9 +281,9 @@ assign-using-variable: ok assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: 0 # not verified, but likely like IBM +defaultbyte: 0 # not verified, but likely like IBM picture-l: unconformable # use fixed word list, synonyms and exceptions specified there diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 4811394f9..0af678a73 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -27,18 +27,18 @@ name: "RM-COBOL" standard-define 6 # Default source reference-format (see default.conf for details) -format: cobol85 # CHECKME +format: cobol85 # CHECKME # TO-DO: Allow configuring WHEN-COMPILED date format (see p. 22). # Value: int -tab-width: 8 # not verified yet -text-column: 72 # TO-DO: add >>IMP MARGIN-R (see p. 50) +tab-width: 8 # not verified yet +text-column: 72 # TO-DO: add >>IMP MARGIN-R (see p. 50) # Maximum word-length for COBOL words / Programmer defined words # current max (COB_MAX_WORDLEN): 63 -#word-length: 240 +# word-length: 240 word-length: 63 -# external-word-length: 30 # TO-DO: Add! +# external-word-length: 30 # TO-DO: Add! literal-length: 65535 numeric-literal-length: 30 pic-length: 30 @@ -48,7 +48,7 @@ areacheck: yes # Default assign type # Value: 'dynamic', 'external' -assign-clause: dynamic # TO-DO: Verify +assign-clause: dynamic # TO-DO: Verify # If yes, file names are resolved at run time using # environment variables. @@ -71,7 +71,7 @@ complex-odo: yes odoslide: no # Allow REDEFINES to other than last equal level number -indirect-redefines: yes # "restriction removed in version 12+" +indirect-redefines: yes # "restriction removed in version 12+" # Binary byte size - defines the allocated bytes according to PIC # Value: signed unsigned bytes @@ -104,10 +104,10 @@ binary-truncate: yes binary-byteorder: big-endian # Allow larger REDEFINES items other than 01 non-external -larger-redefines: ok # (see p. 134) +larger-redefines: ok # (see p. 134) # Allow certain syntax variations (eg. REDEFINES position) -relax-syntax-checks: yes # TO-DO: For REDEFINES position, at least. +relax-syntax-checks: yes # TO-DO: For REDEFINES position, at least. # Allow zero length reference-modification # (only checked with active EC-BOUND-REF-MOD) @@ -115,7 +115,7 @@ ref-mod-zero-length: no # Perform type OSVS - If yes, the exit point of any currently # executing perform is recognized if reached. -perform-osvs: yes # according to MF docs; +perform-osvs: yes # according to MF docs; # CHECKME: R/M docs say (see p. 374) "Any potentially undefined (i.e. overlapping) PERFORMS prohibited" # Compute intermediate decimal results like IBM OSVS @@ -128,7 +128,7 @@ move-ibm: no select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -138,7 +138,7 @@ sticky-linkage: yes relax-level-hierarchy: no # If yes, evaluate constant expressions at compile time -constant-folding: yes # not verified yet +constant-folding: yes # not verified yet # Allow Hex 'F' for NUMERIC test of signed PACKED DECIMAL field hostsign: no @@ -181,7 +181,7 @@ binary-comp-1: yes numeric-pointer: no # not verified yet # auto-adjust to zero like MicroFocus does -move-non-numeric-lit-to-numeric-is-zero: no # not verified yet +move-non-numeric-lit-to-numeric-is-zero: no # not verified yet # If yes, implicitly define a variable for an ASSIGN DYNAMIC which does not # match an existing data item. @@ -191,7 +191,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: rm @@ -203,7 +203,7 @@ dpc-in-data: xml subscript-check: max # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -212,19 +212,19 @@ init-justify: no alter-statement: obsolete comment-paragraphs: obsolete control-division: unconformable -partial-replace-when-literal-src: unconformable # not verified yet +partial-replace-when-literal-src: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok use-for-debugging: obsolete -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: obsolete label-records-clause: obsolete memory-size-clause: obsolete move-noninteger-to-alphanumeric: error -move-figurative-constant-to-numeric: ok # not verified yet +move-figurative-constant-to-numeric: ok # not verified yet move-figurative-space-to-numeric: ok # not verified yet move-figurative-quote-to-numeric: ok # not verified yet multiple-file-tape-clause: obsolete @@ -237,8 +237,8 @@ stop-identifier-statement: ok stop-error-statement: unconformable same-as-clause: ok type-to-clause: unconformable -usage-type: unconformable -special-names-clause: error # not verified yet +usage-type: unconformable +special-names-clause: error # not verified yet synchronized-clause: ok sync-left-right: ok top-level-occurs-clause: unconformable @@ -249,7 +249,7 @@ national-literals: unconformable hexadecimal-national-literals: unconformable national-character-literals: unconformable # TO-DO: Add separate config option for H"..." to be unsupported,numeric(rm/mf),non-numeric -acu-literals: unconformable +acu-literals: unconformable hp-octal-literals: unconformable ebcdic-symbolic-characters: no word-continuation: ok @@ -260,11 +260,11 @@ symbolic-constant: unconformable constant-78: ok constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # TO-DO: error when referring to non-USE-statement DECLARATIVE sections +reference-out-of-declaratives: error # TO-DO: error when referring to non-USE-statement DECLARATIVE sections program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable @@ -274,7 +274,7 @@ record-delimiter: ok sequential-delimiters: ok record-delim-with-fixed-recs: ok missing-statement: warning # not verified yet -missing-period: warning #when format not in {fixed,free}, not verified yet +missing-period: warning # when format not in {fixed,free}, not verified yet zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -284,9 +284,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: unconformable -defaultbyte: " " # not verified, but possibly like ACU/MF +defaultbyte: " " # not verified, but possibly like ACU/MF picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: diff --git a/config/xopen.conf b/config/xopen.conf index 22b2a1451..8bb576113 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -46,8 +46,8 @@ tab-width: 8 text-column: 72 word-length: 30 literal-length: 160 -numeric-literal-length: 18 -pic-length: 30 +numeric-literal-length: 18 +pic-length: 30 # Enable AREACHECK by default, for reference formats other than {fixed,free} areacheck: yes @@ -132,10 +132,10 @@ arithmetic-osvs: no move-ibm: no # SELECT RELATIVE KEY and ASSIGN fields must be in WORKING-STORAGE -select-working: no +select-working: no # LOCAL-STORAGE SECTION implies RECURSIVE attribute -local-implies-recursive: no +local-implies-recursive: no # If yes, LINKAGE SECTION items remain allocated # between invocations. @@ -198,7 +198,7 @@ implicit-assign-dynamic-var: no device-mnemonics: no # full clauses in XML PARSE - and adjusted XML-EVENTs -xml-parse-xmlss: no # not supported at all +xml-parse-xmlss: no # not supported at all # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -210,7 +210,7 @@ dpc-in-data: xml subscript-check: full # Functionality of JUSTIFY for INITIALIZE verb and initialization of storage -init-justify: no +init-justify: no # Dialect features # Value: 'ok', 'warning', 'archaic', 'obsolete', 'skip', 'ignore', 'error', @@ -228,15 +228,15 @@ control-division: unconformable call-overflow: ok data-records-clause: warning # should not be used ... debugging-mode: ok -use-for-debugging: unconformable # complete module removed -listing-statements: skip # may be a user-defined word -title-statement: skip # may be a user-defined word +use-for-debugging: unconformable # complete module removed +listing-statements: skip # may be a user-defined word +title-statement: skip # may be a user-defined word entry-statement: unconformable goto-statement-without-name: warning # should not be used ... label-records-clause: warning # should not be used ... memory-size-clause: warning # should not be used ... move-noninteger-to-alphanumeric: error -move-figurative-constant-to-numeric: archaic # not verified yet +move-figurative-constant-to-numeric: archaic # not verified yet move-figurative-space-to-numeric: error move-figurative-quote-to-numeric: archaic # not verified yet multiple-file-tape-clause: warning # should not be used ... @@ -250,7 +250,7 @@ stop-identifier-statement: unconformable stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable -usage-type: unconformable +usage-type: unconformable synchronized-clause: warning # should not be used ... will prevent portability sync-left-right: ok special-names-clause: error @@ -272,21 +272,21 @@ symbolic-constant: unconformable constant-78: unconformable constant-01: unconformable perform-varying-without-by: unconformable -reference-out-of-declaratives: error # not verified yet +reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable -using-optional: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error free-redefines-position: unconformable -records-mismatch-record-clause error # actually the complete clause is excluded from X/Open... +records-mismatch-record-clause: error # actually the complete clause is excluded from X/Open... record-delimiter: warning # should not be used ... sequential-delimiters: ok record-delim-with-fixed-recs: unconformable missing-statement: error -missing-period: error #when format not in {fixed,free} +missing-period: error # when format not in {fixed,free} zero-length-literals: unconformable xml-generate-extra-phrases: unconformable continue-after: unconformable @@ -296,9 +296,9 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable -self-call-recursive: skip +self-call-recursive: skip record-contains-depending-clause: obsolete -defaultbyte: none # "not specifically defined in Standard COBOL" +defaultbyte: none # "not specifically defined in Standard COBOL" picture-l: unconformable # obsolete in COBOL85 and currently not available as dialect features: From 314adc1ca83055a5676a8e1329e01d6b565f24a3 Mon Sep 17 00:00:00 2001 From: chaat Date: Thu, 11 Jul 2024 23:34:56 +0000 Subject: [PATCH 8/9] Adjustment for build without curses and fix C90 warnings Fix errors in screenio.c when building without curses. Also fix C90 warnings. libcob: * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) fixed C90 warnings Also fixed issue when build without curses * move.c (indirect_move) fixed C90 warnings * profiling.c (profile_setup_clock) fixed C90 warnings --- libcob/ChangeLog | 7 ++++ libcob/move.c | 2 +- libcob/profiling.c | 5 ++- libcob/screenio.c | 82 ++++++++++++++++++++++++++++------------------ 4 files changed, 62 insertions(+), 34 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index a577f46c3..3e8c15fd9 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,11 @@ +2024-07-11 Chuck Haatvedt + + * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) fixed C90 warnings + Also fixed issue when build without curses + * move.c (indirect_move) fixed C90 warnings + * profiling.c (profile_setup_clock) fixed C90 warnings + 2024-07-10 Chuck Haatvedt fix errors in cob_optimized_move_display_to_edited introduced diff --git a/libcob/move.c b/libcob/move.c index c6b92dfd5..36e820f84 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -1458,11 +1458,11 @@ indirect_move (void (*func) (cob_field *src, cob_field *dst), cob_field_attr attr; size_t temp_size; unsigned short digits; + unsigned char buff[COB_MAX_DIGITS + 1] = { 0 }; if (COB_FIELD_TYPE(dst) == COB_TYPE_NUMERIC_EDITED) { temp_size = COB_FIELD_DIGITS(dst) + 1; digits = (unsigned short)temp_size - 1; - unsigned char buff[COB_MAX_DIGITS + 1] = { 0 }; if (COB_FIELD_HAVE_SIGN(dst)) { COB_FIELD_INIT (temp_size, buff, &attr); COB_ATTR_INIT (COB_TYPE_NUMERIC_DISPLAY, diff --git a/libcob/profiling.c b/libcob/profiling.c index 0ce3b888d..7a47f2c08 100644 --- a/libcob/profiling.c +++ b/libcob/profiling.c @@ -117,6 +117,10 @@ get_ns_time (void) static void prof_setup_clock () { +#ifdef HAVE_CLOCK_GETTIME + struct timespec ts; +#endif + #ifdef _WIN32 /* Should always succeed on Windows XP and above, but might fail on Windows 2000. Not available on Windows 9x & NT. */ @@ -130,7 +134,6 @@ prof_setup_clock () #ifdef HAVE_CLOCK_GETTIME /* only CLOCK_REALTIME is guaranteed to be defined (and work), not all defined clocks are guaranteed to work */ - struct timespec ts; #ifdef CLOCK_MONOTONIC_RAW if (clock_gettime (CLOCK_MONOTONIC_RAW, &ts) == 0) { clockid = CLOCK_MONOTONIC_RAW; diff --git a/libcob/screenio.c b/libcob/screenio.c index e3e519f8d..57f04db04 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -4917,46 +4917,64 @@ cob_sys_set_scr_size (unsigned char *line, unsigned char *col) #endif } - /* save the current stdscr screen to a file */ + /* save the current stdscr screen to a file */ int cob_sys_scr_dump(unsigned char *parm) { - const char *filename = cob_get_param_str_buffered (1); - FILE *filep; - - if (filename && (filep = fopen(filename, "wb")) != NULL) - { - refresh(); - int result = putwin(stdscr, filep); - fclose(filep); - return result; - } - - return ERR; + COB_CHK_PARMS (CBL_GC_SCR_DUMP, 1); + init_cob_screen_if_needed (); + +#ifdef WITH_EXTENDED_SCREENIO + int result; + FILE *filep; + const char *filename = cob_get_param_str_buffered (1); + + if (filename && (filep = fopen(filename, "wb")) != NULL) + { + refresh(); + result = putwin(stdscr, filep); + fclose(filep); + return result; + } + + return ERR; +#else + return -1; +#endif + } - /* restore the current stdscr screen from a file */ + /* restore the current stdscr screen from a file */ int cob_sys_scr_restore(unsigned char *parm) { - const char *filename = cob_get_param_str_buffered (1); - FILE *filep; - - if (filename && (filep = fopen(filename, "rb")) != NULL) - { - WINDOW *replacement = getwin(filep); - fclose(filep); - - if (replacement) - { - int result = overwrite(replacement, stdscr); - refresh(); - delwin(replacement); - return result; - } - } - - return ERR; + COB_CHK_PARMS (CBL_GC_SCR_RESTORE, 1); + init_cob_screen_if_needed (); + +#ifdef WITH_EXTENDED_SCREENIO + int result; + FILE *filep; + const char *filename = cob_get_param_str_buffered (1); + + if (filename && (filep = fopen(filename, "rb")) != NULL) + { + WINDOW *replacement = getwin(filep); + fclose(filep); + + if (replacement) + { + result = overwrite(replacement, stdscr); + refresh(); + delwin(replacement); + return result; + } + } + + return ERR; +#else + return -1; +#endif + } int From 73ad00d945450aba0c0da800494de15768785f2b Mon Sep 17 00:00:00 2001 From: chaat Date: Thu, 11 Jul 2024 23:57:15 +0000 Subject: [PATCH 9/9] djustment for build without curses and fix C90 warnings Fix warnings in screenio.c fix C90 warnings. libcob: * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) fixed C90 warnings --- libcob/ChangeLog | 4 ++++ libcob/screenio.c | 12 ++++++------ 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 3e8c15fd9..7fdcb3a72 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,8 @@ +2024-07-11 Chuck Haatvedt + + * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) fixed C90 warnings + 2024-07-11 Chuck Haatvedt * screenio.c (cob_sys_scr_dump, cob_sys_scr_restore) fixed C90 warnings diff --git a/libcob/screenio.c b/libcob/screenio.c index 57f04db04..cb76dcace 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -4921,14 +4921,14 @@ cob_sys_set_scr_size (unsigned char *line, unsigned char *col) int cob_sys_scr_dump(unsigned char *parm) { - COB_CHK_PARMS (CBL_GC_SCR_DUMP, 1); - init_cob_screen_if_needed (); - #ifdef WITH_EXTENDED_SCREENIO int result; FILE *filep; const char *filename = cob_get_param_str_buffered (1); + COB_CHK_PARMS (CBL_GC_SCR_DUMP, 1); + init_cob_screen_if_needed (); + if (filename && (filep = fopen(filename, "wb")) != NULL) { refresh(); @@ -4948,14 +4948,14 @@ cob_sys_scr_dump(unsigned char *parm) /* restore the current stdscr screen from a file */ int cob_sys_scr_restore(unsigned char *parm) { - COB_CHK_PARMS (CBL_GC_SCR_RESTORE, 1); - init_cob_screen_if_needed (); - #ifdef WITH_EXTENDED_SCREENIO int result; FILE *filep; const char *filename = cob_get_param_str_buffered (1); + COB_CHK_PARMS (CBL_GC_SCR_RESTORE, 1); + init_cob_screen_if_needed (); + if (filename && (filep = fopen(filename, "rb")) != NULL) { WINDOW *replacement = getwin(filep);