From b889a491f24da9b7b989d4815d85076a4f241f0f Mon Sep 17 00:00:00 2001 From: sf-mensch Date: Fri, 28 Jul 2023 13:19:06 +0000 Subject: [PATCH] harding CALL statements, improving handling of not passed arguments and implementing EC-PROGRAM-ARG-MISMATCH cobc: * 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 config/general: add option using-optional libcob: * 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 --- NEWS | 66 +++--- cobc/ChangeLog | 16 ++ cobc/codegen.c | 319 ++++++++++++++++---------- cobc/config.def | 3 + cobc/parser.y | 33 ++- cobc/typeck.c | 31 +-- config/ChangeLog | 4 + config/acu-strict.conf | 3 +- config/bs2000-strict.conf | 3 +- config/cobol2002.conf | 3 +- config/cobol2014.conf | 3 +- config/cobol85.conf | 3 +- config/default.conf | 1 + config/gcos-strict.conf | 3 +- config/ibm-strict.conf | 3 +- config/lax.conf-inc | 3 +- config/mf-strict.conf | 3 +- config/mvs-strict.conf | 1 + config/realia-strict.conf | 1 + config/rm-strict.conf | 1 + config/xopen.conf | 3 +- libcob/ChangeLog | 10 + libcob/common.c | 214 +++++++++++++++-- libcob/common.h | 5 +- tests/testsuite.src/configuration.at | 1 + tests/testsuite.src/run_extensions.at | 54 +++-- tests/testsuite.src/run_file.at | 8 +- tests/testsuite.src/run_misc.at | 51 ++-- 28 files changed, 613 insertions(+), 236 deletions(-) diff --git a/NEWS b/NEWS index 1adc3eda3..0e07789fe 100644 --- a/NEWS +++ b/NEWS @@ -4,14 +4,18 @@ NEWS - user visible changes -*- outline -*- 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 + We are likely to release an update for this version (possibly 3.2b) + containing the following sometime in 2023: + + * extended testsuite and documentation + * updated message catalogues + * possibly even minor adjustments from research into code analysis + tools and of 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 +25,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 +62,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 - -** TODO - More to document before 3.2 final + analysis tools such as callgrind or perf to keep all symbols until the end + of the COBOL process +** 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 +101,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 +170,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 +265,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 +385,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 +445,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 +571,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/cobc/ChangeLog b/cobc/ChangeLog index 4f15fca47..0c5659e71 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -3,6 +3,22 @@ * 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 8e77b7702..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) { 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/libcob/ChangeLog b/libcob/ChangeLog index 0e8923535..2edaadf9b 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -4,6 +4,16 @@ * 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..d4d961481 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 @@ -1973,6 +1977,8 @@ cob_cmp_alnum (cob_field *f1, cob_field *f2) } else { /* check with collation */ /* Compare common substring */ + //raise(6); + //if ((ret = common_cmps (data1, data1, min, col)) != 0) { if ((ret = common_cmps (data1, data2, min, col)) != 0) { return ret; } @@ -2333,7 +2339,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 +3004,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 +4177,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 and (later = 4.x) size 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; } @@ -4576,9 +4685,17 @@ static set_cob_time_from_localtime (time_t curtime, #if defined (_BSD_SOURCE) cb_time->offset_known = 1; cb_time->utc_offset = tmptr->tm_gmtoff / 60; -#elif defined (HAVE_TIMEZONE) +#elif defined (HAVE_TIMEZONE_FUNCTIONS) || defined (HAVE_TIMEZONE) cb_time->offset_known = 1; +#if defined (HAVE_TIMEZONE_FUNCTIONS) && defined (_UCRT) + { + long seconds; + _get_timezone (&seconds); + cb_time->utc_offset = seconds / -60; + } +#else cb_time->utc_offset = timezone / -60; +#endif /* LCOV_EXCL_START */ if (tmptr->tm_isdst) { cb_time->utc_offset += 60; @@ -5992,11 +6109,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 +6235,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); @@ -6336,7 +6461,41 @@ cob_sys_hosted (void *p, const void *var) *((int **)data) = &errno; return 0; } -#if defined (HAVE_TIMEZONE) +#if defined (HAVE_TIMEZONE_FUNCTIONS) && defined (_UCRT) + { + static char *tzname_buff[2] = { 0 }; + size_t tznameSize; + unsigned int i; + + _tzset (); /* w may not have called a time function, so init */ + for (i = 0; i != 2; i++) { + tznameSize = 0; + if (_get_tzname (&tznameSize, NULL, 0, 0)) { + return 1; + } + if (tzname_buff[i]) { + tzname_buff[i] = (char *)(cob_cache_realloc (tzname_buff[i], tznameSize)); + } else { + tzname_buff[i] = (char *)(cob_cache_malloc (tznameSize)); + } + if (!tzname_buff[i]) { + return 1; + } + if (_get_tzname (&tznameSize, tzname_buff[i], tznameSize, i)) { + return 1; + } + } + + } + if ((i == 8) && !memcmp (name, "timezone", 8)) { + _get_timezone ((long *)data); + return 0; + } + if ((i == 8) && !memcmp (name, "daylight", 8)) { + _get_daylight ((int *)data); + return 0; + } +#elif defined (HAVE_TIMEZONE) if ((i == 6) && !memcmp (name, "tzname", 6)) { /* Recheck: bcc raises "suspicious pointer conversion */ *((char ***)data) = tzname; @@ -8724,6 +8883,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 +8892,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 +8910,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 +8929,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; } @@ -8983,6 +9148,16 @@ cob_fatal_error (const enum cob_fatal_error fatal_error) cob_statement_name[cobglobptr->last_exception_statement]); } break; + case COB_FERROR_FATAL_EXCEPTION: + if (cobglobptr->last_exception_statement == STMT_UNKNOWN) { + cob_runtime_error (_ ("fatal exception %s"), + cob_get_last_exception_name ()); + } else { + cob_runtime_error (_("fatal exception %s on %s"), + cob_get_last_exception_name (), + cob_statement_name[cobglobptr->last_exception_statement]); + } + break; /* LCOV_EXCL_START */ case COB_FERROR_FUNCTION: cob_runtime_error (_("attempt to use non-implemented function")); @@ -9102,8 +9277,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 +10544,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 +10635,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/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/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_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).