diff --git a/ChangeLog b/ChangeLog index fcc3280df..b34676236 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,8 @@ +2023-07-28 Simon Sobisch + + * configure.ac: check for mousemask and mmask_t + 2023-07-24 Simon Sobisch * configure.ac: fix for resolving COBCRUN_NAME diff --git a/NEWS b/NEWS index 1adc3eda3..8526651c6 100644 --- a/NEWS +++ b/NEWS @@ -1,17 +1,12 @@ NEWS - user visible changes -*- outline -*- + GnuCOBOL 3.2 (20230728) GnuCOBOL 3.2rc1 (20230118) GnuCOBOL 3.2rc2 (20230210) - GnuCOBOL 3.2 to be done end of July 2023 - - planned for final: - * extending testsuite and documentation - * investigation of code analysis tools and user feedback - * New GnuCOBOL features -** Support for LINE SEQUENTIAL file type as per COBOL 2022 +** Support for LINE SEQUENTIAL file type as per COBOL 2023 * OPEN INPUT-OUTPUT and REWRITE are allowed (note that INPUT-OUTPUT leads to slower IO for LINE SEQUENTIAL files) * validation of data on (RE-)WRITE and READ, active by default, @@ -21,31 +16,31 @@ NEWS - user visible changes -*- outline -*- BIT-OF, BIT-TO-CHAR, HEX-OF, HEX-TO-CHAR -** Support for COBOL 2022 directive COBOL-WORDS +** Support for COBOL 2023 directive COBOL-WORDS -** Support for bit operations according to COBOL 2022 with MF compatibility +** Support for bit operations according to COBOL 2023 with MF compatibility ** Support for additional $SET directives: ODOSLIDE -** Support for the EXTFH interface was heavily improved, now also supporting - FH--FCD and FH--KEYDEF, fixed use of different attributes and changing +** Support for the EXTFH has been greatly enhanched and now includes support + for FH--FCD and FH--KEYDEF, fixed use of different attributes and changing pointers and now supports - for 32-bit builds - an internal conversion between FCD2 and FCD3 for cases where existing programs are coded with FCD2 -** OCCURS with multiple VALUEs supported (BS2000 format without FROM/TO) +** OCCURS with multiple VALUEs supported (BS2000 format, FROM and TO pending) -** new function to call COBOL from C that won't exit the program in case +** new function to call COBOL from C that doesn't abort the program in case of runtime errors or STOP RUN: cob_call_with_exception_check() -** Support for GCOS 7 (Bull) dialect, including: +** Support for the GCOS 7 (Bull) dialect, including: * PICTURE strings with L character (variable length fields) * CONTROL DIVISION with SUBSTITUTION SECTION (full support) and DEFAULT SECTION (partial support) -** Multiple sequential files may be concatenated by specifying multiple - files with a separator in its ASSIGN name (either directly or via +** Multiple sequential files can be concatenated by specifying multiple + files with a separator in the ASSIGN name (either directly or via environment), see the new runtime options - COB_SEQ_CONCAT_NAME (defaulting to false) and COB_SEQ_CONCAT_SEP + COB_SEQ_CONCAT_NAME (defaults to false) and COB_SEQ_CONCAT_SEP ** Initial "testing support" of CODE-SET clause to convert between ASCII and EBCDIC on READ/WRITE/REWRITE for sequential and line-sequential files @@ -58,17 +53,14 @@ NEWS - user visible changes -*- outline -*- [core-]dump and stacktrace) with "STOP ERROR" statement or by CALL "CBL_RUNTIME_ERROR" -** COB_PHYSICAL_CANCEL may now be configured as "never" to prevent unloading, +** COB_PHYSICAL_CANCEL can now be configured as "never" to prevent unloading of COBOL modules, both on CANCEL and on process exit, which is useful for - analysis tools like callgrind or perf to keep all symbols until the end of - the COBOL process - -** the system function x'91' was extended to support more functions + analysis tools such as callgrind or perf to keep all symbols until the end + of the COBOL process -** TODO - More to document before 3.2 final +** the system function x'91' has been extended to support more functions - -* Changes that potentially effects existing programs: +* Changes that potentially effect existing programs: ** ALLOCATE statement: earlier versions of GnuCOBOL initialized the memory (to binary zero) if the INITIALIZED clause was not specified, @@ -100,7 +92,7 @@ NEWS - user visible changes -*- outline -*- in case of "overflowing" records previous versions of GnuCOBOL cut the data, set io status 00 and skipped the file until the next line terminator is found; - the default changed (per COBOL 2022 and other compilers) so the data is + the default changed (per COBOL 2023 and other compilers) so the data is returned as "multiple" records and a warning (status 06) is issued; setting COB_LS_SPLIT = false will have the old behaviour of truncating the record, but will now set status 04 @@ -169,10 +161,10 @@ NEWS - user visible changes -*- outline -*- if you set those via COB_SWITCH environment variables you need to adjust their numbers -* Changes that potentially effects recompilation of existing programs: +* Changes that potentially effect recompilation of existing programs: ** the reserved word list and intrinsic functions was updated, especially - to cater for new features of COBOL 2022; if compiling with any non-strict + to cater for new features of COBOL 2023; if compiling with any non-strict dialect you may need to unreserve any conflicting words / functions ** in 64-bit environments, the default size for BY VALUE parameters has changed: @@ -264,6 +256,13 @@ NEWS - user visible changes -*- outline -*- clause for VALUE clause; this is applied to IBM dialects, if you want the previous behavior compile with -fno-init-justified +** depending on the new dialect option "using-optional" (included in the + the default dialect), checks for arguments not passed are now done (only) + on CALL, not on their (possibly many) references; if you want the old + "postponed" check either specify the parameter as OPTIONAL or use + -fusing-optional=skip; note: the non-strict dialects will raise a warning + on the first use of this feature, then automatically enable it + ** the dialect configuration option larger-redefines-ok was replaced by the support option larger-redefines; if specified on the command-line it is now -f[no-]larger-redefines instead of -f[no-]larger-redefines-ok, @@ -377,7 +376,7 @@ NEWS - user visible changes -*- outline -*- and reserved words updated for the dialects "acu" (to ACUCOBOL-GT 10.4), "ibm" (to Enterprise COBOL 6.3) and "mf" (to Micro Focus Visual COBOL 6.0) -** for all "lax" updates SYNC was handled even if commonly ignored by the strict +** for all "lax" varants SYNC was handled even if commonly ignored by the strict dialects, this was fixed so SYNC is ignored depending on the dialect ** COBOL programs compiled with versions before GnuCOBOL 3 that used files with @@ -437,6 +436,10 @@ NEWS - user visible changes -*- outline -*- ** quotes around filenames and parts that are resolved by environment variables are internally ignored +** the exception check for EC-PROGRAM-ARG-MISMATCH is now generated, validating + that non-optional PROCEDURE DIVISION USING items are passed and that their + size in the caller is at least as big as in the program + ** in case of any runtime features being used that are not available an error is generated during compile (may be reduced to a warning by -Wunsupported or be suppressed by -Wno-unsupported) and if the feature is actually used @@ -559,7 +562,7 @@ For more known issues see the bug tracker. ** JSON GENERATE statement (note: runtime support needs additional library cJSON or JSON-C) -** CONTINUE AFTER statement (COBOL 2022) implemented, also handle fractions +** CONTINUE AFTER statement (COBOL 2023) implemented, also handle fractions of seconds in C$SLEEP now ** TYPEDEF and SAME AS (COBOL 2002) implemented, including the MicroFocus diff --git a/build_windows/config.h.in b/build_windows/config.h.in index 76d504a22..55a082451 100644 --- a/build_windows/config.h.in +++ b/build_windows/config.h.in @@ -368,6 +368,9 @@ /* #undef HAVE_ATTRIBUTE_CONSTRUCTOR - using DllMain */ #endif +/* Has __attribute__((pure)) */ +/* #undef HAVE_ATTRIBUTE_PURE */ + /* Define to 1 if you have the `canonicalize_file_name' function. */ #if defined(__ORANGEC__) #define HAVE_CANONICALIZE_FILE_NAME 1 @@ -596,6 +599,13 @@ /* #undef HAVE_MOUSEINTERVAL */ #endif +/* curses has mousemask function and mmask_t definition */ +#if CONFIGURED_CURSES != NOCURSES +#define HAVE_MOUSEMASK 1 +#else +/* #undef HAVE_MOUSEMASK */ +#endif + /* Define to 1 if you have the header file. */ #if USED_MATHLIB == MATHLIB_MPIR #define HAVE_MPIR_H 1 diff --git a/cobc/ChangeLog b/cobc/ChangeLog index bcda32f14..0c5659e71 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1,4 +1,24 @@ +2023-07-26 Simon Sobisch + + * typeck.c (search_set_keys): improving SEARCH ALL syntax checks + +2023-07-25 Simon Sobisch + + * codegen.c (output_entry_function): if COBOL CALL convention is + used, then only use local pointers for specifying not-passed + arguments, improving support for omission of trailing (optional) + parameters in CALL + * config.def, codegen.c, typeck.c: added using-optional dialect option; + if set to "ok" the check for not-passed arguments will only be done + on program entry for all parameters not explicit specified as OPTIONAL + * parser.y (_procedure_optional): added checks for cb_using_optional, + if OPTIONAL used and set to "warning", then reset it to "ok" after first + warning + * codegen.c (output_entry_function): generate checks for + EC-PROGRAM-ARG-MISMATCH validating that non-optional arguments are + passed and if passed then checks its minimal size + 2023-07-24 Simon Sobisch * parser.y (entry_statement): don't check parameter address diff --git a/cobc/codegen.c b/cobc/codegen.c index 4879b8473..f32391606 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -600,9 +600,8 @@ output_newline (void) static void output_prefix (void) { - int i; - if (output_target) { + int i; for (i = 0; i < output_indent_level; i++) { fputc (' ', output_target); } @@ -13042,7 +13041,6 @@ output_entry_function (struct cb_program *prog, cb_tree entry, struct cb_field *f; struct cb_field *f1; struct cb_field *f2; - const char *s_prefix; const char *s_type[MAX_CALL_FIELD_PARAMS]; cob_u32_t parmnum; cob_u32_t n; @@ -13124,21 +13122,62 @@ output_entry_function (struct cb_program *prog, cb_tree entry, output_newline (); output_block_open (); + + if (!cb_sticky_linkage + && (entry_convention & CB_CONV_COBOL)) { + /* By value pointer fields */ + for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) { + f2 = cb_code_field (CB_VALUE (l2)); + if (CB_PURPOSE_INT (l2) == CB_CALL_BY_VALUE + && (f2->usage == CB_USAGE_POINTER + || f2->usage == CB_USAGE_PROGRAM_POINTER)) { + output_line ("unsigned char\t\t*ptr_%d;", f2->id); + } + } + } - /* By value pointer fields */ - for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) { - f2 = cb_code_field (CB_VALUE (l2)); - if (CB_PURPOSE_INT (l2) == CB_CALL_BY_VALUE && - (f2->usage == CB_USAGE_POINTER || - f2->usage == CB_USAGE_PROGRAM_POINTER)) { - output_line ("unsigned char\t\t*ptr_%d;", f2->id); + /* + We have to cater for sticky-linkage here at the entry point + site. Doing it in the internal function is too late as we then do not + have the information as to possible ENTRY clauses. + */ + + /* linkage parameters */ + for (l = using_list, parmnum = 0; l; l = CB_CHAIN (l), parmnum++) { + cb_tree f_tree = CB_VALUE (l); + f = cb_code_field (f_tree); + sticky_ids[parmnum] = f->id; + if (!cb_sticky_linkage + && (entry_convention & CB_CONV_COBOL)) { + output_line ("cob_u8_t *cob_parm_%d = NULL;" + "\t/* linkage for %s */", + f->id, cb_name (f_tree) + ); } + if (CB_PURPOSE_INT (l) == CB_CALL_BY_VALUE) { + const char *s = try_get_by_value_parameter_type (f->usage, l); + if (s) { + if (cb_sticky_linkage) { + output_line ("static %s\tcob_parm_l_%d = %s;" + "\t/* sticky linkage for %s */", + s, f->id, + ( f->usage == CB_USAGE_FP_BIN128 + || f->usage == CB_USAGE_FP_DEC128) + ? "{{0, 0}}" : "0", + cb_name (f_tree) + ); + } + sticky_nonp[parmnum] = 1; + } + } + } + if (using_list) { + output_newline (); } /* For calling into a module, cob_call_params may not be known */ if (using_list) { if (entry_convention & CB_CONV_COBOL) { - unsigned int inc = 0; output_line("/* Get current number of call parameters,"); output_line(" if the parameter count is unknown, set it to all */"); if (cb_flag_implicit_init) { @@ -13147,129 +13186,163 @@ output_entry_function (struct cb_program *prog, cb_tree entry, output_line ("if (cob_get_global_ptr ()->cob_current_module) {"); } output_line ("\tcob_call_params = cob_get_global_ptr ()->cob_call_params;"); - if (!cb_sticky_linkage && !prog->flag_chained -#if 0 /* RXWRXW USERFUNC */ - && prog->prog_type != COB_MODULE_TYPE_FUNCTION -#endif - ) { - output_line ("/* Set not passed parameter pointers to NULL */"); - output_line ("switch (cob_call_params) {"); - for (l = using_list; l; l = CB_CHAIN (l)) { - output_line ("case %u:", inc++); - output_line ("\t%s%d = %s;", - CB_PREFIX_BASE, cb_code_field (CB_VALUE (l))->id, - (CB_PURPOSE_INT (l) == CB_CALL_BY_VALUE) - ? "0" : "NULL"); - output_line ("/* Fall through */"); - } - output_line ("default:"); - output_line ("\tbreak; "); - output_line ("}"); - output_newline (); - } output_line ("} else {"); output_line ("\tcob_call_params = %u;", cb_list_length (using_list)); - output_line ("};"); + output_line ("}"); } else { output_line ("/* Set current number of call parameters to max */"); - output_line (" cob_call_params = %u;", cb_list_length (using_list)); - } - output_newline(); - } - - /* - We have to cater for sticky-linkage here at the entry point - site. Doing it in the internal function is too late as we then do not - have the information as to possible ENTRY clauses. - */ - - /* Sticky linkage parameters */ - if (cb_sticky_linkage && using_list) { - for (l = using_list, parmnum = 0; l; l = CB_CHAIN (l), parmnum++) { - cb_tree f_tree = CB_VALUE (l); - f = cb_code_field (f_tree); - sticky_ids[parmnum] = f->id; - if (CB_PURPOSE_INT (l) == CB_CALL_BY_VALUE) { - const char *s = try_get_by_value_parameter_type (f->usage, l); - if (s) { - output_line ("static %s\tcob_parm_l_%d = %s;" - "\t/* sticky linkage for %s */", - s, f->id, - (f->usage == CB_USAGE_FP_BIN128 - || f->usage == CB_USAGE_FP_DEC128) - ? "{{0, 0}}" : "0", - cb_name (f_tree) - ); - sticky_nonp[parmnum] = 1; - } - } + output_line ("cob_call_params = %u;", cb_list_length (using_list)); } + output_newline (); } - /* FIXME: add check for COB_EC_PROGRAM_ARG_MISMATCH here, - including checking for OPTIONAL items. - See comment in typeck.c (cb_build_identifier), too. */ - - /* Sticky linkage set up */ - if (cb_sticky_linkage && using_list) { + /* Sticky linkage set up */ + if (using_list + && (cb_sticky_linkage + || (entry_convention & CB_CONV_COBOL)) + && !prog->flag_chained +#if 0 /* RXWRXW USERFUNC */ + && prog->prog_type != COB_MODULE_TYPE_FUNCTION +#endif + ) { output_line ("/* Set the parameter list */"); parmnum = 0; - output_line ("switch (cob_call_params) {"); - for (l = using_list; l; l = CB_CHAIN (l), parmnum++) { - output_prefix (); - output ("case %u:", parmnum); - output_newline (); + if (cb_sticky_linkage) { + if (entry_convention & CB_CONV_COBOL) { + output_line ("switch (cob_call_params) {"); + for (l = using_list; l; l = CB_CHAIN (l), parmnum++) { + output_line ("case %u:", parmnum); + output_indent_level += indent_adjust_level; + for (n = 0; n < parmnum; ++n) { + if (sticky_nonp[n]) { + output_line ("cob_parm_l_%d = %s%d;", + sticky_ids[n], CB_PREFIX_BASE, + sticky_ids[n]); + output_line ("cob_parm_%d = (cob_u8_ptr)&cob_parm_l_%d;", + sticky_ids[n], + sticky_ids[n]); + } else { + output_line ("cob_parm_%d = %s%d;", + sticky_ids[n], CB_PREFIX_BASE, + sticky_ids[n]); + } + } + output_line ("break;"); + output_indent_level -= indent_adjust_level; + } + output_prefix (); + output ("default:"); + output_newline (); + output_indent_level += indent_adjust_level; + } else { + parmnum = cb_list_length (using_list); + } for (n = 0; n < parmnum; ++n) { if (sticky_nonp[n]) { - output_line ("\tcob_parm_l_%d = %s%d;", + output_line ("cob_parm_l_%d = %s%d;", sticky_ids[n], CB_PREFIX_BASE, sticky_ids[n]); - output_line ("\tcob_parm_%d = (cob_u8_ptr)&cob_parm_l_%d;", + output_line ("cob_parm_%d = (cob_u8_ptr)&cob_parm_l_%d;", sticky_ids[n], sticky_ids[n]); } else { - output_line ("\tcob_parm_%d = %s%d;", + output_line ("cob_parm_%d = %s%d;", sticky_ids[n], CB_PREFIX_BASE, sticky_ids[n]); } } - output_line ("\tbreak;"); - } - output_prefix (); - output ("default:"); - output_newline (); - for (n = 0; n < parmnum; ++n) { - if (sticky_nonp[n]) { - output_line ("\tcob_parm_l_%d = %s%d;", - sticky_ids[n], CB_PREFIX_BASE, - sticky_ids[n]); - output_line ("\tcob_parm_%d = (cob_u8_ptr)&cob_parm_l_%d;", - sticky_ids[n], - sticky_ids[n]); - } else { - output_line ("\tcob_parm_%d = %s%d;", - sticky_ids[n], CB_PREFIX_BASE, - sticky_ids[n]); + if (entry_convention & CB_CONV_COBOL) { + output_line ("break;"); + output_indent_level -= indent_adjust_level; + output_line ("}"); + } + } else if (entry_convention & CB_CONV_COBOL) { + for (l = using_list; l; l = CB_CHAIN (l), parmnum++) { + if (sticky_nonp[parmnum]) { + continue; + } + output_line ("if (cob_call_params > %u) {", parmnum); + output_indent_level += indent_adjust_level; + output_line ("cob_parm_%d = %s%d;", + sticky_ids[parmnum], CB_PREFIX_BASE, + sticky_ids[parmnum]); + output_indent_level -= indent_adjust_level; + output_line ("}"); } } - output_line ("\tbreak;"); - output ("}"); output_newline (); } - if (cb_sticky_linkage) { - s_prefix = "cob_parm_"; - } else { - s_prefix = CB_PREFIX_BASE; + /* runtime checks for parameters not passed / bad size */ + if (CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_MISMATCH)) { + parmnum = 0; + for (l = using_list; l; l = CB_CHAIN (l), parmnum++) { + if (!sticky_nonp[parmnum]) { + cb_tree f_tree = CB_VALUE (l); + f = cb_code_field (f_tree); + if (!cb_field_variable_size (f) + && (entry_convention & CB_CONV_COBOL)) { + /* for COBOL and fixed-length: more detailed check including size */ + /* "module" structure not available + output_source_reference (f_tree, STMT_ENTRY); */ + const unsigned int stmt_ref = cb_flag_source_location ? + COB_SET_LINE_FILE (f_tree->source_line, + lookup_source (f_tree->source_file)) + : 0; + const char *mod_src = source_cache ? "st_source_files" : "NULL"; + if (cb_flag_c_line_directives) { + output_cobol_info (f_tree); + } + output_line ("if (cob_check_linkage_size (\"%s\", \"%s\", %u, %u, %lu, %s, %u)) {", + entry_name, cb_name (f_tree), parmnum + 1, + cb_sticky_linkage || cb_using_optional != CB_OK || f->flag_is_pdiv_opt, + (unsigned long)f->size, + mod_src, stmt_ref); + if (cb_flag_c_line_directives) { + output_c_info (); + } + if (prog->flag_void) { + output_line ("\treturn;"); + } else { + output_line ("\treturn -1;"); + } + output_line ("}"); + } else + if (!cb_sticky_linkage + && cb_using_optional == CB_OK + && !f->flag_is_pdiv_opt) { + output_line ("if (%s%d == NULL) {", + (entry_convention & CB_CONV_COBOL) + ? "cob_parm_" : CB_PREFIX_BASE, + sticky_ids[parmnum]); + /* "module" structure not available + output_source_reference (f_tree, STMT_ENTRY); */ + output_line ("\tcob_check_linkage (NULL, \"%s\", 0);", + cb_name (f_tree)); + if (prog->flag_void) { + output_line ("\treturn;"); + } else { + output_line ("\treturn -1;"); + } + output_line ("}"); + } + } + } } - - for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) { - f2 = cb_code_field (CB_VALUE (l2)); - if (CB_PURPOSE_INT (l2) == CB_CALL_BY_VALUE - && ( f2->usage == CB_USAGE_POINTER - || f2->usage == CB_USAGE_PROGRAM_POINTER)) { - output_line ("ptr_%d = %s%d;", - f2->id, s_prefix, f2->id); + + if (!cb_sticky_linkage + && (entry_convention & CB_CONV_COBOL)) { + for (l2 = using_list; l2; l2 = CB_CHAIN (l2)) { + f2 = cb_code_field (CB_VALUE (l2)); + if (CB_PURPOSE_INT (l2) == CB_CALL_BY_VALUE + && ( f2->usage == CB_USAGE_POINTER + || f2->usage == CB_USAGE_PROGRAM_POINTER)) { + output_line ("ptr_%d = %s%d;", + f2->id, + (entry_convention & CB_CONV_COBOL) + ? "cob_parm_" : CB_PREFIX_BASE, + f2->id); + } } } @@ -13296,16 +13369,31 @@ output_entry_function (struct cb_program *prog, cb_tree entry, if (strcasecmp (f1->name, f2->name) == 0) { switch (CB_PURPOSE_INT (l2)) { case CB_CALL_BY_VALUE: - if (f2->usage == CB_USAGE_POINTER || - f2->usage == CB_USAGE_PROGRAM_POINTER) { - output (", (cob_u8_ptr)&ptr_%d", f2->id); - break; + if (cb_sticky_linkage) { + if (f2->usage == CB_USAGE_POINTER + || f2->usage == CB_USAGE_PROGRAM_POINTER) { + output (", (cob_u8_ptr)&cob_parm_%d", f2->id); + } else { + output (", (cob_u8_ptr)cob_parm_%d", f2->id); + } + } else { + if ((f2->usage == CB_USAGE_POINTER + || f2->usage == CB_USAGE_PROGRAM_POINTER) + && (entry_convention & CB_CONV_COBOL)) { + output (", (cob_u8_ptr)&ptr_%d", f2->id); + } else { + output (", (cob_u8_ptr)&%s%d", + CB_PREFIX_BASE, f2->id); + } } - /* Fall through */ + break; case CB_CALL_BY_REFERENCE: case CB_CALL_BY_CONTENT: output (", %s%s%d", - s_type[n], s_prefix, f2->id); + s_type[n], + cb_sticky_linkage || (entry_convention & CB_CONV_COBOL) + ? "cob_parm_" : CB_PREFIX_BASE, + f2->id); break; default: break; @@ -13315,8 +13403,7 @@ output_entry_function (struct cb_program *prog, cb_tree entry, } if (l2 == NULL) { if (cb_sticky_linkage) { - output (", %s%d", - s_prefix, f1->id); + output (", cob_parm_%d", f1->id); } else { output (", NULL"); } diff --git a/cobc/config.def b/cobc/config.def index 82d7c4594..ae70c6bc2 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -374,6 +374,9 @@ CB_CONFIG_SUPPORT (cb_call_convention_mnemonic, "call-convention-mnemonic", CB_CONFIG_SUPPORT (cb_call_convention_linkage, "call-convention-linkage", _("specifying call-convention by WITH ... LINKAGE")) +CB_CONFIG_SUPPORT (cb_using_optional, "using-optional", + _("support for PROCEDURE DIVISION USING OPTIONAL")) + CB_CONFIG_SUPPORT (cb_numeric_value_for_edited_item, "numeric-value-for-edited-item", _("numeric literals in VALUE clause of numeric-edited items")) diff --git a/cobc/parser.y b/cobc/parser.y index d304ace1c..b77193c93 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -11154,11 +11154,18 @@ _procedure_optional: } | OPTIONAL { - if (call_mode != CB_CALL_BY_REFERENCE) { - cb_error (_("OPTIONAL only allowed for BY REFERENCE items")); - $$ = cb_int0; + if (cb_verify (cb_using_optional, "USING OPTIONAL")) { + if (cb_using_optional == CB_WARNING) { + cb_using_optional = CB_OK; /* tested for with exception checking */ + } + if (call_mode != CB_CALL_BY_REFERENCE) { + cb_error (_("OPTIONAL only allowed for BY REFERENCE items")); + $$ = cb_int0; + } else { + $$ = cb_int1; + } } else { - $$ = cb_int1; + $$ = cb_int0; } } ; @@ -14340,7 +14347,23 @@ exit_statement: exit_body: /* empty */ %prec SHIFT_PREFER { - /* TODO: add warning/error if there's another statement in the paragraph */ + /* TODO: add dialect specific warning/error if there's another statement in + the same sentence / procedure; if there is another statement _after_ this + statement in the same procedure then the following generates bad code + */ + +#if 0 /* activating this code makes an "assumption" (see above) which is reasonable + but not guaranteed to be correct, and breaks SQ21A and ST133A */ + /* Generate code for implicit exit of the last paragraph/section + used with "PERFORM THRU" */ + if (current_paragraph) { + emit_statement (cb_build_perform_exit (current_paragraph)); + } + if (current_section) { + emit_statement (cb_build_perform_exit (current_section)); + } +#endif + } | PROGRAM goback_exit_body { diff --git a/cobc/typeck.c b/cobc/typeck.c index 21e8a245f..ddc3f567a 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2567,21 +2567,22 @@ cb_build_identifier (cb_tree x, const int subchk) } if (CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_OMITTED) && p->storage == CB_STORAGE_LINKAGE - && p->flag_is_pdiv_parm -#if 0 - /* note: we can only ignore the check for fields with flag_is_pdiv_opt - when we check for COB_EC_PROGRAM_ARG_MISMATCH in all entry points - and this check is currently completely missing... */ - && !(p->flag_is_pdiv_opt && CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_MISMATCH) -#endif - ) { - current_statement->null_check = CB_BUILD_FUNCALL_3 ( - "cob_check_linkage", - cb_build_address (cb_build_field_reference (p, NULL)), - CB_BUILD_STRING0 ( - CB_REFERENCE (cb_build_name_reference (p, f))->word->name), - cb_int1); - optimize_defs[COB_CHK_LINKAGE] = 1; + && p->flag_is_pdiv_parm) { + if (!p->flag_is_pdiv_opt && cb_using_optional == CB_OK + && CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_MISMATCH)) { + /* we don't need to check for missing argument, if we already + check this on entry - done if COB_EC_PROGRAM_ARG_MISMATCH + is enabled, OPTIONAL is not set, but the dialect support option + for USING OPTIONAL is given */ + } else { + current_statement->null_check = CB_BUILD_FUNCALL_3 ( + "cob_check_linkage", + cb_build_address (cb_build_field_reference (p, NULL)), + CB_BUILD_STRING0 ( + CB_REFERENCE (cb_build_name_reference (p, f))->word->name), + cb_int1); + optimize_defs[COB_CHK_LINKAGE] = 1; + } } else if (CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL) && !current_statement->flag_no_based) { @@ -13178,6 +13179,11 @@ search_set_keys (struct cb_field *f, cb_tree x) } } + if (!CB_BINARY_OP_P (x)) { + cb_error_x (x, _("invalid SEARCH ALL condition")); + return 1; + } + p = CB_BINARY_OP (x); switch (p->op) { case '&': @@ -13198,11 +13204,12 @@ search_set_keys (struct cb_field *f, cb_tree x) if (CB_REF_OR_FIELD_P (p->y)) { fldy = CB_FIELD_PTR (p->y); } +#if 0 /* validated in the parser */ if (!fldx && !fldy) { - cb_error_x (CB_TREE (current_statement), - _("invalid SEARCH ALL condition")); + cb_error_x (CB_TREE (p), _("invalid SEARCH ALL condition")); return 1; } +#endif for (i = 0; i < f->nkeys; ++i) { if (fldx == CB_FIELD_PTR (f->keys[i].key)) { @@ -13221,15 +13228,13 @@ search_set_keys (struct cb_field *f, cb_tree x) } } if (i == f->nkeys) { - cb_error_x (CB_TREE (current_statement), - _("invalid SEARCH ALL condition")); + cb_error_x (x, _("SEARCH ALL requires comparision of KEY field")); return 1; } } break; default: - cb_error_x (CB_TREE (current_statement), - _("invalid SEARCH ALL condition")); + cb_error_x (x, _("invalid SEARCH ALL condition")); return 1; } return 0; diff --git a/config/ChangeLog b/config/ChangeLog index 3d6428ec1..2baf2f7fd 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,4 +1,8 @@ +2023-07-25 Simon Sobisch + + * general: add option using-optional + 2023-06-25 Chuck Haatvedt FR #439: dialect option to support justify for IBM compatibility diff --git a/config/acu-strict.conf b/config/acu-strict.conf index e8b94810a..f1f521602 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -262,6 +262,7 @@ numeric-value-for-edited-item: error # not verified yet reference-out-of-declaratives: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable incorrect-conf-sec-order: error define-constant-directive: unconformable free-redefines-position: unconformable diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index d5f347f83..4db799012 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -258,6 +258,7 @@ reference-out-of-declaratives: error program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable diff --git a/config/cobol2002.conf b/config/cobol2002.conf index b1313ee42..1943f9218 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -257,6 +257,7 @@ reference-out-of-declaratives: error program-prototypes: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 94ed5b9b1..c24530200 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -257,6 +257,7 @@ reference-out-of-declaratives: error program-prototypes: ok call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error diff --git a/config/cobol85.conf b/config/cobol85.conf index e31610b99..dd9ed5e66 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -257,6 +257,7 @@ reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error diff --git a/config/default.conf b/config/default.conf index 2f5d5d100..2bb1f985c 100644 --- a/config/default.conf +++ b/config/default.conf @@ -278,6 +278,7 @@ reference-out-of-declaratives: warning program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: ok +using-optional: ok numeric-value-for-edited-item: ok incorrect-conf-sec-order: ok define-constant-directive: archaic diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 87a1345f4..82acacf1c 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2021, 2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2021, 2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman, David Declerck, Fabrice Le Fessant, Nicolas Berthier # @@ -256,6 +256,7 @@ reference-out-of-declaratives: error program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index 4a92ba432..0d664d768 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -256,6 +256,7 @@ reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable diff --git a/config/lax.conf-inc b/config/lax.conf-inc index 40d3738e4..b9475b27c 100644 --- a/config/lax.conf-inc +++ b/config/lax.conf-inc @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2021 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -113,6 +113,7 @@ reference-out-of-declaratives: +warning program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: ok +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 6a71507df..e058757d0 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -260,6 +260,7 @@ reference-out-of-declaratives: warning # not verified yet program-prototypes: ok call-convention-mnemonic: ok call-convention-linkage: unconformable +using-optional: ok numeric-value-for-edited-item: error incorrect-conf-sec-order: ok define-constant-directive: unconformable diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index 1ad2e3246..4f6034575 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -256,6 +256,7 @@ reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable diff --git a/config/realia-strict.conf b/config/realia-strict.conf index 133d985a8..6f4dfb901 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -261,6 +261,7 @@ 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 incorrect-conf-sec-order: error define-constant-directive: unconformable diff --git a/config/rm-strict.conf b/config/rm-strict.conf index d582c59ea..cff60f905 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -263,6 +263,7 @@ reference-out-of-declaratives: error # TO-DO: error when referring to non-USE- program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: unconformable diff --git a/config/xopen.conf b/config/xopen.conf index 8cc310d42..22b2a1451 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2023 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -276,6 +276,7 @@ reference-out-of-declaratives: error # not verified yet program-prototypes: unconformable call-convention-mnemonic: unconformable call-convention-linkage: unconformable +using-optional: unconformable numeric-value-for-edited-item: error incorrect-conf-sec-order: error define-constant-directive: error diff --git a/configure.ac b/configure.ac index bdccf1656..477f877ce 100644 --- a/configure.ac +++ b/configure.ac @@ -25,7 +25,7 @@ dnl AC_PREREQ([2.67]) # note: 2.67 is the one found in old msys, 2.69 is commonly available AC_INIT([GnuCOBOL], - [3.2-dev], + [3.2], [bug-gnucobol@gnu.org], [gnucobol], [https://www.gnu.org/software/gnucobol/]) @@ -179,6 +179,7 @@ AH_TEMPLATE([HAVE_RESIZE_TERM], [curses has resize_term function]) AH_TEMPLATE([HAVE_DEFINE_KEY], [curses has define_key function]) AH_TEMPLATE([HAVE_MOUSEINTERVAL], [curses has mouseinterval function]) AH_TEMPLATE([HAVE_HAS_MOUSE], [curses has has_mouse function]) +AH_TEMPLATE([HAVE_MOUSEMASK], [curses has mousemask function and mmask_t definition]) AH_TEMPLATE([HAVE_CURSES_FREEALL], [curses provides function to free all memory]) AH_TEMPLATE([HAVE_USE_LEGACY_CODING], [ncurses has use_legacy_coding function]) AH_TEMPLATE([HAVE_DESIGNATED_INITS], [Has designated initializers]) @@ -1529,6 +1530,28 @@ if test "$USE_CURSES" != no -a "$USE_CURSES" != "not_found"; then [AC_DEFINE([HAVE_HAS_MOUSE], [1]) AC_MSG_RESULT([yes])], [AC_MSG_RESULT([no])], []) + + AC_MSG_CHECKING([for curses mousemask function and mmask_t]) + AC_LINK_IFELSE([AC_LANG_PROGRAM([[ + #ifdef HAVE_NCURSESW_NCURSES_H + #include + #elif defined (HAVE_NCURSESW_CURSES_H) + #include + #elif defined (HAVE_NCURSES_H) + #include + #elif defined (HAVE_NCURSES_NCURSES_H) + #include + #elif defined (HAVE_PDCURSES_H) + #include + #elif defined (HAVE_CURSES_H) + #include + #endif]], [[ + mmask_t dummy = { 0 }; + mousemask (dummy, NULL); + ]])], + [AC_DEFINE([HAVE_MOUSEMASK], [1]) AC_MSG_RESULT([yes])], + [AC_MSG_RESULT([no])], + []) fi LIBS="$curr_libs $LIBCOB_LIBS" diff --git a/libcob/ChangeLog b/libcob/ChangeLog index d1f073635..c47fc3186 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,24 @@ +2023-07-28 Simon Sobisch + + * screenio.c, common.c: replace use of NCURSES_MOUSE_VERSION by + HAVE_MOUSEMASK + +2023-07-27 Chuck Haatvedt + + * move.c (cob_move_display_to_packed): fix data corruption caused + by packing one extra digit from the input display field + +2023-07-25 Simon Sobisch + + * common.c (cob_check_linkage_size), common.h: new function + to check for EC-PROGRAM-ARG-MISMATCH + * common.c (raise_arg_mismatch): new function to provide a "virtual" + module entry for better error messages + * common.c (call_exit_handlers_and_terminate, cob_runtime_error): + pass information about arguments to handlers written in COBOL + * common.c (cob_stack_trace_internal): slightly improved stack output + 2023-07-24 Simon Sobisch * fileio.c: only check -1 as invalid fd; return fileio status for diff --git a/libcob/common.c b/libcob/common.c index a70cbe336..eef27ffc1 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -115,8 +115,6 @@ #include #define COB_GEN_SCREENIO #elif defined (HAVE_PDCURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #define COB_GEN_SCREENIO @@ -129,6 +127,12 @@ #endif #endif +#if defined (__PDCURSES__) +/* Note: PDC will internally define NCURSES_MOUSE_VERSION with + a recent version when PDC_NCMOUSE was defined; + for older version define manually! */ +#endif + #if defined (WITH_XML2) #include #include @@ -2333,7 +2337,6 @@ cob_set_exception (const int id) strcpy (excp_para, mod->paragraph_name); cobglobptr->last_exception_paragraph = excp_para; } - return; } } else { cobglobptr->cob_got_exception = 0; @@ -2999,8 +3002,15 @@ static void call_exit_handlers_and_terminate (void) { if (exit_hdlrs != NULL) { - struct exit_handlerlist* h = exit_hdlrs; + struct exit_handlerlist *h = exit_hdlrs; while (h != NULL) { + /* ensure that exit handlers set their own locations */ + cob_source_file = NULL; + cob_source_line = 0; + /* tell 'em they are not called with any parameters */ + cobglobptr->cob_call_params = 0; + + /* actual call and starting next iteration */ h->proc (); h = h->next; } @@ -4165,18 +4175,115 @@ cob_check_fence (const char *fence_pre, const char *fence_post, } } +/* raise argument mismatch after pushing a temporary static "current module" + as COB_MODULE_PTR; caller needs to restore pop it afterwards! */ +static int +raise_arg_mismatch (const char *entry_name, + const char **module_sources, unsigned int module_stmt) +{ + static cob_module mod_temp; + + cob_module *mod = &mod_temp; + + memset (mod, 0, sizeof (cob_module)); + mod->next = COB_MODULE_PTR; + mod->module_name = entry_name; /* not correct, but enough */ + mod->module_sources = module_sources; + mod->statement = STMT_ENTRY; + mod->module_stmt = module_stmt; + COB_MODULE_PTR = mod; + + cob_set_exception (COB_EC_PROGRAM_ARG_MISMATCH); + + if (cobglobptr->cob_stmt_exception) { + /* CALL has ON EXCEPTION so return to caller */ + cobglobptr->cob_stmt_exception = 0; + return 0; + } + return 1; +} + +/* validates that the data item 'name' was passed by the caller + and has at least as much size as used in the callee, + used during CALL in the entry points of the callee to check + for COB_EC_PROGRAM_ARG_MISMATCH */ +int +cob_check_linkage_size (const char *entry_name, + const char *name, const unsigned int ordinal_pos, + const int optional, const unsigned long size, + const char **module_sources, unsigned int module_stmt) +{ + /* name includes '' already and can be ... 'x' of 'y' */ + + if (!cobglobptr || !COB_MODULE_PTR) { + /* unlikely case: runtime not initialized, or we have no module + so caller _must_ be something other than a GnuCOBOL module + (while ENTRY-CONVENTION is COBOL) -> skip these checks */ + /* possibly raise (an optional) runtime warning */ + return 0; + } else if (cobglobptr->cob_call_params < ordinal_pos) { + if (optional) { + return 0; + } else { + if (raise_arg_mismatch (entry_name, module_sources, module_stmt)) { + cob_runtime_error (_("LINKAGE item %s not passed by caller"), name); + cob_hard_failure (); + } + COB_MODULE_PTR = COB_MODULE_PTR->next; + } + return -1; + } else { + /* note: the current module points to the caller, as we + are early in the called function (its entry point) */ + const cob_field *parameter = COB_MODULE_PTR->cob_procedure_params[ordinal_pos - 1]; + if (!parameter || !parameter->data) { + if (optional) { + return 0; + } else { + if (raise_arg_mismatch (entry_name, module_sources, module_stmt)) { + cob_runtime_error (_("LINKAGE item %s not passed by caller"), name); + cob_hard_failure (); + } + COB_MODULE_PTR = COB_MODULE_PTR->next; + } + return -1; + } else { + if (parameter->size < size) { + if (raise_arg_mismatch (entry_name, module_sources, module_stmt)) { + cob_runtime_error (_("LINKAGE item %s (size %lu) too small in the caller (size %lu)"), + name, size, (unsigned long) parameter->size); + cob_hard_failure (); + } + COB_MODULE_PTR = COB_MODULE_PTR->next; + return -1; + } else if ((unsigned long)parameter->size != size) { + /* possible warning that can additionally be activated */ + } + } + } + return 0; +} + +/* validates that the data item 'name' has a non-null data 'x', + used for both CALL (COB_EC_PROGRAM_ARG_MISMATCH) and + for actual use of the argument (COB_EC_PROGRAM_ARG_OMITTED) */ void cob_check_linkage (const unsigned char *x, const char *name, const int check_type) { if (!x) { /* name includes '' already and can be ... 'x' of 'y' */ switch (check_type) { - case 0: /* check for passed items and size on module entry */ - /* TODO: raise exception */ + case 0: /* check for passed items on module entry */ + cob_set_exception (COB_EC_PROGRAM_ARG_MISMATCH); + if (cobglobptr->cob_stmt_exception) { + /* CALL has ON EXCEPTION so return to caller */ + cobglobptr->cob_stmt_exception = 0; + return; + } cob_runtime_error (_("LINKAGE item %s not passed by caller"), name); break; case 1: /* check for passed OPTIONAL items on item use */ - /* TODO: raise exception */ + cob_set_exception (COB_EC_PROGRAM_ARG_OMITTED); cob_runtime_error (_("LINKAGE item %s not passed by caller"), name); break; } @@ -5992,11 +6099,15 @@ cob_tidy (void) /* System routines */ +/* CBL_EXIT_PROC - register exit handlers that will be called + before teardown (after posible error procedures) without + any parameters passed + 'dispo': intallation flag (add/remove/priority) + 'pptr': function / ENTRY point to be called */ int cob_sys_exit_proc (const void *dispo, const void *pptr) { - struct exit_handlerlist *hp; - struct exit_handlerlist *h; + struct exit_handlerlist *hp, *h; unsigned char install_flag; /* only initialized to silence -Wmaybe-uninitialized */ unsigned char priority = 0; @@ -6114,11 +6225,15 @@ cob_sys_exit_proc (const void *dispo, const void *pptr) return 0; } +/* CBL_ERROR_PROC - register error handlers that will be called + on runtime errors and may early-stop, those are called with a single + parameter containing the error message + 'dispo': intallation flag (add/remove/priority) + 'pptr': function / ENTRY point to be called */ int cob_sys_error_proc (const void *dispo, const void *pptr) { - struct handlerlist *hp; - struct handlerlist *h; + struct handlerlist *hp, *h; const unsigned char *x; int (**p) (char *s); @@ -8724,6 +8839,8 @@ cob_runtime_error (const char *fmt, ...) const char *err_source_file; unsigned int err_source_line, err_module_statement = 0; cob_module_ptr err_module_pointer = NULL; + cob_field *err_module_param0 = NULL; + cob_field err_field = {COB_ERRBUF_SIZE, NULL, &const_alpha_attr }; int call_params = cobglobptr->cob_call_params; /* save error location */ @@ -8731,6 +8848,8 @@ cob_runtime_error (const char *fmt, ...) if (COB_MODULE_PTR) { err_module_pointer = COB_MODULE_PTR; err_module_statement = COB_MODULE_PTR->module_stmt; + err_module_param0 = COB_MODULE_PTR->cob_procedure_params[0]; + COB_MODULE_PTR->cob_procedure_params[0] = &err_field; } /* run registered error handlers */ @@ -8747,6 +8866,7 @@ cob_runtime_error (const char *fmt, ...) /* fresh error buffer with guaranteed size */ char local_err_str[COB_ERRBUF_SIZE]; memcpy (local_err_str, runtime_err_str, COB_ERRBUF_SIZE); + err_field.data = (unsigned char *)local_err_str; /* ensure that error handlers set their own locations */ cob_source_file = NULL; @@ -8765,6 +8885,7 @@ cob_runtime_error (const char *fmt, ...) COB_MODULE_PTR = err_module_pointer; if (COB_MODULE_PTR) { COB_MODULE_PTR->module_stmt = err_module_statement; + COB_MODULE_PTR->cob_procedure_params[0] = err_module_param0; } cobglobptr->cob_call_params = call_params; } @@ -9102,8 +9223,10 @@ get_screenio_and_mouse_info (char *version_buffer, size_t size, const int verbos mouse_support = _("no"); } } -#elif defined (NCURSES_MOUSE_VERSION) +#elif defined (HAVE_MOUSEMASK) #if defined (__PDCURSES__) + /* CHECKME: that looks wrong - can't we test as above? + Double check with older PDCurses! */ mouse_support = _("yes"); #endif #else @@ -10367,12 +10490,12 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) if (count > 0 && count == i) { break; } + write_or_return_arr (file_no, " "); if (mod->module_stmt != 0 && mod->module_sources) { const unsigned int source_file_num = COB_GET_FILE_NUM (mod->module_stmt); const unsigned int source_line = COB_GET_LINE_NUM (mod->module_stmt); const char *source_file = mod->module_sources[source_file_num]; - write_or_return_arr (file_no, " "); if (!verbose) { write_or_return_str (file_no, mod->module_name); write_or_return_arr (file_no, " at "); @@ -10458,7 +10581,12 @@ cob_stack_trace_internal (FILE *target, int verbose, int count) } write_or_return_arr (file_no, "\""); write_or_return_str (file_no, mod->module_name); - write_or_return_arr (file_no, "\" unknown"); + if (mod->statement != STMT_UNKNOWN) { + write_or_return_arr (file_no, "\" was "); + write_or_return_str (file_no, cob_statement_name[mod->statement]); + } else { + write_or_return_arr (file_no, "\" unknown"); + } } else { write_or_return_str (file_no, mod->module_name); write_or_return_arr (file_no, " at unknown"); diff --git a/libcob/common.h b/libcob/common.h index d643bc565..c01965eff 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1889,7 +1889,10 @@ COB_EXPIMP void cob_check_ref_mod (const int, const int, COB_EXPIMP void cob_check_beyond_exit (const char *); COB_EXPIMP void cob_check_fence (const char *, const char *, const enum cob_statement, const char *); - +COB_EXPIMP int cob_check_linkage_size (const char *, + const char *, const unsigned int, + const int, const unsigned long, + const char **, unsigned int); /* Comparison functions */ COB_EXPIMP int cob_numeric_cmp (cob_field *, cob_field *); diff --git a/libcob/move.c b/libcob/move.c index 877d7890d..c8216ba68 100644 --- a/libcob/move.c +++ b/libcob/move.c @@ -554,6 +554,10 @@ cob_move_display_to_packed (cob_field *f1, cob_field *f2) p += 2; } } + /* 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); diff --git a/libcob/screenio.c b/libcob/screenio.c index b64223f8b..3197019a2 100644 --- a/libcob/screenio.c +++ b/libcob/screenio.c @@ -55,26 +55,18 @@ #include #define WITH_EXTENDED_SCREENIO #elif defined (HAVE_PDCURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #define WITH_EXTENDED_SCREENIO #elif defined (HAVE_PDCURSES_CURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #define WITH_EXTENDED_SCREENIO #elif defined (HAVE_XCURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #define WITH_EXTENDED_SCREENIO #elif defined (HAVE_XCURSES_CURSES_H) -/* will internally define NCURSES_MOUSE_VERSION with - a recent version (for older version define manually): */ #define PDC_NCMOUSE /* use ncurses compatible mouse API */ #include #define WITH_EXTENDED_SCREENIO @@ -87,6 +79,12 @@ #define WITH_EXTENDED_SCREENIO #endif +#if defined (__PDCURSES__) +/* Note: PDC will internally define NCURSES_MOUSE_VERSION with + a recent version when PDC_NCMOUSE was defined; + for older version define manually! */ +#endif + /* work around broken system headers or compile flags defining NCURSES_WIDECHAR / PDC_WIDE but not including the actual definitions */ #if defined (NCURSES_WIDECHAR) && !defined (WACS_HLINE) @@ -106,7 +104,7 @@ #ifdef HAVE_CURSES_FREEALL extern void _nc_freeall (void); #endif -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK static mmask_t cob_mask_accept; /* mask that is returned to COBOL ACCEPT */ static mmask_t cob_mask_routine; /* mask that is returned to COBOL routines (reserved) */ #if defined BUTTON5_PRESSED /* added in NCURSES_MOUSE_VERSION 2 */ @@ -164,7 +162,7 @@ static int accept_cursor_x; static int pending_accept; static int got_sys_char; static unsigned int curr_setting_insert_mode = INT_MAX; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK static unsigned int curr_setting_mouse_flags = UINT_MAX; #endif #endif @@ -2147,7 +2145,7 @@ find_field_by_pos (const int initial_curs, const int line, const int column) { return -1; } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK static int mouse_to_exception_code (mmask_t mask) { int fret = -1; @@ -2397,7 +2395,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) int integer_part_end; char sign; int fix_position = 0; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK MEVENT mevent; #endif @@ -2429,7 +2427,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) } } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* prevent warnings about not intialized structure */ memset (&mevent, 0, sizeof (MEVENT)); #endif @@ -2458,7 +2456,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) goto screen_return; } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* get mouse event here, handle later */ if (keyp == KEY_MOUSE) { getmouse (&mevent); @@ -2722,7 +2720,7 @@ cob_screen_get_all (const int initial_curs, const int accept_timeout) /* Enter sign */ break; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK case KEY_MOUSE: { int mline = mevent.y; @@ -3401,7 +3399,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum int status; chtype prompt_char; /* prompt character */ chtype default_prompt_char; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK MEVENT mevent; #endif @@ -3421,7 +3419,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum origin_y = 0; origin_x = 0; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* prevent warnings about not intialized structure */ memset (&mevent, 0, sizeof (MEVENT)); #endif @@ -3636,7 +3634,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum continue; } -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK /* get mouse event here, handle later */ if (keyp == KEY_MOUSE) { getmouse (&mevent); @@ -3722,7 +3720,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum /* End key. */ fret = 2015; goto field_return; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK case KEY_MOUSE: { int mline = mevent.y; @@ -3949,7 +3947,7 @@ field_accept (cob_field *f, cob_flags_t fattr, const int sline, const int scolum cob_move_cursor (cline, ccolumn); continue; -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK case KEY_MOUSE: { int mline = mevent.y; @@ -4965,7 +4963,7 @@ cob_settings_screenio (void) #ifdef HAVE_MOUSEINTERVAL mouseinterval (COB_MOUSE_INTERVAL); #endif -#ifdef NCURSES_MOUSE_VERSION +#ifdef HAVE_MOUSEMASK if (curr_setting_mouse_flags != COB_MOUSE_FLAGS) { mmask_t mask_applied = cob_mask_routine; if (COB_MOUSE_FLAGS) { diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index 06d73c844..9a417b0f5 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -515,6 +515,7 @@ test.conf: missing definitions: no definition of 'program-prototypes' no definition of 'call-convention-mnemonic' no definition of 'call-convention-linkage' + no definition of 'using-optional' no definition of 'numeric-value-for-edited-item' no definition of 'incorrect-conf-sec-order' no definition of 'define-constant-directive' diff --git a/tests/testsuite.src/data_packed.at b/tests/testsuite.src/data_packed.at index 24b3694bc..674d8125b 100644 --- a/tests/testsuite.src/data_packed.at +++ b/tests/testsuite.src/data_packed.at @@ -830,13 +830,34 @@ AT_DATA([prog.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - 01 D-S99V99 PIC S99V99 DISPLAY VALUE 1.23. - 01 D-N99V99 PIC S99V99 DISPLAY VALUE -1.32. - 01 D-9V99 PIC 9V99 DISPLAY VALUE 1.1. - 01 D-S99 PIC S99 DISPLAY VALUE 12. - 01 D-99 PIC 99 DISPLAY VALUE 2. - 01 D-P99 PIC P99 DISPLAY VALUE 0.02. - 01 D-9PP PIC 9PP DISPLAY VALUE 200. + 01 FILLER. + 05 FILLER PIC XX VALUE '12'. + 05 D-S99V99 PIC S99V99 DISPLAY VALUE 1.23. + 05 FILLER PIC XX VALUE '34'. + 01 FILLER. + 05 FILLER PIC XX VALUE '12'. + 05 D-N99V99 PIC S99V99 DISPLAY VALUE -1.32. + 05 FILLER PIC XX VALUE '34'. + 01 FILLER. + 05 FILLER PIC XX VALUE '12'. + 05 D-9V99 PIC 9V99 DISPLAY VALUE 1.1. + 05 FILLER PIC XX VALUE '34'. + 01 FILLER. + 05 FILLER PIC XX VALUE '12'. + 05 D-S99 PIC S99 DISPLAY VALUE 12. + 05 FILLER PIC XX VALUE '34'. + 01 FILLER. + 05 FILLER PIC XX VALUE '12'. + 05 D-99 PIC 99 DISPLAY VALUE 2. + 05 FILLER PIC XX VALUE '34'. + 01 FILLER. + 05 FILLER PIC XX VALUE '12'. + 05 D-P99 PIC P99 DISPLAY VALUE 0.02. + 05 FILLER PIC XX VALUE '34'. + 01 FILLER. + 05 FILLER PIC XX VALUE '12'. + 05 D-9PP PIC 9PP DISPLAY VALUE 200. + 05 FILLER PIC XX VALUE '34'. 01 P-S99V99 PIC S99V99 PACKED-DECIMAL. 01 P-99V9 PIC 99V9 PACKED-DECIMAL. 01 P-S999 PIC S999 PACKED-DECIMAL. diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 12fd22133..e937044f8 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -2182,9 +2182,9 @@ AT_DATA([callee.cob], [ 01 Y PIC X. 01 Z PIC X. PROCEDURE DIVISION - USING W X Y Z. - DISPLAY NUMBER-OF-CALL-PARAMETERS - END-DISPLAY. + USING OPTIONAL W + X Y Z. + DISPLAY NUMBER-OF-CALL-PARAMETERS. EXIT PROGRAM. ]) @@ -2198,27 +2198,53 @@ AT_DATA([caller.cob], [ 01 Y PIC X. 01 Z PIC X. PROCEDURE DIVISION. - CALL "callee" - END-CALL. - CALL "callee" USING W - END-CALL. - CALL "callee" USING W X - END-CALL. - CALL "callee" USING W X Y - END-CALL. - CALL "callee" USING W X Y Z - END-CALL. + CALL "callee". + CALL "callee" USING W. + CALL "callee" USING W X. + CALL "callee" USING W X Y. + CALL "callee" USING W X Y OMITTED. + CALL "callee" USING W X Y Z. STOP RUN. ]) AT_CHECK([$COMPILE caller.cob], [0], [], []) -AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) + +# having USING OPTIONAL not supported leads to only check on use +AT_CHECK([$COMPILE_MODULE -fusing-optional=skip callee.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./caller], [0], [+000000000 +000000001 +000000002 +000000003 +000000004 ++000000004 +], []) + +# no argument check leads to only check on use +AT_CHECK([$COMPILE_MODULE -fno-ec=program-arg-mismatch callee.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./caller], [0], +[+000000000 ++000000001 ++000000002 ++000000003 ++000000004 ++000000004 +], []) + +# sticky linkage leads to only check on use +AT_CHECK([$COMPILE_MODULE -fsticky-linkage callee.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./caller], [0], +[+000000000 ++000000001 ++000000002 ++000000003 ++000000004 ++000000004 +], []) + +AT_CHECK([$COMPILE_MODULE callee.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./caller], [1], [], +[libcob: callee.cob:12: error: LINKAGE item X not passed by caller ]) AT_CLEANUP diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index 641076f57..1f290a7a4 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -1197,7 +1197,7 @@ AT_CLEANUP AT_SETUP([ASSIGN DYNAMIC with data item in LINKAGE]) -AT_KEYWORDS([runfile-CONTROL file status]) +AT_KEYWORDS([runfile-CONTROL file status CALL]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -1249,7 +1249,7 @@ AT_DATA([prog.cob], [ 01 REC-NUM PIC 9(4). 01 CUST-STAT PIC X(2). - PROCEDURE DIVISION USING s-path, REC-NUM, CUST-STAT. + PROCEDURE DIVISION USING OPTIONAL s-path, REC-NUM, CUST-STAT. IF ADDRESS OF s-path = NULL SET ADDRESS OF s-path TO ADDRESS OF z-path END-IF. @@ -1297,7 +1297,7 @@ AT_DATA([prog.cob], [ LINKAGE SECTION. 01 s-path PIC X(80). - PROCEDURE DIVISION USING s-path. + PROCEDURE DIVISION USING OPTIONAL s-path. OPEN OUTPUT f IF IO-STS NOT = "00" DISPLAY "Opened error: " IO-STS "." @@ -1341,7 +1341,7 @@ AT_DATA([prog2.cob], [ LINKAGE SECTION. 01 s-path PIC X(80). - PROCEDURE DIVISION USING s-path. + PROCEDURE DIVISION USING OPTIONAL s-path. OPEN OUTPUT f GOBACK. END PROGRAM TSTOPEN. diff --git a/tests/testsuite.src/run_fundamental.at b/tests/testsuite.src/run_fundamental.at index a88b6cf61..767556ad4 100644 --- a/tests/testsuite.src/run_fundamental.at +++ b/tests/testsuite.src/run_fundamental.at @@ -1,7 +1,7 @@ ## Copyright (C) 2003-2012, 2014-2015, 2017-2020, 2022-2023 ## Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, -## Ron Norman +## Ron Norman, Denis HUGONNARD-ROCHE, Chuck Haatvedt ## ## This file is part of GnuCOBOL. ## @@ -1556,12 +1556,13 @@ some (void) AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([$COMPILE_MODULE module.c], [0], [], []) -# CHECKME: the waning itself is likely system specific, -# in this case re-adjust to only check for a warning -AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], -[libcob: prog.cob:6: warning: loading from existing path './module.so' failed; ./module.so: undefined symbol: module -libcob: prog.cob:6: error: entry point 'module' not found +# the warning itself is very system specific, so disable it, +# then run again checking only for the warning +AT_CHECK([COB_DISABLE_WARNINGS=1 $COBCRUN_DIRECT ./prog], [1], [], +[libcob: prog.cob:6: error: entry point 'module' not found ]) +AT_CHECK([$COBCRUN_DIRECT ./prog 2> err.log], [1], [], []) +AT_CHECK([$GREP "libcob: prog.cob:6: warning: " err.log], [0], ignore, []) AT_CLEANUP @@ -6315,7 +6316,7 @@ AT_CLEANUP AT_SETUP([DISPLAY with P fields]) -AT_KEYWORDS([runmisc pretty-display pretty-printing pretty PACKED-DECIMAL]) +AT_KEYWORDS([fundamental runmisc pretty-display pretty-printing pretty PACKED-DECIMAL]) # this test verifies that the size is correctly printed, which was buggy # with "P on the left side of the decimal point", see bug #874 @@ -6400,8 +6401,8 @@ AT_CHECK([$COBCRUN_DIRECT ./packed], [0], AT_CLEANUP -AT_SETUP([Condition IS ZERO AND]) -AT_KEYWORDS([IF]) +AT_SETUP([condition IS ZERO AND]) +AT_KEYWORDS([fundamental IF]) # for more details see bug #875 @@ -6452,7 +6453,7 @@ AT_CLEANUP AT_SETUP([abbreviated conditions with multiple words operators]) -AT_KEYWORDS([IF]) +AT_KEYWORDS([fundamental IF]) # for more details see bug #880 @@ -6490,7 +6491,7 @@ AT_CLEANUP AT_SETUP([abbreviated conditions with multiple words operators]) -AT_KEYWORDS([IF]) +AT_KEYWORDS([fundamental IF]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -6518,7 +6519,7 @@ AT_CLEANUP AT_SETUP([MOVE with JUSTIFIED clause]) -AT_KEYWORDS([RIGHT]) +AT_KEYWORDS([fundamental RIGHT]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. @@ -6560,3 +6561,2566 @@ AT_CHECK([$COMPILE -Wno-truncate prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP + + +AT_SETUP([MOVE with PICTURE P]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. Move_Basic_P_Pic . + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> Basic checking of P Picture + *> -check lengt content and move + *>---------------------------------------------------------------- + *> + DATA DIVISION. + WORKING-STORAGE SECTION. + *> + 01 P-PIC-1 PIC 99P(4) . + 01 P-PIC-1-9 REDEFINES P-PIC-1 PIC 9(02) . + 01 FLD-1 PIC 9(06) . + 01 FLD-1-RES PIC 9(06) . + *> + 01 P-PIC-2 PIC S99P(4) . + 01 P-PIC-2-9 REDEFINES P-PIC-2 PIC S9(02) . + 01 FLD-2 PIC S9(06) . + 01 FLD-2-RES PIC S9(06) . + *> + 01 P-PIC-3 PIC P(4)9 . + 01 P-PIC-3-9 REDEFINES P-PIC-3 PIC 9(01) . + 01 FLD-3 PIC V9(05) . + 01 FLD-3-RES PIC V9(05) . + *> + 01 P-PIC-4 PIC SP(4)9 . + 01 P-PIC-4-9 REDEFINES P-PIC-4 PIC S9(01) . + 01 FLD-4 PIC SV9(05) . + 01 FLD-4-RES PIC SV9(05) . + *> + 01 W01-I PIC 9(02) . + *> + PROCEDURE DIVISION . + *> + *> Check Length + *> + PERFORM CHECK-LENGTH . + *> + PERFORM CHECK-CONTENT. + *> + PERFORM CHECK-MOVE . + *> + GOBACK . + *> + CHECK-CONTENT. + *>------------ + *> + MOVE 123456 TO P-PIC-1 . + IF P-PIC-1-9 NOT = 12 + THEN + DISPLAY 'Error C1 VALUE <' P-PIC-1-9 '> != 12' . + *> + MOVE 345678 TO P-PIC-2 . + IF P-PIC-2-9 NOT = 34 + THEN + DISPLAY 'Error C2 VALUE <' P-PIC-2-9 '> != 34' . + *> + MOVE -456789 TO P-PIC-2 . + IF P-PIC-2-9 NOT = -45 + THEN + DISPLAY 'Error C3 VALUE <' P-PIC-2-9 '> != -45' . + *> + MOVE 0.12345 TO P-PIC-3 . + IF P-PIC-3-9 NOT = 5 + THEN + DISPLAY 'Error C4 VALUE <' P-PIC-3-9 '> != 5' . + *> + MOVE 0.56789 TO P-PIC-4 . + IF P-PIC-4-9 NOT = 9 + THEN + DISPLAY 'Error C5 VALUE <' P-PIC-4-9 '> != 9' . + *> + MOVE -0.34567 TO P-PIC-4 . + IF P-PIC-4-9 NOT = -7 + THEN + DISPLAY 'Error C6 VALUE <' P-PIC-4-9 '> != -7' . + *> + CHECK-MOVE . + *>---------- + *> + MOVE 123456 TO P-PIC-1 . + MOVE P-PIC-1 TO FLD-1 . + MOVE 120000 TO FLD-1-RES . + IF FLD-1 NOT = FLD-1-RES + THEN + DISPLAY 'M1 <' FLD-1-RES '> != ' FLD-1 . + *> + MOVE 001234 TO P-PIC-1 . + MOVE P-PIC-1 TO FLD-1 . + MOVE 000000 TO FLD-1-RES . + IF FLD-1 NOT = FLD-1-RES + THEN + DISPLAY 'M2 <' FLD-1-RES '> != ' FLD-1 . + *>----------------------------------- + MOVE 001234 TO P-PIC-2 . + MOVE P-PIC-2 TO FLD-2 . + MOVE 000000 TO FLD-2-RES . + IF FLD-2 NOT = FLD-2-RES + THEN + DISPLAY 'M3 <' FLD-2-RES '> != ' FLD-2 . + *> + MOVE -005678 TO P-PIC-2 . + MOVE P-PIC-2 TO FLD-2 . + MOVE 000000 TO FLD-2-RES . + IF FLD-2 NOT = FLD-2-RES + THEN + DISPLAY 'M4 <' FLD-2-RES '> != ' FLD-2 . + *> + MOVE 456789 TO P-PIC-2 . + MOVE P-PIC-2 TO FLD-2 . + MOVE 450000 TO FLD-2-RES . + IF FLD-2 NOT = FLD-2-RES + THEN + DISPLAY 'M5 <' FLD-2-RES '> != ' FLD-2 . + *> + MOVE -456789 TO P-PIC-2 . + MOVE P-PIC-2 TO FLD-2 . + MOVE -450000 TO FLD-2-RES . + IF FLD-2 NOT = FLD-2-RES + THEN + DISPLAY 'M6 <' FLD-2-RES '> != ' FLD-2 . + *>----------------------------------- + MOVE 0.12345 TO P-PIC-3 . + MOVE P-PIC-3 TO FLD-3 . + MOVE 0.00005 TO FLD-3-RES . + IF FLD-3 NOT = FLD-3-RES + THEN + DISPLAY 'M7 <' FLD-3-RES '> != ' FLD-3 . + *> + MOVE 0.00010 TO P-PIC-3 . + MOVE P-PIC-3 TO FLD-3 . + MOVE 0.00000 TO FLD-3-RES . + IF FLD-3 NOT = FLD-3-RES + THEN + DISPLAY 'M8 <' FLD-3-RES '> != ' FLD-3 . + *> + *>----------------------------------- + *> + MOVE 0.23456 TO P-PIC-4 . + MOVE P-PIC-4 TO FLD-4 . + MOVE 0.00006 TO FLD-4-RES . + IF FLD-4 NOT = FLD-4-RES + THEN + DISPLAY 'M9 <' FLD-4-RES '> != ' FLD-4 . + *> + MOVE 0.02340 TO P-PIC-4 . + MOVE P-PIC-4 TO FLD-4 . + MOVE 0.00000 TO FLD-4-RES . + IF FLD-4 NOT = FLD-4-RES + THEN + DISPLAY 'M10 <' FLD-4-RES '> != ' FLD-4 . + *> + MOVE -0.12345 TO P-PIC-4 . + MOVE P-PIC-4 TO FLD-4 . + MOVE -0.00005 TO FLD-4-RES . + IF FLD-4 NOT = FLD-4-RES + THEN + DISPLAY 'M11 <' FLD-4-RES '> != ' FLD-4 . + *> + MOVE -0.34560 TO P-PIC-4 . + MOVE P-PIC-4 TO FLD-4 . + MOVE 0.00000 TO FLD-4-RES . + IF FLD-4 NOT = FLD-4-RES + THEN + DISPLAY 'M11 <' FLD-4-RES '> != ' FLD-4 . + *> + *>----------------------------------- + *> + CHECK-LENGTH. + *>----------- + *> + MOVE LENGTH OF P-PIC-1 TO W01-I . + IF W01-I NOT = 2 + THEN + DISPLAY 'Error 1 size <' W01-I '> !=2' . + *> + MOVE LENGTH OF P-PIC-2 TO W01-I . + IF W01-I NOT = 2 + THEN + DISPLAY 'Error 2 size <' W01-I '> !=2' . + *> + MOVE LENGTH OF P-PIC-3 TO W01-I . + IF W01-I NOT = 1 + THEN + DISPLAY 'Error 3 size <' W01-I '> !=1' . + *> + + MOVE LENGTH OF P-PIC-4 TO W01-I . + IF W01-I NOT = 1 + THEN + DISPLAY 'Error 4 size <' W01-I '> !=1' . +]) + +AT_CHECK([$COMPILE -Wno-truncate prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE with de-editting to USAGE DISPLAY]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. MoveDeEditing. + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> CHECK DE-EDITING + *> Receiving field is NUMERIC DISPLAY Type + *>---------------------------------------------------------------- + *> + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 EDIT-1 PIC $(4)9.99CR. + 01 DISP-1 PIC S9(4)V99. + 01 EDIT-2 PIC --9B.99B99/99. + 01 DISP-2 PIC S99V9(6). + + + PROCEDURE DIVISION . + + MOVE -123.45 TO EDIT-1 . + MOVE EDIT-1 TO DISP-1 . + IF DISP-1 NOT = -123.45 + THEN + DISPLAY 'Error 1: DISP-1 <' DISP-1 '> != -0123.45' . + + IF EDIT-1 NOT = " $123.45CR" + THEN + DISPLAY 'Error 2: EDIT-1 <' EDIT-1 '> != < $123.45CR>'. + + MOVE -42.9876 TO EDIT-2. + MOVE EDIT-2 TO DISP-2. + IF DISP-2 NOT = -42.987600 + THEN + DISPLAY 'Error 3: DISP-2 <' DISP-2 '> != <-42.987600>'. + + IF EDIT-2 NOT = "-42 .98 76/00" + THEN + DISPLAY 'Error 4: EDIT-2 <' EDIT-2 '> != <-42 .98 76/00>'. + + + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE with de-editting to DECIMAL IS COMMA]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. MoveDeEditing_2 . + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> CHECK DE-EDITING WITH DECIMAL-POINT IS COMMA + *> Receiving fied is display type + *>---------------------------------------------------------------- + *> + + ENVIRONMENT DIVISION . + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + + WORKING-STORAGE SECTION. + 01 EDIT-1 PIC $(4)9,99CR. + 01 DISP-1 PIC S9(4)V99. + 01 EDIT-2 PIC --9B,99B99/99. + 01 DISP-2 PIC S99V9(6). + + + PROCEDURE DIVISION . + + MOVE -123,45 TO EDIT-1 . + MOVE EDIT-1 TO DISP-1 . + IF DISP-1 NOT = -123,45 + THEN + DISPLAY 'Error 1: DISP-1 <' DISP-1 '> != -0123,45' . + + IF EDIT-1 NOT = " $123,45CR" + THEN + DISPLAY 'Error 2: EDIT-1 <' EDIT-1 '> != < $123,45CR>'. + + MOVE -42,9876 TO EDIT-2. + MOVE EDIT-2 TO DISP-2. + IF DISP-2 NOT = -42,987600 + THEN + DISPLAY 'Error 3: DISP-2 <' DISP-2 '> != <-42,987600>'. + + IF EDIT-2 NOT = "-42 ,98 76/00" + THEN + DISPLAY 'Error 4: EDIT-2 <' EDIT-2 '> != <-42 ,98 76/00>'. + + + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE with de-editting to BINARY]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. MoveDeEditing_3. + DATA DIVISION. + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> CHECK DE-EDITING + *> Receiving fied is binary type + *>---------------------------------------------------------------- + WORKING-STORAGE SECTION. + 01 EDIT-1 PIC $(4)9.99CR. + 01 DISP-1 PIC S9(4)V99 BINARY . + 01 EDIT-2 PIC --9B.99B99/99. + 01 DISP-2 PIC S99V9(6) BINARY . + + + PROCEDURE DIVISION . + + MOVE -123.45 TO EDIT-1 . + MOVE EDIT-1 TO DISP-1 . + IF DISP-1 NOT = -123.45 + THEN + DISPLAY 'Error 1: DISP-1 <' DISP-1 '> != -0123.45' . + + IF EDIT-1 NOT = " $123.45CR" + THEN + DISPLAY 'Error 2: EDIT-1 <' EDIT-1 '> != < $123.45CR>'. + + MOVE -42.9876 TO EDIT-2. + MOVE EDIT-2 TO DISP-2. + IF DISP-2 NOT = -42.987600 + THEN + DISPLAY 'Error 3: DISP-2 <' DISP-2 '> != <-42.987600>'. + + IF EDIT-2 NOT = "-42 .98 76/00" + THEN + DISPLAY 'Error 4: EDIT-2 <' EDIT-2 '> != <-42 .98 76/00>'. + + + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE with de-editting to COMP-3]) +AT_KEYWORDS([fundamental PACKED-DECIMAL]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. MoveDeEditing_4. + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> CHECK DE-EDITING + *> Receiving field is PACKED Type + *>---------------------------------------------------------------- + *> + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 EDIT-1 PIC $(4)9.99CR. + 01 DISP-1 PIC S9(4)V99 COMP-3 . + 01 EDIT-2 PIC --9B.99B99/99. + 01 DISP-2 PIC S99V9(6) COMP-3 . + + + PROCEDURE DIVISION . + + MOVE -123.45 TO EDIT-1 . + MOVE EDIT-1 TO DISP-1 . + IF DISP-1 NOT = -123.45 + THEN + DISPLAY 'Error 1: DISP-1 <' DISP-1 '> != -0123.45' . + + IF EDIT-1 NOT = " $123.45CR" + THEN + DISPLAY 'Error 2: EDIT-1 <' EDIT-1 '> != < $123.45CR>'. + + MOVE -42.9876 TO EDIT-2. + MOVE EDIT-2 TO DISP-2. + IF DISP-2 NOT = -42.987600 + THEN + DISPLAY 'Error 3: DISP-2 <' DISP-2 '> != <-42.987600>'. + + IF EDIT-2 NOT = "-42 .98 76/00" + THEN + DISPLAY 'Error 4: EDIT-2 <' EDIT-2 '> != <-42 .98 76/00>'. + + + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE with de-editting to COMP-5]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. MoveDeEditing_5. + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> CHECK DE-EDITING + *> Receiving field is COMP-5 Type + *>---------------------------------------------------------------- + *> + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 EDIT-1 PIC $(4)9.99CR. + 01 DISP-1 PIC S9(4)V99 COMP-5 . + 01 EDIT-2 PIC --9B.99B99/99. + 01 DISP-2 PIC S99V9(6) COMP-5 . + + + PROCEDURE DIVISION . + + MOVE -123.45 TO EDIT-1 . + MOVE EDIT-1 TO DISP-1 . + IF DISP-1 NOT = -123.45 + THEN + DISPLAY 'Error 1: DISP-1 <' DISP-1 '> != -0123.45' . + + IF EDIT-1 NOT = " $123.45CR" + THEN + DISPLAY 'Error 2: EDIT-1 <' EDIT-1 '> != < $123.45CR>'. + + MOVE -42.9876 TO EDIT-2. + MOVE EDIT-2 TO DISP-2. + IF DISP-2 NOT = -42.987600 + THEN + DISPLAY 'Error 3: DISP-2 <' DISP-2 '> != <-42.987600>'. + + IF EDIT-2 NOT = "-42 .98 76/00" + THEN + DISPLAY 'Error 4: EDIT-2 <' EDIT-2 '> != <-42 .98 76/00>'. + + + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE with de-editting to NUMERIC DISPLAY (2)]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. MoveEditedToDisplay. + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> Add more test case for edited field + *>---------------------------------------------------------------- + *> + + ENVIRONMENT DIVISION. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + 01 EDITED-FIELD . + + + 05 SRC-FIELD-100 PIC +$ZZ9999900BB9 . + 05 SRC-FIELD-101 PIC -$ZZ9999900BB9 . + 05 SRC-FIELD-102 PIC $ZZ9999900BB9CR . + 05 SRC-FIELD-103 PIC $ZZ9999900BB9DB . + 05 SRC-FIELD-400 PIC +$**9999900BB9 . + 05 SRC-FIELD-401 PIC -$**9999900BB9 . + 05 SRC-FIELD-402 PIC $**9999900BB9CR . + 05 SRC-FIELD-403 PIC $**9999900BB9DB . + * + 01 DST-FIELD. + 05 DST-FIELD-1 PIC 9(10)V9(04) . + 05 DST-FIELD-2 PIC S9(10)V9(04) . + * + PROCEDURE DIVISION. + *>------------------- + *> + MOVE 12345 TO SRC-FIELD-100 . + MOVE SRC-FIELD-100 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 1234005 + DISPLAY '1: DST-FIELD-1 <' DST-FIELD-1 '> != 1234005' . + *> + MOVE 23456 TO SRC-FIELD-101 . + MOVE SRC-FIELD-101 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 2345006 + DISPLAY '2: DST-FIELD-1 <' DST-FIELD-1 '> != 2345006' . + *> + MOVE 34567 TO SRC-FIELD-102 . + MOVE SRC-FIELD-102 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 3456007 + DISPLAY '3: DST-FIELD-1 <' DST-FIELD-1 '> != 3456007' . + *> + MOVE 45678 TO SRC-FIELD-103 . + MOVE SRC-FIELD-103 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 4567008 + DISPLAY '4: DST-FIELD-1 <' DST-FIELD-1 '> != 4567008' . + *> + *>-------------------------------------------------------------- + *> + MOVE -12345 TO SRC-FIELD-100 . + MOVE SRC-FIELD-100 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = 1234005 + DISPLAY '5: DST-FIELD-2 <' DST-FIELD-2 '> != 1234005' . + *> + MOVE -23456 TO SRC-FIELD-101 . + MOVE SRC-FIELD-101 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = -2345006 + DISPLAY '6: DST-FIELD-2 <' DST-FIELD-2 '> != -2345006' . + *> + MOVE -34567 TO SRC-FIELD-102 . + MOVE SRC-FIELD-102 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = -3456007 + DISPLAY '7: DST-FIELD-2 <' DST-FIELD-2 '> != -3456007' . + *> + MOVE -45678 TO SRC-FIELD-103 . + MOVE SRC-FIELD-103 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = 4567008 + DISPLAY '8: DST-FIELD-2 <' DST-FIELD-2 '> != 45676008' . + *> + *>-------------------------------------------------------------- + *> + MOVE 12345 TO SRC-FIELD-400 . + MOVE SRC-FIELD-400 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 1234005 + DISPLAY '9: DST-FIELD-1 <' DST-FIELD-1 '> != 1234005' . + *> + MOVE 23456 TO SRC-FIELD-401 . + MOVE SRC-FIELD-401 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 2345006 + DISPLAY '10: DST-FIELD-1 <' DST-FIELD-1 '> != 2345006' . + *> + MOVE 34567 TO SRC-FIELD-402 . + MOVE SRC-FIELD-402 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 3456007 + DISPLAY '11: DST-FIELD-1 <' DST-FIELD-1 '> != 3456007' . + *> + MOVE 45678 TO SRC-FIELD-403 . + MOVE SRC-FIELD-403 TO DST-FIELD-1 . + IF DST-FIELD-1 NOT = 4567008 + DISPLAY '12: DST-FIELD-1 <' DST-FIELD-1 '1 != 45676008' . + *> + MOVE -12345 TO SRC-FIELD-400 . + MOVE SRC-FIELD-400 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = 1234005 + DISPLAY '13: DST-FIELD-2 <' DST-FIELD-2 '> != 1234005' . + *> + MOVE -23456 TO SRC-FIELD-401 . + MOVE SRC-FIELD-401 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = -2345006 + DISPLAY '14: DST-FIELD-2 <' DST-FIELD-2 '> != -2345006' . + *> + MOVE -34567 TO SRC-FIELD-402 . + MOVE SRC-FIELD-402 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = -3456007 + DISPLAY '15: DST-FIELD-2 <' DST-FIELD-2 '> != -3456007' . + *> + MOVE -45678 TO SRC-FIELD-403 . + MOVE SRC-FIELD-403 TO DST-FIELD-2 . + IF DST-FIELD-2 NOT = 4567008 + DISPLAY '16: DST-FIELD-2 <' DST-FIELD-2 '> != 4567008' . + *> + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE misc. edited]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID . MoveOtherCases . + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> Last several specifics test cases + *>---------------------------------------------------------------- + *> + ENVIRONMENT DIVISION. + *>------------- + + DATA DIVISION . + *>-------------- + + WORKING-STORAGE SECTION. + *>----------------------- + + 01 SRC-BIN PIC S9(09) BINARY . + 01 DST-BIN PIC 9(09) BINARY . + *> + 01 SRC-EDIT PIC $$$$,$$9V99- . + 01 DST-DISP PIC 9(06) . + *> + 01 DST-FIELD-1 PIC XB0XB099/ . + + *> + PROCEDURE DIVISION . + *>------------------- + *> + *> Case 1 move unsigned to signed + *> + MOVE -12345678 TO SRC-BIN . + MOVE SRC-BIN TO DST-BIN . + IF DST-BIN NOT = 12345678 + THEN + DISPLAY '1: DST-BIN <' DST-BIN '>!= <12345678>' . + + *> + *> Case 2 move negative edited to display + *> + MOVE -3 TO SRC-EDIT . + MOVE SRC-EDIT TO DST-DISP . + IF SRC-EDIT NOT = ' $300-' + THEN + DISPLAY '2: SRC-EDIT <' SRC-EDIT '> != < $300->' . + *> + IF DST-DISP NOT = 3 + THEN + DISPLAY '2.1: DST-DISP <' DST-DISP '> != <3>' . + + + *> + *> Case 3 cob_move alphanum to edited case + *> + MOVE 3 TO SRC-EDIT . + MOVE SRC-EDIT TO DST-FIELD-1 . + + IF DST-FIELD-1 NOT = ' 0 0 /' + THEN + DISPLAY '3: DST-FIELD-1 <' DST-FIELD-1 '> != < 0 0 />'. + + *> + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +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-SHORT FLOAT-DECIMAL-16 FLOAT-DECIMAL-34 +FLOAT-SHORT SIGNED-INT SIGNED-LONG SIGNED-SHORT +UNSIGNED-INT UNSIGNED-LONG UNSIGNED-SHORT]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID . MoveTestCobMove . + *>---------------------------------------------------------------- + *> This programm cover the cob_move function for numeric + *> data types except numeric edited + *>---------------------------------------------------------------- + *> + ENVIRONMENT DIVISION. + DATA DIVISION . + WORKING-STORAGE SECTION. + + 01 ALL-SRC . + 05 FIELD-02 BINARY-C-LONG SIGNED . + 05 FIELD-03 BINARY-C-LONG UNSIGNED . + 05 FIELD-04 BINARY-CHAR SIGNED . + 05 FIELD-05 BINARY-CHAR UNSIGNED . + 05 FIELD-06 BINARY-DOUBLE SIGNED . + 05 FIELD-07 BINARY-DOUBLE UNSIGNED . + 05 FIELD-08 BINARY-INT . + 05 FIELD-09 BINARY-LONG SIGNED . + 05 FIELD-10 BINARY-LONG UNSIGNED . + 05 FIELD-11 BINARY-LONG-LONG . + 05 FIELD-12 BINARY-SHORT SIGNED . + 05 FIELD-13 BINARY-SHORT UNSIGNED . + 05 FIELD-14 FLOAT-DECIMAL-16 . + 05 FIELD-15 FLOAT-DECIMAL-34 . + 05 FIELD-16 FLOAT-LONG . + 05 FIELD-17 FLOAT-SHORT . + 05 FIELD-18 SIGNED-INT . + 05 FIELD-19 SIGNED-LONG . + 05 FIELD-20 SIGNED-SHORT . + 05 FIELD-21 UNSIGNED-INT . + 05 FIELD-22 UNSIGNED-LONG . + 05 FIELD-23 UNSIGNED-SHORT . + 05 FIELD-24 COMP-1 . + 05 FIELD-25 COMP-2 . + 05 FIELD-26 PIC 9(10) COMP-6 . + 05 FIELD-50 PIC S9(09) BINARY . + 05 FIELD-51 PIC S9(09) COMP . + 05 FIELD-52 PIC S9(09)V99 COMP-3 . + 05 FIELD-53 PIC S9(09) COMP-4 . + 05 FIELD-54 PIC S9(09) COMP-5 . + 05 FIELD-55 PIC S9(09) COMP-X . + 05 FIELD-56 PIC S9(09)V99 DISPLAY . + *> + 01 EXPTD-RESULT PIC 9(09) . + *> + 01 ALL-DST . + 05 FIELD-02 BINARY-C-LONG SIGNED . + 05 FIELD-03 BINARY-C-LONG UNSIGNED . + 05 FIELD-04 BINARY-CHAR SIGNED . + 05 FIELD-05 BINARY-CHAR UNSIGNED . + 05 FIELD-06 BINARY-DOUBLE SIGNED . + 05 FIELD-07 BINARY-DOUBLE UNSIGNED . + 05 FIELD-08 BINARY-INT . + 05 FIELD-09 BINARY-LONG SIGNED . + 05 FIELD-10 BINARY-LONG UNSIGNED . + 05 FIELD-11 BINARY-LONG-LONG . + 05 FIELD-12 BINARY-SHORT SIGNED . + 05 FIELD-13 BINARY-SHORT UNSIGNED . + 05 FIELD-14 FLOAT-DECIMAL-16 . + 05 FIELD-15 FLOAT-DECIMAL-34 . + 05 FIELD-16 FLOAT-LONG . + 05 FIELD-17 FLOAT-SHORT . + 05 FIELD-18 SIGNED-INT . + 05 FIELD-19 SIGNED-LONG . + 05 FIELD-20 SIGNED-SHORT . + 05 FIELD-21 UNSIGNED-INT . + 05 FIELD-22 UNSIGNED-LONG . + 05 FIELD-23 UNSIGNED-SHORT . + 05 FIELD-24 COMP-1 . + 05 FIELD-25 COMP-2 . + 05 FIELD-26 PIC 9(10) COMP-6 . + 05 FIELD-50 PIC S9(09) BINARY . + 05 FIELD-51 PIC S9(09) COMP . + 05 FIELD-52 PIC S9(09)V99 COMP-3 . + 05 FIELD-53 PIC S9(09) COMP-4 . + 05 FIELD-54 PIC S9(09) COMP-5 . + 05 FIELD-55 PIC S9(09) COMP-X . + 05 FIELD-56 PIC S9(09)V99 DISPLAY . + + *> + PROCEDURE DIVISION . + *> + INITIALIZE ALL-SRC REPLACING NUMERIC BY 1 . + PERFORM TEST-PASS-1 . + *> + INITIALIZE ALL-DST REPLACING NUMERIC BY 2 . + PERFORM TEST-PASS-2 . + *> + MOVE 3 TO FIELD-02 OF ALL-SRC . + MOVE 3 TO EXPTD-RESULT . + MOVE FIELD-02 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 4 TO FIELD-03 OF ALL-SRC . + MOVE 4 TO EXPTD-RESULT . + MOVE FIELD-03 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 5 TO FIELD-04 OF ALL-SRC . + MOVE 5 TO EXPTD-RESULT . + MOVE FIELD-04 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 6 TO FIELD-05 OF ALL-SRC . + MOVE 6 TO EXPTD-RESULT . + MOVE FIELD-05 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 7 TO FIELD-06 OF ALL-SRC . + MOVE 7 TO EXPTD-RESULT . + MOVE FIELD-06 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 8 TO FIELD-07 OF ALL-SRC . + MOVE 8 TO EXPTD-RESULT . + MOVE FIELD-07 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 9 TO FIELD-08 OF ALL-SRC . + MOVE 9 TO EXPTD-RESULT . + MOVE FIELD-08 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 10 TO FIELD-09 OF ALL-SRC . + MOVE 10 TO EXPTD-RESULT . + MOVE FIELD-09 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 11 TO FIELD-10 OF ALL-SRC . + MOVE 11 TO EXPTD-RESULT . + MOVE FIELD-10 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 12 TO FIELD-11 OF ALL-SRC . + MOVE 12 TO EXPTD-RESULT . + MOVE FIELD-11 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 13 TO FIELD-12 OF ALL-SRC . + MOVE 13 TO EXPTD-RESULT . + MOVE FIELD-12 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 14 TO FIELD-13 OF ALL-SRC . + MOVE 14 TO EXPTD-RESULT . + MOVE FIELD-13 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 15 TO FIELD-14 OF ALL-SRC . + MOVE 15 TO EXPTD-RESULT . + MOVE FIELD-14 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 16 TO FIELD-15 OF ALL-SRC . + MOVE 16 TO EXPTD-RESULT . + MOVE FIELD-15 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 17 TO FIELD-16 OF ALL-SRC . + MOVE 17 TO EXPTD-RESULT . + MOVE FIELD-16 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 18 TO FIELD-17 OF ALL-SRC . + MOVE 18 TO EXPTD-RESULT . + MOVE FIELD-17 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 19 TO FIELD-18 OF ALL-SRC . + MOVE 19 TO EXPTD-RESULT . + MOVE FIELD-18 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 20 TO FIELD-19 OF ALL-SRC . + MOVE 20 TO EXPTD-RESULT . + MOVE FIELD-19 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 21 TO FIELD-20 OF ALL-SRC . + MOVE 21 TO EXPTD-RESULT . + MOVE FIELD-20 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 22 TO FIELD-21 OF ALL-SRC . + MOVE 22 TO EXPTD-RESULT . + MOVE FIELD-21 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 23 TO FIELD-22 OF ALL-SRC . + MOVE 23 TO EXPTD-RESULT . + MOVE FIELD-22 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 24 TO FIELD-23 OF ALL-SRC . + MOVE 24 TO EXPTD-RESULT . + MOVE FIELD-23 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 25 TO FIELD-24 OF ALL-SRC . + MOVE 25 TO EXPTD-RESULT . + MOVE FIELD-24 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 26 TO FIELD-25 OF ALL-SRC . + MOVE 26 TO EXPTD-RESULT . + MOVE FIELD-25 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 27 TO FIELD-26 OF ALL-SRC . + MOVE 27 TO EXPTD-RESULT . + MOVE FIELD-26 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 50 TO FIELD-50 OF ALL-SRC . + MOVE 50 TO EXPTD-RESULT . + MOVE FIELD-50 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 51 TO FIELD-51 OF ALL-SRC . + MOVE 51 TO EXPTD-RESULT . + MOVE FIELD-51 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 52 TO FIELD-52 OF ALL-SRC . + MOVE 52 TO EXPTD-RESULT . + MOVE FIELD-52 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 53 TO FIELD-53 OF ALL-SRC . + MOVE 53 TO EXPTD-RESULT . + MOVE FIELD-53 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 54 TO FIELD-54 OF ALL-SRC . + MOVE 54 TO EXPTD-RESULT . + MOVE FIELD-54 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 55 TO FIELD-55 OF ALL-SRC . + MOVE 55 TO EXPTD-RESULT . + MOVE FIELD-55 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + MOVE 56 TO FIELD-56 OF ALL-SRC . + MOVE 56 TO EXPTD-RESULT . + MOVE FIELD-56 OF ALL-SRC + TO FIELD-02 OF ALL-DST + FIELD-03 OF ALL-DST + FIELD-04 OF ALL-DST + FIELD-05 OF ALL-DST + FIELD-06 OF ALL-DST + FIELD-07 OF ALL-DST + FIELD-08 OF ALL-DST + FIELD-09 OF ALL-DST + FIELD-10 OF ALL-DST + FIELD-11 OF ALL-DST + FIELD-12 OF ALL-DST + FIELD-13 OF ALL-DST + FIELD-14 OF ALL-DST + FIELD-15 OF ALL-DST + FIELD-16 OF ALL-DST + FIELD-17 OF ALL-DST + FIELD-18 OF ALL-DST + FIELD-19 OF ALL-DST + FIELD-20 OF ALL-DST + FIELD-21 OF ALL-DST + FIELD-22 OF ALL-DST + FIELD-23 OF ALL-DST + FIELD-24 OF ALL-DST + FIELD-25 OF ALL-DST + FIELD-26 OF ALL-DST + FIELD-50 OF ALL-DST + FIELD-51 OF ALL-DST + FIELD-52 OF ALL-DST + FIELD-53 OF ALL-DST + FIELD-54 OF ALL-DST + FIELD-55 OF ALL-DST + FIELD-56 OF ALL-DST . + PERFORM TEST-PASS-3 . + *> + GOBACK . + *> + TEST-PASS-1. + *>---------- + *> + IF FIELD-02 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-02 <' FIELD-02 OF + ALL-SRC '> != 1' . + *> + IF FIELD-03 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-03 <' FIELD-03 OF + ALL-SRC '> != 1' . + *> + IF FIELD-04 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-04 <' FIELD-04 OF + ALL-SRC '> != 1' . + *> + IF FIELD-05 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-05 <' FIELD-05 OF + ALL-SRC '> != 1' . + *> + IF FIELD-06 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-06 <' FIELD-06 OF + ALL-SRC '> != 1' . + *> + IF FIELD-07 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-07 <' FIELD-07 OF + ALL-SRC '> != 1' . + *> + IF FIELD-08 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-08 <' FIELD-08 OF + ALL-SRC '> != 1' . + *> + IF FIELD-09 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-09 <' FIELD-09 OF + ALL-SRC '> != 1' . + *> + IF FIELD-10 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-10 <' FIELD-10 OF + ALL-SRC '> != 1' . + *> + IF FIELD-11 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-11 <' FIELD-11 OF + ALL-SRC '> != 1' . + *> + IF FIELD-12 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-12 <' FIELD-12 OF + ALL-SRC '> != 1' . + *> + IF FIELD-13 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-13 <' FIELD-13 OF + ALL-SRC '> != 1' . + *> + IF FIELD-14 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-14 <' FIELD-14 OF + ALL-SRC '> != 1' . + *> + IF FIELD-15 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-15 <' FIELD-15 OF + ALL-SRC '> != 1' . + *> + IF FIELD-16 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-16 <' FIELD-16 OF + ALL-SRC '> != 1' . + *> + IF FIELD-17 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-17 <' FIELD-17 OF + ALL-SRC '> != 1' . + *> + IF FIELD-18 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-18 <' FIELD-18 OF + ALL-SRC '> != 1' . + *> + IF FIELD-19 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-19 <' FIELD-19 OF + ALL-SRC '> != 1' . + *> + IF FIELD-20 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-20 <' FIELD-20 OF + ALL-SRC '> != 1' . + *> + IF FIELD-21 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-21 <' FIELD-21 OF + ALL-SRC '> != 1' . + *> + IF FIELD-22 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-22 <' FIELD-22 OF + ALL-SRC '> != 1' . + *> + IF FIELD-23 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-23 <' FIELD-23 OF + ALL-SRC '> != 1' . + *> + IF FIELD-24 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-24 <' FIELD-24 OF + ALL-SRC '> != 1' . + *> + IF FIELD-25 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-25 <' FIELD-25 OF + ALL-SRC '> != 1' . + *> + IF FIELD-26 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-26 <' FIELD-26 OF + ALL-SRC '> != 1' . + *> + IF FIELD-50 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-50 <' FIELD-50 OF + ALL-SRC '> != 1' . + *> + IF FIELD-51 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-51 <' FIELD-51 OF + ALL-SRC '> != 1' . + *> + IF FIELD-52 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-52 <' FIELD-52 OF + ALL-SRC '> != 1' . + *> + IF FIELD-53 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-53 <' FIELD-52 OF + ALL-SRC '> != 1' . + *> + IF FIELD-54 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-54 <' FIELD-54 OF + ALL-SRC '> != 1' . + *> + IF FIELD-55 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-55 <' FIELD-55 OF + ALL-SRC '> != 1' . + *> + IF FIELD-56 OF ALL-SRC IS NOT = 1 + THEN + DISPLAY 'PASS ONE: FIELD-56 <' FIELD-56 OF + ALL-SRC '> != 1' . + *> + TEST-PASS-2. + *>---------- + *> + IF FIELD-02 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-02 <' FIELD-02 OF + ALL-DST '> != 2' . + *> + IF FIELD-03 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-03 <' FIELD-03 OF + ALL-DST '> != 2' . + *> + IF FIELD-04 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-04 <' FIELD-04 OF + ALL-DST '> != 2' . + *> + IF FIELD-05 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-05 <' FIELD-05 OF + ALL-DST '> != 2' . + *> + IF FIELD-06 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-06 <' FIELD-06 OF + ALL-DST '> != 2' . + *> + IF FIELD-07 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-07 <' FIELD-07 OF + ALL-DST '> != 2' . + *> + IF FIELD-08 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-08 <' FIELD-08 OF + ALL-DST '> != 2' . + *> + IF FIELD-09 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-09 <' FIELD-09 OF + ALL-DST '> != 2' . + *> + IF FIELD-10 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-10 <' FIELD-10 OF + ALL-DST '> != 2' . + *> + IF FIELD-11 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-11 <' FIELD-11 OF + ALL-DST '> != 2' . + *> + IF FIELD-12 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-12 <' FIELD-12 OF + ALL-DST '> != 2' . + *> + IF FIELD-13 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-13 <' FIELD-13 OF + ALL-DST '> != 2' . + *> + IF FIELD-14 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-14 <' FIELD-14 OF + ALL-DST '> != 2' . + *> + IF FIELD-15 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-15 <' FIELD-15 OF + ALL-DST '> != 2' . + *> + IF FIELD-16 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-16 <' FIELD-16 OF + ALL-DST '> != 2' . + *> + IF FIELD-17 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-17 <' FIELD-17 OF + ALL-DST '> != 2' . + *> + IF FIELD-18 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-18 <' FIELD-18 OF + ALL-DST '> != 2' . + *> + IF FIELD-19 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-19 <' FIELD-19 OF + ALL-DST '> != 2' . + *> + IF FIELD-20 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-20 <' FIELD-20 OF + ALL-DST '> != 2' . + *> + IF FIELD-21 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-21 <' FIELD-21 OF + ALL-DST '> != 2' . + *> + IF FIELD-22 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-22 <' FIELD-22 OF + ALL-DST '> != 2' . + *> + IF FIELD-23 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-23 <' FIELD-23 OF + ALL-DST '> != 2' . + *> + IF FIELD-24 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-24 <' FIELD-24 OF + ALL-DST '> != 2' . + *> + IF FIELD-25 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-25 <' FIELD-25 OF + ALL-DST '> != 2' . + *> + IF FIELD-26 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-26 <' FIELD-26 OF + ALL-DST '> != 2' . + *> + IF FIELD-50 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-50 <' FIELD-50 OF + ALL-DST '> != 2' . + *> + IF FIELD-51 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-51 <' FIELD-51 OF + ALL-DST '> != 2' . + *> + IF FIELD-52 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-52 <' FIELD-52 OF + ALL-DST '> != 2' . + *> + IF FIELD-53 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-53 <' FIELD-52 OF + ALL-DST '> != 2' . + *> + IF FIELD-54 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-54 <' FIELD-54 OF + ALL-DST '> != 2' . + *> + IF FIELD-55 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-55 <' FIELD-55 OF + ALL-DST '> != 2' . + *> + IF FIELD-56 OF ALL-DST IS NOT = 2 + THEN + DISPLAY 'PASS TWO: FIELD-56 <' FIELD-56 OF + ALL-DST '> != 2' . + *> + TEST-PASS-3. + *>---------- + *> + IF FIELD-02 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-02 <' FIELD-02 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-03 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-03 <' FIELD-03 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-04 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-04 <' FIELD-04 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + + *> + IF FIELD-05 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-05 <' FIELD-05 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-06 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-06 <' FIELD-06 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-07 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-07 <' FIELD-07 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-08 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-08 <' FIELD-08 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-09 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-09 <' FIELD-09 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-10 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-10 <' FIELD-10 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-11 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-11 <' FIELD-11 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-12 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-12 <' FIELD-12 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-13 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-13 <' FIELD-13 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-14 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-14 <' FIELD-14 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-15 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-15 <' FIELD-15 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-16 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-16 <' FIELD-16 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-17 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-17 <' FIELD-17 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-18 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-18 <' FIELD-18 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-19 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-19 <' FIELD-19 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-20 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-20 <' FIELD-20 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-21 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-21 <' FIELD-21 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-22 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-22 <' FIELD-22 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-23 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-23 <' FIELD-23 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-24 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-24 <' FIELD-24 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-25 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-25 <' FIELD-25 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-26 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-26 <' FIELD-26 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-50 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-50 <' FIELD-50 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-51 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-51 <' FIELD-51 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-52 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-52 <' FIELD-52 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-53 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-53 <' FIELD-52 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-54 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-54 <' FIELD-54 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-55 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-55 <' FIELD-55 OF + ALL-DST '> != <' EXPTD-RESULT '>' . + *> + IF FIELD-56 OF ALL-DST IS NOT = EXPTD-RESULT + THEN + DISPLAY 'PASS THREE: FIELD-56 <' FIELD-56 OF + ALL-DST '> != <' EXPTD-RESULT '>' . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([MOVE to editted ZERO]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. MoveToEditedZero . + *>---------------------------------------------------------------- + *> Additional test cases for MOVE statement + *> Move To Edited + *> Edited field contains only '*' and sending field is ZERO + *>---------------------------------------------------------------- + *> + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 DISP-1 PIC 999999 . + 01 EDIT-1 PIC ****** . + 01 EDIT-1-X REDEFINES EDIT-1 PIC X(06) . + + *> + PROCEDURE DIVISION . + *> + MOVE 111111 TO EDIT-1 *> avoid init by default + *> + MOVE ZEROES TO DISP-1 . + MOVE DISP-1 TO EDIT-1 . + IF EDIT-1-X NOT = '******' + THEN + DISPLAY 'Error EDIT-1-X <' EDIT-1-X '> != <******>' . + *> + *> + MOVE 123 TO DISP-1 . + MOVE DISP-1 TO EDIT-1 . + IF EDIT-1-X NOT = '***123' + THEN + DISPLAY 'Error EDIT-1-X <' EDIT-1-X '> != <***123>' . + *> + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + +AT_SETUP([SPECIAL-NAMES CLASS]) +AT_KEYWORDS([fundamental]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. TSTCLASS. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION . + SPECIAL-NAMES . + CLASS HEXA IS '0' THRU '9' + 'A' THRU 'F' . + CLASS ODD IS '1' '3' '5' '7' '9' . + + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * * + * NOTICE THAT THE VALUES SUPPLIED ARE NUMERIC LITERALS * + * WHICH REPRESENT A VALUE WHICH IS 1 NUMBER HIGHER THAN * + * THE HEX VALUES WHICH THEY REPRESENT. THIS IS BECAUSE * + * THE ALLOWABLE VALUES ARE FROM 1 THROUGH 256. * + * * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + CLASS EVEN IS 49 51 53 55 57. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 ALPHA PIC X(01) . + 01 NUM-1 PIC 9(01) . + *> + PROCEDURE DIVISION. + *> + MOVE '3' TO ALPHA . + IF ALPHA IS HEXA + THEN + CONTINUE + ELSE + DISPLAY 'ERROR 1' + END-IF. + *> + IF ALPHA IS ODD + THEN + CONTINUE + ELSE + DISPLAY 'ERROR 2' + END-IF. + *> + MOVE 2 TO NUM-1 + IF NUM-1 IS EVEN + THEN + CONTINUE + ELSE + DISPLAY 'ERROR 3' + END-IF. + *> + GOBACK . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index de3b7a6a5..1b0a26de6 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -4041,7 +4041,7 @@ AT_CLEANUP AT_SETUP([Sticky LINKAGE]) -AT_KEYWORDS([runmisc]) +AT_KEYWORDS([runmisc CALL]) AT_DATA([callee.cob], [ IDENTIFICATION DIVISION. @@ -4056,10 +4056,7 @@ AT_DATA([callee.cob], [ SET ADDRESS OF P3 TO ADDRESS OF P2 ELSE IF P3 NOT = "OKOKOK" - DISPLAY P3 - END-DISPLAY - END-IF - END-IF. + DISPLAY P3. EXIT PROGRAM. ]) @@ -4071,12 +4068,10 @@ AT_DATA([caller.cob], [ 01 P1 PIC X VALUE "A". 01 P2 PIC X(6) VALUE "NOT OK". PROCEDURE DIVISION. - CALL "callee" USING P1 P2 - END-CALL. + CALL "callee" USING P1 P2. MOVE "B" TO P1. MOVE "OKOKOK" TO P2. - CALL "callee" USING P1 - END-CALL. + CALL "callee" USING P1. STOP RUN. ]) @@ -4717,7 +4712,6 @@ AT_DATA([callee.cob], [ DISPLAY P1. IF P2 NOT EQUAL "FROM C" DISPLAY P2 - END-DISPLAY ELSE DISPLAY "OK" WITH NO ADVANCING. EXIT PROGRAM. @@ -4786,17 +4780,11 @@ AT_DATA([prog.cob], [ PROCEDURE DIVISION EXTERN USING BY VALUE P1 P2 BY REFERENCE P3. IF P1 NOT EQUAL ADDRESS OF P3 - DISPLAY P1 - END-DISPLAY - END-IF + DISPLAY "P1 != ADDRESS OF P3: " P1. IF P2 NOT EQUAL 42 - DISPLAY P2 - END-DISPLAY - END-IF + DISPLAY "P2 != 42: " P2. IF P3 NOT EQUAL "CALLBACK" - DISPLAY P3 - END-DISPLAY - END-IF + DISPLAY "P3 != CALLBACK: " P3. EXIT PROGRAM. ]) @@ -4820,6 +4808,15 @@ cprog (void *cb) AT_CHECK([$COMPILE -Wno-unfinished -o prog prog.cob cprog.c], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CHECK([$COMPILE -Wno-unfinished -fsticky-linkage -o prog prog.cob cprog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CHECK([$COMPILE -Wno-unfinished -fusing-optional=skip -o prog prog.cob cprog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CHECK([$COMPILE -Wno-unfinished -fusing-optional=skip -fsticky-linkage -o prog prog.cob cprog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + AT_CLEANUP @@ -5244,7 +5241,7 @@ AT_CLEANUP AT_SETUP([ANY LENGTH (5)]) -AT_KEYWORDS([runmisc]) +AT_KEYWORDS([runmisc CALL]) # any length variables resulted in SIGSEGV when module was first program called @@ -5257,7 +5254,7 @@ AT_DATA([subprog.cob], [ 01 str1 PIC X ANY LENGTH. 01 str2 PIC X ANY LENGTH. - PROCEDURE DIVISION USING str1 str2. + PROCEDURE DIVISION USING OPTIONAL str1 OPTIONAL str2. DISPLAY 'IN' WITH NO ADVANCING . END PROGRAM subprog. @@ -5308,7 +5305,7 @@ AT_CLEANUP AT_SETUP([access to OPTIONAL LINKAGE item not passed]) -AT_KEYWORDS([runmisc]) +AT_KEYWORDS([runmisc CALL]) AT_DATA([caller.cob], [ IDENTIFICATION DIVISION. @@ -5317,10 +5314,8 @@ AT_DATA([caller.cob], [ WORKING-STORAGE SECTION. 01 X PIC X(4) VALUE '9876'. PROCEDURE DIVISION. - CALL 'callee' USING X - END-CALL - CALL 'callee' USING OMITTED - END-CALL + CALL 'callee' USING X. + CALL 'callee' USING OMITTED. STOP RUN. ]) @@ -10202,7 +10197,7 @@ AT_CLEANUP AT_SETUP([stack and dump feature]) -AT_KEYWORDS([stacktrace configuration COB_STACKTRACE COB_DUMP_FILE]) +AT_KEYWORDS([stacktrace configuration COB_STACKTRACE COB_DUMP_FILE CALL]) AT_DATA([cpyabrt], [ MOVE "Quick brown fox jumped over the dog" @@ -10370,7 +10365,7 @@ AT_DATA([prog.cob], [ 10 CM-DISK PICTURE X(8). 10 CM-NO-TERMINALS PICTURE 9(4). - PROCEDURE DIVISION USING X, TSPFL-RECORD. + PROCEDURE DIVISION USING X, OPTIONAL TSPFL-RECORD. MAIN-1 SECTION. MOVE ALL "X" TO TSTREC. MOVE 1 TO TSTG-1 (1). diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 63b8b6acf..f030478b2 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -6643,6 +6643,126 @@ AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CLEANUP +AT_SETUP([SEARCH ALL checks]) +AT_KEYWORDS([misc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TAB-1. + 05 TAB-1-ENTRY OCCURS 50 + ASCENDING KEY IS TAB-1-KEY + INDEXED BY TAB-1-INDEX. + 10 TAB-1-KEY. + 15 T1K-SUB1 PIC X(03). + 15 T1K-SUB2 PIC 9(03). + 10 TAB-1-DATA PIC X(50). + 01 TAB-2. + 05 TAB-2-ENTRY OCCURS 50 + INDEXED BY TAB-2-INDEX. + 10 TAB-2-KEY. + 15 T2K-SUB1 PIC X(03). + 15 T2K-SUB2 PIC 9(03). + 10 TAB-2-DATA PIC X(50). + + PROCEDURE DIVISION. + TESTING SECTION. + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN TAB-1-KEY = ALL ZERO + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN TAB-1-KEY (TAB-1-INDEX) = ALL ZERO + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN "ABC123" = TAB-1-KEY (TAB-1-INDEX) + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN TAB-1-KEY (TAB-2-INDEX) = ALL ZERO + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + WHEN TAB-1-KEY (TAB-1-INDEX) = ALL ZERO + CONTINUE + AT END + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN TAB-1-KEY (TAB-1-INDEX) = ALL ZERO + WHEN TAB-1-KEY (TAB-1-INDEX) = "ZZZ999" + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN TESTING + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN T1K-SUB1 (TAB-1-INDEX) = "ZZZ" + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN TAB-2-KEY (TAB-1-INDEX) = ALL ZERO + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN TAB-2-KEY (TAB-2-INDEX) = ALL ZERO + CONTINUE + END-SEARCH + SEARCH ALL TAB-1-ENTRY + AT END + CONTINUE + WHEN "AA" = "BB" + CONTINUE + END-SEARCH + SEARCH ALL TAB-2-ENTRY + AT END + CONTINUE + WHEN TAB-2-KEY (TAB-2-INDEX) = ALL ZERO + CONTINUE + END-SEARCH + . +]) + +AT_CHECK([$COMPILE prog.cob], [1], [], +[prog.cob: in section 'TESTING': +prog.cob:27: error: 'TAB-1-KEY' requires one subscript +prog.cob:51: error: syntax error, unexpected AT END +prog.cob:53: error: syntax error, unexpected END-SEARCH +prog.cob:58: error: syntax error, unexpected WHEN +prog.cob:64: error: 'TESTING' is not a field +prog.cob:70: error: SEARCH ALL requires comparision of KEY field +prog.cob:76: error: SEARCH ALL requires comparision of KEY field +prog.cob:82: error: SEARCH ALL requires comparision of KEY field +prog.cob:88: warning: expression 'AA' EQUALS 'BB' is always FALSE +prog.cob:88: error: invalid SEARCH ALL condition +prog.cob:91: error: SEARCH ALL requires KEY phrase +prog.cob:15: note: 'TAB-2-ENTRY' defined here +]) +AT_CLEANUP + + AT_SETUP([Invalid parentheses around condition]) AT_KEYWORDS([misc])