From 859723c39c2dea238c4c62974e0c1b7771ff11b0 Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Sat, 8 Jun 2024 11:10:14 +0000 Subject: [PATCH] Merged revisions 3931, 3937, 3940, 3943, 3944, 3945, 3954, 3961 from branches/gnucobol-3.x: ........ pre 3.1.1 changes (bugfixes for 3.1) libcob: * common.c (cob_stack_trace_internal): early exit if no data available * common.c (cob_check_version): test for minimal version 2.2 cobc: * pplex.l (ppinput): fixed processing after "line not terminated" [feature-requests:#53] TURN directive and -fno-ec=NAME/-fec=NAME - finish * cobc.c (turn_ec_for_table): correct handling for EC-ALL * cobc.c (cobc_turn_ec): handling EC-USER as PENDING * cobc.c (process_command_line), cobc.h: handle -debug before all the flags and exception options it sets, allowing to remove its internal explicit_set flag tests: * run_misc.at: test for [r3957] * general: pass AWK, GREP, SED to the testsuite and use those * atlocal.in, atlocal_valgrind, atlocal_win: remove temporary file info.out after use ........ cleanup for 3.1 build_aux: * create_win_dist.sh: removed obsolete defaults.h * pre-inst-env.in: exec_prefix as exec_prefix tests: * atlocal.in, atlocal_valgrind: exec_prefix as exec_prefix * testsuite.src/run_misc.at: added test for r3952 ........ Adjusted NEWS for 3.1 release additional: added expected test failure for INITIALIZE OCCURS UNBOUNDED and fixed eol-style attribute for exception-io.def ........ rework file mapping via environment names and apply them to `CBL_`/`C$` file routines libcob: * fileio.c (has_directory_separator, looks_absolute): new helpers * fileio.c (cob_chk_file_mapping, cob_chk_file_env): rewritten: * file names / parts that start with period/digit are not converted * periods within the name converted to underscores to get the environment variable name * empty environment names are not used * if COB_FILE_PATH is set, it is always applied if the file name is neither absolute nor start with -F/-D (acu-compat) * fileio.c (cob_open): return COB_STATUS_31_INCONSISTENT_FILENAME if it is unset/empty * fileio.c (open_cbl_file, cob_sys_delete_file, cob_sys_copy_file, cob_sys_check_file_exist, cob_sys_rename_file): CBL_ and C$ file routines use common mapping rules now ........ handling CHECKNUM directive, preparation for SPZERO cobc * pplex.l, ppparse.y: implemented CHECKNUM/NOCHECKNUM, preparation for SPZERO(NOSPZERO ........ better error-handling for errors in conditional compilation directives * cobc/ppparse.y: improved error handling for broken IF/ELIF directives by consuming as much errors as possible and emitting a "false" * tests: moved some compile-only checks for directives from run_extensions.at to syn_misc.at, adding known issues with level 78 constants as expected failures ........ minor cleanup and test adjustments ........ cobc: * codegen.c (output_initialize_compound): adjusted OCCURS initialization to only do the initialization (and runtime checks) once and then memcpy to all other occurences * tree.c: preparation for all-upper-case names (post 3.1) libcob: * fileio.c: initialize errno in all places where it is checked afterwards * fileio.c [_WIN32]: implemented file locking via LockFileEx/UnlockFile * common.c (cob_sys_waitpid) [_WIN32]: fixed logic error in #if, allowing the best process synchronization possible on that platform * common.h [_MSC_VER]: removed unused global includes tests: * atlocal.in, atlocal_valgrind, atlocal_win: * fix unsetting of variables which values contain "COB" (rendered the testuite unusable before...) * allow screenio-tests to be run on cygwin/msys with ncurses out-of-the box * fixed TEST_LOCAL (may not use pre-inst-env) and "external" versions with old indexed file msgid * worked around some win32 issues ........ --- NEWS | 4 +- build_aux/bootstrap | 3 + build_aux/create_win_dist.sh | 5 +- cobc/ChangeLog | 35 +- cobc/cobc.c | 82 ++-- cobc/codegen.c | 6 + cobc/field.c | 5 +- cobc/pplex.l | 33 +- cobc/ppparse.y | 53 ++- cobc/typeck.c | 3 + libcob/ChangeLog | 34 ++ libcob/call.c | 1 + libcob/common.c | 22 +- libcob/common.h | 3 - libcob/fbdb.c | 3 +- libcob/fileio.c | 518 +++++++++++++++++++------- libcob/fisam.c | 7 +- libcob/focextfh.c | 2 + libcob/fsqlxfd.c | 4 +- tests/ChangeLog | 11 +- tests/atlocal.in | 3 + tests/atlocal_valgrind | 26 ++ tests/atlocal_win | 6 +- tests/testsuite.src/configuration.at | 22 +- tests/testsuite.src/run_extensions.at | 206 +++++----- tests/testsuite.src/run_file.at | 324 ++++++++++++---- tests/testsuite.src/run_misc.at | 220 ++++++++++- tests/testsuite.src/syn_copy.at | 10 +- tests/testsuite.src/syn_misc.at | 323 ++++++++++++++-- tests/testsuite.src/syn_occurs.at | 2 +- tests/testsuite.src/used_binaries.at | 3 +- 31 files changed, 1558 insertions(+), 421 deletions(-) diff --git a/NEWS b/NEWS index 8d2beb73f..2dcf6e6bb 100644 --- a/NEWS +++ b/NEWS @@ -469,7 +469,7 @@ Open Plans: still applied; File name mapping now applies both to COBOL statements and CALLable CBL_ and C$ file routines. - + ** Screen I/O: initial mouse support (for details see runtime.cfg), use of CURSOR clause in SPECIAL-NAMES for positioning on ACCEPT @@ -522,7 +522,7 @@ Open Plans: not included in -Wall any more -Wno-ignored-error allows to suppress messages that normally would be an error and are only allowed because they are never executed - -Wcorresponding is now enabled by default + -Wimplicit-define and -Wcorresponding are now enabled by default -f[no]-diagnostics-show-option, enabled by default, shows the command line option responsible for the diagnostic message diff --git a/build_aux/bootstrap b/build_aux/bootstrap index e1df537e2..e01562ee4 100755 --- a/build_aux/bootstrap +++ b/build_aux/bootstrap @@ -96,12 +96,15 @@ autoreconf $AC_OPTS $MAINPATH > $msgs 2>&1; ret=$? # Filter aminclude_static as those are only used _within_ another # check so reporting as portability problem is only noise. # This has the effect of redirecting some error messages to stdout. +# to be moved to the Makefile - currently only usable for bootstrap, +# but should be done on autogen, too awk '/^aminclude_static[.]am:/ { msg = msg sep $0; sep = "\n"; next } /Makefile[.]am.+aminclude_static.am.+from here/ { msg = ""; sep = ""; next } msg { print msg > "/dev/stderr"; msg = "" } { print }' $msgs +rm -rf $msgs if test $ret -ne 0; then echo; echo "ERROR, autoreconf returned $ret - aborting bootstrap" && exit $ret diff --git a/build_aux/create_win_dist.sh b/build_aux/create_win_dist.sh index 0f6dde04c..0196ffec0 100755 --- a/build_aux/create_win_dist.sh +++ b/build_aux/create_win_dist.sh @@ -1,7 +1,7 @@ #!/bin/sh # create_win_dist.sh gnucobol # -# Copyright (C) 2016-2017,2019 Free Software Foundation, Inc. +# Copyright (C) 2016-2017,2019-2020 Free Software Foundation, Inc. # Written by Simon Sobisch # # This file is part of GnuCOBOL. @@ -65,10 +65,9 @@ cp "$EXTSRCDIR/tests/atlocal_win" "$EXTWINDISTDIR/tests/atlocal_win" || exit 2 olddir="$(pwd)" cd "$EXTWINDISTDIR" || exit 3 -# rename templates for faster setup +# rename template for faster setup cd build_windows || exit 5 mv "config.h.in" "config.h" -mv "defaults.h.in" "defaults.h" cd .. # remove content not necessary for windows-only distribution --> breaks make dist[check] diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 70d42049e..ec8b7fc54 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -1028,6 +1028,19 @@ 'memcpy' to speed up the process If size is not known until run time then emit call to cob_init_table +2020-11-20 Simon Sobisch + + * pplex.l (ppinput): fixed processing after "line not terminated" + +2020-11-19 Simon Sobisch + + FR #53 TURN directive and -fno-ec=NAME/-fec=NAME - finish + * cobc.c (turn_ec_for_table): correct handling for EC-ALL + * cobc.c (cobc_turn_ec): handling EC-USER as PENDING + * cobc.c (process_command_line), cobc.h: handle -debug before all the + flags and exception options it sets, allowing to remove its internal + explicit_set flag + 2020-11-18 Ron Norman * codegen.c,typeck.c: Generated code for INITIALIZE computes the actual @@ -1270,6 +1283,14 @@ * config.def: added possible values for assign-clause and screen-section-rules. +2020-07-21 Simon Sobisch + + * pplex.l, ppparse.y: implemented CHECKNUM/NOCHECKNUM, + preparation for SPZERO + * ppparse.y: improved error handling for broken IF/ELIF + directives by consuming as much errors as possible and + emitting a "false" + 2020-07-19 Edward Hart * cobc.c, typeck.c: added support for JSON-C as JSON handler. @@ -1326,6 +1347,13 @@ * cobc.c (compare_prepare): fixed bug #569: stop copying into cmp_line when line length exceeds CB_LINE_LENGTH. +2020-06-30 Simon Sobisch + + FR #53 TURN directive - finished command line variant as -fno-ec/-fec + * cobc.c, flag.def, help.c: renamed -fdisable-ec/-fenable-ec + * cobc.c: removed the need to use EC- prefix in the name for -f[no-]ec + * flag.def, help.c: fixed some help output + 2020-06-30 Edward Hart * typeck.c (validate_move): refactored. @@ -1373,14 +1401,15 @@ 2020-06-23 Edward Hart FR #53 TURN directive - * cobc.c, cobc.h: completed initial implementation on disabling ECs. + * cobc.c, cobc.h: completed initial implementation on disabling ECs + on command line with -fdisable-ec=NAME -fenable-ec=NAME * cobc.c, cobc.h, parser.y, ppparse.y, scanner.l: completed initial - implementation of >>TURN. + implementation of >>TURN 2020-06-22 Simon Sobisch * cobc.c, cobc.h, flag.def, ppparse.y: draft work on >>TURN and - disabling exceptions (FR #53). + disabling exceptions (FR #53) 2020-06-22 Simon Sobisch diff --git a/cobc/cobc.c b/cobc/cobc.c index 8530b5457..9673c6a49 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -161,10 +161,6 @@ struct list_files *cb_current_file = NULL; struct cob_time current_compile_time = { 0 }; struct tm current_compile_tm = { 0 }; -#if 0 /* RXWRXW - source format */ -char *source_name = NULL; -#endif - enum cb_format cb_source_format = CB_FORMAT_FIXED; #if 0 /* ancient OSVS registers that need special runtime handling - low priority */ enum cb_current_date current_date = CB_DATE_MDY; @@ -1517,32 +1513,25 @@ turn_ec_for_table (struct cb_exception *table, const size_t table_len, { size_t i; - if (ec.code & 0x00FF) { - /* Set individual level-1 EC */ + if (ec.code == CB_EXCEPTION_CODE (COB_EC_ALL)) { + /* EC-ALL - level-1 EC to set all ECs */ for (i = 0; i < table_len; ++i) { - if (table[i].code == ec.code) { - table[i].enable = to_on_off; - table[i].explicit_enable_val = 1; - break; - } + table[i].enable = to_on_off; } - } else if (ec.code != 0) { - /* - Simon: ToDo: Group activation; check occurences of - EC-generation - */ + } else if ((ec.code & 0x00FF) == 0) { /* Set all ECs subordinate to level-2 EC */ for (i = 0; i < table_len; ++i) { if ((table[i].code & 0xFF00) == ec.code) { table[i].enable = to_on_off; - table[i].explicit_enable_val = 1; } } } else { - /* EC-ALL; set all ECs */ + /* Set individual level-3 EC */ for (i = 0; i < table_len; ++i) { - table[i].enable = to_on_off; - table[i].explicit_enable_val = 1; + if (table[i].code == ec.code) { + table[i].enable = to_on_off; + break; + } } } } @@ -1615,11 +1604,6 @@ ec_duped (struct cb_text_list *ec_list, struct cb_text_list *ec, return 0; } -/* - Simon: ToDo: Move save/restore of activated exceptions before - preparse; after C generation A dynamic save (only if changed) - and restore (only if set) would be nice -*/ unsigned int cobc_turn_ec (struct cb_text_list *ec_list, const cob_u32_t to_on_off, cb_tree loc) { @@ -1638,6 +1622,15 @@ cobc_turn_ec (struct cb_text_list *ec_list, const cob_u32_t to_on_off, cb_tree l for (i = 0; i < len; ++i) { upme[i] = cb_toupper (upme[i]); } + + /* User specified exception (always nonfatal, compared by name) */ + if (!strncmp (ec->text, "EC-USER", 7)) { + /* TODO: EC-USER[NAME] not supported yet, maybe addd as table + of strings or hash into the generated program */ + CB_PENDING ("EC-USER"); + return 1; + } + /* extract exception code via text comparison */ ec_idx = 0; for (i = (enum cob_exception_id)1; i < COB_EC_MAX; ++i) { @@ -1648,7 +1641,6 @@ cobc_turn_ec (struct cb_text_list *ec_list, const cob_u32_t to_on_off, cb_tree l } /* Error if not a known exception name */ - /* TO-DO: What about EC-USER? */ if (ec_idx == 0) { cb_error_x (loc, _("invalid exception-name: %s"), ec->text); @@ -1659,7 +1651,7 @@ cobc_turn_ec (struct cb_text_list *ec_list, const cob_u32_t to_on_off, cb_tree l return 1; } - if (!strncmp(CB_EXCEPTION_NAME(ec_idx), "EC-I-O", 6)) { + if (!strncmp (CB_EXCEPTION_NAME(ec_idx), "EC-I-O", 6)) { if (turn_ec_io (cb_exception_table[ec_idx], to_on_off, loc, &ec)) { return 1; @@ -2874,7 +2866,8 @@ process_command_line (const int argc, char **argv) } #endif - /* First run of getopt: handle std/conf and all listing options + /* First run of getopt: handle std/conf and all listing options, along + with grouping options that should not override other entries (as --debug) We need to postpone single configuration flags as we need a full configuration to be loaded before */ cob_optind = 1; @@ -3106,6 +3099,13 @@ process_command_line (const int argc, char **argv) cobc_early_exit (EXIT_FAILURE); } + /* debug: Turn on all exception conditions */ + if (cobc_wants_debug) { + for (i = (enum cob_exception_id)1; i < COB_EC_MAX; ++i) { + CB_EXCEPTION_ENABLE (i) = 1; + } + } + /* dump implies extra information (may still be disabled later) */ if (cb_flag_dump != COB_DUMP_NONE) { cb_flag_source_location = 1; @@ -3837,6 +3837,13 @@ process_command_line (const int argc, char **argv) cobc_main_free (output_name_buff); } + /* debug: Turn on all exception conditions + -> drop note about this after hanling exit_option and general problems */ + if (cobc_wants_debug && verbose_output > 1) { + fputs (_ ("all runtime checks are enabled"), stderr); + fputc ('\n', stderr); + } + /* Set relaxed syntax configuration options if requested */ /* part 1: relaxed syntax compiler configuration option */ if (cb_relaxed_syntax_checks) { @@ -3941,19 +3948,6 @@ process_command_line (const int argc, char **argv) } #endif - /* debug: Turn on all exception conditions */ - if (cobc_wants_debug) { - for (i = (enum cob_exception_id)1; i < COB_EC_MAX; ++i) { - if (!CB_EXCEPTION_EXPLICIT (i)) { - CB_EXCEPTION_ENABLE (i) = 1; - } - } - if (verbose_output > 1) { - fputs (_("all runtime checks are enabled"), stderr); - fputc ('\n', stderr); - } - } - /* If C debug, do not strip output */ if (cb_source_debugging) { strip_output = 0; @@ -4134,7 +4128,7 @@ process_filename (const char *filename) #if defined(__OS400__) extension[0] == 0 #else - cb_strcasecmp (extension, COB_OBJECT_EXT) == 0 + cb_strcasecmp (extension, COB_OBJECT_EXT) == 0 #if defined(_WIN32) || cb_strcasecmp (extension, "lib") == 0 #endif @@ -4160,8 +4154,8 @@ process_filename (const char *filename) fn->preprocess = cobc_main_strdup (fn->source); } else if (output_name && cb_compile_level == CB_LEVEL_PREPROCESS) { fn->preprocess = cobc_main_strdup (output_name); - } else if (save_all_src || save_temps || - cb_compile_level == CB_LEVEL_PREPROCESS) { + } else if (save_all_src || save_temps + || cb_compile_level == CB_LEVEL_PREPROCESS) { fn->preprocess = cobc_main_stradd_dup (fbasename, ".i"); } else { fn->preprocess = cobc_main_malloc (COB_FILE_MAX); diff --git a/cobc/codegen.c b/cobc/codegen.c index 20f576571..4f1ddc9f7 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -11925,6 +11925,12 @@ output_module_init_function (struct cb_program *prog) if (cb_flag_trace) { opt |= COB_MODULE_TRACE; } +#if 0 /* currently unused */ + if (cobc_wants_debug + || cb_flag_dump) { + opt |= COB_MODULE_DEBUG; + } +#endif output_line ("module->flag_debug_trace |= %d;", opt); } output_line ("module->flag_dump_sect = 0x%02X;", cb_flag_dump); diff --git a/cobc/field.c b/cobc/field.c index 841aa1fbc..e896b8e02 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -1240,7 +1240,10 @@ validate_any_length_item (struct cb_field *f) return 1; } - /* CHECKME: Why do we increase the reference counter here and not in another place? */ + /* CHECKME: Why do we increase the reference counter here + (to ensure the field is generated)? + Better would be to add the check for 'f->count != 0' to the place + where it possibly is missing... */ f->count++; return 0; } diff --git a/cobc/pplex.l b/cobc/pplex.l index c180c37d3..c478b4ff5 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -227,7 +227,8 @@ DEFNUM_LITERAL [+-]?[0-9]*[\.]*[0-9]+ } ^[ ]*">>"[ ]?"DISPLAY"[ ]+ { - /* OpenCOBOL/GnuCOBOL 2.x extension, 202x: display message during compilation */ + /* previous OpenCOBOL/GnuCOBOL 2.x extension, added in COBOL 202x with slightly different syntax: + display message during compilation --> needs a dialect option to switch to the appropriate state */ display_msg[0] = 0; BEGIN DISPLAY_DIRECTIVE_STATE; } @@ -686,6 +687,10 @@ COBOL_WORDS_DIRECTIVE_STATE>{ "CALLFH" { return CALLFH; } + "CHECKNUM" | + "CHECK-NUM" { + return CHECKNUM; + } "COMP1" | "COMP-1" { return COMP1; @@ -715,6 +720,11 @@ COBOL_WORDS_DIRECTIVE_STATE>{ "NO-BOUND" { return NOBOUND; } + "NOCHECKNUM" | + "NO-CHECKNUM" | + "NO-CHECK-NUM" { + return NOCHECKNUM; + } "NODPCINDATA" | "NO-DPCINDATA" | "NODPC-IN-DATA" | @@ -730,6 +740,10 @@ COBOL_WORDS_DIRECTIVE_STATE>{ "NO-SSRANGE" { return NOSSRANGE; } + "NOSPZERO" | + "NO-SPZERO" { + return NOSPZERO; + } "NOODOSLIDE" | "NO-ODOSLIDE" { return NOODOSLIDE; @@ -746,6 +760,9 @@ COBOL_WORDS_DIRECTIVE_STATE>{ "SSRANGE" { return SSRANGE; } + "SPZERO" { + return SPZERO; + } "SOURCEFORMAT" | "SOURCE-FORMAT" { return SOURCEFORMAT; @@ -1729,20 +1746,22 @@ start: if (cb_source_format == CB_FORMAT_FREE) { if (line_overflow == 0) { cb_plex_warning (cb_missing_newline, newline_count + 1, - _("line not terminated by a newline")); + _("line not terminated by a newline")); + n++; } else if (line_overflow == 2) { cb_plex_warning (COBC_WARN_FILLER, newline_count + 1, - _("source text exceeds %d bytes, will be truncated"), - PPLEX_BUFF_LEN); + _("source text exceeds %d bytes, will be truncated"), + PPLEX_BUFF_LEN); } } else { if (line_overflow == 0) { cb_plex_warning (cb_missing_newline, newline_count, - _("line not terminated by a newline")); + _("line not terminated by a newline")); + n++; } else if (line_overflow == 2) { cb_plex_warning (COBC_WARN_FILLER, newline_count, - _("source text exceeds %d bytes, will be truncated"), - PPLEX_BUFF_LEN); + _("source text exceeds %d bytes, will be truncated"), + PPLEX_BUFF_LEN); } } buff[n++] = '\n'; diff --git a/cobc/ppparse.y b/cobc/ppparse.y index ce9859aa7..b1d1bafab 100644 --- a/cobc/ppparse.y +++ b/cobc/ppparse.y @@ -625,6 +625,7 @@ ppparse_clear_vars (const struct cb_define_struct *p) %token BOUND %token CALLFH %token XFD +%token CHECKNUM %token COMP1 %token CONSTANT %token DPC_IN_DATA "DPC-IN-DATA" @@ -633,9 +634,11 @@ ppparse_clear_vars (const struct cb_define_struct *p) %token NOKEYCOMPRESS %token MAKESYN %token NOBOUND +%token NOCHECKNUM %token NODPC_IN_DATA "NODPC-IN-DATA" %token NOFOLDCOPYNAME %token NOODOSLIDE +%token NOSPZERO %token NOSSRANGE /* OVERRIDE token defined above. */ %token ODOSLIDE @@ -741,12 +744,12 @@ directive: { current_cmd = PLEX_ACT_IF; } - if_directive + if_directive_if | ELIF_DIRECTIVE { current_cmd = PLEX_ACT_ELIF; } - if_directive + if_directive_elif | ELSE_DIRECTIVE { plex_action_directive (PLEX_ACT_ELSE, 0); @@ -767,6 +770,24 @@ directive: } ; +if_directive_if: + if_directive +| error + { + cb_error (_("invalid %s directive"), "IF"); + yyerrok; + } +; + +if_directive_elif: + if_directive +| error + { + cb_error (_("invalid %s directive"), "ELIF"); + yyerrok; + } +; + set_directive: set_choice | set_directive set_choice @@ -848,6 +869,11 @@ set_choice: p[strlen (p) - 1] = '\0'; fprintf (ppout, "#XFD \"%s\"\n", p); } +| CHECKNUM + { + /* Enable EC-DATA-INCOMPATIBLE checking */ + append_to_turn_list (ppp_list_add (NULL, "EC-DATA-INCOMPATIBLE"), 1, 0); + } | COMP1 LITERAL { char *p = $2; @@ -927,6 +953,11 @@ set_choice: /* Disable EC-BOUND-SUBSCRIPT checking */ append_to_turn_list (ppp_list_add (NULL, "EC-BOUND-SUBSCRIPT"), 0, 0); } +| NOCHECKNUM + { + /* Disable EC-DATA-INCOMPATIBLE checking */ + append_to_turn_list (ppp_list_add (NULL, "EC-DATA-INCOMPATIBLE"), 0, 0); + } | NODPC_IN_DATA { cb_dpc_in_data = CB_DPC_IN_NONE; @@ -935,6 +966,11 @@ set_choice: { cb_fold_copy = 0; } +| NOSPZERO + { + CB_PENDING ("SPZERO"); + /* TODO: cb_space_is_zero = 0; */ + } | NOSSRANGE { /* Disable EC-BOUND-SUBSCRIPT and -REF-MOD checking */ @@ -993,7 +1029,7 @@ set_choice: } | SOURCEFORMAT _as error { - /* FIXME: we should consume until end of line here! */ + /* FIXME: we should consume until end of line here! */ ppp_error_invalid_option ("SOURCEFORMAT", NULL); } | SPZERO @@ -1412,12 +1448,19 @@ if_directive: } plex_action_directive (current_cmd, found ^ $3); } -| variable_or_literal +| garbage { - cb_error (_("invalid %s directive"), "IF/ELIF"); + plex_action_directive (current_cmd, 0); + YYERROR; } ; +garbage: + variable_or_literal +| garbage variable_or_literal +| garbage error +; + variable_or_literal: VARIABLE_NAME | LITERAL diff --git a/cobc/typeck.c b/cobc/typeck.c index 3d72c7542..04685071b 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2351,6 +2351,9 @@ cb_build_identifier (cb_tree x, const int subchk) f = CB_FIELD (v); /* BASED check and check for OPTIONAL LINKAGE items */ + + /* CHECKME: do we need the field founder to decide? LINKAGE and flag_item_based + should be available in 'f' already ... */ if (current_statement && !suppress_data_exceptions && (CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL) || CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_OMITTED))) { diff --git a/libcob/ChangeLog b/libcob/ChangeLog index b5bb0ab8c..bad60a183 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -1,4 +1,9 @@ +2024-06-08 David Declerck + + * fileio.c (apply_file_paths): extracted from cob_chk_file_mapping + to factor out duplicated code + 2023-06-02 Simon Sobisch * fisam.c (isam_read_next): use ISSTAT only for COB_WITH_STATUS_02, @@ -1307,6 +1312,11 @@ * fextfh.c (copy_file_to_fcd): use cob_cache_malloc instead of cob_strdup * fsqlxfd.c: if count_components > 1 then its a composite key +2020-11-20 Simon Sobisch + + * common.c (cob_stack_trace_internal): early exit if no data available + * common.c (cob_check_version): test for minimal version 2.2 + 2020-11-18 Simon Sobisch * common.c (cob_init): skip initialization again if already done as @@ -1321,6 +1331,14 @@ * common.c (cob_check_version): support 3-part version strings +2020-11-05 Simon Sobisch + + * fileio.c: initialize errno in all places where it is checked afterwards + * fileio.c [_WIN32]: implemented file locking via LockFileEx/UnlockFile + * common.c (cob_sys_waitpid) [_WIN32]: fixed logic error in #if, allowing + the best process synchronization possible on that platform + * common.h [_MSC_VER]: removed unused global includes + 2020-11-01 Ron Norman * fsqlxfd.c: use cob_str_case_str instead of strcasestr @@ -1460,6 +1478,22 @@ COB_STACKTRACE allowing to disable stracktrace creation on abort * common.c: also handle SIGEMT; skip module dump for SIGTERM and SIGINT +2020-08-18 Simon Sobisch + + rework file mapping via environment names and apply them to CBL_/C$ + * fileio.c (has_directory_separator, looks_absolute): new helpers + * fileio.c (cob_chk_file_mapping, cob_chk_file_env): rewritten: + file names / parts that start with period/digit are not converted, + periods within the name converted to underscores to get the environment + variable name, empty environment names are not used, if COB_FILE_PATH + is set, it is always applied if the file name is neither absolute nor + start with -F/-D (acu-compat) + * fileio.c (cob_open): return COB_STATUS_31_INCONSISTENT_FILENAME if it is + unset/empty + * fileio.c (open_cbl_file, cob_sys_delete_file, cob_sys_copy_file, + cob_sys_check_file_exist, cob_sys_rename_file): CBL_ and C$ file routines + use common mapping rules now + 2020-08-17 Simon Sobisch * common.c (struct exit_handlerlist, cob_sys_exit_proc): diff --git a/libcob/call.c b/libcob/call.c index 76534493c..d4eb5f89e 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -60,6 +60,7 @@ FILE *fmemopen (void *buf, size_t size, const char *mode); #define WIN32_LEAN_AND_MEAN #include +#include /* for access */ static HMODULE lt_dlopen (const char *x) diff --git a/libcob/common.c b/libcob/common.c index 08e8a2b17..695839039 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -3520,9 +3520,7 @@ cob_check_version (const char *prog, app.point = 0; lib.major = 9; lib.minor = 9; - lib.point = 9; - - /* note: to be tested with direct C call */ + lib.point = 0; nparts = sscanf (PACKAGE_VERSION, "%d.%d.%d", &lib.major, &lib.minor, &lib.point); @@ -3536,8 +3534,12 @@ cob_check_version (const char *prog, if (app.version == lib.version && patchlev_prog <= PATCH_LEVEL) return; - if (app.version < lib.version) - return; + if (app.version < lib.version) { + struct ver_t minimal = { 4, 0 }; + if (app.version >= version_bitstring (minimal)) { + return; + } + } } /* TODO: when CALLed - raise exception so program can go ON EXCEPTION */ @@ -6677,7 +6679,7 @@ cob_sys_waitpid (const void *p_id) */ #if defined (PROCESS_QUERY_LIMITED_INFORMATION) process = OpenProcess (SYNCHRONIZE | PROCESS_QUERY_LIMITED_INFORMATION, FALSE, pid); -#if !defined (_MSC_VER) || !COB_USE_VC2012_OR_GREATER /* only try a higher level if we possibly compile on XP/2003 */ +#if !defined (_MSC_VER) || COB_USE_VC2012_OR_GREATER /* only try a higher level if we possibly compile on XP/2003 */ /* TODO: check what happens on WinXP / 2003 as PROCESS_QUERY_LIMITED_INFORMATION isn't available there */ if (!process && GetLastError () == ERROR_ACCESS_DENIED) { process = OpenProcess (SYNCHRONIZE | PROCESS_QUERY_INFORMATION, FALSE, pid); @@ -10015,6 +10017,14 @@ cob_stack_trace (void *target) static void flush_target (FILE *target) { + /* exit early in the case of no module loaded at all, + possible to happen for example when aborted from cob_check_version of first module */ + if (!COB_MODULE_PTR + || ( COB_MODULE_PTR->module_stmt == 0 + && COB_MODULE_PTR->next == NULL)) { + return; + } + if (target == stderr || target == stdout) { fflush (stdout); diff --git a/libcob/common.h b/libcob/common.h index 2ae5954ee..fcbfc8ecf 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -280,9 +280,6 @@ typedef __mpz_struct mpz_t[1]; #ifndef _CRT_SECURE_NO_DEPRECATE #define _CRT_SECURE_NO_DEPRECATE 1 #endif -#include -#include -#include /* Disable certain warnings */ /* Deprecated functions */ diff --git a/libcob/fbdb.c b/libcob/fbdb.c index d89d8ebef..75300feb4 100644 --- a/libcob/fbdb.c +++ b/libcob/fbdb.c @@ -797,7 +797,7 @@ ix_bdb_write_internal (cob_file *f, const int rewrite, const int opt) memset(&p->data,0,sizeof(p->data)); if (f->keys[i].tf_duplicates) { flags = 0; - dupno = get_dupno(f, i); + dupno = get_dupno (f, i); dupno = COB_DUPSWAP (dupno); if (dupno > dupcnt) dupcnt = dupno; @@ -1091,6 +1091,7 @@ ix_bdb_file_delete (cob_file_api *a, cob_file *f, char *filename) snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s.%d", filename, (int)i); } file_open_buff[COB_FILE_MAX] = 0; + errno = 0; unlink (file_open_buff); } return 0; diff --git a/libcob/fileio.c b/libcob/fileio.c index a09f47485..53d2484fc 100644 --- a/libcob/fileio.c +++ b/libcob/fileio.c @@ -1431,7 +1431,11 @@ cob_read_dict (cob_file *f, char *filename, int updt) return ret; } -/* Check for file options from environment variables */ +/* Check for DD_xx, dd_xx, xx environment variables for a filename + or a part specified with 'src'; + returns either the value or NULL if not found in the environment + Note: MF only checks for xx if the variable started with a $, + ACUCOBOL only checks for xx in general ... */ static char * cob_chk_file_env (cob_file *f, const char *src) { @@ -1441,78 +1445,106 @@ cob_chk_file_env (cob_file *f, const char *src) const char *t; unsigned int i; + /* GC-sanity rule: no environment handling if src starts with period */ + if (*src == '.') { + return NULL; + } + + /* no mapping if filename begins with a slash [externally checked], hypen or digits + (taken from "Programmer's Guide to File Handling, Chapter 2: File Naming") */ + switch (*file_open_name) { + case '-': + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + return NULL; + default: + break; + } + + q = cob_strdup (src); + s = q; if (file_setptr->cob_env_mangle) { - q = cob_strdup (src); - s = q; for (i = 0; s[i] != 0; ++i) { if (!isalnum ((int)s[i])) { s[i] = '_'; } } } else { - q = NULL; - s = (char *)src; - } - - if ((file_open_io_env = cob_get_env ("IO_OPTIONS", NULL)) != NULL) { - cob_set_file_format (f, file_open_io_env, 1); /* Set initial defaults */ - } - if (f->organization == COB_ORG_INDEXED) { - t = "IX"; - } else if (f->organization == COB_ORG_SEQUENTIAL) { - t = "SQ"; - } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) { - if((f->flag_line_adv & COB_LINE_ADVANCE)) - t = "LA"; - else - t = "LS"; - } else if (f->organization == COB_ORG_RELATIVE) { - t = "RL"; - } else { - t = "IO"; - } - snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s_OPTIONS", t); - if ((file_open_io_env = cob_get_env (file_open_env, NULL)) == NULL) { - snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s_options", t); - file_open_env[0] = (char)tolower(file_open_env[0]); - file_open_env[1] = (char)tolower(file_open_env[1]); - file_open_io_env = cob_get_env (file_open_env, NULL); - } - if (file_open_io_env != NULL) { - cob_set_file_format (f, file_open_io_env, 1); /* Defaults for file type */ + for (i = 0; s[i] != 0; ++i) { + if (s[i] == '.') { + s[i] = '_'; + } + } } - /* Check for IO_filename with file specific options */ - file_open_io_env = NULL; - snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "IO_", s); - if ((file_open_io_env = cob_get_env (file_open_env, NULL)) == NULL) { - snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "io_", s); + if (f != NULL) { + if ((file_open_io_env = cob_get_env ("IO_OPTIONS", NULL)) != NULL) { + cob_set_file_format (f, file_open_io_env, 1); /* Set initial defaults */ + } + if (f->organization == COB_ORG_INDEXED) { + t = "IX"; + } else if (f->organization == COB_ORG_SEQUENTIAL) { + t = "SQ"; + } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) { + if((f->flag_line_adv & COB_LINE_ADVANCE)) + t = "LA"; + else + t = "LS"; + } else if (f->organization == COB_ORG_RELATIVE) { + t = "RL"; + } else { + t = "IO"; + } + snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s_OPTIONS", t); if ((file_open_io_env = cob_get_env (file_open_env, NULL)) == NULL) { - for (i = 0; file_open_env[i] != 0; ++i) { /* Try all Upper Case */ - file_open_env[i] = (char)toupper((unsigned char)file_open_env[i]); - } + snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s_options", t); + file_open_env[0] = (char)tolower(file_open_env[0]); + file_open_env[1] = (char)tolower(file_open_env[1]); file_open_io_env = cob_get_env (file_open_env, NULL); } - } - if (file_open_io_env == NULL) { /* Re-check for IO_fdname */ - snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "IO_", f->select_name); + if (file_open_io_env != NULL) { + cob_set_file_format (f, file_open_io_env, 1); /* Defaults for file type */ + } + + /* Check for IO_filename with file specific options */ + file_open_io_env = NULL; + snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "IO_", s); if ((file_open_io_env = cob_get_env (file_open_env, NULL)) == NULL) { - snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "io_", f->select_name); + snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "io_", s); if ((file_open_io_env = cob_get_env (file_open_env, NULL)) == NULL) { for (i = 0; file_open_env[i] != 0; ++i) { /* Try all Upper Case */ - file_open_env[i] = (unsigned char)toupper((int)file_open_env[i]); + file_open_env[i] = (char)toupper((unsigned char)file_open_env[i]); } file_open_io_env = cob_get_env (file_open_env, NULL); } } + if (file_open_io_env == NULL) { /* Re-check for IO_fdname */ + snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "IO_", f->select_name); + if ((file_open_io_env = cob_get_env (file_open_env, NULL)) == NULL) { + snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", "io_", f->select_name); + if ((file_open_io_env = cob_get_env (file_open_env, NULL)) == NULL) { + for (i = 0; file_open_env[i] != 0; ++i) { /* Try all Upper Case */ + file_open_env[i] = (unsigned char)toupper((int)file_open_env[i]); + } + file_open_io_env = cob_get_env (file_open_env, NULL); + } + } + } } + /* no mapping at all if explicit disabled on compile-time (dialect configuration)*/ if (COB_MODULE_PTR && !COB_MODULE_PTR->flag_filename_mapping) { /* No DD_name checks */ strcpy (file_open_env, file_open_name); - if (q) { - cob_free (q); - } + cob_free (q); return NULL; } @@ -1520,9 +1552,11 @@ cob_chk_file_env (cob_file *f, const char *src) for (i = 0; i < NUM_PREFIX; ++i) { snprintf (file_open_env, (size_t)COB_FILE_MAX, "%s%s", prefix[i], s); file_open_env[COB_FILE_MAX] = 0; - if ((p = cob_get_env (file_open_env, NULL)) != NULL) { + p = cob_get_env (file_open_env, NULL); + if (p && *p) { break; } + p = NULL; } if (p == NULL) { /* Try all Upper case env var name */ for (i = 0; i < NUM_PREFIX; ++i) { @@ -1531,20 +1565,113 @@ cob_chk_file_env (cob_file *f, const char *src) for (i = 0; file_open_env[i] != 0; ++i) { file_open_env[i] = (char)toupper((unsigned char)file_open_env[i]); } - if ((p = cob_get_env (file_open_env, NULL)) != NULL) { + p = cob_get_env (file_open_env, NULL); + if (p && *p) { break; } + p = NULL; } if (p == NULL) { strcpy (file_open_env, file_open_name); } } - if (q) { - cob_free (q); - } + cob_free (q); return p; } +/* checks if 'src' containes a / or \ */ +static int +has_directory_separator (char *src) +{ + for (; *src; src++) { + if (*src == '/' || *src == SLASH_CHAR) { + return 1; + } + } + return 0; +} + +/* checks if 'src' looks like starting with name */ +static int +looks_absolute (char *src) +{ + /* no file path adjustment if filename is absolute + because it begins with a slash (or win-disk-drive) */ + if (file_open_name[0] == '/' + || file_open_name[0] == SLASH_CHAR +#if WIN32 + || file_open_name[1] == ':' +#endif + ) { + return 1; + } + return 0; +} + +/* checks for special ACUCOBOL-case: file that start with hypen [note: -P not supported] + no translation at all, name starts after first non-space */ +static int +has_acu_hypen (char *src) +{ + if ( src[0] == '-' + && (src[1] == 'F' || src[1] == 'D' || src[1] == 'f' || src[1] == 'd') + && isspace((cob_u8_t)src[2])) { + return 1; + } + return 0; +} + +/* do acu translation, 'src' may not be file_open_buff! */ +static void +do_acu_hypen_translation (char *src) +{ + /* maybe store device type to "adjust locking rules" */ + /* find first non-space and return it in the original storage */ + for (src = src + 3; *src && isspace ((cob_u8_t)*src); src++); + + strncpy (file_open_buff, src, (size_t)COB_FILE_MAX); + strncpy (file_open_name, file_open_buff, (size_t)COB_FILE_MAX); +} + +/* apply COB_FILE_PATH if set (similar to ACUCOBOL's FILE-PREFIX) + MF and Fujistu simply don't have that - not set by default, + so no compatilibity issue here; writes to global file_open_buff */ +static void +apply_file_paths (char *src) +{ + int k; + if (file_paths) { + for(k=0; file_paths[k] != NULL; k++) { + snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s", + file_paths[k], SLASH_CHAR, src); + file_open_buff[COB_FILE_MAX] = 0; + if (access (file_open_buff, F_OK) == 0) { + break; + } +#if defined(WITH_CISAM) || defined(WITH_DISAM) || defined(WITH_VBISAM) || defined(WITH_VISAM) + /* ISAM may append '.dat' to file name */ + snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s.dat", + file_paths[k], SLASH_CHAR, src); + file_open_buff[COB_FILE_MAX] = 0; + if (access (file_open_buff, F_OK) == 0) { + snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s", + file_paths[k], SLASH_CHAR, src); + file_open_buff[COB_FILE_MAX] = 0; + break; + } +#endif + } + if (file_paths[k] == NULL) { + snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s", + file_paths[0], SLASH_CHAR, src); + file_open_buff[COB_FILE_MAX] = 0; + } + strncpy (file_open_name, file_open_buff, (size_t)COB_FILE_MAX); + } else if (src != file_open_name) { + strncpy (file_open_name, src, (size_t)COB_FILE_MAX); + } +} + void cob_chk_file_mapping (cob_file *f, char *filename) { @@ -1554,13 +1681,21 @@ cob_chk_file_mapping (cob_file *f, char *filename) char *saveptr; char *orig; unsigned int dollar, badchar; - int k, qt; + int qt; - memset (f->file_status, '0', (size_t)2); + if (f != NULL) + memset (f->file_status, '0', (size_t)2); if (filename) strcpy(file_open_name, filename); - /* Misuse "dollar" here to indicate a separator */ - dollar = 0; + + /* Special ACUCOBOL-case: file that start with hypen [note: -P not supported] + no translation at all, name starts after first non-space */ + if (has_acu_hypen (file_open_name)) { + do_acu_hypen_translation (file_open_name); + return ; + } + + /* Handle the COB_FILENAME_SPACES option */ if (chk_filename_spaces) { p = file_open_name; if (*p == '"') { @@ -1572,9 +1707,7 @@ cob_chk_file_mapping (cob_file *f, char *filename) badchar = 0; } for (; 1; p++) { - if (*p == '/' || *p == SLASH_CHAR) { - dollar = 1; - } else if (*p == qt) { + if (*p == qt) { *p = 0; if (qt == '"') memmove (file_open_name, file_open_name + 1, (size_t)(p - file_open_name)); @@ -1592,77 +1725,59 @@ cob_chk_file_mapping (cob_file *f, char *filename) break; } } - if (badchar) { + if (badchar && f != NULL) { f->file_status[0] = '9'; f->file_status[1] = 4; } - } else { - for (p = file_open_name; *p; p++) { - if (*p == '/' || *p == SLASH_CHAR) { - dollar = 1; - break; - } - } } src = file_open_name; - /* Simple case - No separators */ - if (dollar == 0) { + /* Simple case - No separators [note: this is also the ACU and Fujitsu way] */ + if (!looks_absolute(src) + && !has_directory_separator(src)) { /* Ignore leading dollar */ if (*src == '$') { src++; } /* Check for DD_xx, dd_xx, xx environment variables */ - /* If not found, use as is including the dollar character */ + /* Note: ACU and Fujitsu would only check for xx */ + /* If not found, use as is, possibly including the dollar character */ if ((p = cob_chk_file_env (f, src)) != NULL) { strncpy (file_open_name, p, (size_t)COB_FILE_MAX); - } else if (file_paths) { - for(k=0; file_paths[k] != NULL; k++) { - snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s", - file_paths[k], SLASH_CHAR, file_open_name); - file_open_buff[COB_FILE_MAX] = 0; - if (access (file_open_buff, F_OK) == 0) { - break; - } -#if defined(WITH_CISAM) || defined(WITH_DISAM) || defined(WITH_VBISAM) || defined(WITH_VISAM) - /* ISAM may append '.dat' to file name */ - snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s.dat", - file_paths[k], SLASH_CHAR, file_open_name); - file_open_buff[COB_FILE_MAX] = 0; - if (access (file_open_buff, F_OK) == 0) { - snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s", - file_paths[k], SLASH_CHAR, file_open_name); - file_open_buff[COB_FILE_MAX] = 0; - break; - } -#endif + /* Note: ACU specifies: "repeated until variable can't be resolved" + we don't apply this and will not in the future + [recursion is only one of the problems] */ + if (looks_absolute (src)) { + return; } - if (file_paths[k] == NULL) { - snprintf (file_open_buff, (size_t)COB_FILE_MAX, "%s%c%s", - file_paths[0], SLASH_CHAR, file_open_name); - file_open_buff[COB_FILE_MAX] = 0; + if (has_acu_hypen (file_open_name)) { + do_acu_hypen_translation (file_open_name); + return ; } - strncpy (file_open_name, file_open_buff, (size_t)COB_FILE_MAX); } + apply_file_paths (file_open_name); return; } /* Complex */ + + /* Note: ACU and Fujitsu would return the value back and stop here */ + /* Isolate first element (everything before the slash) */ - /* If it starts with a slash, it's absolute, do nothing */ - /* Else if it starts with a $, mark and skip over the $ */ + /* If it starts with a $, mark and skip over the $ */ /* Try mapping on resultant string - DD_xx, dd_xx, xx */ /* If successful, use the mapping */ /* If not, use original element EXCEPT if we started */ - /* with a $, in which case, we ignore the element AND */ + /* with a $, in which case we ignore the element AND */ /* the following slash */ - dollar = 0; dst = file_open_buff; *dst = 0; - if (*src == '$') { + if (*src != '$') { + dollar = 0; + } else { dollar = 1; src++; } @@ -1686,29 +1801,48 @@ cob_chk_file_mapping (cob_file *f, char *filename) } /* First element completed, loop through remaining */ /* elements delimited by slash */ - /* Check each for $ mapping */ + /* Check only for $ from now on; includes the DD_xx/dd_xx/xx mapping */ + src = NULL; for (; ;) { p = strtok (orig, "/\\"); if (!p) { break; } if (!orig) { - if (dollar) { - dollar = 0; - } else { + if (!dollar) { strcat (file_open_buff, SLASH_STR); } } else { orig = NULL; } - if (*p == '$' && (src = cob_chk_file_env (f, p + 1)) != NULL) { - strncat (file_open_buff, src, (size_t)COB_FILE_MAX); + if (*p != '$') { + dollar = 0; } else { + dollar = 1; + p++; + } + if (dollar && (src = cob_chk_file_env (f, p)) != NULL) { + strncat (file_open_buff, src, (size_t)COB_FILE_MAX); + src = NULL; + } else if (!dollar) { strncat (file_open_buff, p, (size_t)COB_FILE_MAX); + src = NULL; + } else { + src = p - 1; } } + /* if we have a final $something that cannot be resolved - use as plain name */ + if (src) { + strncat (file_open_buff, src, (size_t)COB_FILE_MAX); + } strcpy (file_open_name, file_open_buff); cob_free (saveptr); + + if (looks_absolute (file_open_name)) { + return; + } + + apply_file_paths (file_open_name); } void @@ -2808,6 +2942,7 @@ lock_record (cob_file *f, unsigned int recnum, int forwrite, int *errsts) lck.l_whence = SEEK_SET; lck.l_start = pos; lck.l_len = rcsz; + errno = 0; if (fcntl (f->fd, F_SETLK, &lck) != -1) { *errsts = 0; if(recnum == 0 @@ -2937,9 +3072,60 @@ unlock_record (cob_file *f, unsigned int recnum) return 0; /* Record is not locked! */ } +#elif defined _WIN32 + +/*TODO: handle record-level locks*/ +static int +lock_record(cob_file *f, unsigned int recnum, int forwrite, int *errsts) +{ + HANDLE osHandle; + + COB_UNUSED (recnum); + + f->blockpid = 0; + f->flag_file_lock = 1; + + osHandle = (HANDLE)_get_osfhandle (f->fd); + if (osHandle != INVALID_HANDLE_VALUE) { + DWORD flags = LOCKFILE_FAIL_IMMEDIATELY; + OVERLAPPED fromStart = {0}; + if (forwrite) flags |= LOCKFILE_EXCLUSIVE_LOCK; + if (LockFileEx (osHandle, flags, 0, MAXDWORD, MAXDWORD, &fromStart)) { + *errsts = 0; + return 1; + } + } + + *errsts = EAGAIN; /*TODO: return actual error*/ + return 0; +} + +/*TODO: handle record-level locks*/ +static int +unlock_record(cob_file *f, unsigned int recnum) +{ + HANDLE osHandle; + + COB_UNUSED (recnum); + + osHandle = (HANDLE)_get_osfhandle (f->fd); + if (osHandle != INVALID_HANDLE_VALUE) { + if (!UnlockFile (osHandle, 0, 0, MAXDWORD, MAXDWORD)) { +#if 0 /* CHECKME - What is the correct thing to do here? */ + /* not translated as "testing only" */ + cob_runtime_warning ("issue during UnLockFile (%s), lastError: " CB_FMT_LLU, + "unlock_record", (cob_u64_t)GetLastError ()); +#endif + return 0; + } + return 1; + } + + return 0; +} + #else /* System does not even have 'fcntl' so no explicit Record/File lock is used */ - /* TODO: check later for possible fall-back [at least WIN32]*/ static int lock_record(cob_file *f, unsigned int recnum, int forwrite, int *errsts) { @@ -4313,8 +4499,8 @@ cob_file_open (cob_file_api *a, cob_file *f, char *filename, return COB_XSTATUS_NOT_DIR; } if (f->flag_optional) { - f->file = fp; - f->fd = fileno (fp); + f->file = NULL; + f->fd = -1; f->open_mode = (unsigned char)mode; f->flag_nonexistent = 1; f->flag_end_of_file = 1; @@ -4438,10 +4624,24 @@ cob_file_close (cob_file_api *a, cob_file *f, const int opt) lock.l_whence = SEEK_SET; lock.l_start = 0; lock.l_len = 0; + errno = 0; if (fcntl (f->fd, F_SETLK, &lock) == -1) { cob_runtime_warning ("issue during unlock (%s), errno: %d", "cob_file_close", errno); } } +#elif defined _WIN32 + { + HANDLE osHandle = (HANDLE)_get_osfhandle (f->fd); + if (osHandle != INVALID_HANDLE_VALUE) { + if (!UnlockFile (osHandle, 0, 0, MAXDWORD, MAXDWORD)) { +#if 0 /* CHECKME - What is the correct thing to do here? */ + /* not translated as "testing only" */ + cob_runtime_warning ("issue during UnLockFile (%s), lastError: " CB_FMT_LLU, + "cob_file_close", (cob_u64_t)GetLastError ()); +#endif + } + } + } #endif /* Close the file */ if (f->organization == COB_ORG_LINE_SEQUENTIAL) { @@ -5062,6 +5262,7 @@ lineseq_write (cob_file_api *a, cob_file *f, const int opt) } } if (i < size) { + errno = 0; ret = fwrite (&p[i],(int)size - i, 1, fo); if (ret <= 0) { return errno_cob_sts (COB_STATUS_30_PERMANENT_ERROR); @@ -5077,6 +5278,7 @@ lineseq_write (cob_file_api *a, cob_file *f, const int opt) } } } + errno = 0; ret = fwrite (f->record->data, size, (size_t)1, fo); /* LCOV_EXCL_START */ if (ret != 1) { @@ -6043,6 +6245,19 @@ cob_file_unlock (cob_file *f) } } } +#elif defined _WIN32 + { + HANDLE osHandle = (HANDLE)_get_osfhandle (f->fd); + if (osHandle != INVALID_HANDLE_VALUE) { + if (!UnlockFile (osHandle, 0, 0, MAXDWORD, MAXDWORD)) { +#if 0 /* CHECKME - What is the correct thing to do here? */ + /* not translated as "testing only" */ + cob_runtime_warning ("issue during UnLockFile (%s), lastError: " CB_FMT_LLU, + "cob_file_unlock", (cob_u64_t)GetLastError()); +#endif + } + } + } #endif } else { @@ -6638,12 +6853,17 @@ cob_open (cob_file *f, const int mode, const int sharing, cob_field *fnstatus) } if (f->assign == NULL) { + /* CHECKME: that _seems_ to be a codegen error, but may also happen with EXTFH */ cob_runtime_error (_("ERROR FILE %s has ASSIGN field is NULL"), f->select_name); cob_file_save_status (f, fnstatus, COB_STATUS_31_INCONSISTENT_FILENAME); return; } if (f->assign->data == NULL) { +#if 0 /* we don't raise an error in other places and a similar error is raised in cob_fatal_error */ + cob_runtime_error ("file %s has ASSIGN field with NULL address", + f->select_name); +#endif cob_file_save_status (f, fnstatus, COB_STATUS_31_INCONSISTENT_FILENAME); return; } @@ -7573,6 +7793,7 @@ cob_param_no_quotes (int n) return (void*)s; } +/* actual processing for CBL_OPEN_FILE and CBL_CREATE_FILE */ static int open_cbl_file (cob_u8_ptr file_name, int file_access, cob_u8_ptr file_handle, const int file_flags) @@ -7604,8 +7825,12 @@ open_cbl_file (cob_u8_ptr file_name, int file_access, memset (file_handle, -1, (size_t)4); return -1; } - fd = open (fn, flag, COB_FILE_MODE); + + strncpy (file_open_name, fn, (size_t)COB_FILE_MAX); cob_free (fn); + cob_chk_file_mapping (NULL, NULL); + + fd = open (file_open_name, flag, COB_FILE_MODE); if (fd < 0) { memset (file_handle, -1, (size_t)4); return 35; @@ -7614,6 +7839,7 @@ open_cbl_file (cob_u8_ptr file_name, int file_access, return 0; } +/* entry point for library routine CBL_OPEN_FILE */ int cob_sys_open_file (unsigned char *file_name, unsigned char *file_access, unsigned char *file_lock, unsigned char *file_dev, @@ -7628,6 +7854,7 @@ cob_sys_open_file (unsigned char *file_name, unsigned char *file_access, return open_cbl_file (file_name, (int)cob_get_s64_param (2), file_handle, 0); } +/* entry point for library routine CBL_CREATE_FILE */ int cob_sys_create_file (unsigned char *file_name, unsigned char *file_access, unsigned char *file_lock, unsigned char *file_dev, @@ -7657,6 +7884,7 @@ cob_sys_create_file (unsigned char *file_name, unsigned char *file_access, return open_cbl_file (file_name, (int)cob_get_s64_param (2), file_handle, O_CREAT | O_TRUNC); } +/* entry point and processing for library routine CBL_READ_FILE */ int cob_sys_read_file (unsigned char *file_handle, unsigned char *file_offset, unsigned char *file_len, unsigned char *flags, @@ -7682,6 +7910,7 @@ cob_sys_read_file (unsigned char *file_handle, unsigned char *file_offset, if (lseek (fd, (off_t)off, SEEK_SET) == -1) { return -1; } + if (len > 0) { rc = read (fd, buf, len); if (rc < 0) { @@ -7703,6 +7932,7 @@ cob_sys_read_file (unsigned char *file_handle, unsigned char *file_offset, return rc; } +/* entry point and processing for library routine CBL_WRITE_FILE */ int cob_sys_write_file (unsigned char *file_handle, unsigned char *file_offset, unsigned char *file_len, unsigned char *flags, @@ -7732,6 +7962,7 @@ cob_sys_write_file (unsigned char *file_handle, unsigned char *file_offset, return COB_STATUS_00_SUCCESS; } +/* entry point and processing for library routine CBL_CLOSE_FILE */ int cob_sys_close_file (unsigned char *file_handle) { @@ -7743,6 +7974,7 @@ cob_sys_close_file (unsigned char *file_handle) return close (fd); } +/* dummy entry point for library routine CBL_FLUSH_FILE - doesn't do anything yet! */ int cob_sys_flush_file (unsigned char *file_handle) { @@ -7753,6 +7985,7 @@ cob_sys_flush_file (unsigned char *file_handle) return 0; } +/* entry point and processing for library routine CBL_DELETE_FILE */ int cob_sys_delete_file (unsigned char *file_name) { @@ -7767,14 +8000,20 @@ cob_sys_delete_file (unsigned char *file_name) if (fn == NULL) { return -1; } - ret = unlink (fn); + + strncpy (file_open_name, fn, (size_t)COB_FILE_MAX); cob_free (fn); + cob_chk_file_mapping (NULL, NULL); + + ret = unlink (file_open_name); if (ret) { return 128; } return 0; } +/* entry point and processing for library routine CBL_COPY_FILE, + does a direct read + write of the complete file */ int cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) { @@ -7799,20 +8038,27 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) cob_free (fn1); return -1; } + + strncpy (file_open_name, fn1, (size_t)COB_FILE_MAX); + cob_free (fn1); + cob_chk_file_mapping (NULL, NULL); + flag |= O_RDONLY; - fd1 = open (fn1, flag, 0); + fd1 = open (file_open_name, flag, 0); if (fd1 < 0) { - cob_free (fn1); cob_free (fn2); return -1; } + + strncpy (file_open_name, fn2, (size_t)COB_FILE_MAX); + cob_free (fn2); + cob_chk_file_mapping (NULL, NULL); + flag &= ~O_RDONLY; flag |= O_CREAT | O_TRUNC | O_WRONLY; - fd2 = open (fn2, flag, COB_FILE_MODE); + fd2 = open (file_open_name, flag, COB_FILE_MODE); if (fd2 < 0) { close (fd1); - cob_free (fn1); - cob_free (fn2); return -1; } @@ -7825,11 +8071,10 @@ cob_sys_copy_file (unsigned char *fname1, unsigned char *fname2) } close (fd1); close (fd2); - cob_free (fn1); - cob_free (fn2); return ret; } +/* entry point and processing for library routine CBL_CHECK_FILE_EXIST */ int cob_sys_check_file_exist (unsigned char *file_name, unsigned char *file_info) { @@ -7859,11 +8104,14 @@ cob_sys_check_file_exist (unsigned char *file_name, unsigned char *file_info) #endif } - if (stat (fn, &st) < 0) { - cob_free (fn); + strncpy (file_open_name, fn, (size_t)COB_FILE_MAX); + cob_free (fn); + cob_chk_file_mapping (NULL, NULL); + + if (stat (file_open_name, &st) < 0) { return 35; } - cob_free (fn); + sz = (cob_s64_t)st.st_size; tm = localtime (&st.st_mtime); d = (short)tm->tm_mday; @@ -7893,12 +8141,14 @@ cob_sys_check_file_exist (unsigned char *file_name, unsigned char *file_info) return 0; } +/* entry point and processing for library routine CBL_RENAME_FILE */ int cob_sys_rename_file (unsigned char *fname1, unsigned char *fname2) { char *fn1; char *fn2; - int ret; + char localbuff [COB_FILE_BUFF]; + int ret; COB_UNUSED (fname1); COB_UNUSED (fname2); @@ -7914,15 +8164,25 @@ cob_sys_rename_file (unsigned char *fname1, unsigned char *fname2) cob_free (fn1); return -1; } - ret = rename (fn1, fn2); + + strncpy (file_open_name, fn1, (size_t)COB_FILE_MAX); cob_free (fn1); + cob_chk_file_mapping (NULL, NULL); + + strncpy (localbuff, file_open_name, (size_t)COB_FILE_MAX); + + strncpy (file_open_name, fn2, (size_t)COB_FILE_MAX); cob_free (fn2); + cob_chk_file_mapping (NULL, NULL); + + ret = rename (localbuff, file_open_name); if (ret) { return 128; } return 0; } +/* entry point and processing for library routine CBL_GET_CURRENT_DIR */ int cob_sys_get_current_dir (const int p1, const int p2, unsigned char *p3) { @@ -7970,6 +8230,7 @@ cob_sys_get_current_dir (const int p1, const int p2, unsigned char *p3) return 0; } +/* entry point and processing for library routine CBL_CREATE_DIR */ int cob_sys_create_dir (unsigned char *dir) { @@ -7992,6 +8253,7 @@ cob_sys_create_dir (unsigned char *dir) return 0; } +/* entry point and processing for library routine CBL_CHANGE_DIR */ int cob_sys_change_dir (unsigned char *dir) { @@ -8014,6 +8276,7 @@ cob_sys_change_dir (unsigned char *dir) return 0; } +/* entry point and processing for library routine CBL_DELETE_DIR */ int cob_sys_delete_dir (unsigned char *dir) { @@ -8036,6 +8299,7 @@ cob_sys_delete_dir (unsigned char *dir) return 0; } +/* entry point for C$MAKEDIR, processing in cob_sys_create_dir */ int cob_sys_mkdir (unsigned char *dir) { @@ -8050,6 +8314,7 @@ cob_sys_mkdir (unsigned char *dir) return ret; } +/* entry point for C$CHDIR, processing in cob_sys_change_dir */ int cob_sys_chdir (unsigned char *dir, unsigned char *status) { @@ -8067,6 +8332,7 @@ cob_sys_chdir (unsigned char *dir, unsigned char *status) return ret; } +/* entry point for C$COPY, processing in cob_sys_copy_file */ int cob_sys_copyfile (unsigned char *fname1, unsigned char *fname2, unsigned char *file_type) @@ -8088,6 +8354,7 @@ cob_sys_copyfile (unsigned char *fname1, unsigned char *fname2, return ret; } +/* entry point and processing for C$FILEINFO */ int cob_sys_file_info (unsigned char *file_name, unsigned char *file_info) { @@ -8156,6 +8423,7 @@ cob_sys_file_info (unsigned char *file_name, unsigned char *file_info) return 0; } +/* entry point for C$DELETE, processing in cob_sys_delete_file */ int cob_sys_file_delete (unsigned char *file_name, unsigned char *file_type) { diff --git a/libcob/fisam.c b/libcob/fisam.c index 0df8e8ac1..60dd8d6fa 100644 --- a/libcob/fisam.c +++ b/libcob/fisam.c @@ -1508,8 +1508,9 @@ isam_read_next (cob_file_api *a, cob_file *f, const int read_opts) lmode = ISLOCK; } else if (read_opts & COB_READ_WAIT_LOCK) { lmode = ISLCKW; - } else if ((f->lock_mode & COB_LOCK_AUTOMATIC) - && f->open_mode != COB_OPEN_INPUT) { + } else + if ((f->lock_mode & COB_LOCK_AUTOMATIC) + && f->open_mode != COB_OPEN_INPUT) { if (!(read_opts & COB_READ_IGNORE_LOCK)) { lmode = ISLOCK; } @@ -1902,6 +1903,8 @@ isam_write (cob_file_api *a, cob_file *f, const int opt) if (ret == COB_STATUS_00_SUCCESS && retdup != COB_STATUS_00_SUCCESS) ret = retdup; + /* FIXME: use (is_suppressed_key_value) or similar to verify + that the duplicate this is not a SUPPRESSed KEY */ return ret; } diff --git a/libcob/focextfh.c b/libcob/focextfh.c index 50ae091b2..934af6326 100644 --- a/libcob/focextfh.c +++ b/libcob/focextfh.c @@ -120,6 +120,7 @@ indexed_open (cob_file_api *a, cob_file *f, char *filename, const int mode, cons switch (ret) { case COB_NOT_CONFIGURED: a->chk_file_mapping (f, NULL); + errno = 0; if (access (filename, F_OK) && errno == ENOENT) { if (mode != COB_OPEN_OUTPUT && f->flag_optional == 0) { return COB_STATUS_35_NOT_EXISTS; @@ -321,6 +322,7 @@ seqra_open (cob_file_api *a, cob_file *f, char *filename, const int mode, const switch (ret) { case COB_NOT_CONFIGURED: a->chk_file_mapping (f, NULL); + errno = 0; if (access (filename, F_OK) && errno == ENOENT) { if (mode != COB_OPEN_OUTPUT && f->flag_optional == 0) { return COB_STATUS_35_NOT_EXISTS; diff --git a/libcob/fsqlxfd.c b/libcob/fsqlxfd.c index 6659d93d6..2a186129b 100644 --- a/libcob/fsqlxfd.c +++ b/libcob/fsqlxfd.c @@ -56,7 +56,7 @@ cob_findkey_attr (cob_file *f, cob_field *kf, int *fullkeylen, int *partlen) } else { *partlen = *fullkeylen; } - return k; + return (int)k; } } } @@ -104,7 +104,7 @@ db_savekey (cob_file *f, unsigned char *keyarea, unsigned char *record, int idx) return totlen; } memcpy (keyarea, record + f->keys[idx].offset, f->keys[idx].field->size); - return f->keys[idx].field->size; + return (int)f->keys[idx].field->size; } /* Compare key for given index 'keyarea' to 'record'. diff --git a/tests/ChangeLog b/tests/ChangeLog index e059b7bab..feb35cba8 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -108,10 +108,9 @@ 2020-11-20 Simon Sobisch - * general: pass AWK, GREP, SED to the testsuite + * general: pass AWK, GREP, SED to the testsuite and use those * atlocal.in, atlocal_valgrind, atlocal_win: remove temporary file info.out after use - * listings-sed.sh: replace both 2 and 3-part version numbers 2020-11-12 Simon Sobisch @@ -121,6 +120,14 @@ * atlocal.in, atlocal_valgrind: exec_prefix as exec_prefix +2020-11-04 Simon Sobisch + + * atlocal.in, atlocal_valgrind, atlocal_win: + fix unsetting of variables which values contain "COB"; + allow screenio-tests to be run on cygwin/msys with ncurses + out-of-the box; fixed TEST_LOCAL (may not use pre-inst-env) + and "external" versions with old indexed file msgid + 2020-10-26 Simon Sobisch * atlocal.in, atlocal_valgrind, atlocal_win: diff --git a/tests/atlocal.in b/tests/atlocal.in index db0496794..ff4e4332e 100644 --- a/tests/atlocal.in +++ b/tests/atlocal.in @@ -224,6 +224,9 @@ else COB_HAS_64_BIT_POINTER=$(grep "64bit-mode" info.out | cut -d: -f2 | cut -b2-) cob_indexed=$(grep -i "indexed file" info.out | cut -d: -f2) + if test "x$cob_indexed" = "x"; then + cob_indexed=$(grep ISAM info.out | cut -d: -f2) + fi case "$cob_indexed" in " disabled") COB_HAS_ISAM="no";; " BDB") COB_HAS_ISAM="db";; diff --git a/tests/atlocal_valgrind b/tests/atlocal_valgrind index 19c80c547..1c196e0c0 100644 --- a/tests/atlocal_valgrind +++ b/tests/atlocal_valgrind @@ -223,6 +223,9 @@ else COB_HAS_64_BIT_POINTER=$(grep "64bit-mode" info.out | cut -d: -f2 | cut -b2-) cob_indexed=$(grep -i "indexed file" info.out | cut -d: -f2) + if test "x$cob_indexed" = "x"; then + cob_indexed=$(grep ISAM info.out | cut -d: -f2) + fi case "$cob_indexed" in " disabled") COB_HAS_ISAM="no";; " BDB") COB_HAS_ISAM="db";; @@ -252,6 +255,29 @@ else fi fi +if test "x$MSYSTEM" != "x" -o "$OSTYPE" = "cygwin"; then + # running MSYS builds as not-visible child processes result in + # "Redirection is not supported" (at least with PDCurses "wincon" port) + # --> disabling the tests for this feature + # ncurses is known to work as long as TERM is appropriate + if test $(grep -i -c "ncurses" info.out) != 0; then + if test "x$MSYSTEM" != "x"; then + TERM="" + else + TERM="xterm" + fi + export TERM + # no change here... COB_HAS_CURSES="yes" + else + # manual tests are executed in separate window + # and are visible - so no need to handle it there + echo "$at_help_all" | grep -q "run_manual_screen" 2>/dev/null + if test $? -ne 0; then + COB_HAS_CURSES="no" + fi + fi +fi + rm -rf info.out # NIST tests (tests/cobol85) are executed in a separate perl process with a new environment --> export needed diff --git a/tests/atlocal_win b/tests/atlocal_win index 4b2b0fcef..cf939824a 100644 --- a/tests/atlocal_win +++ b/tests/atlocal_win @@ -149,6 +149,9 @@ export COB_MSG_FORMAT COB_HAS_64_BIT_POINTER=$(grep "64bit-mode" info.out | cut -d: -f2 | cut -b2-) cob_indexed=$(grep -i "indexed file" info.out | cut -d: -f2) + if test "x$cob_indexed" = "x"; then + cob_indexed=$(grep ISAM info.out | cut -d: -f2) + fi case "$cob_indexed" in " disabled") COB_HAS_ISAM="no";; " BDB") COB_HAS_ISAM="db";; @@ -177,10 +180,9 @@ export COB_MSG_FORMAT COB_HAS_CURSES="no" fi - if test "x$MSYSTEM" != "x" -o "$OSTYPE" = "cygwin"; then # running MSYS builds as not-visible child processes result in - # "Redirection is not supported" (at least old PDCurses) + # "Redirection is not supported" (at least with PDCurses "wincon" port) # --> disabling the tests for this feature # ncurses is known to work as long as TERM is appropriate if test $(grep -i -c "ncurses" info.out) != 0; then diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index 4c7618a46..c6a67c697 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -551,9 +551,9 @@ AT_CHECK([$COBCRUN --runtime-conf], [0], ignore, []) # use tr to remove newlines and spaces as the path likely is split # into two lines AT_CHECK([$COBCRUN --runtime-conf | tr -d '\n ' | \ -grep "runtime_empty.cfg"], [0], ignore, []) +$GREP "runtime_empty.cfg"], [0], ignore, []) AT_CHECK([COB_RUNTIME_CONFIG="" $COBCRUN --runtime-conf | tr -d '\n ' \ -| grep "runtime.cfg"], +| $GREP "runtime.cfg"], [0], ignore, []) AT_CLEANUP @@ -577,23 +577,23 @@ setenv COB_PHYSICAL_CANCEL=true # verify that default for physical cancel is still "no" AT_CHECK([$COBCRUN --runtime-conf | \ -grep "COB_PHYSICAL_CANCEL" | grep "no" | grep "default"], [0], ignore, []) +$GREP "COB_PHYSICAL_CANCEL" | $GREP "no" | $GREP "default"], [0], ignore, []) # verify that override via -c works and if include works AT_CHECK([$COBCRUN -c test2.cfg --runtime-conf | \ -grep "physical_cancel" | grep "yes"], [0], ignore, []) +$GREP "physical_cancel" | $GREP "yes"], [0], ignore, []) AT_CHECK([$COBCRUN -c test.cfg --runtime-conf | \ -grep "physical_cancel" | grep "yes"], [0], ignore, []) +$GREP "physical_cancel" | $GREP "yes"], [0], ignore, []) AT_CHECK([$COBCRUN -c test3.cfg --runtime-conf | \ -grep "COB_PHYSICAL_CANCEL" | grep "yes"], [0], ignore, []) +$GREP "COB_PHYSICAL_CANCEL" | $GREP "yes"], [0], ignore, []) # verify that that long option works AT_CHECK([$COBCRUN --config=test3.cfg --runtime-conf | \ -grep "COB_PHYSICAL_CANCEL" | grep "yes"], [0], ignore, []) +$GREP "COB_PHYSICAL_CANCEL" | $GREP "yes"], [0], ignore, []) # verify that that environment setting works AT_CHECK([COB_RUNTIME_CONFIG=test3.cfg $COBCRUN --runtime-conf | \ -grep "COB_PHYSICAL_CANCEL" | grep "yes"], [0], ignore, []) +$GREP "COB_PHYSICAL_CANCEL" | $GREP "yes"], [0], ignore, []) # verify that configuration file loading with full path works AT_CHECK([$COBCRUN -c "$(_return_path "$(pwd)/test.cfg")" --runtime-conf], @@ -639,7 +639,7 @@ physical_cancel true ]) AT_CHECK([COB_PHYSICAL_CANCEL=false $COBCRUN -c test.cfg --runtime-conf | \ -grep "COB_PHYSICAL_CANCEL" | grep "no"], [0], ignore, []) +$GREP "COB_PHYSICAL_CANCEL" | $GREP "no"], [0], ignore, []) AT_CLEANUP @@ -774,9 +774,9 @@ AT_CHECK([unset greet name ; \ TESTME="this is a test" \ COB_EXIT_MSG='${greet:Bye} ${name:-user}, ${TESTME}' \ $COBCRUN --runtime-conf | \ -grep "COB_EXIT_MSG" | grep "Bye user, this is a test"], [0], ignore, []) +$GREP "COB_EXIT_MSG" | $GREP "Bye user, this is a test"], [0], ignore, []) AT_CHECK([$COBCRUN --runtime-conf | \ -grep "COB_EXIT_MSG" | grep "end of program, please press a key to exit"], [0], ignore, []) +$GREP "COB_EXIT_MSG" | $GREP "end of program, please press a key to exit"], [0], ignore, []) AT_CLEANUP diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 153846bfa..cdf24f7be 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -968,6 +968,7 @@ AT_DATA([prog.cob], [ # note: IBM implies -fodoslide AT_CHECK([$COBC -x -std=ibm prog.cob], [0], [], []) AT_CHECK([$COMPILE -std=ibm prog.cob], [0], [], []) +AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) @@ -1273,6 +1274,74 @@ GRP-5:***Mon49eyMon49eyMon49eyMon49eyMon49eyMon49eyMon49eyMon AT_CLEANUP +AT_SETUP([INITIALIZE OCCURS UNBOUNDED]) +AT_KEYWORDS([extensions runsubscripts subscripts refmod INITIALIZE]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 p USAGE POINTER. + 01 p2 USAGE POINTER. + + LINKAGE SECTION. + 01 a-table. + 03 prefix. + 05 n PIC 9(03) VALUE 123. + 03 table-data value all "ABCDE". + 04 rows OCCURS 0 TO UNBOUNDED TIMES + DEPENDING ON n. + 05 col1 PIC X. + 05 col2 PIC X(02). + + PROCEDURE DIVISION. + ALLOCATE LENGTH OF prefix CHARACTERS + RETURNING p + SET ADDRESS OF a-table TO p + INITIALIZE prefix ALL TO VALUE + IF FUNCTION LENGTH (a-table) NOT = 372 + DISPLAY 'WRONG LENGTH table: ' FUNCTION LENGTH (a-table) + END-DISPLAY + END-IF + ALLOCATE FUNCTION LENGTH (a-table) CHARACTERS + RETURNING p2 + SET ADDRESS OF a-table TO p2 + FREE p + INITIALIZE prefix ALL TO VALUE + *> FIXME: broken - initializes up to max but only should initialize + *> up to current size INITIALIZE table-data ALL TO VALUE + *> INITIALIZE table-data ALL TO VALUE + *> FIXME: broken - FUNCTION LENGTH(table-data) must be resolved + *> at run-time but is currently set to max at compile-time + *> INITIALIZE table-data (1:FUNCTION LENGTH(table-data)) + *> ALL TO VALUE + INITIALIZE table-data (1:FUNCTION LENGTH(rows(1)) * n) + ALL TO VALUE + IF col2(1) NOT = "BC" + DISPLAY "col2(1) wrong: " col2(1) + END-DISPLAY + END-IF + IF rows(2) NOT = "DEA" + DISPLAY "rows(2) wrong: " rows(2) + END-DISPLAY + END-IF + DISPLAY LENGTH OF a-table + *> check if ref-mod also works as expected + MOVE ALL ZEROES TO a-table (1: (LENGTH OF a-table)) + . +]) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) + +# multiple issues, see comments above +AT_XFAIL_IF(true) + +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_CLEANUP + + AT_SETUP([DEPENDING ON with ODOSLIDE]) AT_KEYWORDS([nested ODO]) @@ -2879,6 +2948,7 @@ STATUS OPENO 2 30 AT_CLEANUP + AT_SETUP([ASSIGN with COB_FILE_PATH]) AT_KEYWORDS([extensions runfile]) @@ -2899,17 +2969,56 @@ AT_DATA([prog.cob], [ STOP RUN. ]) +AT_DATA([prog2.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT TEST-FILE ASSIGN "SUBDIR/FILENAMEX". + DATA DIVISION. + FILE SECTION. + FD TEST-FILE. + 01 TEST-REC PIC X(4). + PROCEDURE DIVISION. + OPEN OUTPUT TEST-FILE. + CLOSE TEST-FILE. + STOP RUN. +]) + AT_CHECK([$COMPILE -ffilename-mapping prog.cob], [0], [], []) + AT_CHECK([rm -rf "tstdir" && mkdir "tstdir"], [0], [], []) + AT_CHECK([COB_FILE_PATH="tstdir" $COBCRUN_DIRECT ./prog], [0], [], []) AT_CHECK([test -f "tstdir/FILENAMEX" && rm -f "tstdir/FILENAMEX"], [0], [], []) + AT_CHECK([COB_FILE_PATH="tstdir/" $COBCRUN_DIRECT ./prog], [0], [], []) AT_CHECK([test -f "tstdir/FILENAMEX"], [0], [], []) # FIXME: on OPEN we should also output the full filename (if any) leading to the error -AT_CHECK([COB_FILE_PATH="./nosubhere" $COBCRUN_DIRECT ./prog], [1], [], +AT_CHECK([COB_FILE_PATH="./nosubhere" $COBCRUN_DIRECT ./prog 2>prog.err], [1], [], []) +# workaround for testing windows-builds... +AT_CHECK([cat prog.err | tr '\\' '/'], [0], [libcob: prog.cob:13: error: permanent file error (status = 30) for file TEST-FILE ('FILENAMEX' => ./nosubhere/FILENAMEX) on OPEN -]) +], []) + + +AT_CHECK([$COMPILE -ffilename-mapping prog2.cob], [0], [], []) + +AT_CHECK([mkdir "tstdir/SUBDIR"], [0], [], []) + +AT_CHECK([COB_FILE_PATH="tstdir" $COBCRUN_DIRECT ./prog2], [0], [], []) +AT_CHECK([test -f "tstdir/SUBDIR/FILENAMEX" && rm -f "tstdir/SUBDIR/FILENAMEX"], [0], [], []) + +AT_CHECK([COB_FILE_PATH="tstdir/" $COBCRUN_DIRECT ./prog2], [0], [], []) +AT_CHECK([test -f "tstdir/SUBDIR/FILENAMEX"], [0], [], []) + +AT_CHECK([COB_FILE_PATH="./nosubhere" $COBCRUN_DIRECT ./prog2 2>prog.err], [1], [], []) +AT_CHECK([cat prog.err | tr '\\' '/'], [0], +[libcob: prog2.cob:13: error: permanent file error (status = 30) for file TEST-FILE ('SUBDIR/FILENAMEX' => ./nosubhere/SUBDIR/FILENAMEX) on OPEN +], []) + AT_CLEANUP @@ -5769,99 +5878,6 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP -AT_SETUP([Conditional / define directives (5)]) -AT_KEYWORDS([extensions directive]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - PROCEDURE DIVISION. - >>IF ACTIVATE DEFINED - >>DISPLAY NOTOK - >>ELIF ACTIVATE2 DEFINED - >>DISPLAY OK - >>ELSE - >>DISPLAY NOTOK - >>END-IF - STOP RUN. -]) - -AT_CHECK([$COMPILE -DACTIVATE2 prog.cob], [0], -[OK -]) -AT_CLEANUP - - -AT_SETUP([Conditional / define directives (6)]) -AT_KEYWORDS([extensions directive]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - PROCEDURE DIVISION. - >>IF X DEFINED - >>DISPLAY X defined - >>ELSE - >>DISPLAY X not defined - >>DEFINE X 1 - >>END-IF - CONTINUE - . -]) - -AT_CHECK([$COMPILE -D X prog.cob], [0], -[X defined -]) -AT_CHECK([$COMPILE prog.cob], [0], -[X not defined -]) -AT_CLEANUP - - -AT_SETUP([Conditional / define directives (7)]) -AT_KEYWORDS([extensions directive]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - PROCEDURE DIVISION. - >>IF A IS DEFINED - >>IF B IS DEFINED - CONTINUE - . - >>ELSE - CONTINUE - . - >>END-IF - >>END-IF -]) - -AT_CHECK([$COMPILE prog.cob], [0], []) -AT_CLEANUP - - -AT_SETUP([Conditional/define directives (8)]) -AT_KEYWORDS([extensions directive]) - -AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - PROCEDURE DIVISION. - >>IF A IS DEFINED - CONTINUE - . - >>else - CONTINUE - . - >>eNd-If -]) - -AT_CHECK([$COMPILE prog.cob], [0], []) -AT_CLEANUP - - AT_SETUP([Variable format]) AT_KEYWORDS([extensions runmisc]) diff --git a/tests/testsuite.src/run_file.at b/tests/testsuite.src/run_file.at index d683b585e..153ac32d3 100644 --- a/tests/testsuite.src/run_file.at +++ b/tests/testsuite.src/run_file.at @@ -110,40 +110,40 @@ AT_DATA([prog.cob], [ * *> DELETE FILE FILE-OPT *> ON EXCEPTION - *> DISPLAY "STATUS DELETE FILE (missing) - EXCEPTION:" WSFS + *> DISPLAY "STATUS DELETE FILE (missing) - EXCEPTION: " WSFS *> END-DISPLAY *> NOT ON EXCEPTION *> IF WSFS NOT = "05" - *> DISPLAY "STATUS DELETE FILE (missing):" WSFS + *> DISPLAY "STATUS DELETE FILE (missing): " WSFS *> END-IF *> END-DELETE OPEN I-O FILE-OPT IF WSFS NOT = "05" - DISPLAY "STATUS I-O, missing optional file:" WSFS. + DISPLAY "STATUS I-O, missing optional file: " WSFS. CLOSE FILE-OPT IF WSFS NOT = "00" - DISPLAY "STATUS CLOSE:" WSFS. + DISPLAY "STATUS CLOSE: " WSFS. OPEN I-O FILE-OPT IF WSFS NOT = "00" - DISPLAY "STATUS I-O, empty file:" WSFS. + DISPLAY "STATUS I-O, empty file: " WSFS. DELETE FILE FILE-OPT *> ON EXCEPTION IF WSFS NOT = "41" - DISPLAY "STATUS DELETE FILE (OPENED):" WSFS + DISPLAY "STATUS DELETE FILE (opened): " WSFS END-IF *> NOT ON EXCEPTION - *> DISPLAY "STATUS DELETE FILE (OPENED) - NO EXCEPTION:" WSFS + *> DISPLAY "STATUS DELETE FILE (opened) - NO EXCEPTION: " WSFS *> END-DELETE CLOSE FILE-OPT IF WSFS NOT = "00" - DISPLAY "STATUS CLOSE #2:" WSFS. + DISPLAY "STATUS CLOSE #2: " WSFS. DELETE FILE FILE-OPT *> ON EXCEPTION - *> DISPLAY "STATUS DELETE FILE (closed) - EXCEPTION:" WSFS + *> DISPLAY "STATUS DELETE FILE (closed) - EXCEPTION: " WSFS *> END-DISPLAY *> NOT ON EXCEPTION IF WSFS NOT = "00" - DISPLAY "STATUS DELETE FILE (closed):" WSFS + DISPLAY "STATUS DELETE FILE (closed): " WSFS END-IF *> END-DELETE * @@ -291,40 +291,40 @@ AT_DATA([prog.cob], [ * *> DELETE FILE FILE-OPT *> ON EXCEPTION - *> DISPLAY "STATUS DELETE FILE (missing) - EXCEPTION:" WSFS + *> DISPLAY "STATUS DELETE FILE (missing) - EXCEPTION: " WSFS *> END-DISPLAY *> NOT ON EXCEPTION *> IF WSFS NOT = "05" - *> DISPLAY "STATUS DELETE FILE (missing):" WSFS + *> DISPLAY "STATUS DELETE FILE (missing): " WSFS *> END-IF *> END-DELETE OPEN I-O FILE-OPT IF WSFS NOT = "05" - DISPLAY "STATUS I-O, missing optional file:" WSFS. + DISPLAY "STATUS I-O, missing optional file: " WSFS. CLOSE FILE-OPT IF WSFS NOT = "00" - DISPLAY "STATUS CLOSE:" WSFS. + DISPLAY "STATUS CLOSE: " WSFS. OPEN I-O FILE-OPT IF WSFS NOT = "00" - DISPLAY "STATUS I-O, empty file:" WSFS. + DISPLAY "STATUS I-O, empty file: " WSFS. DELETE FILE FILE-OPT *> ON EXCEPTION IF WSFS NOT = "41" - DISPLAY "STATUS DELETE FILE (OPENED):" WSFS + DISPLAY "STATUS DELETE FILE (opened): " WSFS END-IF *> NOT ON EXCEPTION - *> DISPLAY "STATUS DELETE FILE (OPENED) - NO EXCEPTION:" WSFS + *> DISPLAY "STATUS DELETE FILE (opened) - NO EXCEPTION: " WSFS *> END-DELETE CLOSE FILE-OPT IF WSFS NOT = "00" - DISPLAY "STATUS CLOSE #2:" WSFS. + DISPLAY "STATUS CLOSE #2: " WSFS. DELETE FILE FILE-OPT *> ON EXCEPTION - *> DISPLAY "STATUS DELETE FILE (closed) - EXCEPTION:" WSFS + *> DISPLAY "STATUS DELETE FILE (closed) - EXCEPTION: " WSFS *> END-DISPLAY *> NOT ON EXCEPTION IF WSFS NOT = "00" - DISPLAY "STATUS DELETE FILE (closed):" WSFS + DISPLAY "STATUS DELETE FILE (closed): " WSFS END-IF *> END-DELETE * @@ -3109,6 +3109,47 @@ AT_CHECK([$COBCRUN_DIRECT ./prog2], [1], [], AT_CLEANUP +AT_SETUP([ASSIGN with empty data item]) +AT_KEYWORDS([runfile status]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT test-file ASSIGN path + ORGANIZATION LINE SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD test-file. + 01 test-rec PIC X(5). + WORKING-STORAGE SECTION. + 01 WS-SUBSCRIPT-CNT PIC 9. + 01 path PIC X(10). + 01 x PIC X. + PROCEDURE DIVISION CHAINING x. + IF X = SPACE + MOVE SPACES TO path + ELSE + MOVE LOW-VALUES TO path + END-IF + OPEN INPUT test-file + DISPLAY "Hello" + STOP RUN. +]) + +AT_CHECK([$COBC -x prog.cob]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], +[libcob: error: inconsistant file name (status = 31) for file test-file ('') +]) +AT_CHECK([$COBCRUN_DIRECT ./prog X], [1], [], +[libcob: error: inconsistant file name (status = 31) for file test-file ('') +]) + +AT_CLEANUP + + AT_SETUP([INDEXED file key-name]) AT_KEYWORDS([runfile split key]) @@ -3830,7 +3871,7 @@ AT_CLEANUP AT_SETUP([INDEXED file variable length record]) -AT_KEYWORDS([runfile WRITE START READ]) +AT_KEYWORDS([runfile OPTIONAL SUPPRESS WRITE START READ]) AT_SKIP_IF([test "$COB_HAS_ISAM" = "no"]) @@ -3915,9 +3956,10 @@ AT_DATA([prog.cob], [ Perform tbw-read-next thru tbw-exit. - * Second test. Perform tbw-close thru tbw-exit. + * Second test. + Perform tbw-delete-file thru tbw-exit. Perform tbw-open-i-o thru tbw-exit. @@ -3950,6 +3992,9 @@ AT_DATA([prog.cob], [ Move spaces to tbw-alt. Perform tbw-rewrite thru tbw-exit. + *> note: should not have status 02 as it a suppressed alternate key + *> therefore duplicate checks must be skipped + * Finish. Perform tbw-close thru tbw-exit. Display "Test completed". @@ -3958,75 +4003,92 @@ AT_DATA([prog.cob], [ * I/O. tbw-Open-I-O. If flag-tbw-open - Perform tbw-Close thru tbw-Close-exit - end-if. + Perform tbw-Close thru tbw-Close-exit. Display "open". Open i-o tbw. - Display "open". + Display "open done". If fs-file-status is less than "10" - Set flag-tbw-open to true - end-if. + Set flag-tbw-open to true. Go to tbw-exit. * tbw-Start-Primary-Greater. Display "start > tbw-key". Start tbw key is greater than tbw-key - invalid key Continue - end-start. - Display "start > tbw-key". + invalid key + Display "start > tbw-key inv" + Go to tbw-exit + not invalid + Display "start > tbw-key done" + Go to tbw-exit. + Display "start > tbw-key " fs-file-status Go to tbw-exit. * tbw-Start-Alternate. Display "start >= tbw-alt". Start tbw key is not less than tbw-alt - invalid key Continue - end-start. - Display "start >= tbw-alt". + invalid key + *>Inspect! Display "start >= tbw-alt inv" + Display "start >= tbw-alt done" + Go to tbw-exit + not invalid + Display "start >= tbw-alt done" + Go to tbw-exit. + Display "start >= tbw-alt " fs-file-status Go to tbw-exit. * tbw-Read-Next. Display "read next". Read tbw next record - at end Continue - end-read. - Display "read next done". + at end + Display "read next end" + Go to tbw-exit + not at end + Display "read next done" + Go to tbw-exit. + Display "read next " fs-file-status Go to tbw-exit. * tbw-Write. Display "write". Write tbw-record - invalid key Continue - end-write. - Display "write". + invalid key + Display "write inv" + Go to tbw-exit + not invalid + Display "write done" + Go to tbw-exit. + Display "write " fs-file-status Go to tbw-exit. * tbw-Rewrite. Display "rewrite". Rewrite tbw-record - invalid key Continue - end-rewrite. - Display "rewrite " fs-file-status. + invalid key + Display "rewrite inv " fs-file-status + Go to tbw-exit + not invalid + Display "rewrite done " fs-file-status + Go to tbw-exit. + Display "rewrite " fs-file-status Go to tbw-exit. * tbw-Delete-File. If flag-tbw-open - Perform tbw-Close thru tbw-Close-exit - end-if. + Perform tbw-Close thru tbw-Close-exit. Move "xx" to fs-file-status. Display "delete file". - Delete file tbw - end-delete. - Display "delete file". + Delete file tbw. + Display "delete file done". Go to tbw-exit. * tbw-Close. If flag-tbw-open Display "close" Close tbw - Display "close" + Display "close done" Set flag-tbw-closed to true end-if. tbw-Close-exit. @@ -4039,45 +4101,45 @@ AT_CHECK([$COMPILE prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [delete file -delete file +delete file done open -open -start > tbw-key +open done start > tbw-key +start > tbw-key inv read next -read next done -write +read next 46 write +write done start >= tbw-alt -start >= tbw-alt -start > tbw-key +start >= tbw-alt done start > tbw-key +start > tbw-key done read next read next done read next -read next done +read next end close -close -delete file +close done delete file +delete file done open -open -start > tbw-key +open done start > tbw-key +start > tbw-key inv read next -read next done -write -write +read next 46 write +write done write +write done start >= tbw-alt -start >= tbw-alt +start >= tbw-alt done read next read next done rewrite -rewrite 00 -close +rewrite done 00 close +close done Test completed ], []) @@ -5519,16 +5581,120 @@ AT_DATA([prog2.cob], [ STOP RUN. ]) +AT_DATA([prog3.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog3. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FNAME PIC X(256). + 01 RET PIC -9. + 01 FHANDLE PIC X(4) USAGE COMP-X. + + 01 OFFSET PIC X(8) USAGE COMP-X. + 01 NBYTES PIC X(4) USAGE COMP-X. + 01 READ-BUFFER PIC X(10). + + PROCEDURE DIVISION CHAINING FNAME. + DISPLAY 'RUN WITH ' FUNCTION TRIM (FNAME TRAILING). + CALL 'CBL_OPEN_FILE' USING FNAME 1 0 0 FHANDLE. + IF RETURN-CODE NOT = 0 + DISPLAY 'error opening file ...' + MOVE 0 TO RETURN-CODE + STOP RUN. + + CALL 'CBL_CLOSE_FILE' USING FHANDLE. + IF RETURN-CODE NOT = 0 + DISPLAY 'error closing file ...' + return-code + MOVE 0 TO RETURN-CODE. + + STOP RUN. +]) + AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COMPILE prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], [libcob: prog.cob:15: warning: call to CBL_CREATE_FILE with wrong file_lock: 11 libcob: prog.cob:15: warning: call to CBL_CREATE_FILE with wrong file_dev: 22 libcob: prog.cob:15: warning: call to CBL_OPEN_FILE with wrong access mode: 55 ]) + +AT_CHECK([$COMPILE prog2.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) +AT_CHECK([mkdir -p sub], [0], [], []) +AT_CHECK([$COMPILE prog3.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog3 notthere], [0], +[RUN WITH notthere +error opening file ... +], []) +AT_CHECK([$COBCRUN_DIRECT ./prog3 prog2], [0], +[RUN WITH prog2 +], []) +AT_CHECK([$COBCRUN_DIRECT ./prog3 ./prog2], [0], +[RUN WITH ./prog2 +], []) +# the first part is resolved by DD_var and dd_var +AT_CHECK([DD_dot="." dd_dot="A" dot="B" $COBCRUN_DIRECT ./prog3 'dot/prog'], [0], +[RUN WITH dot/prog +], []) +AT_CHECK([DD_dot="" dd_dot="." dot="A" $COBCRUN_DIRECT ./prog3 'dot/prog'], [0], +[RUN WITH dot/prog +], []) +# MF would say (ignore for now as this conflicts with ACUCOBOL) don't resolve by $ +# as it does not start with $: +#AT_CHECK([DD_dot="" dd_dot="" dot="." $COBCRUN_DIRECT ./prog3 'dot/prog'], [0], +#[RUN WITH dot/prog +#error opening file ... +#], []) +AT_CHECK([DD_dot="" dd_dot="" dot="." $COBCRUN_DIRECT ./prog3 'dot/prog'], [0], +[RUN WITH dot/prog +], []) +AT_CHECK([DD_dot="" dd_dot="" dot="" $COBCRUN_DIRECT ./prog3 'dot/prog'], [0], +[RUN WITH dot/prog +error opening file ... +], []) +# the first part with $ is resolved by DD_var and dd_var and var +AT_CHECK([DD_dot="." dd_dot="" dot="" $COBCRUN_DIRECT ./prog3 '$dot/prog'], [0], +[RUN WITH $dot/prog +], []) +AT_CHECK([DD_dot="" dd_dot="." dot="" $COBCRUN_DIRECT ./prog3 '$dot/prog'], [0], +[RUN WITH $dot/prog +], []) +AT_CHECK([DD_dot="" dd_dot="" dot="." $COBCRUN_DIRECT ./prog3 '$dot/prog'], [0], +[RUN WITH $dot/prog +], []) +# if a _leading_ $ does not exist it is removed, together with the following slash +# should ignore the variable and the first slash +AT_CHECK([DD_dot="" dd_dot="" dot="" $COBCRUN_DIRECT ./prog3 '$dot/prog'], [0], +[RUN WITH $dot/prog +], []) +# would _possibly_ fail with MF (docs are wrong here in any case...) +# but this is by GnuCOBOL design here: +AT_CHECK([DD_dot="" dd_dot="" dot="" $COBCRUN_DIRECT ./prog3 '$dot/$dotter/prog'], [0], +[RUN WITH $dot/$dotter/prog +], []) +AT_CHECK([DD_dot="" dd_dot="" dot="dot" $COBCRUN_DIRECT ./prog3 '$dot/prog'], [0], +[RUN WITH $dot/prog +error opening file ... +], []) +# should try './prog' +AT_CHECK([DD_prog="A" dd_prog="B" prog="C" $COBCRUN_DIRECT ./prog3 './prog'], [0], +[RUN WITH ./prog +], []) +# should try './$prog' +AT_CHECK([DD_prog="" dd_prog="" prog="" $COBCRUN_DIRECT ./prog3 './$prog'], [0], +[RUN WITH ./$prog +error opening file ... +], []) +AT_CHECK([$COBCRUN_DIRECT ./prog3 ../prog2], [0], +[RUN WITH ../prog2 +error opening file ... +], []) +AT_CHECK([$COBCRUN_DIRECT ./prog3 sub/../prog2], [0], +[RUN WITH sub/../prog2 +], []) + AT_CLEANUP @@ -6366,12 +6532,12 @@ AT_DATA([prog2.cob], [ procedure division. open i-o file1. if fs not = "61" - display "I-O FAILED: " fs + display "I-O FAILED 1: " fs close file1 end-if. open input file1. if fs not = "00" - display "IN FAILED: " fs + display "IN FAILED 2: " fs else close file1 end-if. @@ -14036,9 +14202,9 @@ Program-Id: prog # hack for not checking Status 02 as this isn't returned by all # ISAM implementations -AT_CHECK([sed -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ +AT_CHECK([$SED -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ reference > references], [0], [], []) -AT_CHECK([sed -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ +AT_CHECK([$SED -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ -e 's/'"OPEN OUTPUT TSPFILE -> 'testisam' Status: 05"'/'"OPEN OUTPUT TSPFILE -> 'testisam' Status: 00"'/g' \ trace.txt > traces.txt], [0], [], []) @@ -15624,10 +15790,10 @@ Program-Id: prog # hack for not checking Status 02 as this isn't returned by all # ISAM implementations -AT_CHECK([sed -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ +AT_CHECK([$SED -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ -e 's/_$//g' \ reference > references], [0], [], []) -AT_CHECK([sed -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ +AT_CHECK([$SED -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ -e 's/'"OPEN OUTPUT TSPFILE -> 'testisam' Status: 05"'/'"OPEN OUTPUT TSPFILE -> 'testisam' Status: 00"'/g' \ trace.txt > traces.txt], [0], [], []) @@ -16686,10 +16852,10 @@ AT_DATA([reference], # hack for not checking Status 02 as this isn't returned by all # ISAM implementations; meve trailing line helper along -AT_CHECK([sed -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ +AT_CHECK([$SED -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ -e 's/_$//g' \ reference > references], [0], [], []) -AT_CHECK([sed -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ +AT_CHECK([$SED -e 's/WRITE TSPFILE Status: 02/WRITE TSPFILE Status: 00/g' \ -e 's/'"OPEN OUTPUT TSPFILE -> 'testisam' Status: 05"'/'"OPEN OUTPUT TSPFILE -> 'testisam' Status: 00"'/g' \ trace.txt > traces.txt], [0], [], []) @@ -25856,7 +26022,8 @@ AT_DATA([prog.cob], [ OPEN OUTPUT f WRITE f-rec FROM "a" CLOSE f - + + SET LAST EXCEPTION TO OFF >>TURN EC-I-O CHECKING ON *> Read f too many times without libcob error OPEN INPUT f @@ -25867,6 +26034,7 @@ AT_DATA([prog.cob], [ DISPLAY f-status DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + SET LAST EXCEPTION TO OFF CLOSE f @@ -25881,6 +26049,7 @@ AT_DATA([prog.cob], [ DISPLAY f-status DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + SET LAST EXCEPTION TO OFF CLOSE f @@ -25906,7 +26075,8 @@ a 10 a -], [libcob: prog.cob:61: error: end of file (status = 10) for file g ('out.txt') on READ +], +[libcob: prog.cob:61: error: end of file (status = 10) for file g ('out.txt') on READ libcob: prog.cob:61: warning: implicit CLOSE of g ('out.txt') ]) diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index 578f30535..eb24118ea 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -12361,7 +12361,7 @@ AT_CHECK([diff reference prt.log], [0], [], [], # Previous test "failed" --> check if EOL of PIPE is the issue -AT_CHECK([sed -e 's/PIPE.\r/PIPE./g' prt.log > prt2.log], [0], [], []) +AT_CHECK([$SED -e 's/PIPE.\r/PIPE./g' prt.log > prt2.log], [0], [], []) AT_CHECK([diff reference prt2.log], [0], [], []) ) @@ -17266,3 +17266,221 @@ succeeded AT_CLEANUP + +AT_SETUP([runtime checks within conditions]) +AT_KEYWORDS([runmisc condition expression]) + +# this serves as a sample what was broken in the initial +# 3.1 release + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + 01 mytab. + 03 VAR PIC 9(02) value 1. + 03 VAR2 PIC 9(02) value 2. + 03 OCCURS 2. + 05 T15-PRGM PIC X(08). + 05 T16-PRGM PIC X(08). + 03 OCCURS 2. + 05 T15-NRGM PIC 9(04). + 05 T16-NRGM USAGE BINARY-INT. + + PROCEDURE DIVISION. + * + MOVE 'TESTME' TO T16-PRGM (VAR) (VAR2:) + MOVE T16-PRGM (VAR) (1:VAR2) TO T15-PRGM (VAR) + IF T16-PRGM(VAR) + = T15-PRGM(VAR2) + DISPLAY 'WRONG RESULT OCCURS'. + + IF MYTAB(VAR:VAR2) + = MYTAB(VAR2:VAR) + DISPLAY 'WRONG RESULT REFMOD'. + + INITIALIZE mytab + + GOBACK. +]) +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +# note: we mostly are interessted in a good codegen here... + + +AT_DATA([prog2.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + 01 mytab. + 03 VAR PIC 9(02) value 1. + 03 VAR2 PIC 9(02) value 3. + 03 OCCURS 2. + 05 T15-PRGM PIC X(08). + 05 T16-PRGM PIC X(08). + 03 OCCURS 2. + 05 T15-NRGM PIC 9(04). + 05 T16-NRGM USAGE BINARY-INT. + 05 buffer PIC X(500). + + PROCEDURE DIVISION. + * + IF T16-PRGM(VAR) + = T15-PRGM(VAR2) + DISPLAY 'WRONG RESULT OCCURS'. + + GOBACK. +]) +AT_CHECK([$COBC -x prog2.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog2], [0], [], []) +AT_CHECK([$COBC -x --debug -o prog2b prog2.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog2b], [1], [], +[libcob: prog2.cob:21: error: subscript of 'T15-PRGM' out of bounds: 3 +note: maximum subscript for 'T15-PRGM': 2 +]) +AT_DATA([prog3.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog3. + + DATA DIVISION. + WORKING-STORAGE SECTION. + + 01 mytab. + 03 VAR PIC 9(02) value 1. + 03 VAR2 PIC 9(02) value 99. + 03 OCCURS 2. + 05 T15-PRGM PIC X(08). + 05 T16-PRGM PIC X(08). + 03 OCCURS 2. + 05 T15-NRGM PIC 9(04). + 05 T16-NRGM USAGE BINARY-INT. + + PROCEDURE DIVISION. + + IF MYTAB(VAR:VAR2) + *> = MYTAB(VAR2:VAR) that _should_ work but on x86_64 + *> the second line is evaluated first + = MYTAB(VAR:VAR ) + DISPLAY 'WRONG RESULT REFMOD'. + + GOBACK. +]) +AT_CHECK([$COBC -x prog3.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CHECK([$COBC -x --debug -o prog3b prog3.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog3b], [1], [], +[libcob: prog3.cob:20: error: length of 'mytab' out of bounds: 99, maximum: 52 +]) + +AT_CLEANUP + + +AT_SETUP([libcob version check]) +AT_KEYWORDS([runmisc]) + +# using a C program here, normally this would be called from old or newer modules +AT_DATA([prog.c], [[ +#include +#include + +#define COUNT_OF(x) (sizeof(x)/sizeof(x[0])) + +struct verify_t { + char *prog, *packver_prog; + int patchlev_prog; +} verify[] = { +#include "testdata.h" +}; + +int +main(int argc, char *argv[]) +{ + struct verify_t *p; + for( p=verify; p < verify + COUNT_OF(verify); p++ ) { + cob_check_version(p->prog, p->packver_prog, p->patchlev_prog); + } + return 0; +} +]]) + +# good cases +AT_DATA([testdata.h], [[ +#define TST_STRINGIFY(s) #s +#define TST_XSTRINGIFY(s) TST_STRINGIFY (s) + { "test40", "4.0", 0 }, +/* { "TestMatch1", + TST_XSTRINGIFY (__LIBCOB_VERSION) "." + TST_XSTRINGIFY (__LIBCOB_VERSION_MINOR) "." + TST_XSTRINGIFY (__LIBCOB_VERSION_PATCHLEVEL), + 0}, */ + { "TestMatch2", + TST_XSTRINGIFY (__LIBCOB_VERSION) "." + TST_XSTRINGIFY (__LIBCOB_VERSION_MINOR) "." + "0", + 0}, + { "TestMatch3", + TST_XSTRINGIFY (__LIBCOB_VERSION) "." + TST_XSTRINGIFY (__LIBCOB_VERSION_MINOR), + 0 } +]]) + +AT_CHECK([$COMPILE prog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) + +AT_DATA([testdata.h], [[ + { "TooSmall1", "1.1", 0 } +]]) +AT_CHECK([$COMPILE -o small1 prog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./small1 2>small1.log], [1], [], []) +AT_CHECK([$GREP -v "libcob has" small1.log], [0], +[libcob: error: version mismatch +note: TooSmall1 has version 1.1.0 +], []) + +AT_DATA([testdata.h], [[ + { "TooSmall2", "2.0", 0 } +]]) +AT_CHECK([$COMPILE -o small2 prog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./small2 2>small2.log], [1], [], []) +AT_CHECK([$GREP -v "libcob has" small2.log], [0], +[libcob: error: version mismatch +note: TooSmall2 has version 2.0.0 +], []) + +AT_DATA([testdata.h], [[ + { "TooSmall3", "3.2", 0 }, +]]) +AT_CHECK([$COMPILE -o small3 prog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./small3 2>small3.log], [1], [], []) +AT_CHECK([$GREP -v "libcob has" small3.log], [0], +[libcob: error: version mismatch +note: TooSmall3 has version 3.2.0 +], []) + +AT_DATA([testdata.h], [[ + { "TooHigh2", "4.1", 0 } +]]) +AT_CHECK([$COMPILE -o high2 prog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./high2 2>high2.log], [1], [], []) +AT_CHECK([$GREP -v "libcob has" high2.log], [0], +[libcob: error: version mismatch +note: TooHigh2 has version 4.1.0 +], []) + +AT_DATA([testdata.h], [[ + { "TooHigh3", "4.0.1", 2 } +]]) +AT_CHECK([$COMPILE -o high3 prog.c], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./high3 2>high3.log], [1], [], []) +AT_CHECK([$GREP -v "libcob has" high3.log], [0], +[libcob: error: version mismatch +note: TooHigh3 has version 4.0.1.2 +], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index 6e03a7f91..d61c8469a 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -195,7 +195,7 @@ AT_DATA([prog3.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - COPY "sub.inc" OF SUB. + COPY "subb.inc" OF SUB. PROCEDURE DIVISION. DISPLAY TEST-VAR. STOP RUN. @@ -206,7 +206,7 @@ AT_DATA([prog4.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - COPY "sub" OF SUB. + COPY "subb" OF SUB. PROCEDURE DIVISION. DISPLAY TEST-VAR. STOP RUN. @@ -217,7 +217,7 @@ AT_DATA([prog5.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - COPY "sub" OF "..". + COPY "subb" OF "..". PROCEDURE DIVISION. DISPLAY TEST-VAR. STOP RUN. @@ -228,7 +228,7 @@ AT_DATA([prog6.cob], [ PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - COPY "sub". + COPY "subb". PROCEDURE DIVISION. DISPLAY TEST-VAR. STOP RUN. @@ -238,7 +238,7 @@ AT_DATA([copy.inc], [ 77 TEST-VAR PIC X VALUE 'V'. ]) AT_CHECK([mkdir -p SUB/OSUB], [0], [], []) -AT_DATA([SUB/sub.inc], [ +AT_DATA([SUB/subb.inc], [ 77 TEST-VAR PIC X VALUE 'V'. ]) diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 43c2d8f11..c07ef640e 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -1768,14 +1768,14 @@ AT_CHECK([$COMPILE_ONLY -Wextra prog.cob], [0], [], AT_CLEANUP -AT_SETUP([line overflow in Fixed-form / Free-form]) +AT_SETUP([line overflow in fixed-form / free-form]) AT_KEYWORDS([misc]) # We're testing trailing tabs and whitespace (should not lead to warning) # along with comments after boundaries (col 72 / col 512) -# AT_DATA removes trailing spaces, workaround: add "_" and -# remove it later via sed +# remark: some editors remove trailing spaces, the workaround: add "_" and +# remove it later via sed; AT_DATA would not do that when using double [[ ]] AT_DATA([prog_tmpl.cob], [ IDENTIFICATION DIVISION. @@ -1793,23 +1793,23 @@ AT_DATA([prog_tmpl.cob], [ ]) # AT_DATA workaround via sed: -AT_CHECK([sed -e 's/_$//' prog_tmpl.cob > prog.cob], [0], [], []) +AT_CHECK([$SED -e 's/_$//' prog_tmpl.cob > prog.cob], [0], [], []) -AT_CHECK([$COMPILE_ONLY -fixed -Wextra prog.cob], [0], [], -[prog.cob:7: warning: source text exceeds 512 bytes, will be truncated -prog.cob:8: warning: source text exceeds 512 bytes, will be truncated -prog.cob:11: warning: source text after program-text area (column 72) +AT_CHECK([$COBC -fsyntax-only -fixed -Wextra prog.cob], [0], [], +[prog.cob:7: warning: source text exceeds 512 bytes, will be truncated [[-Wothers]] +prog.cob:8: warning: source text exceeds 512 bytes, will be truncated [[-Wothers]] +prog.cob:11: warning: source text after program-text area (column 72) [[-Wdangling-text]] ]) -AT_CHECK([$COMPILE_ONLY -free -Wextra prog.cob], [1], [], -[prog.cob:7: warning: source text exceeds 512 bytes, will be truncated -prog.cob:8: warning: source text exceeds 512 bytes, will be truncated +AT_CHECK([$COBC -fsyntax-only -free -Wextra prog.cob], [1], [], +[prog.cob:7: warning: source text exceeds 512 bytes, will be truncated [[-Wothers]] +prog.cob:8: warning: source text exceeds 512 bytes, will be truncated [[-Wothers]] prog.cob:8: error: unknown statement 'This' ]) -AT_CHECK([$COMPILE_ONLY -F -Wextra prog.cob], [1], [], -[prog.cob:7: warning: source text exceeds 512 bytes, will be truncated -prog.cob:8: warning: source text exceeds 512 bytes, will be truncated +AT_CHECK([$COBC -fsyntax-only -F -Wextra prog.cob], [1], [], +[prog.cob:7: warning: source text exceeds 512 bytes, will be truncated [[-Wothers]] +prog.cob:8: warning: source text exceeds 512 bytes, will be truncated [[-Wothers]] prog.cob:8: error: unknown statement 'This' ]) @@ -1835,19 +1835,17 @@ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], # fixing the initial setup but now producing a missing newline: printf " CONTINUE." >> prog.cob -AT_CHECK([$COBC -fsyntax-only -Wextra -fixed prog.cob], [1], [], +AT_CHECK([$COBC -fsyntax-only -Wextra -fixed prog.cob], [0], [], [prog.cob:8: warning: line not terminated by a newline [[-Wmissing-newline]] -prog.cob:9: error: syntax error, unexpected end of file ]) -AT_CHECK([$COBC -fsyntax-only -Wextra -free prog.cob], [1], [], +AT_CHECK([$COBC -fsyntax-only -Wextra -free prog.cob], [0], [], [prog.cob:8: warning: line not terminated by a newline [[-Wmissing-newline]] -prog.cob:9: error: syntax error, unexpected end of file ]) -# not yet merged to trunk: + # should not happen if the data only consists of space characters -#printf "\n \t " >> prog.cob -# -#AT_CHECK([$COMPILE_ONLY -Wextra prog.cob], [0], [], []) +printf "\n \t " >> prog.cob + +AT_CHECK([$COMPILE_ONLY -Wextra prog.cob], [0], [], []) AT_CLEANUP @@ -8161,3 +8159,284 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY -Wno-pending -Wno-unfinished -free prog.cob], [0], [], []) AT_CLEANUP + + +AT_SETUP([DISPLAY directive (1)]) +AT_KEYWORDS([misc directive]) + +# this format is COBOL 202x without UPON +# --> implied UPON LISTING which goes to stdout +# as there is no listing active +# TODO: extend the >> DISPLAY tests and actually support +# the complete format... + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >>DISPLAY "OK" + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], +[OK +]) +AT_CLEANUP + + +AT_SETUP([DISPLAY directive (2)]) +AT_KEYWORDS([misc extension directive]) + +# this is an OpenCOBOL/GnuCOBOL 2.x extension, with implied literal +# similar to $DISPLAY + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >>DISPLAY OK + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], +[OK +]) +AT_CLEANUP + + +AT_SETUP([DISPLAY directive (3)]) +AT_KEYWORDS([misc extension directive]) + +# this is the classical MicroFocus format + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + $DISPLAY OK + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], +[OK +]) +AT_CLEANUP + + +AT_SETUP([conditional / define directives (1)]) +AT_KEYWORDS([misc directive]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + >>IF ACTIVATE DEFINED + >>DISPLAY "NOTOK" + >>ELIF ACTIVATE2 DEFINED + >>DISPLAY "OK" + >>ELSE + >>DISPLAY "NOTOK" + >>END-IF + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY -DACTIVATE2 prog.cob], [0], +[OK +]) +AT_CLEANUP + + +AT_SETUP([conditional / define directives (2)]) +AT_KEYWORDS([misc directive]) + +# COBOL 2002 format; checks that defines are applied at correct place + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >> IF X DEFINED + >>DISPLAY "X defined" + >> ELSE + >> DISPLAY "X not defined" + >> DEFINE X 1 + >> END-IF + CONTINUE + . +]) + +AT_CHECK([$COMPILE_ONLY -D X prog.cob], [0], +[X defined +]) +AT_CHECK([$COMPILE_ONLY prog.cob], [0], +[X not defined +]) +AT_CLEANUP + + +AT_SETUP([conditional / define directives (3)]) +AT_KEYWORDS([misc directive]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >>IF A IS DEFINED + >>IF B IS DEFINED + CONTINUE + >> DISPLAY "NOT OK (not both definitions)" + . + >>ELSE + CONTINUE + >> DISPLAY "NOT OK (no definitions)" + . + >>END-IF + >>ELSE + CONTINUE + >> DISPLAY "OK" + . + >>END-IF +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], +[OK +], []) +AT_CLEANUP + + +AT_SETUP([conditional / define directives (4)]) +AT_KEYWORDS([misc directive]) + +# check for case-insensivity + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >>IF A IS DEFINED + CONTINUE + . + >>else + CONTINUE + . + >>eNd-If +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], []) +AT_CLEANUP + + +AT_SETUP([error handling in conditional directives]) +AT_KEYWORDS([misc directive]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + >> IF BANANA + >>DISPLAY "Who throws bananas?" + >> ELSE + >> DISPLAY "No BANANA here." + >> DEFINE X 1 + >> END-IF + CONTINUE + . +]) + +AT_CHECK([$COMPILE_ONLY -D X prog.cob], [1], +[No BANANA here. +], +[prog.cob:5: error: invalid IF directive +prog.cob:9: error: duplicate DEFINE directive 'X' +]) +AT_CLEANUP + + +AT_SETUP([conditional directives with lvl 78 (1)]) +AT_KEYWORDS([misc extensions directive]) + +# MicroFocus format; checks that level 78 are applied + +# FIXME - not done yet: +AT_XFAIL_IF(true) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 78 Y VALUE 'a'. + PROCEDURE DIVISION. + $IF X DEFINED + $DISPLAY X defined + $ELIF Y DEFINED + $DISPLAY X not defined, but Y via lvl 78 + $ELSE + $DISPLAY X not defined + $END + CONTINUE + . +]) + +AT_CHECK([$COMPILE_ONLY -D X prog.cob], [0], +[X defined +]) +AT_CHECK([$COMPILE_ONLY prog.cob], [0], +[X not defined, but Y via lvl 78 +]) +AT_CLEANUP + + +AT_SETUP([conditional directives with lvl 78 (2)]) +AT_KEYWORDS([misc extensions directive]) + +# MicroFocus format; checks that level 78 are applied with correct values + +# FIXME - not done yet: +AT_XFAIL_IF(true) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 78 Y VALUE 1. + 78 Y2 VALUE 1. + 78 X VALUE 2. + 78 Z VALUE 354. + PROCEDURE DIVISION. + $IF Y = Y2X + $DISPLAY correct Y = Y2 + $ELSE + $DISPLAY bad: Y should be = Y2 + $END + $IF Y > X + $DISPLAY BAD - Y is not > X + $ELIF Y < X + $DISPLAY correct Y < X + $ELSE + $DISPLAY BROKEN + $END + + $IF X > Y + $DISPLAY correct X > Y + $ELIF X < Y + $DISPLAY BAD - X is not < Y + $ELSE + $DISPLAY BROKEN + $END + CONTINUE + . +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], +[correct Y = Y2 +correct Y < X +correct X > Y +]) +AT_CLEANUP + +# TODO: add missing tests for syntax errors in >>IF/ELSE/END + diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at index 6b1b81949..c27aebc52 100644 --- a/tests/testsuite.src/syn_occurs.at +++ b/tests/testsuite.src/syn_occurs.at @@ -463,7 +463,7 @@ AT_DATA([prog.cob], [ # all entries may raise this error but only the last error message is guaranteed. AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], ignore) AT_CHECK([$COMPILE_ONLY prog.cob 2>&1 | \ -grep "prog.cob:11: error: numeric literal '9223372036854775808' exceeds limit"], +$GREP "prog.cob:11: error: numeric literal '9223372036854775808' exceeds limit"], [0], ignore, []) AT_CLEANUP diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 85e89e82a..0a71e2854 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -461,7 +461,8 @@ AT_CHECK([$COBCRUN -v --version], [0], [ignore], []) AT_CHECK([$COBCRUN -q --version], [0], [ignore], []) AT_CHECK([$COBCRUN --help], [0], [ignore], []) AT_CHECK([$COBCRUN --info], [0], [ignore], []) -AT_CHECK([$COBCRUN -v --info], [0], [ignore], []) +# we explicit do not want to run this here, as it initializes curses +# AT_CHECK([$COBCRUN -v --info], [0], [ignore], []) AT_CHECK([$COBCRUN -q --info], [0], [ignore], []) AT_CHECK([$COBCRUN --dumpversion], [0], [ignore], []) AT_CLEANUP