From b6c64f2b9774af98d4a699d02183647f0f86bbdc Mon Sep 17 00:00:00 2001 From: ddeclerck Date: Thu, 20 Jun 2024 17:36:03 +0000 Subject: [PATCH] Merged revisions 4628, 4630-4635, 4637-4639, 4644-4646, 4652, 4653, 4655-4658, 4663 from branches/gnucobol-3.x: ........ build_windows: adjusted svn properties (global-ignores instead of single ones) ........ preparation for CANCEL ALL [feature-requests:#164] runtime part mostly missing, too much effort for now, compiler part finished ........ minor cleanup related to resolving COBOL modules * bin/cobcrun.c: no module name check (done in libcob now) * libcob/call.c: * (cob_resolve_internal): added check for module name length, fixed compiler warnings * call.c (cob_call): switched argument table from dynamic allocation to stack allocation fixed [bugs:#844] stack-based buffer overflow found with fuzzing cobc/tree.c (literal_for_diagnostic): fixed #844 stack-based buffer overflow ........ follow-up to [r4625] "move of defaultbyte from flag to dialect option" NEWS entry added cobc: * config.def, config.c: changed defaultbyte option from "INT" to ANY" with explicit check for "init" (GnuCOBOL default behavior, in r4625 as "ignore", now also allowing to set it after it was set different) and "none" (in preparation of missing feature, for now => implicit 0) config: * set defaultbyte to "none" for standard COBOL, 32 to " " ........ literal handling overhaul, first time working national literals cobc: * scanner.l (read_literal): do the necessary conversion for national literals (simple approach, only working with source in iso-8859-15 or plain ascii) * typeck.c (get_value): return correct numeric value for national (utf16) literals * tree.c (cb_build_intrinsic): fixed optimized length generation for national fields and literals * typeck.c (cb_validate_program_environment): refactored, reducing variable scope and extracted (validate_alphabet) and (check_class_duplicates); call the later depending on cb_warn_additional, no need to test if the final result is ignored * typeck.c (validate_alphabet): adjustments for national literals, now partially supported * scanner.l: moved static literal_error to local variable, passing it (to error_literal); return a valid literal in case of literal errors (intead of cb_error_node) to prevent spurious follow-up errors on their use ........ follow-up to [r4625] "move of defaultbyte from flag to dialect option" config: * ibm-strict.conf, mvs-strict.conf, gcos-strict.conf, bs2000-strict.conf: adjusted defaultbyte to 0 ........ Merged revisions 4548-4549,4553-4554,4624-4625 from trunk: Fix for BIT-WISE ops on Bigendian ........ added test for internal initialize for WORKING-STORAGE - revival of [bugs:#694] ........ Fix codegen issues ........ Fix for WORKING Initialize with OCCURS/VALUE ........ Improve INITIALIZE - more later ........ Move defaultbyte from flag.def to config.def ........ add preliminary support for DEFAULT SECTION cobc: * pplex.l, parser.y: parse DISPLAY and ACCEPT statements in DEFAULT SECTION (GCOS 7 extension) ........ add support for more source formats [feature-requests:#29] support for ACUCOBOL-GT Terminal format [feature-requests:#230] support for X/Open Free-form format * NEWS: added news entry for source formats * configure.ac: check for __attribute__((pure)) cobc: * cobc.h, cobc.c: extend cb_format enum with VARIABLE, TERMINAL, XOPEN, XCARD, CRT, and COBOLX source formats * cobc.c, flag.def: add new flag -fformat * ppparse.y: extend SOURCEFORMAT directive * cobc.h, cobc.c, pplex.l (cobc_get_indicator_column, cobc_get_text_column, cobc_get_indicator, cobc_get_margin_a, cobc_get_margin_b): encapsulate source format-related variables with pure functions * cobc.c: drop source format-related macros * cobc.h, pplex.l (cobc_deciph_source_format, cobc_set_source_format, cobc_get_source_format): encapsulate source format configuration into preprocessor lexer * pplex.l (ppinput): add support for ACU terminal and X/Open indicators, as well as floating margin B * pplex.l (check_listing): do not output sequence number of short lines * cobc.h: define function purity attribute COB_A_PURE * cobc.c (cobc_print_info): silence a warning with string indexing doc: * gnucobol.texi: document newly supported source formats ........ add support for CONTROL DIVISION (with SUBSTITUTION SECTION only) cobc: * pplex.l, ppparse.y: add support for CONTROL DIVISION (GCOS 7 extension); only SUBSTITUTION SECTION is handled yet * config.def: new control-division option config: * general: added option control-division ........ compiler speedup cobc/field.c.c (cb_resolve_redefines): always search candidate with (small) word list first, instead of checking the complete parent for a same name with case-insensitive name comparison ........ fixed syntax check for DISPLAY AT cobc/typeck.c (numeric_children_screen_pos_type): ignore redefined fields ........ allow DEPENDING clause in RECORD CONTAINS cobc: * config.def, parser.y: allow DEPENDING clause in RECORD CONTAINS config: * general: added option record-contains-depending-clause Co-authored-by: David Declerck ........ add GCOS-specific device name mnemonics cobc: * config.def, typeck.c (cb_emit_accept_name, cb_build_display_name): rely on new option device-mnemonics (boolean) instead of standard-define to accept device name mnemonics for DISPLAY and ACCEPT * parser.y, reserved.c, scanner.l, typeck.c: add GCOS-specific mnemonics ALTERNATE-CONSOLE, ALTERNATE CONSOLE and TERMINAL config: * general: added config option device-mnemonics (boolean) Co-athored-by: David Declerck ........ libcob/strings.c (cob_unstring_into): minor performance-tweak for UNSTRING with a single DELIMITED BY phrase ........ parse WITH CONVERSION clause for DISPLAY statement cobc: * parser.y: allow the WITH CONVERSION clause right after DISPLAY (ignored) Co-authored-by: David Declerck ........ [feature-requests:#137] support literal operands in partial replacing phrases cobc: * ppparse.y (literal_token): support SPACE or SPACES figurative constant as second operand of partial replacing phrases * pplex.l, ppparse.y, config.h: support COPY and REPLACE statements with partial REPLACING operands specified using literals * config.def: new option partial-replacing-with-literal * cobc.h, pplex.l (ppparse_verify): feature verification while in ppparse.y * pplex.l (ppparse_error): shift newline counter by one when reporting an error when in ppparse.y config: * general: added option partial-replacing-with-literal ........ factorize some code in the compiler cobc: * ppparse.y (unquote, fix_filename): factorize code for unquotation of alphanumeric literals ........ add support for the STOP ERROR statement config: * general: add a stop-error-statement option cobc: * config.def, parser.y: add support for the STOP ERROR statement libcob: * common.c, common.h (cob_stop_error): new function for STOP ERROR statement Co-authored-by: Fabrice Le Fessant ........ --- ChangeLog | 4 + NEWS | 3 + bin/ChangeLog | 4 + bin/cobcrun.c | 25 +- cobc/ChangeLog | 160 +++++++++- cobc/cobc.c | 122 ++++---- cobc/cobc.h | 26 +- cobc/codegen.c | 83 +++--- cobc/config.c | 46 ++- cobc/config.def | 32 +- cobc/field.c | 47 +-- cobc/flag.def | 5 + cobc/parser.y | 92 +++++- cobc/pplex.l | 338 +++++++++++++++++---- cobc/ppparse.y | 198 +++++++------ cobc/reserved.c | 5 +- cobc/scanner.l | 411 +++++++++++++------------- cobc/tree.c | 43 ++- cobc/tree.h | 2 + cobc/typeck.c | 360 ++++++++++++---------- config/ChangeLog | 44 ++- config/acu-strict.conf | 11 +- config/bs2000-strict.conf | 11 +- config/cobol2002.conf | 9 +- config/cobol2014.conf | 9 +- config/cobol85.conf | 11 +- config/default.conf | 9 +- config/gcos-strict.conf | 9 +- config/ibm-strict.conf | 9 +- config/lax.conf-inc | 1 + config/mf-strict.conf | 9 +- config/mvs-strict.conf | 9 +- config/realia-strict.conf | 9 +- config/rm-strict.conf | 9 +- config/xopen.conf | 13 +- doc/ChangeLog | 4 + doc/gnucobol.texi | 51 +++- libcob/ChangeLog | 21 ++ libcob/call.c | 81 +++-- libcob/common.c | 7 + libcob/common.h | 1 + libcob/intrinsic.c | 3 + libcob/strings.c | 118 ++++++-- tests/testsuite.src/configuration.at | 63 +++- tests/testsuite.src/run_extensions.at | 218 ++++++++++++++ tests/testsuite.src/run_functions.at | 58 +++- tests/testsuite.src/run_initialize.at | 19 +- tests/testsuite.src/run_misc.at | 25 ++ tests/testsuite.src/syn_copy.at | 104 +++++++ tests/testsuite.src/syn_file.at | 28 ++ tests/testsuite.src/syn_misc.at | 185 +++++++++++- tests/testsuite.src/syn_screen.at | 42 ++- tests/testsuite.src/used_binaries.at | 16 +- 53 files changed, 2421 insertions(+), 801 deletions(-) diff --git a/ChangeLog b/ChangeLog index e84d909e8..0a410a533 100644 --- a/ChangeLog +++ b/ChangeLog @@ -60,6 +60,10 @@ * configure.ac: check for PDC_free_memory_allocations +2022-07-06 Nicolas Berthier + + * configure.ac: Check for __attribute__((pure)) + 2022-06-21 Simon Sobisch * configure.ac: always build INDEXED handlers as separate libraries, diff --git a/NEWS b/NEWS index 2dcf6e6bb..1d7721c1b 100644 --- a/NEWS +++ b/NEWS @@ -357,6 +357,9 @@ Open Plans: ** in 64-bit environments, the maximum field size was increased from 268435456 bytes (999999998 bytes for OCCURS UNBOUNDED) to 2 GB +** the call-stack on error / in the dump file now contains all parameters given + to the program via command line options, if any + ** in case of any runtime features being used that are not available an error is generated during compile (may be reduced to a warning by -Wunsupported or be suppressed by -Wno-unsupported) and if the feature is actually used diff --git a/bin/ChangeLog b/bin/ChangeLog index 577fcb2ad..e933cac7d 100644 --- a/bin/ChangeLog +++ b/bin/ChangeLog @@ -16,6 +16,10 @@ * cobfile.c: fixed compiler warnings -Wunused-result * cobfile.c: handle --quiet to output less progress info +2022-07-15 Simon Sobisch + + * cobcrun.c: no module name check (done in libcob now) + 2022-06-28 Simon Sobisch * cobcrun.c: added -dumpversion (called from libcob) diff --git a/bin/cobcrun.c b/bin/cobcrun.c index 180cc96c6..9b88cfe4c 100644 --- a/bin/cobcrun.c +++ b/bin/cobcrun.c @@ -419,24 +419,23 @@ main (int argc, char **argv) return 1; } - if (strlen (argv[arg_shift]) > COB_MAX_NAMELEN) { - /* note: we allow up to COB_MAX_WORDLEN for relaxed syntax... */ - fprintf (stderr, _("%s: PROGRAM name exceeds %d characters"), argv[0], COB_MAX_NAMELEN); - putc ('\n', stderr); - fflush (stderr); - return 1; - } - - /* Initialize the COBOL system, resolve the PROGRAM name */ - /* and invoke, wrapped in a STOP RUN, if found */ - /* note: we use cob_init_nomain here as there are no functions */ - /* linked here we want to provide for the COBOL environment */ + /* Initialize the COBOL system, ... */ + /* Note: we use cob_init_nomain here as there are no functions + linked here we want to provide for the COBOL environment */ cob_init_nomain (argc - arg_shift, &argv[arg_shift]); if (print_runtime_wanted) { print_runtime_conf (); putc ('\n', stdout); } - /* Note: cob_resolve_cobol takes care for call errors, no need to check here */ + /* ... verify and resolve the PROGRAM name, ... */ + /* Note: cob_resolve_cobol takes care for call errors, + because of the last parameter; no need to check here afterwards; + another program may use "0" and check for function pointer != NULL */ unifunc.funcvoid = cob_resolve_cobol (argv[arg_shift], 0, 1); + + /* ... then invoke, wrapped in a STOP RUN */ + /* Note: we requested a program exit if resolving had issues, + so are only still running if we have a a valid, _likely_ COBOL + function to execute */ cob_stop_run (unifunc.funcint()); } diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 865531bda..e3de7d4f5 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -237,6 +237,74 @@ * tree.c (cb_build_picture), tree.h: return cb_picture instead of cb_tree as all but one caller directly use it that way +2022-07-14 Matthew Remacle + + * tree.c (literal_for_diagnostic): fixed #844 stack-based buffer overflow + +2022-07-14 Simon Sobisch + + * config.def, config.c: changed defaultbyte option from "INT" to ANY" + with explicit check for "init" (GnuCOBOL default behavior, now also + allowing to set it after it was set different) and "none" (in + preparation of missing feature, for now => implicit 0) + +2022-07-12 Simon Sobisch + + * scanner.l (read_literal): do the necessary conversion for national + literals (simple approach, only working with source in iso-8859-15 + or plain ascii) + * typeck.c (get_value): return correct numeric value for national + (utf16) literals + * tree.c (cb_build_intrinsic): fixed optimized length generation for + national fields and literals + * typeck.c (cb_validate_program_environment): refactored, + reducing variable scope and extracted (validate_alphabet) and + (check_class_duplicates); call the later depending on + cb_warn_additional, no need to test if the final result is ignored + * typeck.c (validate_alphabet): adjustments for national literals, + now partially supported + * scanner.l: moved static literal_error to local variable, + passing it (to error_literal); return a valid literal in case of + literal errors (intead of cb_error_node) to prevent spurious + follow-up errors on their use + +2022-07-08 Simon Sobisch + + * parser.y (cancel_body): preparation for CANCEL ALL + +2022-07-06 Nicolas Berthier + + * cobc.h: define function purity attribute COB_A_PURE + * cobc.h, cobc.c, pplex.l (cobc_get_indicator_column, + cobc_get_text_column, cobc_get_indicator, cobc_get_margin_a, + cobc_get_margin_b): encapsulate source format-related variables with + pure functions + * cobc.c: drop source format-related macros + * cobc.c (cobc_print_info): silence a warning with string indexing + +2022-07-05 Nicolas Berthier + + * pplex.l, parser.y: parse DISPLAY and ACCEPT statements in DEFAULT + SECTION (GCOS 7 extension) + +2022-07-04 Nicolas Berthier + + FR #29 support for ACUCOBOL-GT Terminal format + FR #230 support for X/Open Free-form format + * cobc.h, cobc.c: extend cb_format enum with VARIABLE, TERMINAL, XOPEN, + XCARD, CRT, and COBOLX source formats + * ppparse.y: extend SOURCEFORMAT directive + * cobc.c: drop IS_DEBUG_LINE macro to improve support for new source + formats + * cobc.c, flag.def: add new flag -fformat and remove flag + indicator-column + * cobc.h, pplex.l (cobc_deciph_source_format, cobc_set_source_format, + cobc_get_source_format): encapsulate source format configuration into + preprocessor lexer + * pplex.l (ppinput): add support for ACU terminal and X/Open indicators, + as well as floating margin B + * pplex.l (check_listing): do not output sequence number of short lines + 2022-07-01 Simon Sobisch * field.c (validate_blank_when_zero): iterate over pic->str @@ -257,18 +325,34 @@ * cobc.c, help.c: added -dumpversion +2022-06-27 Simon Sobisch + + * typeck.c (numeric_children_screen_pos_type): ignore redefined + fields + * field.c (cb_resolve_redefines): always search candidate with (small) + word list first, instead of checking the complete parent for a same + name with case-insensitive name comparison + +2022-06-24 Nicolas Berthier + + * cobc.c, config.def, flag.def, ppparse.y: requalify indicator-column as + a flag instead of a dialect option + +2022-06-17 Nicolas Berthier + + * config.def, typeck.c (cb_emit_accept_name, cb_build_display_name): + rely on new option device-mnemonics (boolean) instead of + standard-define to accept device name mnemonics for DISPLAY and ACCEPT + 2022-06-10 Ron Norman * flag.def,config.def : Moved defaultbyte from flag to config * cobc.h,help.c,codegen.c : Add define CB_CONFIG_SINT as signed 'int' * config.c (cb_config_entry): for CB_INT check for a single character Also check for word 'ignore' and make no changes - -2022-06-10 Ron Norman - * codegen.c : Improvement of code emitted for INITIALIZE of tables - Initial table values, then clear next, - then propagate through remainder of the table + Initial table values, then clear next, + then propagate through remainder of the table 2022-05-31 Simon Sobisch @@ -319,6 +403,11 @@ * cobc.c (process_translate) [HAVE_8DOT3_FILENAMES]: fixed missing variable definition +2022-03-29 Nicolas Berthier + + * ppparse.y (literal_token): support SPACE or SPACES figurative + constant as second operand of partial replacing phrases + 2022-03-28 Ron Norman * cobc.c : Added calls to cobc_getenv_path which will check for @@ -335,6 +424,10 @@ * tree.c (cb_init_parse_constants), tree.h, cobc.c: renamed from cb_init_constants +2022-03-11 Fabrice Le Fessant + + * config.def, parser.y: add support for the STOP ERROR statement + 2022-03-10 Simon Sobisch * pplex.l (next_word_is_comment_paragraph_name): extracted from (ppinput) @@ -389,15 +482,57 @@ * codegen.c: removed check for "has condition a reference" or disabled this within [COB_TREE_DEBUG] +2022-02-07 David Declerck + + * config.def, parser.y: allow DEPENDING clause in RECORD CONTAINS + 2022-02-06 Ron Norman * codegen.c: if verb changes then emit trace/debug code, too +2022-02-04 David Declerck + + * cobc.c, cobc.h, config.def, pplex.l, ppparse.y: make the + indicator column configurable + +2022-02-04 David Declerck + + * parser.y, reserved.c, scanner.l, typeck.c: Add GCOS-specific mnemonics + ALTERNATE-CONSOLE, ALTERNATE CONSOLE and TERMINAL + +2022-02-04 David Declerck + + * parser.y: allow the WITH CONVERSION clause right after DISPLAY (ignored) + +2022-01-28 Fabrice Le Fessant + + * warning.def, pplex.l: split warning for missing newlines, it now + can be disabled by -Wno-missing-newline instead of -Wno-others + 2022-01-28 Simon Sobisch * typeck.c (cb_emit_write): changed configuration check and warning for cb_sequential_advancing to dialect variant +2022-01-27 Nicolas Berthier + + * pplex.l, ppparse.y: add support for CONTROL DIVISION (GCOS 7 + extension); only SUBSTITUTION SECTION is handled yet + * config.def: new control-division option + +2022-01-25 Nicolas Berthier + + * pplex.l, ppparse.y, config.h: support COPY and REPLACE + statements with partial REPLACING operands specified using + literals + * config.def: new option partial-replacing-with-literal + * cobc.h, pplex.l (ppparse_verify): feature verification while in + ppparse.y + * pplex.l (ppparse_error): shift newline counter by one when + reporting an error when in ppparse.y + * ppparse.y (unquote, fix_filename): factorize code for + unquotation of alphanumeric literals + 2022-01-25 Ron Norman * field.c: Check that COMP-X size does not exceed what is supported @@ -550,7 +685,6 @@ WRITE ADVANCING was used then default to LINE SEQUENTIAL * typeck.c: If ORGANIZATION not specific and WRITE ADVANCING default to LINE SEQUENTIAL based on 'record-sequential-advancing' - 2021-11-08 Ron Norman @@ -4804,7 +4938,7 @@ * tree.c (cb_name_1): output name for USER FUNCTIONs -2017-01-11 Mário Matos +2017-01-11 Mário Matos * codegen.c (output_entry_function): fixed bug #349 (compatibility for C89 / _MSC_VER < 1800) - moved @@ -6637,11 +6771,11 @@ * parser.y, reserved.c, typeck.c: Added parser support for OCCURS DYNAMIC along with CAPACITY clause as not implemented -2014-09-08 Philipp Böhme +2014-09-08 Philipp Böhme * cobc.c (process) [_MSC_VER]: bugfix in output filter -2014-09-03 Philipp Böhme +2014-09-03 Philipp Böhme * cobc.c, cobc.h: added cobc_free() function (Own freeing functions for debugging purposes. @@ -6689,11 +6823,11 @@ * pplex.l: fixed bug #86 whitespace handling for IDENTIFICATION DIVISION and DEBUGGING MODE -2014-07-10 Philipp Böhme +2014-07-10 Philipp Böhme * typeck.c (cb_emit_sort_init): calculation of table key offset fixed -2014-07-02 Philipp Böhme +2014-07-02 Philipp Böhme * cobc.c [_MSC_VER]: filter output of cl.exe (instead of redirecting to NUL), errors are printed in non-verbose mode now; new: (read_buffer_line) @@ -6732,7 +6866,7 @@ * parser.y: Added extension "USE AT PROGRAM START/END" as not implemented -2014-05-14 Philipp Böhme +2014-05-14 Philipp Böhme * cobc.c: Catch and treat error when no disc space is available for output files @@ -6745,7 +6879,7 @@ * parser.y: Added extension "GOBACK/EXIT PROGRAM RETURNING/GIVING x" -2014-04-29 Philipp Böhme +2014-04-29 Philipp Böhme * codeoptim.c: Fixed bug in COB_ADD_PACKED_INT. Computing COMP-3 failed in MSVC-build versions, diff --git a/cobc/cobc.c b/cobc/cobc.c index 4bd4d9933..35d987dfb 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -123,14 +123,6 @@ FILE *cb_listing_file = NULL; #define CB_LINE_LENGTH 1024 /* hint: we only read PPLEX_BUF_LEN bytes */ #define CB_READ_AHEAD 800 /* lines to read ahead */ -/* TODO: add new compiler configuration flags for this*/ -#define CB_MARGIN_A cb_indicator_column -#define CB_MARGIN_B 11 /* careful, for COBOL 85 this would be 11, - for COBOL 2002 (removed it) would be 7 */ -#define CB_INDICATOR CB_MARGIN_A - 1 -#define CB_SEQUENCE cb_text_column /* the only configuration available...*/ -#define CB_ENDLINE (cb_text_column + cb_indicator_column + 1) - #define CB_MAX_LINES 55 #define CB_LIST_PICSIZE 80 #define CB_PRINT_LEN 132 @@ -138,11 +130,6 @@ FILE *cb_listing_file = NULL; char print_data[CB_PRINT_LEN + 1]; size_t pd_off; -#define IS_DEBUG_LINE(line) ((line)[CB_INDICATOR] == 'D') -#define IS_CONTINUE_LINE(line) ((line)[CB_INDICATOR] == '-') -#define IS_COMMENT_LINE(line) \ - ((line)[CB_INDICATOR] == '*' || (line)[CB_INDICATOR] == '/') - FILE *cb_src_list_file = NULL; int cb_listing_page = 0; int cb_listing_wide = 0; @@ -161,12 +148,9 @@ struct list_files *cb_current_file = NULL; struct cob_time current_compile_time = { 0 }; struct tm current_compile_tm = { 0 }; -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; #endif -int cb_text_column; -int cb_indicator_column; int cb_id = 0; int cb_pic_id = 0; int cb_attr_id = 0; @@ -2449,7 +2433,7 @@ cobc_print_info (void) cobc_var_print ("COB_OBJECT_EXT", COB_OBJECT_EXT, 0); cobc_var_print ("COB_MODULE_EXT", COB_MODULE_EXT, 0); if (!verbose_output && COB_EXE_EXT[0] == '.') { - cobc_var_print ("COB_EXE_EXT", COB_EXE_EXT + 1, 0); + cobc_var_print ("COB_EXE_EXT", &COB_EXE_EXT[1], 0); } else { cobc_var_print ("COB_EXE_EXT", COB_EXE_EXT, 0); } @@ -3302,13 +3286,13 @@ process_command_line (const int argc, char **argv) break; case 'F': - /* --free */ - cb_source_format = CB_FORMAT_FREE; + /* --free, alias of `-fformat=free` */ + cobc_set_source_format (CB_FORMAT_FREE); break; case 'f': - /* --fixed */ - cb_source_format = CB_FORMAT_FIXED; + /* --fixed, alias of `-fformat=fixed` */ + cobc_set_source_format (CB_FORMAT_FIXED); break; case 'q': @@ -3625,6 +3609,13 @@ process_command_line (const int argc, char **argv) cb_max_errors = n; break; + case 16: + /* -fformat= */ + if (cobc_deciph_source_format (cob_optarg) != 0) { + cobc_err_exit (COBC_INV_PAR, "-fformat"); + } + break; + case 8: /* -fdump= : Add sections for dump code generation */ cobc_def_dump_opts (cob_optarg, 1); @@ -4953,7 +4944,7 @@ preprocess (struct filename *fn) /* Save default exceptions and flags in case program directives change them */ memcpy(save_exception_table, cb_exception_table, sizeof(struct cb_exception) * COB_EC_MAX); - save_source_format = cb_source_format; + save_source_format = cobc_get_source_format (); save_fold_copy = cb_fold_copy; save_fold_call = cb_fold_call; save_ref_mod_zero_length = cb_ref_mod_zero_length; @@ -4963,7 +4954,7 @@ preprocess (struct filename *fn) /* Restore default exceptions and flags */ memcpy(cb_exception_table, save_exception_table, sizeof(struct cb_exception) * COB_EC_MAX); - cb_source_format = save_source_format; + cobc_set_source_format (save_source_format); cb_fold_copy = save_fold_copy; cb_fold_call = save_fold_call; cb_ref_mod_zero_length = save_ref_mod_zero_length; @@ -5050,7 +5041,7 @@ set_listing_header_code (void) "............................."); if (cb_listing_wide) { if (cb_listing_file_struct->source_format == CB_FORMAT_FIXED - && cb_text_column == 72 && cb_indicator_column == 7) { + && cobc_get_text_column () == 72) { strcat (cb_listing_header, "SEQUENCE"); } else { strcat (cb_listing_header, @@ -6218,14 +6209,17 @@ get_next_listing_line (FILE *fd, char **pline, int fixed) } if (fixed) { + const unsigned int endline = + cobc_get_text_column () + + cobc_get_indicator_column () + 1; #if 1 /* Simon: that should be portable enough */ - int size = (unsigned int)CB_ENDLINE - i; + const int size = endline - i; if (size > 0) { memset (&out_line[i], ' ', (size_t)size); - i = (unsigned int)CB_ENDLINE; + i = endline; } #else - while (i < (unsigned int)CB_ENDLINE) { + while (i < endline) { out_line[i++] = ' '; } #endif @@ -6244,7 +6238,7 @@ static COB_INLINE COB_A_INLINE char * get_first_nonspace (char *line, const enum cb_format source_format) { if (source_format != CB_FORMAT_FREE) { - return get_next_nonspace (line + CB_INDICATOR + 1); + return get_next_nonspace (line + cobc_get_indicator () + 1); } else { return get_next_nonspace (line); } @@ -6299,7 +6293,7 @@ line_has_page_eject (char *line, const enum cb_format source_format) { char *directive_start; - if (source_format != CB_FORMAT_FREE && line[CB_INDICATOR] == '/') { + if (source_format != CB_FORMAT_FREE && line[cobc_get_indicator ()] == '/') { return 1; } else { directive_start = get_directive_start (line, source_format); @@ -6399,9 +6393,11 @@ print_fixed_line (const int line_num, char pch, char *line) int len = strlen (line); const int max_chars_on_line = cb_listing_wide ? 112 : 72; const char *format_str; + const int indicator = cobc_get_indicator (); + const int text_column = cobc_get_text_column (); - if (line[CB_INDICATOR] == '&') { - line[CB_INDICATOR] = '-'; + if (line[indicator] == '&') { + line[indicator] = '-'; pch = '+'; } @@ -6415,7 +6411,7 @@ print_fixed_line (const int line_num, char pch, char *line) (void)terminate_str_at_first_trailing_space (print_data); print_program_data (print_data); - if (cb_text_column == 72) { + if (text_column == 72) { break; } pch = '+'; @@ -6545,7 +6541,7 @@ compare_prepare (char *cmp_line, char *pline[CB_READ_AHEAD], int out_pos = 0; int line_idx; int in_string = 0; - int last_col = CB_SEQUENCE; + int last_col = cobc_get_text_column (); int last_nonspace; cmp_line[0] = 0; @@ -6635,14 +6631,16 @@ adjust_line_numbers (struct list_files *cfile, int line_num, int adjust) } static COB_INLINE COB_A_INLINE int -is_debug_line (char *line, int fixed) +is_debug_line (char *line, int fixed, int acudebug) { if (line == NULL || line[0] == 0) { return 0; } return !cb_flag_debugging_line - && ((fixed && IS_DEBUG_LINE (line)) - || (!fixed && !strncasecmp (line, "D ", 2))); + && ((fixed && line[cobc_get_indicator ()] == 'D') + || (!fixed && (acudebug + ? !strncasecmp (line, "\\D", 2) + : !strncasecmp (line, "D ", 2)))); } static COB_INLINE COB_A_INLINE int @@ -6650,9 +6648,12 @@ is_comment_line (char *line, int fixed) { if (line == NULL || line[0] == 0) { return 0; + } else { + const int indicator = cobc_get_indicator (); + return fixed + ? line[indicator] == '*' || line[indicator] == '/' + : !strncmp (line, "*>", 2); } - return (fixed && IS_COMMENT_LINE (line)) - || (!fixed && !strncmp (line, "*>", 2)); } static int @@ -6664,8 +6665,8 @@ is_continuation_line (char *line, int fixed) return 0; } if (fixed) { - /* check for "-" in column 7 */ - if (IS_CONTINUE_LINE (line)) { + /* check for "-" in indicator column */ + if (line [cobc_get_indicator ()] == '-') { return 1; } } else { @@ -6695,6 +6696,9 @@ static void make_new_continuation_line (const char *cfile_name, char *pline[CB_READ_AHEAD], int * const pline_cnt, int line_num) { + const int margin_a = cobc_get_margin_a (1); + const int indicator = cobc_get_indicator (); + const int sequence_col = cobc_get_text_column (); abort_if_too_many_continuation_lines (*pline_cnt + 1, cfile_name, line_num); if (pline[*pline_cnt + 1] == NULL) { @@ -6702,9 +6706,9 @@ make_new_continuation_line (const char *cfile_name, char *pline[CB_READ_AHEAD], } strcpy (pline[*pline_cnt + 1], pline[*pline_cnt]); strcpy (pline[*pline_cnt], pline[*pline_cnt - 1]); - memset (&pline[*pline_cnt][CB_MARGIN_A], ' ', - CB_SEQUENCE - CB_MARGIN_A); - pline[*pline_cnt][CB_INDICATOR] = '&'; + memset (&pline[*pline_cnt][margin_a], ' ', + sequence_col - margin_a); + pline[*pline_cnt][indicator] = '&'; (*pline_cnt)++; } @@ -6721,6 +6725,7 @@ add_token_over_multiple_lines (const char *cfile_name, int * const out_col) { int tok_char = 0; + const int sequence_col = cobc_get_text_column (); #ifdef DEBUG_REPLACE fprintf (stdout, " new_token_len = %d\n", new_token_len); @@ -6734,7 +6739,7 @@ add_token_over_multiple_lines (const char *cfile_name, /* Move to the next line when reach the end of the current one. */ - if (*out_col == CB_SEQUENCE) { + if (*out_col == sequence_col) { #ifdef DEBUG_REPLACE fprintf (stdout, " NEW pline[%2d] = %s\n", *out_line, pline[*out_line]); @@ -6770,6 +6775,9 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A int out_line; int force_next_line; int new_token_len; + const int margin_b = cobc_get_margin_b (1); + const int indicator = cobc_get_indicator (); + const int sequence_col = cobc_get_text_column (); new_token = cobc_malloc (strlen(newline) + 2); new_line_ptr = get_next_token (newline, new_token, token_terminator); @@ -6781,8 +6789,8 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A (first_nonspace < last) && isspace ((unsigned char)(pline[0][first_nonspace])); first_nonspace++); - if (first_nonspace >= CB_MARGIN_B) { - first_col = CB_MARGIN_B; + if (first_nonspace >= margin_b) { + first_col = margin_b; } /* For each line, */ @@ -6793,7 +6801,7 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A /* Add as many token as possible to the current line. */ while (new_line_ptr && !force_next_line) { new_token_len = strlen (new_token); - if (new_token_len >= (CB_SEQUENCE - first_col)) { + if (new_token_len >= (sequence_col - first_col)) { /* If the new token does not fit on this line, reflow it onto the next line. @@ -6827,7 +6835,7 @@ reflow_replaced_fixed_format_text (const char *cfile_name, char *pline[CB_READ_A } if (out_col == first_col) { - pline[out_line][CB_INDICATOR] = ' '; + pline[out_line][indicator] = ' '; } while (out_col < last) { pline[out_line][out_col++] = ' '; @@ -6911,7 +6919,8 @@ print_replace_text (struct list_files *cfile, FILE *fd, char *to_ptr; char *newline; const int fixed = (cfile->source_format == CB_FORMAT_FIXED); - int first_col = fixed ? CB_MARGIN_A : 0; + const int acudebug = (cfile->source_format == CB_FORMAT_ACUTERM); + int first_col = fixed ? cobc_get_margin_a (1) : 0; int last; int multi_token; int match = 0; @@ -7058,7 +7067,7 @@ print_replace_text (struct list_files *cfile, FILE *fd, adjust_line_numbers (cfile, line_num, -1); overread = 1; } - if (is_debug_line (pline[pline_cnt], fixed)) { + if (is_debug_line (pline[pline_cnt], fixed, acudebug)) { adjust_line_numbers (cfile, line_num, -1); overread = 1; } @@ -7076,7 +7085,7 @@ print_replace_text (struct list_files *cfile, FILE *fd, pline[pline_cnt][0] = 0; eof = 1; } - if (is_debug_line (pline[pline_cnt], fixed) + if (is_debug_line (pline[pline_cnt], fixed, acudebug) || is_comment_line (pline[pline_cnt], fixed)) { adjust_line_numbers (cfile, line_num, -1); goto next_rec; @@ -7246,7 +7255,7 @@ print_replace_main (struct list_files *cfile, FILE *fd, struct list_files *cur; int i; const int fixed = (cfile->source_format == CB_FORMAT_FIXED); - const int first_col = fixed ? CB_MARGIN_A : 0; + const int first_col = fixed ? cobc_get_margin_a (1) : 0; int is_copy_line; int is_replace_line; int is_replace_off = 0; @@ -7360,6 +7369,7 @@ print_program_code (struct list_files *cfile, int in_copy) int i; int line_num = 1; const int fixed = (cfile->source_format == CB_FORMAT_FIXED); + const int indicator = cobc_get_indicator (); int eof = 0; int pline_cnt = 0; char *pline[CB_READ_AHEAD] = { NULL }; @@ -7450,7 +7460,7 @@ print_program_code (struct list_files *cfile, int in_copy) /* Print each line except the last. */ for (i = 0; i < pline_cnt; i++) { if (pline[i][0]) { - if (fixed && pline[i][CB_INDICATOR] == '&') { + if (fixed && pline[i][indicator] == '&') { print_line (cfile, pline[i], line_num, in_copy); } else { print_line (cfile, pline[i], line_num + i, in_copy); @@ -8696,7 +8706,7 @@ process_file (struct filename *fn, int status) cb_current_file = cb_listing_file_struct; cb_current_file->copy_tail = NULL; /* may include an old reference */ cb_current_file->name = cobc_strdup (fn->source); - cb_current_file->source_format = cb_source_format; + cb_current_file->source_format = cobc_get_source_format (); force_new_page_for_next_line (); } @@ -8874,8 +8884,8 @@ main (int argc, char **argv) finish_setup_compiler_env (); finish_setup_internal_env (); - cb_text_column = cb_config_text_column; - cb_indicator_column = 7; + /* Reset source format in case text column has been configured manually. */ + cobc_set_source_format (cobc_get_source_format ()); memset (cb_listing_header, 0, sizeof (cb_listing_header)); /* If -P=file specified, all lists go to this file */ diff --git a/cobc/cobc.h b/cobc/cobc.h index 8ce0d4ef3..443323319 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -46,6 +46,12 @@ #include "../libcob/sysdefines.h" +#ifdef HAVE_ATTRIBUTE_PURE +#define COB_A_PURE __attribute__((pure)) +#else +#define COB_A_PURE +#endif + /* Defines for access() */ #ifndef F_OK #define F_OK 0 @@ -70,7 +76,13 @@ /* Source format enum */ enum cb_format { CB_FORMAT_FIXED = 0, - CB_FORMAT_FREE + CB_FORMAT_FREE, + CB_FORMAT_VARIABLE, /* MF's Variable format */ + CB_FORMAT_XOPEN_FFF, /* X/Open Free-form format */ + CB_FORMAT_ICOBOL_XCARD, /* ICOBOL xCard */ + CB_FORMAT_ICOBOL_CRT, /* ICOBOL Free-form format (CRT) */ + CB_FORMAT_ACUTERM, /* ACU Terminal format, named "TERMINAL" */ + CB_FORMAT_COBOLX, /* GCOS's COBOLX */ }; #if 0 /* ancient OSVS registers that need special runtime handling - low priority */ @@ -331,11 +343,9 @@ struct list_files { extern struct list_files *cb_current_file; -extern enum cb_format cb_source_format; #if 0 /* ancient OSVS registers that need special runtime handling - low priority */ extern enum cb_current_date current_date; #endif -extern int cb_text_column; /* end of area B (in single-byte characters) */ extern int cb_mf_ibm_comp; extern int cb_cob_line_num; extern int cb_all_files_xfd; @@ -602,8 +612,18 @@ extern int ppcopy (const char *, const char *, struct cb_replace_list *); extern void pp_set_replace_list (struct cb_replace_list *, const cob_u32_t); +extern unsigned int ppparse_verify (const enum cb_support tag, + const char *feature); extern void ppparse_error (const char *); +extern int cobc_deciph_source_format (const char *); +extern void cobc_set_source_format (const enum cb_format); +extern enum cb_format cobc_get_source_format (void) COB_A_PURE; +extern int cobc_get_indicator_column (void) COB_A_PURE; +extern int cobc_get_text_column (void) COB_A_PURE; +extern int cobc_get_indicator (void) COB_A_PURE; +extern int cobc_get_margin_a (int indicator_width) COB_A_PURE; +extern int cobc_get_margin_b (int indicator_width) COB_A_PURE; /* parser (in scanner.l, parser.y) */ #if !defined (COB_IN_SCANNER ) && !defined (COB_IN_PPLEX) && \ diff --git a/cobc/codegen.c b/cobc/codegen.c index 4f993cf30..c6cc9eeb8 100644 --- a/cobc/codegen.c +++ b/cobc/codegen.c @@ -4326,7 +4326,11 @@ output_param (cb_tree x, int id) break; case CB_TAG_REPORT_LINE: /* NOTE: do not use CB_REFERENCE_P because 'x' has a tag of CB_TAG_REPORT_LINE */ +#if 1 /* FIXME: Should have expected type! */ r = (struct cb_reference *)x; +#else + r = CB_REFERENCE (x); +#endif f = CB_FIELD (r->value); output ("&%s%d", CB_PREFIX_REPORT_LINE, f->id); break; @@ -5249,11 +5253,12 @@ propagate_table (cb_tree x, int bgn_idx) struct cb_field *f = cb_code_field (x); const unsigned int occ = (unsigned int)f->occurs_max; cob_uli_t len = (cob_uli_t)f->size; - size_t maxlen = len * occ; + cob_uli_t maxlen = len * occ; unsigned int j = 1; - if (bgn_idx < 1) + if (bgn_idx < 1) { bgn_idx = 1; + } if (gen_init_working || (!chk_field_variable_size (f) @@ -5261,39 +5266,40 @@ propagate_table (cb_tree x, int bgn_idx) && !f->depending)) { /* Table size is known at compile time */ /* Generate inline 'memcpy' to propagate the array data */ - output_block_open (); - output_prefix (); - output ("cob_u8_ptr b_ptr = "); - output_data(x); - if (bgn_idx > 1) { - output (" + %ld",len * (bgn_idx - 1)); - maxlen -= len * (bgn_idx - 1); - } - output (";"); - output_newline (); - - /* double the chunks each time */ - do { + if (occ > 1) { + output_block_open (); output_prefix (); - output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, len); - output ("\t/* %s: %6u thru %u */", - f->name, j + bgn_idx, j * 2 + bgn_idx - 1); + output ("cob_u8_ptr b_ptr = "); + output_data (x); + if (bgn_idx > 1) { + output (" + %ld",len * (bgn_idx - 1)); + maxlen -= len * (bgn_idx - 1); + } + output (";"); output_newline (); - j = j * 2; - len = len * 2; - } while ((j * 2) < occ); - /* missing piece after last chunk */ - if (j < occ - && maxlen > len) { - output_prefix (); - output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", - len, maxlen - len); - output ("\t/* %s: %6u thru %u */", - f->name, j + bgn_idx, occ); - output_newline (); + /* double the chunks each time */ + do { + output_prefix (); + output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", len, len); + output ("\t/* %s: %6u thru %u */", + f->name, j + bgn_idx, j * 2 + bgn_idx - 1); + output_newline (); + j = j * 2; + len = len * 2; + } while ((j * 2) < occ); + /* missing piece after last chunk */ + if (j < occ + && maxlen > len) { + output_prefix (); + output ("memcpy (b_ptr + %6lu, b_ptr, %6lu);", + len, maxlen - len); + output ("\t/* %s: %6u thru %u */", + f->name, j + bgn_idx, occ); + output_newline (); + } + output_block_close (); } - output_block_close (); } else { /* Table size is only known at run time */ output_prefix (); @@ -5341,6 +5347,10 @@ initialize_uniform_char (const struct cb_field *f, return '0'; case COB_TYPE_ALPHANUMERIC: return ' '; +#if 1 /* TODO: proper initialization of NATIONAL data */ + case COB_TYPE_NATIONAL: + return ' '; +#endif default: return -1; } @@ -5915,9 +5925,9 @@ output_initialize_occurs (struct cb_initialize *p, cb_tree x) cb_tree list; cb_tree l; int k, offset, idx, idx_clr, total_occurs, simple_occurs; - int idxtbl[COB_MAX_SUBSCRIPTS+1]; - int occtbl[COB_MAX_SUBSCRIPTS+1]; - struct cb_field *pftbl[COB_MAX_SUBSCRIPTS+1]; + int idxtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; + int occtbl[COB_MAX_SUBSCRIPTS+1] = { 0 }; + struct cb_field *pftbl[COB_MAX_SUBSCRIPTS+1] = { NULL }; f = cb_code_field (x); if (f->flag_occurs @@ -5926,10 +5936,12 @@ output_initialize_occurs (struct cb_initialize *p, cb_tree x) simple_occurs = 1; else simple_occurs = 0; +#if 0 /* CHECKME: the init above should be fine */ for (idx=0; idx <= COB_MAX_SUBSCRIPTS; idx++) { idxtbl[idx] = 0; pftbl[idx] = NULL; } +#endif total_occurs = 1; idx_clr = 0; for (idx = 0, pf = f; pf; pf = pf->parent) { @@ -6131,6 +6143,9 @@ output_initialize_compound (struct cb_initialize *p, cb_tree x) if (f->occurs_max > 1) { + /* all exceptions should have been raised above, + so temporarily detach from the reference */ + ref->check = NULL; ref->length = NULL; for (pf = f; pf && !pf->flag_occurs_values; pf = pf->parent); diff --git a/cobc/config.c b/cobc/config.c index f7dc109b9..cfc2b8c6d 100644 --- a/cobc/config.c +++ b/cobc/config.c @@ -203,14 +203,12 @@ check_valid_value (const char *fname, const int line, const char *name, const ch return ret; } -#if 0 /* unused */ static void unsupported_value (const char *fname, const int line, const char *name, const char *val) { configuration_error (fname, line, 1, _("unsupported value '%s' for configuration tag '%s'"), val, name); } -#endif static void split_and_iterate_on_comma_separated_str ( @@ -756,7 +754,6 @@ cb_config_entry (char *buff, const char *fname, const int line) return -1; } break; - /* for enums without a string value: set max_value and fall through to CB_INT */ } else if (strcmp (name, "dpc-in-data") == 0) { if (strcmp (val, "none") == 0) { cb_dpc_in_data = CB_DPC_IN_NONE; @@ -771,6 +768,40 @@ cb_config_entry (char *buff, const char *fname, const int line) return -1; } break; + } else if (strcmp (name, "defaultbyte") == 0) { + if (strcmp (val, "init") == 0) { + /* generate default initialization per INITIALIZE rules */ + cb_default_byte = -1; + break; + } + if (strcmp (val, "none") == 0) { + cb_default_byte = -2; +#if 1 /* TODO: do not generate any default initialization for fields without VALUE, + only the storage (best performance, least reproducibility); for now warn + if specified on command line (allowing config files be correct already) */ + if (strcmp (fname, "-fdefaultbyte=none") == 0) { + unsupported_value (fname, line, name, val); + } + cb_default_byte = 0; /* at least a single fixed value for now... */ +#endif + break; + } + /* otherwise init by character (transformed to number */ + /* convert quoted character to number */ + if (val[0] == '"' && val[1] != 0 && val[2] == '"' && val[3] == 0) { + cb_default_byte = val[1]; + break; + } else + /* convert character to number (as quotes will commonly + be removed when given on shell) */ + if (val[1] == 0 && (val[0] <= '0' || val[0] >= '9')) { + cb_default_byte = val[0]; + break; + } + /* just use decimal as character number */ + config_table[i].min_value = 0; + config_table[i].max_value = 255; + /* fall through */ /* for enums without a string value: set max_value and fall through to CB_INT */ } else if (strcmp (name, "standard-define") == 0) { config_table[i].max_value = CB_STD_MAX - 1; @@ -785,14 +816,7 @@ cb_config_entry (char *buff, const char *fname, const int line) /* LCOV_EXCL_STOP */ case CB_INT: - if (strcmp (val, "ignore") == 0) - break; - if (val[1] == 0 - && (islower(val[0]) || isupper(val[0]))) { - int v = val[0]; - sprintf(valx,"%d",v); - val = valx; - } + /* check for number */ for (j = 0; val[j]; j++) { if (val[j] < '0' || val[j] > '9') { invalid_value (fname, line, name, val, NULL, 0, 0); diff --git a/cobc/config.def b/cobc/config.def index 760fe6b1d..efa9120c2 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -49,10 +49,10 @@ CB_CONFIG_STRING (cb_reserved_words, "reserved-words", _("use of complete/fixed /* Integer flags */ CB_CONFIG_INT (cb_tab_width, "tab-width", 1, 12, CB_XRANGE(1,12), - _("set number of spaces that are assumed for tabs")) + _("number of spaces that are assumed for tabs")) CB_CONFIG_INT (cb_config_text_column, "text-column", 72, 255, CB_XRANGE(72,255), - _("set right margin for source (fixed format only)")) + _("right margin column number for fixed-form reference-format")) CB_CONFIG_INT (cb_pic_length, "pic-length", 1, COB_MINI_MAX, _(""), _("maximum number of characters allowed in the PICTURE character-string")) @@ -66,11 +66,6 @@ CB_CONFIG_INT (cb_lit_length, "literal-length", 1, COB_MAX_LITERAL_LEN, _(""), - _("initialize fields without VALUE to \n" - " * decimal 0..255 representing a character\n" - " * default: initialize to picture")) - CB_CONFIG_INT (cb_align_record, "align-record", 0, 256, CB_XRANGE(0,256), _("align WORKING-STORAGE/LOCAL-STORAGE record on boundary")) @@ -83,6 +78,14 @@ CB_CONFIG_BOOLEAN (cb_align_opt, "align-opt", /* Flags with required parameter and special values */ +CB_CONFIG_ANY (signed int, cb_default_byte, "defaultbyte", + _("default initialization for fields without VALUE, may be one of\n" + " * character in quotes\n" + " * decimal 0..255 representing a character\n" + " * \"init\" to initialize to PICTURE/USAGE\n" + " * \"none\" to do no explicit initialization\n" + " * default: \"init\"")) + CB_CONFIG_ANY (enum cb_std_def, cb_std_define, "standard-define", NULL) /* Used Standard (set via -std) */ CB_CONFIG_ANY (enum cb_binary_size_options, cb_binary_size, "binary-size", @@ -186,11 +189,21 @@ CB_CONFIG_BOOLEAN (cb_move_nonnumlit_to_numeric_is_zero, "move-non-numeric-lit-t CB_CONFIG_BOOLEAN (cb_implicit_assign_dynamic_var, "implicit-assign-dynamic-var", _("implicitly define a variable if an ASSIGN DYNAMIC does not match any data item")) +CB_CONFIG_BOOLEAN (cb_device_mnemonics, "device-mnemonics", + _("specifying device by mnemonic")) + /* Support flags */ CB_CONFIG_SUPPORT (cb_comment_paragraphs, "comment-paragraphs", _("comment paragraphs in IDENTIFICATION DIVISION (AUTHOR, DATE-WRITTEN, ...)")) +CB_CONFIG_SUPPORT (cb_control_division, "control-division", + _("CONTROL DIVISION")) + +CB_CONFIG_SUPPORT (cb_partial_replacing_with_literal, + "partial-replacing-with-literal", + _("partial replacing with literal")) + CB_CONFIG_SUPPORT (cb_memory_size_clause, "memory-size-clause", _("MEMORY-SIZE clause")) @@ -241,6 +254,9 @@ CB_CONFIG_SUPPORT (cb_stop_literal_statement, "stop-literal-statement", CB_CONFIG_SUPPORT (cb_stop_identifier_statement, "stop-identifier-statement", _("STOP-identifier statement")) +CB_CONFIG_SUPPORT (cb_stop_error_statement, "stop-error-statement", + _("STOP ERROR statement")) + CB_CONFIG_SUPPORT (cb_debugging_mode, "debugging-mode", _("DEBUGGING MODE and debugging indicator")) @@ -427,3 +443,5 @@ CB_CONFIG_SUPPORT (cb_vsam_status, "vsam-status", CB_CONFIG_SUPPORT (cb_self_call_recursive, "self-call-recursive", _("CALL to own PROGRAM-ID implies RECURSIVE attribute")) +CB_CONFIG_SUPPORT (cb_record_contains_depending_clause, "record-contains-depending-clause", + _("DEPENDING clause in RECORD CONTAINS")) diff --git a/cobc/field.c b/cobc/field.c index 279f41b1a..0e04dd47a 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -637,31 +637,32 @@ cb_resolve_redefines (struct cb_field *field, cb_tree redefines) return NULL; } - /* Resolve the name in the current group (if any) */ - if (field->parent && field->parent->children) { - for (f = field->parent->children; f; f = f->sister) { - if (strcasecmp (f->name, name) == 0) { - break; - } - } - if (f == NULL) { - cb_error_x (x, _("'%s' is not defined in '%s'"), name, field->parent->name); - return NULL; - } - } else { - /* Get last defined name */ - candidate = NULL; - items = r->word->items; - for (; items; items = CB_CHAIN (items)) { - if (CB_FIELD_P (CB_VALUE (items))) { - candidate = CB_VALUE (items); - } - } - if (!candidate) { + /* Get last defined name */ + /* note: chaining over these are much faster than chaining over the complete + parent using strcasecmp */ + for (items = r->word->items; items; items = CB_CHAIN (items)) { + const cb_tree value = CB_VALUE (items); + if (CB_FIELD_P (value)) { + candidate = value; + /* we want to get the last, so no "break" here */ + } + } + if (!candidate) { + if (field->parent) { + cb_error_x (x, _("'%s' is not defined in '%s'"), + name, field->parent->name); + } else { undefined_error (redefines); - return NULL; } - f = CB_FIELD_PTR (candidate); + return NULL; + } + f = CB_FIELD_PTR (candidate); + + /* Check if candidate is in the current group (if any) */ + if (field->parent && field->parent != f->parent) { + cb_error_x (x, _ ("'%s' is not defined in '%s'"), + name, field->parent->name); + return NULL; } /* Check level number */ diff --git a/cobc/flag.def b/cobc/flag.def index 218e3c847..f167c3e78 100644 --- a/cobc/flag.def +++ b/cobc/flag.def @@ -63,6 +63,11 @@ CB_FLAG_RQ (cb_max_errors, 1, "max-errors", 128, 7, /* Flags with required parameter and no associated variable */ +CB_FLAG_NQ (1, "format", 16, + _(" -fformat=[FIXED|FREE|VARIABLE|XOPEN|XCARD|CRT|TERMINAL|COBOLX]\n" + " reference format\n" + " * default: FIXED")) + CB_FLAG_NQ (1, "intrinsics", 10, /* added to cb_intrinsic_list */ _(" -fintrinsics=[ALL|intrinsic function name(,name,...)]\n" " intrinsics to be used without FUNCTION keyword")) diff --git a/cobc/parser.y b/cobc/parser.y index 78a565ecc..415490a88 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -3372,6 +3372,7 @@ nested_list: depth = 0; setup_from_identification = 0; } + _control_division /* GCOS extension */ source_element_list ; @@ -3559,6 +3560,51 @@ _prototype_procedure_division_header: } ; +/* CONTROL DIVISION (GCOS extension) */ + +_control_division: + /* empty */ +| CONTROL DIVISION TOK_DOT + { + cb_verify (cb_control_division, "CONTROL DIVISION"); + } + _default_section +; + +_default_section: + /* empty */ +| DEFAULT SECTION TOK_DOT + _default_clauses + { + cobc_cs_check = 0; + } +; + +_default_clauses: + /*empty*/ +| _default_accept_clause + _default_display_clause + TOK_DOT +; + +_default_accept_clause: + /* empty */ +| ACCEPT _is word_or_terminal + { + CB_PENDING ("ACCEPT statement in DEFAULT SECTION"); + /* TODO: setup_default_accept ($3); */ + } +; + +_default_display_clause: + /* empty */ +| DISPLAY _is word_or_terminal + { + CB_PENDING ("DISPLAY statement in DEFAULT SECTION"); + /* TODO: setup_default_display ($3); */ + } +; + /* PROGRAM body */ _program_body: @@ -4200,7 +4246,7 @@ special_name: /* Mnemonic name clause */ mnemonic_name_clause: - WORD + word_or_terminal { check_headers_present (COBC_HD_ENVIRONMENT_DIVISION, COBC_HD_CONFIGURATION_SECTION, @@ -4218,6 +4264,11 @@ mnemonic_name_clause: mnemonic_choices ; +word_or_terminal: + WORD { $$ = $1; } + /* under GCOS, this reserved name can also be a system name */ +| TERMINAL { $$ = cb_build_reference("TERMINAL"); } + mnemonic_choices: _is CRT { @@ -6227,12 +6278,19 @@ record_clause: } } | RECORD _contains integer TO integer _characters + _record_depending /* GCOS extension */ { check_repeated ("RECORD", SYN_CLAUSE_4, &check_duplicate); if (current_file->organization == COB_ORG_LINE_SEQUENTIAL) { cb_warning (cb_warn_additional, _("RECORD clause ignored for LINE SEQUENTIAL")); } else { set_record_size ($3, $5); + if ($7) { + cb_verify (cb_record_contains_depending_clause, "RECORD CONTAINS DEPENDING"); + current_file->record_depending = $7; + current_file->flag_check_record_varying_limits = + current_file->record_min == 0 || current_file->record_max == 0; + } } } | RECORD _is VARYING _in _size _from_integer _to_integer _characters @@ -6240,16 +6298,15 @@ record_clause: { check_repeated ("RECORD", SYN_CLAUSE_4, &check_duplicate); set_record_size ($6, $7); + current_file->record_depending = $9; current_file->flag_check_record_varying_limits = current_file->record_min == 0 || current_file->record_max == 0; } ; _record_depending: -| DEPENDING _on reference - { - current_file->record_depending = $3; - } + /* empty */ { $$ = NULL; } +| DEPENDING _on reference { $$ = $3; } ; _from_integer: @@ -12167,11 +12224,21 @@ cancel_statement: ; cancel_body: + cancel_list +| ALL + { + const char *all_name = "CANCEL ALL"; + struct cb_literal *all = build_literal (CB_CATEGORY_ALPHANUMERIC, all_name, strlen (all_name)); + cb_emit_cancel (CB_TREE(all)); + } +; + +cancel_list: id_or_lit_or_program_name { cb_emit_cancel ($1); } -| cancel_body id_or_lit_or_program_name +| cancel_list id_or_lit_or_program_name { cb_emit_cancel ($2); } @@ -12461,6 +12528,10 @@ display_body: cb_emit_command_line ($1); } | screen_or_device_display _common_exception_phrases +| _with CONVERSION screen_or_device_display _common_exception_phrases + { + CB_PENDING ("DISPLAY WITH CONVERSION"); + } | display_erase /* note: may also be part of display_pos_specifier */ | display_pos_specifier | display_message_box @@ -12595,7 +12666,7 @@ display_upon: { upon_value = cb_build_display_mnemonic ($2); } -| UPON WORD +| UPON word_or_terminal { upon_value = cb_build_display_name ($2); } @@ -15812,6 +15883,13 @@ stop_statement: check_unreached = 1; cobc_cs_check = 0; } +| STOP ERROR /* GCOS */ + { + begin_statement (STMT_STOP_ERROR, 0); + cb_verify (cb_stop_error_statement, cb_statement_name[STMT_STOP_ERROR]); + cb_emit_stop_error (); + check_unreached = 1; + } | STOP stop_argument { begin_statement (STMT_STOP, 0); diff --git a/cobc/pplex.l b/cobc/pplex.l index c388180ac..dd42e73a4 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -131,7 +131,6 @@ struct plex_stack { /* Global variables */ - /* Local variables */ static char *plexbuff1 = NULL; static char *plexbuff2 = NULL; @@ -149,6 +148,14 @@ static int quotation_mark = 0; static int listing_line = 0; static int requires_listing_line; static int requires_new_line = 0; +static enum cb_format source_format; +static int indicator_column = 7; +static int text_column = 72; /* end of area B (in single-byte + characters) */ +static int floating_area_b = 0; /* whether indicator is optional */ +static int fill_continued_alnums = 1; /* whether continued alphanumeric + literals should be filled with + spaces up to text column */ static char display_msg[PPLEX_BUFF_LEN]; @@ -187,6 +194,8 @@ DEFNUM_LITERAL [+-]?[0-9]*[\.]*[0-9]+ %x COBOL_WORDS_DIRECTIVE_STATE %x COPY_STATE %x PSEUDO_STATE +%x CONTROL_DIVISION_STATE +%x SUBSTITUTION_SECTION_STATE %x SOURCE_DIRECTIVE_STATE %x DEFINE_DIRECTIVE_STATE %x ON_OFF_DIRECTIVE_STATE @@ -447,7 +456,65 @@ DEFNUM_LITERAL [+-]?[0-9]*[\.]*[0-9]+ return CONTROL_STATEMENT; } +"CONTROL"[ ,;\n]+"DIVISION" { + /* Syntax extension for GCOS: such a division may include a SUBSTITUTION + SECTION that records source text replacement statements, along with a + DEFAULT SECTION where compile-time defaults are specified. */ + /* cf `ppparse.y`, grammar entry `program_with_control_division`, along + with `parser.y`, entry `_control_division`. */ + ppecho (yytext, 0, (int)yyleng); + yy_push_state (CONTROL_DIVISION_STATE); + return CONTROL_DIVISION; +} + +{ + "SUBSTITUTION"[ ,;\n]+"SECTION" { + yy_push_state (SUBSTITUTION_SECTION_STATE); + return SUBSTITUTION_SECTION; + } + \. { + /* Pass dots to the parser to handle DEFAULT SECTION. */ + ppecho (yytext, 0, (int)yyleng); + return DOT; + } +} + +{ + "REPLACE" { + yy_push_state (COPY_STATE); + return REPLACE; + } + \. { + /* Intercept dots within the SUBSTITUTION SECTION */ + return DOT; + } +} + +{ + "DEFAULT"[ ,;\n]+"SECTION" { + /* Pop any control division-related start condition state. */ + while (YY_START == CONTROL_DIVISION_STATE || + YY_START == SUBSTITUTION_SECTION_STATE) + yy_pop_state (); + ppecho (yytext, 0, (int)yyleng); + } + [,;]?\n { + ECHO; + check_listing (yytext, 0); + cb_source_line++; + } + [,;]?[ ]+ { /* ignore */ } +} + + ("ID"|"IDENTIFICATION")[ ,;\n]+"DIVISION" { + /* Pop any control division-related start condition state. */ + while (YY_START == CONTROL_DIVISION_STATE || + YY_START == SUBSTITUTION_SECTION_STATE) + yy_pop_state (); /* Allow comment sentences/paragraphs */ comment_allowed = 1; ppecho (yytext, 0, (int)yyleng); @@ -617,9 +684,10 @@ COBOL_WORDS_DIRECTIVE_STATE>{ { "FORMAT" { return FORMAT; } "IS" { return IS; } - "FIXED" { return FIXED; } - "FREE" { return FREE; } - "VARIABLE" { return VARIABLE; } + {WORD} { + pplval.s = cobc_plex_strdup (yytext); + return VARIABLE_NAME; + } } { @@ -988,7 +1056,7 @@ ENDIF_DIRECTIVE_STATE>{ /* Restore variables */ current_replace_list = current_copy_info->replacing; quotation_mark = current_copy_info->quotation_mark; - cb_source_format = current_copy_info->source_format; + cobc_set_source_format (current_copy_info->source_format); copy_stack = current_copy_info->next; cobc_free (current_copy_info->dname); @@ -1115,7 +1183,7 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) current_copy_info->replacing = current_replace_list; current_copy_info->line = cb_source_line; current_copy_info->quotation_mark = quotation_mark; - current_copy_info->source_format = cb_source_format; + current_copy_info->source_format = cobc_get_source_format (); current_copy_info->next = copy_stack; current_copy_info->containing_files = old_list_file; @@ -1324,10 +1392,123 @@ ppcopy (const char *name, const char *lib, struct cb_replace_list *replace_list) return -1; } +/* `newline_count` is one line ahead when the two functions below are called + (from `ppparse.y`). */ + +unsigned int +ppparse_verify (const enum cb_support tag, const char *feature) +{ + return cb_plex_verify (newline_count-1, tag, feature); +} + void ppparse_error (const char *err_msg) { - cb_plex_error (newline_count, "%s", err_msg); + cb_plex_error (newline_count-1, "%s", err_msg); +} + +/* Sets `source_format`, `indicator_column`, `text_column`, + `floating_area_b`, and `fill_continued_alnums`, based on the given source + format. */ +void +cobc_set_source_format (const enum cb_format sf) { + source_format = sf; + + switch (source_format) { + case CB_FORMAT_XOPEN_FFF: + case CB_FORMAT_ICOBOL_CRT: + case CB_FORMAT_ACUTERM: + case CB_FORMAT_COBOLX: + indicator_column = 1; + floating_area_b = source_format != CB_FORMAT_COBOLX; + fill_continued_alnums = 0; + break; + default: + indicator_column = 7; + floating_area_b = 0; + fill_continued_alnums = 1; + break; + } + + switch (source_format) { + case CB_FORMAT_FIXED: + text_column = cb_config_text_column; /* 72 by default */ + break; + case CB_FORMAT_VARIABLE: + /* This value matches most MF Visual COBOL 4.0 version. */ + text_column = 250; + break; + case CB_FORMAT_XOPEN_FFF: + text_column = 80; + break; + case CB_FORMAT_ACUTERM: + case CB_FORMAT_ICOBOL_CRT: + /* CHECKME: + https://sf.net/p/gnucobol/feature-requests/29/#c2d0/8d2f */ + text_column = 320; + break; + case CB_FORMAT_COBOLX: + case CB_FORMAT_ICOBOL_XCARD: + text_column = 255; + break; + case CB_FORMAT_FREE: + /* text-column should be ignored: put an invalid value to catch + some bugs? */ + text_column = -1; + break; + } +} + +COB_A_PURE enum cb_format cobc_get_source_format (void) { return source_format; } +COB_A_PURE int cobc_get_indicator_column (void) { return indicator_column; } +COB_A_PURE int cobc_get_text_column (void) { return text_column; } + +/* The three functions below return indexes on the lines (starting from 0), not + character positions (counted from 1). */ +COB_A_PURE int cobc_get_indicator (void) { + return indicator_column - 1; +} +COB_A_PURE int cobc_get_margin_a (const int indicator_width) { + return indicator_column + indicator_width - 1; +} +COB_A_PURE int cobc_get_margin_b (const int indicator_width) { + /* careful, for COBOL 2002 there is no margin B */ + return indicator_column + indicator_width + 3; +} + +static int +cobc_parse_source_format (enum cb_format *const out, const char *const sfname) { + enum cb_format format; + if (!cb_strcasecmp (sfname, "FIXED")) { + format = CB_FORMAT_FIXED; + } else if (!cb_strcasecmp (sfname, "FREE")) { + format = CB_FORMAT_FREE; + } else if (!cb_strcasecmp (sfname, "VARIABLE")) { + format = CB_FORMAT_VARIABLE; + } else if (!cb_strcasecmp (sfname, "XOPEN")) { + format = CB_FORMAT_XOPEN_FFF; + } else if (!cb_strcasecmp (sfname, "XCARD")) { + format = CB_FORMAT_ICOBOL_XCARD; + } else if (!cb_strcasecmp (sfname, "CRT")) { + format = CB_FORMAT_ICOBOL_CRT; + } else if (!cb_strcasecmp (sfname, "TERMINAL")) { + format = CB_FORMAT_ACUTERM; + } else if (!cb_strcasecmp (sfname, "COBOLX")) { + format = CB_FORMAT_COBOLX; + } else { + return 1; /* invalid argument */ + } + *out = format; + return 0; +} + +int cobc_deciph_source_format (const char* const sfname) { + enum cb_format format; + if (cobc_parse_source_format (&format, sfname) == 0) { + cobc_set_source_format (format); + return 0; + } + return 1; } void @@ -1474,7 +1655,7 @@ get_new_listing_file (void) cb_current_file->copy_tail = newfile; newfile->copy_line = cb_source_line; - newfile->source_format = cb_source_format; + newfile->source_format = cobc_get_source_format (); old_list_file = cb_current_file; cb_current_file = newfile; } @@ -1624,6 +1805,7 @@ ppinput (char *buff, const size_t max_size) size_t gotcr; size_t line_overflow; size_t continuation; + size_t indicator_width; int ipchar; int i,k; int n; @@ -1738,7 +1920,7 @@ start: [but only during ppinput() in pplex.l ?] Workaround for now: Temporary newline_count + 1 */ - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { if (line_overflow == 0) { cb_plex_warning (cb_missing_newline, newline_count + 1, _("line not terminated by a newline")); @@ -1768,24 +1950,24 @@ start: if (memcmp("<<<<<<<", buff, 7) == 0 || memcmp("=======", buff, 7) == 0 || memcmp(">>>>>>>", buff, 7) == 0) { - /* FIXME: the different line numbers (see test "conflict markers" + /* FIXME: the different line numbers (see test "conflict markers" are definitely a bug to solve in short time */ - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { ++newline_count; } cb_plex_error (newline_count, _("version control conflict marker in file")); - if (cb_source_format != CB_FORMAT_FREE) { + if (source_format != CB_FORMAT_FREE) { ++newline_count; } goto start; } } - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { bp = buff; } else { - if (n < 8) { + if (n <= indicator_column) { /* Line too short */ newline_count++; goto start; @@ -1798,16 +1980,15 @@ start: } } - /* Check if text is longer than cb_text_column */ - if (cb_source_format == CB_FORMAT_FIXED - && n > cb_text_column + 1) { + /* Check if text is longer than text_column */ + if (n > text_column + 1) { /* Show warning if it is not whitespace (postponed after checking for comments by setting line_overflow to first column that leads to "source text too long") */ if (cb_warn_opt_val[cb_warn_column_overflow] && line_overflow == 0) { - for (coln = cb_text_column; coln < n; ++coln) { + for (coln = text_column; coln < n; ++coln) { if (buff[coln] != ' ' && buff[coln] != '\n') { line_overflow = coln; break; @@ -1817,21 +1998,21 @@ start: line_overflow = 0; } /* Remove it */ - buff[cb_text_column] = '\n'; - buff[cb_text_column + 1] = 0; - n = cb_text_column + 1; + buff[text_column] = '\n'; + buff[text_column + 1] = 0; + n = text_column + 1; } else { line_overflow = 0; } - memset (buff, ' ', (size_t)6); - /* Note we allow directive lines to start at column 7 */ - bp = &buff[6]; + memset (buff, ' ', (size_t)(indicator_column - 1)); + /* Note we allow directive lines to start in the indicator column */ + bp = &buff[indicator_column - 1]; /* Special case: acucomment must be checked here as we'd pass comments as directives otherwise */ - if (cb_flag_acucomment && buff[6] == '$') { - buff[6] = '*'; + if (cb_flag_acucomment && buff[indicator_column - 1] == '$') { + buff[indicator_column - 1] = '*'; } } /* @@ -1942,7 +2123,7 @@ start: } /* Return when free format (no floating comments removed!) */ - if (cb_source_format == CB_FORMAT_FREE) { + if (source_format == CB_FORMAT_FREE) { within_comment = 0; if (newline_count) { memmove (buff + newline_count, buff, (size_t)n + 1); @@ -1955,11 +2136,21 @@ start: /* Fixed format */ - /* Check the indicator (column 7) */ - switch (buff[6]) { + /* Check the indicator */ + indicator_width = 1; + switch (buff[indicator_column - 1]) { case ' ': + if (floating_area_b) { /* indicator is optional */ + indicator_width = 0; + } break; case '-': + if (source_format == CB_FORMAT_XOPEN_FFF) { + /* X/Open free-form does not interpret '-' as + continuation indicator */ + indicator_width = 0; + break; + } if (within_comment) { cb_plex_error (newline_count, _("invalid continuation in comment entry")); @@ -1973,6 +2164,19 @@ start: break; case 'd': case 'D': + if (source_format == CB_FORMAT_ACUTERM) { + indicator_width = 0; + break; /* ACU terminal: this 'D' denotes a nominal text line */ + } else if (source_format == CB_FORMAT_XOPEN_FFF) { + if (buff[indicator_column - 1] == 'D' && + buff[indicator_column] == ' ') { + indicator_width = 2; + } else { + /* X/Open free-form: not a debugging line */ + indicator_width = 0; + break; + } + } /* Debugging line */ (void) cb_verify (cb_debugging_mode, _("debugging indicator")); if (cb_flag_debugging_line) { @@ -1984,10 +2188,32 @@ start: case '/': /* Comment line requested page-break in listing */ newline_count++; goto start; + case '\\': + if (buff[indicator_column] == 'D' && + source_format == CB_FORMAT_ACUTERM) { + /* ACUTERM debugging line */ + (void) cb_verify (cb_debugging_mode, _("debugging indicator")); + indicator_width = 2; + if (cb_flag_debugging_line) { + break; + } + } else { + /* Invalid ACU terminal indicator? */ + cb_plex_error (newline_count, + _("invalid indicator '\\' at column %d"), + indicator_column); + } + newline_count++; + goto start; default: + if (floating_area_b) { /* indicator is optional */ + indicator_width = 0; + break; + } /* Invalid indicator */ cb_plex_error (newline_count, - _("invalid indicator '%c' at column 7"), buff[6]); + _("invalid indicator '%c' at column %d"), + buff[indicator_column - 1], indicator_column); /* Note: Treat as comment line to allow further parsing instead of aborting compilation */ newline_count++; @@ -1997,13 +2223,13 @@ start: /* Skip comments that follow after AUTHORS, etc. */ if (within_comment) { /* Check all of "Area A" */ - for (ipchar = 7; ipchar < (n - 1) && ipchar < 11; ++ipchar) { - if (buff[ipchar] != ' ') { - ipchar = 0; - break; - } - } - if (ipchar) { + const int margin_a = cobc_get_margin_a (indicator_width); + const int margin_b = cobc_get_margin_b (indicator_width); + const int ipchar_max = (n - 1 < margin_b) ? n - 1 : margin_b; + for (ipchar = margin_a; + ipchar < ipchar_max && buff[ipchar] == ' '; + ++ipchar); + if (ipchar == ipchar_max) { newline_count++; goto start; } @@ -2011,17 +2237,20 @@ start: } /* Skip blank lines */ - for (i = 7; buff[i] == ' '; ++i) { - ; - } - + for (i = indicator_column; buff[i] == ' '; ++i); if (buff[i] == '\n') { newline_count++; goto start; } - buff[6] = ' '; - bp = buff + 7; + /* Substitute spaces for indicator */ + { + const int margin_a = cobc_get_margin_a (indicator_width); + for (i = indicator_column - 1; i < margin_a; i++) { + buff[i] = ' '; + } + bp = buff + margin_a; + } if (continuation) { /* Line continuation */ @@ -2069,7 +2298,7 @@ start: /* remove indicator "source text too long" if the column leading to the indicator comes after the floating comment */ - if (i < cb_text_column) { + if (i < text_column) { line_overflow = 0; } /* Set to null, 'i' is predecremented further below */ @@ -2080,7 +2309,7 @@ start: /* Literal start */ quotation_mark = buff[i]; } else if (quotation_mark == buff[i]) { - if (i == cb_text_column - 1) { + if (i == text_column - 1) { /* Consecutive quotation */ consecutive_quotation = 1; } else { @@ -2096,8 +2325,10 @@ start: if (!consecutive_quotation) { need_continuation = 1; } - for (; i < cb_text_column;) { - buff[i++] = ' '; + if (fill_continued_alnums) { + for (; i < text_column;) { + buff[i++] = ' '; + } } buff[i] = 0; } else { @@ -2116,12 +2347,12 @@ start: buff[i + 1] = 0; } - /* Show warning if text is longer than cb_text_column + /* Show warning if text is longer than text_column and not whitespace (postponed here) */ if (line_overflow != 0) { cb_plex_warning (cb_warn_source_after_code, newline_count, _("source text after program-text area (column %d)"), - cb_text_column); + text_column); } if (continuation) { @@ -2389,11 +2620,12 @@ check_listing (const char *text, const unsigned int comment) fprintf (cb_listing_file, "%6d%c", ++listing_line, c); } - if (requires_listing_line && cb_source_format != CB_FORMAT_FREE && - strlen (text) > 6) { - s = &text[6]; + if (requires_listing_line && + source_format != CB_FORMAT_FREE && + strlen (text) >= indicator_column) { + s = &text[indicator_column - 1]; } else { - s = text; + s = ""; /* do not output sequence area */ } fputs (s, cb_listing_file); if (strchr (text, '\n')) { diff --git a/cobc/ppparse.y b/cobc/ppparse.y index b1d1bafab..82fec0f33 100644 --- a/cobc/ppparse.y +++ b/cobc/ppparse.y @@ -67,16 +67,38 @@ static enum cb_directive_action current_cmd = PLEX_ACT_IF; /* Local functions */ +/* Strips the given string from its quotation characters, if any. Returns its + argument as is otherwise. */ static char * -fix_filename (char *name) +unquote (char *name) { - /* remove quotation from alphanumeric literals */ - if (name[0] == '\'' || name[0] == '\"') { + size_t size; + if ((name[0] == '\'' || name[0] == '"') && (size = strlen (name)) > 1 && + (name[0] == name[size - 1])) { + name[size - 1] = '\0'; name++; - name[strlen (name) - 1] = 0; } return name; } +#define fix_filename(filename) unquote (filename) + +static char * +literal_token (char *t, int allow_spaces) +{ + if (t[0] == '\'' || t[0] == '"') { + (void) ppparse_verify (cb_partial_replacing_with_literal, + _("partial replacing with literal")); + } else if (allow_spaces && (strcmp ("SPACE", t) == 0 || + strcmp ("SPACES", t) == 0)) { + (void) ppparse_verify (cb_partial_replacing_with_literal, + _("partial replacing with literal")); + t[0] = '\0'; + } else { + ppparse_error (_("unexpected COBOL word in partial replacement " + "phrase")); + } + return unquote (t); +} static char * fold_lower (char *name) @@ -128,7 +150,7 @@ ppp_set_value (struct cb_define_struct *p, const char *value) const char *s; size_t size; unsigned int dotseen; - + p->value = NULL; p->sign = 0; p->int_part = 0; @@ -471,7 +493,7 @@ append_to_turn_list (struct cb_text_list *ec_names, int enable, int with_locatio l->next = NULL; /* The line number is set properly in the scanner */ l->line = -1; - + if (cb_turn_list) { for (turn_list_end = cb_turn_list; turn_list_end->next; @@ -598,12 +620,12 @@ ppparse_clear_vars (const struct cb_define_struct *p) %token LEAP_SECOND_DIRECTIVE +%token CONTROL_DIVISION "CONTROL DIVISION" +%token SUBSTITUTION_SECTION "SUBSTITUTION SECTION" + %token SOURCE_DIRECTIVE %token FORMAT %token IS -%token FIXED -%token FREE -%token VARIABLE %token CALL_DIRECTIVE %token COBOL @@ -700,6 +722,7 @@ ppparse_clear_vars (const struct cb_define_struct *p) %type alnum_equality %type alnum_equality_list %type ec_list +%type unquoted_literal %type copy_replacing %type replacing_list @@ -716,13 +739,46 @@ ppparse_clear_vars (const struct cb_define_struct *p) %% +program_structure: + CONTROL_DIVISION DOT program_with_control_division +| statement_list +; + +/* GCOS 7 COBOL85 ref. manual p. 136: [...] If the replace-entry is present in +the Substitution Section of the Control Division of a source program, that +source program, including all contained programs, must contain no REPLACE +statement. Thankfully this helps avoiding some conflicts. */ +program_with_control_division: + statement_list +| control_division_no_replace statement_no_replace statement_list +| control_division_no_replace +| control_division_with_replace DOT statement_no_replace_list +; + +control_division_no_replace: + SUBSTITUTION_SECTION DOT +; + +control_division_with_replace: + /* The period could be optional. */ + SUBSTITUTION_SECTION DOT replace_statement +; + statement_list: | statement_list statement ; +statement_no_replace_list: +| statement_no_replace_list statement_no_replace +; + statement: - copy_statement DOT + statement_no_replace | replace_statement DOT +; + +statement_no_replace: + copy_statement DOT | directive TERMINATOR | listing_statement | CONTROL_STATEMENT control_options _dot TERMINATOR @@ -825,15 +881,9 @@ set_choice: fprintf (ppout, "#ADDSYN %s %s\n", l->text, l->next->text); } } -| ASSIGN LITERAL +| ASSIGN unquoted_literal { char *p = $2; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "EXTERNAL")) { fprintf (ppout, "#ASSIGN %d\n", (int)CB_ASSIGN_EXT_FILE_NAME_REQUIRED); @@ -841,22 +891,16 @@ set_choice: fprintf (ppout, "#ASSIGN %d\n", (int)CB_ASSIGN_VARIABLE_DEFAULT); } else { ppp_error_invalid_option ("ASSIGN", p); - } + } } | BOUND { /* Enable EC-BOUND-SUBSCRIPT checking */ append_to_turn_list (ppp_list_add (NULL, "EC-BOUND-SUBSCRIPT"), 1, 0); } -| CALLFH LITERAL +| CALLFH unquoted_literal { - char *p = $2; - /* Remove surrounding quotes/brackets */ - size_t size; - ++p; - size = strlen (p) - 1; - p[size] = '\0'; - fprintf (ppout, "#CALLFH \"%s\"\n", p); + fprintf (ppout, "#CALLFH \"%s\"\n", $2); } | CALLFH { @@ -874,15 +918,9 @@ set_choice: /* Enable EC-DATA-INCOMPATIBLE checking */ append_to_turn_list (ppp_list_add (NULL, "EC-DATA-INCOMPATIBLE"), 1, 0); } -| COMP1 LITERAL +| COMP1 unquoted_literal { char *p = $2; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "BINARY")) { cb_binary_comp_1 = 1; @@ -892,15 +930,9 @@ set_choice: ppp_error_invalid_option ("COMP1", p); } } -| DPC_IN_DATA LITERAL +| DPC_IN_DATA unquoted_literal { char *p = $2; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "XML")) { cb_dpc_in_data = CB_DPC_IN_XML; @@ -912,15 +944,9 @@ set_choice: ppp_error_invalid_option ("DPC-IN-DATA", p); } } -| FOLDCOPYNAME _as LITERAL +| FOLDCOPYNAME _as unquoted_literal { char *p = $3; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; if (!cb_strcasecmp (p, "UPPER")) { cb_fold_copy = COB_FOLD_UPPER; @@ -976,7 +1002,7 @@ set_choice: /* Disable EC-BOUND-SUBSCRIPT and -REF-MOD checking */ struct cb_text_list *txt = ppp_list_add (NULL, "EC-BOUND-SUBSCRIPT"); txt = ppp_list_add (txt, "EC-BOUND-REF-MOD"); - + append_to_turn_list (txt, 0, 0); } | NOODOSLIDE @@ -1001,30 +1027,15 @@ set_choice: fprintf (ppout, "#REMOVE %s\n", l->text); } } -| SOURCEFORMAT _as LITERAL +| SOURCEFORMAT _as unquoted_literal { char *p = $3; - size_t size; - - /* Remove surrounding quotes/brackets */ - ++p; - size = strlen (p) - 1; - p[size] = '\0'; - if (!cb_strcasecmp (p, "FIXED")) { - cb_source_format = CB_FORMAT_FIXED; - cb_text_column = cb_config_text_column; - } else if (!cb_strcasecmp (p, "FREE")) { - cb_source_format = CB_FORMAT_FREE; - } else if (!cb_strcasecmp (p, "VARIABLE")) { - cb_source_format = CB_FORMAT_FIXED; - /* This value matches most MF Visual COBOL 4.0 version. */ - cb_text_column = 250; - } else { + if (cobc_deciph_source_format (p) != 0) { ppp_error_invalid_option ("SOURCEFORMAT", p); } if (cb_src_list_file) { - cb_current_file->source_format = cb_source_format; + cb_current_file->source_format = cobc_get_source_format (); } } | SOURCEFORMAT _as error @@ -1041,7 +1052,7 @@ set_choice: { char *p = $2; char ep = 0; - + /* Remove surrounding quotes/brackets */ if (p) { size_t size; @@ -1161,32 +1172,18 @@ refmod_directive: ; source_directive: - _format _is format_type + _format _is VARIABLE_NAME { + if (cobc_deciph_source_format ($3) != 0) { + ppp_error_invalid_option ("SOURCE", $3); + } if (cb_src_list_file) { - cb_current_file->source_format = cb_source_format; + cb_current_file->source_format = cobc_get_source_format (); } } -; - -format_type: - FIXED - { - cb_source_format = CB_FORMAT_FIXED; - cb_text_column = cb_config_text_column; - } -| FREE - { - cb_source_format = CB_FORMAT_FREE; - } -| VARIABLE - { - cb_source_format = CB_FORMAT_FIXED; - cb_text_column = 500; - } -| GARBAGE +| _format _is LITERAL { - cb_error (_("invalid %s directive"), "SOURCE"); + ppp_error_invalid_option ("SOURCE", $3); YYERROR; } ; @@ -1661,6 +1658,10 @@ text_partial_src: { $$ = ppp_list_add (NULL, $2); } +| TOKEN + { + $$ = ppp_list_add (NULL, literal_token ($1, 0)); + } ; text_partial_dst: @@ -1672,6 +1673,10 @@ text_partial_dst: { $$ = ppp_list_add (NULL, $2); } +| TOKEN + { + $$ = ppp_list_add (NULL, literal_token ($1, 1)); + } ; token_list: @@ -1741,6 +1746,23 @@ lead_trail: } ; +unquoted_literal: + LITERAL + { + /* Do not reuse unquote as some literals here may be delimited with + parentheses */ + char *p = $1; + size_t size; + + /* Remove surrounding quotes/brackets */ + ++p; + size = strlen (p) - 1; + p[size] = '\0'; + + $$ = p; + } +; + /* Optional keywords */ _override: diff --git a/cobc/reserved.c b/cobc/reserved.c index 43a9e686f..ceb35ebcc 100644 --- a/cobc/reserved.c +++ b/cobc/reserved.c @@ -60,6 +60,9 @@ static struct system_name_struct system_name_table[] = { {"SYSERR", CB_DEVICE_NAME, CB_DEVICE_SYSERR, CB_FEATURE_ACTIVE}, {"STDERR", CB_DEVICE_NAME, CB_DEVICE_SYSERR, CB_FEATURE_ACTIVE}, {"CONSOLE", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, + {"ALTERNATE-CONSOLE", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, + {"ALTERNATE CONSOLE", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, + {"TERMINAL", CB_DEVICE_NAME, CB_DEVICE_CONSOLE, CB_FEATURE_ACTIVE}, {"C01", CB_FEATURE_NAME, CB_FEATURE_C01, CB_FEATURE_ACTIVE}, {"C02", CB_FEATURE_NAME, CB_FEATURE_C02, CB_FEATURE_ACTIVE}, {"C03", CB_FEATURE_NAME, CB_FEATURE_C03, CB_FEATURE_ACTIVE}, @@ -813,7 +816,7 @@ static struct cobc_reserved default_reserved_words[] = { 0, 0 }, { "CONVERSION", 0, 1, CONVERSION, /* Extension */ - 0, CB_CS_ACCEPT + 0, CB_CS_ACCEPT | CB_CS_DISPLAY }, { "CONVERTING", 0, 0, CONVERTING, /* 2002 */ 0, 0 diff --git a/cobc/scanner.l b/cobc/scanner.l index f62734552..8ae70549f 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -157,7 +157,6 @@ static size_t pic2_size; static unsigned int last_token_is_dot = 0; static unsigned int integer_is_label = 0; static unsigned int inside_bracket = 0; -static unsigned int literal_error; static char err_msg[COB_MINI_BUFF]; /* Function declarations */ @@ -906,6 +905,11 @@ H#[0-9A-Za-z]+ { } } +"ALTERNATE"[ ,;\n]+"CONSOLE"/[ .,;\n] { + count_lines (yytext); + yylval = cb_build_reference ("ALTERNATE CONSOLE"); + RETURN_TOK (WORD); +} "SWITCH"[ ]+([0-9][0-9]?|[A-Z])/[ .,;\n] { /* ACUCOBOL extension: switch-names with space and with letter */ @@ -1284,7 +1288,7 @@ H#[0-9A-Za-z]+ { %% static void -error_literal (const char *type, const char *literal) +error_literal (const char *type, const char *literal, unsigned int literal_error) { if (!literal_error) { char lit_out[CB_ERR_LITMAX + 1]; @@ -1313,7 +1317,6 @@ error_literal (const char *type, const char *literal) } #endif } - literal_error++; cb_error ("%s", err_msg); } @@ -1322,8 +1325,7 @@ read_literal (const char mark, const char *type) { size_t i; int c; - - literal_error = 0; + unsigned int literal_error = 0; i = 0; /* read until a not-escaped mark is found (see break) @@ -1358,10 +1360,13 @@ read_literal (const char mark, const char *type) for (escaped) mark before checking the max length */ if (i++ == cb_lit_length) { snprintf (err_msg, COB_MINI_MAX, - _("literal length exceeds %d characters"), + _("literal length exceeds %u characters"), cb_lit_length); plex_buff[cb_lit_length] = 0; /* ensure valid C-string for error message */ - error_literal ("", plex_buff); + error_literal ("", plex_buff, literal_error); + if (!literal_error) { + literal_error = cb_lit_length; + } } } if (c == EOF @@ -1371,8 +1376,11 @@ read_literal (const char mark, const char *type) ) { snprintf (err_msg, COB_MINI_MAX, _("missing terminating %c character"), mark); - plex_buff[plex_size - 1] = 0; /* ensure valid C-string for error message */ - error_literal ("", plex_buff); + plex_buff[i] = 0; /* ensure valid C-string for error message */ + error_literal ("", plex_buff, literal_error); + if (!literal_error) { + literal_error = i; + } } /* FIXME: Exact behavior should depend on level of support: @@ -1399,6 +1407,20 @@ read_literal (const char mark, const char *type) if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, i); } else { + /* poor-man's conversion iso-8859 -> utf-16 */ + /* "!a0" = x'21613000' -> nx'00210061003000' */ + size_t new_size = i * 2; + if (new_size + 1 > plex_size) { + plex_size = new_size + 1; + plex_buff = cobc_realloc (plex_buff, plex_size); + } + plex_buff[new_size] = 0; + while (i) { + i--; + plex_buff[i * 2 + 1] = plex_buff [i]; + plex_buff[i * 2] = 0; + } + i = new_size; if (type[1] != 'C') { if (cb_verify (cb_national_literals, _("national literal"))) { CB_UNFINISHED (_("national literal")); @@ -1420,9 +1442,8 @@ scan_x (const char *text, const char *type) char *dst; size_t curr_len; size_t result_len; - int c; - - literal_error = 0; + char c; + unsigned int literal_error = 0; /* Remark: The standard allows for 8,191 (normal/national/boolean) character positions */ @@ -1434,8 +1455,7 @@ scan_x (const char *text, const char *type) curr_len--; if (curr_len == 0) { cb_verify (cb_zero_length_lit, _("zero-length literal")); - plex_buff[0] = '\0'; - plex_buff[1] = '\0'; + memset (plex_buff, 0, 5); cb_warning (COBC_WARN_FILLER, _("hexadecimal literal has zero length; X'00' will be assumed")); if (type[0] == 'B') { @@ -1448,39 +1468,50 @@ scan_x (const char *text, const char *type) RETURN_TOK (LITERAL); } + /* ensure buffers don't get too big */ + if (curr_len > (size_t)cb_lit_length + 1) { + curr_len = cb_lit_length + 1; + } if (curr_len + 1 > plex_size) { plex_size = curr_len + 1; - plex_buff = cobc_realloc (plex_buff, plex_size); + cobc_free (plex_buff); + plex_buff = cobc_malloc (plex_size); } memcpy (plex_buff, text, curr_len); if (type[0] == 'X') { result_len = curr_len / 2; /* characters, two half-bytes (hex) = 1 byte */ } else if (type[0] == 'B') { + result_len = curr_len * 4; /* boolean characters B -> 1110 */ if (!cb_verify (cb_hexadecimal_boolean, _("hexadecimal-boolean literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } - result_len = curr_len * 4; /* boolean characters B -> 1110 */ + /* GnuCOBOL currently only support 64 bit booleans */ if (result_len > 64) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) result_len, 64); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) result_len, 64); + error_literal (type, plex_buff, literal_error++); + /* we'll get an overflow below, but that's no problem, + an alternative would be to incement *text to only parse 64 / 4 + characters but that leads to not verified data, which is + more important as the compilation will error-exit in any case */ } } else { + result_len = curr_len / (2 * COB_NATIONAL_SIZE); if (!cb_verify (cb_national_hex_literals, _("hexadecimal-national literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + yylval = cb_build_national_literal ("", 1); + RETURN_TOK (LITERAL); + } else { + CB_UNFINISHED (_("national literal")); } - CB_UNFINISHED (_("national literal")); - result_len = curr_len / (2 * COB_NATIONAL_SIZE); /* national characters */ } if (result_len > cb_lit_length) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) result_len, cb_lit_length); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) result_len, cb_lit_length); + error_literal (type, plex_buff, literal_error++); } p = (char *)text; @@ -1491,13 +1522,13 @@ scan_x (const char *text, const char *type) /* hexadecimal-boolean */ cob_u64_t val = 0; for (; *p != *e; p++) { - c = (int) *p; + c = *p; if ('0' <= c && c <= '9') { - val = (val << 4) + ((cob_u64_t)c - '0'); + c = c - '0'; } else if ('A' <= c && c <= 'F') { - val = (val << 4) + ((cob_u64_t)c - 'A' + 10); + c = c - 'A' + 10; } else if ('a' <= c && c <= 'f') { - val = (val << 4) + ((cob_u64_t)c - 'a' + 10); + c = c - 'a' + 10; } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); @@ -1505,15 +1536,13 @@ scan_x (const char *text, const char *type) memcpy (plex_buff, text, curr_len + 1); plex_buff[curr_len] = 0; } - error_literal (type, plex_buff); + error_literal (type, plex_buff, literal_error++); /* By not breaking immediately, we detect any following - invalid chars + invalid chars */ - continue; + c = 0; } - } - if (literal_error != 0) { - goto error; + val = (val << 4) + c; } sprintf ((char *)plex_buff, CB_FMT_LLU, val); yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); @@ -1537,18 +1566,16 @@ scan_x (const char *text, const char *type) memcpy (plex_buff, text, curr_len + 1); plex_buff[curr_len] = 0; } - error_literal (type, plex_buff); + error_literal (type, plex_buff, literal_error++); /* By not breaking immediately, we detect any following invalid chars */ - continue; + c = 0; } - if (literal_error == 0) { - if (high) { - *dst = (cob_u8_t)(c << 4); - } else { - *dst++ += (cob_u8_t)c; - } + if (high) { + *dst = (cob_u8_t)(c << 4); + } else { + *dst++ += (cob_u8_t)c; } high = 1 - high; } @@ -1561,10 +1588,7 @@ scan_x (const char *text, const char *type) memcpy (plex_buff, text, curr_len + 1); plex_buff[curr_len] = 0; } - error_literal (type, plex_buff); - } - if (literal_error != 0) { - goto error; + error_literal (type, plex_buff, literal_error++); } if (type[0] != 'N') { yylval = cb_build_alphanumeric_literal (plex_buff, (size_t)(dst - plex_buff)); @@ -1574,87 +1598,80 @@ scan_x (const char *text, const char *type) } RETURN_TOK (LITERAL); - -error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int scan_z (const char *text, const char *type) { - size_t currlen; - - literal_error = 0; - - /* currlen includes the terminating quote */ - currlen = strlen (text); - if ((currlen - 1) > cb_lit_length) { - currlen--; + /* curr_len includes the terminating quote */ + size_t curr_len = strlen (text); + + if (curr_len == 1) { + curr_len--; + snprintf (err_msg, COB_MINI_MAX, + _("%s literals must contain at least one character"), + type); + error_literal (type, "", 0); + yylval = cb_build_alphanumeric_literal ("", 1); + RETURN_TOK (LITERAL); + } + if ((unsigned long)(curr_len - 1) > cb_lit_length) { + curr_len--; snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, cb_lit_length); - error_literal (type, text); - goto error; - } else if (currlen == 1) { - currlen--; - snprintf (err_msg, COB_MINI_MAX, - _("%s literals must contain at least one character"), - type); - error_literal (type, ""); - goto error; - } - if (currlen > plex_size) { - plex_size = currlen; - plex_buff = cobc_realloc (plex_buff, plex_size); - } - memcpy (plex_buff, text, currlen); - plex_buff[currlen - 1] = 0; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, cb_lit_length); + error_literal (type, text, 0); + curr_len = cb_lit_length + 1; /* ensure buffers don't get too big */ + } + if (curr_len > plex_size) { + plex_size = curr_len; + cobc_free (plex_buff); + plex_buff = cobc_malloc (plex_size); + } + memcpy (plex_buff, text, curr_len); + plex_buff[curr_len - 1] = 0; /* Count is correct here as the trailing quote is now a null */ - yylval = cb_build_alphanumeric_literal (plex_buff, currlen); + yylval = cb_build_alphanumeric_literal (plex_buff, curr_len); if (type[0] == 'L') { CB_LITERAL(yylval)->llit = 1; } RETURN_TOK (LITERAL); - - error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int scan_h (const char *text, const char *type) { - size_t currlen; + size_t curr_len; char *p; cob_u64_t val = 0; int c; + unsigned int literal_error = 0; - literal_error = 0; - - if (type[1] == '#' && - !cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + if (type[1] == '#' + && !cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { + /* note: early exit with valid literal */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } - /* currlen can include the terminating quote */ - currlen = strlen (text); - memcpy (plex_buff, text, currlen + 1); + /* curr_len can include the terminating quote */ + curr_len = strlen (text); + memcpy (plex_buff, text, curr_len + 1); if (type[1] != '#') { - currlen--; - if (currlen == 0) { + curr_len--; + if (curr_len == 0) { cb_error (_("H literals must contain at least one character")); - goto error; + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } - plex_buff[currlen] = 0; + plex_buff[curr_len] = 0; } - if (currlen > 16) { + if (curr_len > 16) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, 16); - error_literal ("hex", plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, 16); + error_literal ("hex", plex_buff, literal_error++); } for (p = plex_buff; *p != 0; p++) { @@ -1668,11 +1685,11 @@ scan_h (const char *text, const char *type) } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); - error_literal (type, plex_buff); + error_literal (type, plex_buff, literal_error++); /* By not breaking immediately, we detect any following invalid chars */ - continue; + c = 0; } val = (val << 4) + c; @@ -1681,25 +1698,20 @@ scan_h (const char *text, const char *type) if (type[1] == '#') { /* limit for ACUCOBOL literals: UINT_MAX */ if (val > UINT_MAX) { - snprintf (err_msg, COB_MINI_MAX, - _("literal exceeds limit %u"), UINT_MAX); - error_literal (type, plex_buff); + if (curr_len <= 16) { + snprintf (err_msg, COB_MINI_MAX, + _("literal exceeds limit %u"), UINT_MAX); + error_literal (type, plex_buff, literal_error++); + } + val = UINT_MAX; } } - if (literal_error) { - goto error; - } - /* Duplication? */ sprintf ((char *)plex_buff, CB_FMT_LLU, val); yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); RETURN_TOK (LITERAL); - -error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int @@ -1709,50 +1721,56 @@ scan_b (const char *text, const char *type) COBOL 2002 allows up to 160 boolean characters --> both identical to "literal-length" maximum GnuCOBOL currently only supports 64 boolean characters, - check if it works to concatenate after 64 characters, similar to read_literal() + more need a different storage */ - size_t currlen; + size_t curr_len; char *p; cob_u64_t val = 0; int c; + unsigned int literal_error = 0; - literal_error = 0; - - /* currlen can include the terminating quote */ - currlen = strlen (text); + /* curr_len can include the terminating quote */ + curr_len = strlen (text); if (type[1] == 0) { if (!cb_verify (cb_numeric_boolean, _("numeric boolean literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + /* early exit possible as complete literal is consumed */ + curr_len = 0; } - if (currlen == 1) { + if (curr_len == 1) { cb_verify (cb_zero_length_lit, _("zero-length literal")); cb_warning (COBC_WARN_FILLER, _("Boolean literal has zero length; B'0' will be assumed")); + } + if (curr_len <= 1) { /* FIXME: we should really build a boolean literal... */ yylval = cb_build_numeric_literal (0, "0", 0); RETURN_TOK (LITERAL); } } else { if (!cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } }; - if (currlen >= plex_size) { - currlen = plex_size - 1; + if (curr_len >= plex_size) { + curr_len = plex_size - 1; } - memcpy (plex_buff, text, currlen + 1); + memcpy (plex_buff, text, curr_len + 1); if (type[1] == 0) { - currlen--; + curr_len--; } - plex_buff[currlen] = 0; - if (currlen > 64) { + plex_buff[curr_len] = 0; + if (curr_len > 64) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, 64); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, 64); + error_literal (type, plex_buff, literal_error++); + /* we'll get an overflow below, but that's no problem, + an alternative would be to incement *text to only parse 64 / 4 + characters but that leads to not verified data, which is + more important as the compilation will error-exit in any case */ } for (p = plex_buff; *p != 0; p++) { @@ -1764,8 +1782,8 @@ scan_b (const char *text, const char *type) } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); - error_literal (type, plex_buff); - continue; + error_literal (type, plex_buff, literal_error++); + c = 0; } val = (val << 1) + c; @@ -1773,78 +1791,75 @@ scan_b (const char *text, const char *type) if (type[1] == '#') { /* limit for ACUCOBOL literals: UINT_MAX */ if (val > UINT_MAX) { - snprintf (err_msg, COB_MINI_MAX, - _("literal exceeds limit %u"), UINT_MAX); - error_literal (type, plex_buff); + if (curr_len <= 64) { + snprintf (err_msg, COB_MINI_MAX, + _("literal exceeds limit %u"), UINT_MAX); + error_literal (type, plex_buff, literal_error); + } + val = UINT_MAX; } } - if (literal_error) { - goto error; - } - sprintf ((char *)plex_buff, CB_FMT_LLU, val); /* FIXME: we should likely build a boolean literal ... */ yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); RETURN_TOK (LITERAL); - - error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int scan_o (const char *text, const char *type) { - size_t currlen; - char *p; + size_t curr_len; cob_u64_t val = 0; - int c; - - literal_error = 0; + char *p; + char c; + unsigned int literal_error = 0; if (type[0] == '%') { if (!cb_verify (cb_hp_octal_literals, _("HP COBOL octal literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } } else { if (!cb_verify (cb_acu_literals, _("ACUCOBOL numeric literal"))) { - goto error; /* early exit possible as complete literal is consumed */ + /* early exit possible as complete literal is consumed */ + yylval = cb_build_numeric_literal (0, "0", 0); + RETURN_TOK (LITERAL); } } - currlen = strlen (text); - memcpy (plex_buff, text, currlen + 1); - if (currlen > 22) { + curr_len = strlen (text); + memcpy (plex_buff, text, curr_len + 1); + if (curr_len > 22) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d characters"), - (int) currlen, 22); - error_literal (type, plex_buff); - goto error; + _("literal length %lu exceeds %u characters"), + (unsigned long) curr_len, 22); + error_literal (type, plex_buff, literal_error++); } for (p = plex_buff; *p != 0; p++) { - c = (int) *p; - if (!('0' <= c && c <= '7')) { + c = *p; + if ('0' <= c && c <= '7') { + c = c - '0'; + } else { snprintf (err_msg, COB_MINI_MAX, _("literal contains invalid character '%c'"), c); - error_literal (type, plex_buff); - continue; + error_literal (type, plex_buff, literal_error++); + c = 0; } - c = c - '0'; val = (val << 3) + c; } /* limit for ACUCOBOL literals: UINT_MAX */ if (val > UINT_MAX) { - snprintf (err_msg, COB_MINI_MAX, - _("literal exceeds limit %u"), UINT_MAX); - error_literal (type, plex_buff); - } - - if (literal_error) { - goto error; + if (curr_len <= 22) { + snprintf (err_msg, COB_MINI_MAX, + _("literal exceeds limit %u"), UINT_MAX); + error_literal (type, plex_buff, literal_error++); + } + val = UINT_MAX; } if (type[0] == '%') { @@ -1864,10 +1879,6 @@ scan_o (const char *text, const char *type) yylval = cb_build_numeric_literal (0, (const void *)plex_buff, 0); RETURN_TOK (LITERAL); - - error: - yylval = cb_error_node; - RETURN_TOK (LITERAL); } static int @@ -1896,6 +1907,7 @@ scan_numeric (const char *text) char *s; int sign; int scale; + size_t curr_len; /* Get sign */ sign = get_sign (*p); @@ -1914,22 +1926,22 @@ scan_numeric (const char *text) /* Note that leading zeroes are not removed from the literal. */ - if (strlen (p) > COB_MAX_DIGITS) { + curr_len = strlen (p); + + if (curr_len > COB_MAX_DIGITS) { /* Absolute limit */ snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds maximum of %d digits"), - (int) strlen (p), COB_MAX_DIGITS); - error_literal ("num", text); - yylval = cb_error_node; - } else if (strlen (p) > cb_numlit_length) { + _("literal length %lu exceeds maximum of %u digits"), + (unsigned long) curr_len, COB_MAX_DIGITS); + error_literal ("num", text, 0); + p[COB_MAX_DIGITS] = 0; + } else if (curr_len > cb_numlit_length) { snprintf (err_msg, COB_MINI_MAX, - _("literal length %d exceeds %d digits"), - (int) strlen (p), cb_numlit_length); - error_literal ("num", text); - yylval = cb_error_node; - } else { - yylval = cb_build_numeric_literal (sign, p, scale); + _("literal length %lu exceeds %u digits"), + (unsigned long) curr_len, cb_numlit_length); + error_literal ("num", text, 0); } + yylval = cb_build_numeric_literal (sign, p, scale); RETURN_TOK (LITERAL); } @@ -1983,8 +1995,7 @@ scan_floating_numeric (const char *text) char *exponent_pos; char result[128] = { '\0' }; - - literal_error = 0; + unsigned int literal_error = 0; /* Separate into significand and exponent */ n = sscanf (text, COB_FLOAT_DIGITS_WIDTH "[0-9.,+-]%*1[Ee]%7[0-9.,+-]", @@ -2039,18 +2050,18 @@ scan_floating_numeric (const char *text) /* note: same message in tree.c for floating-point numeric-edited item */ snprintf (err_msg, COB_MINI_MAX, _("significand has more than %d digits"), COB_FLOAT_DIGITS_MAX); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } else { if (strchr (exponent_pos, current_program->decimal_point)) { snprintf (err_msg, COB_MINI_MAX, _("exponent has decimal point")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } else { if (strlen (exponent_pos) > 4) { /* note: same message in tree.c for floating-point numeric-edited item */ snprintf (err_msg, COB_MINI_MAX, _("exponent has more than 4 digits")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } else { n = sscanf (exponent_pos, "%d", &exponent); /* We check the return for silencing warnings, but @@ -2080,7 +2091,7 @@ scan_floating_numeric (const char *text) if (!(-6143 <= exponent && exponent <= 6144)) { snprintf (err_msg, COB_MINI_MAX, _("exponent not between -6143 and 6144")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } } } @@ -2089,22 +2100,22 @@ scan_floating_numeric (const char *text) if (sig_sign == -1) { snprintf (err_msg, COB_MINI_MAX, _("significand of 0 must be positive")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } if (exponent != 0) { snprintf (err_msg, COB_MINI_MAX, _("exponent of 0 must be 0")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } if (exp_sign == -1) { snprintf (err_msg, COB_MINI_MAX, _("exponent of 0 must be positive")); - error_literal ("float", text); + error_literal ("float", text, literal_error++); } } if (literal_error) { - yylval = cb_error_node; + yylval = cb_build_numeric_literal (0, "0", 0); RETURN_TOK (LITERAL); } diff --git a/cobc/tree.c b/cobc/tree.c index ceae92f0f..c9664649e 100644 --- a/cobc/tree.c +++ b/cobc/tree.c @@ -7172,6 +7172,10 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, double drslt, dval; char result[64]; + /* TODO: if all arguments are constants: build a cob_field, + then call into libcob to get the value and from there the string representation + inserting it here directly (-> numeric/alphanumeric/national constant, + which allows also for optimized use of it */ numargs = (int)cb_list_length (args); if (isuser) { @@ -7430,17 +7434,34 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, fld = CB_FIELD_PTR (x); if (!cb_field_variable_size (fld) && !fld->flag_any_length) { - if (!(fld->pic - && (fld->pic->category == CB_CATEGORY_NATIONAL - || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED))) - return cb_build_length (x); + int len = fld->size; + char buff[32]; + if (cbp->intr_enum != CB_INTR_BYTE_LENGTH) { + /* CHECKME: why don't we just check the category? + Maybe needs to enforce field validation (see cb_build_length) */ + if ( fld->pic + && (fld->pic->category == CB_CATEGORY_NATIONAL + || fld->pic->category == CB_CATEGORY_NATIONAL_EDITED)) { + len /= COB_NATIONAL_SIZE; + } + } + sprintf (buff, "%d", len); + return cb_build_numeric_literal (0, buff, 0); } } else if (CB_LITERAL_P (x)) { - /* FIXME: we currently generate national constants as alphanumeric constants */ - if (cbp->intr_enum != CB_INTR_BYTE_LENGTH - || (CB_TREE_CATEGORY (x) != CB_CATEGORY_NATIONAL_EDITED - && CB_TREE_CATEGORY (x) != CB_CATEGORY_NATIONAL)) - return cb_build_length (x); + unsigned int len = CB_LITERAL(x)->size; + char buff[32]; + if (cbp->intr_enum != CB_INTR_BYTE_LENGTH) { + enum cb_category cat = CB_TREE_CATEGORY (x); + /* CHECKME: why don't we just check the category? + Maybe needs to enforce field validation (see cb_build_length) */ + if (cat == CB_CATEGORY_NATIONAL + || cat == CB_CATEGORY_NATIONAL_EDITED) { + len /= COB_NATIONAL_SIZE; + } + } + sprintf (buff, "%u", len); + return cb_build_numeric_literal (0, buff, 0); } return make_intrinsic (func, cbp, args, NULL, NULL, 0); @@ -7551,6 +7572,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_HIGHEST_ALGEBRAIC: case CB_INTR_LOWEST_ALGEBRAIC: + /* TODO: resolve for all (?) values */ x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x)) { cb_error_x (func, _("FUNCTION '%s' has invalid argument"), cbp->name); @@ -7587,11 +7609,13 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, case CB_INTR_DISPLAY_OF: case CB_INTR_NATIONAL_OF: + /* TODO: resolve for literals */ return make_intrinsic (func, cbp, args, cb_int1, refmod, 0); case CB_INTR_BIT_OF: case CB_INTR_HEX_OF: + /* TODO: resolve for literals */ x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x) && !CB_LITERAL_P (x)) { @@ -7601,6 +7625,7 @@ cb_build_intrinsic (cb_tree func, cb_tree args, cb_tree refmod, return make_intrinsic (func, cbp, args, NULL, refmod, 0); case CB_INTR_BIT_TO_CHAR: case CB_INTR_HEX_TO_CHAR: + /* TODO: resolve for literals */ x = CB_VALUE (args); if (!CB_REF_OR_FIELD_P (x) &&!CB_LITERAL_P (x)) { diff --git a/cobc/tree.h b/cobc/tree.h index 9e332ebdb..fc7abd3f6 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2430,6 +2430,8 @@ extern void cb_emit_start (cb_tree, cb_tree, cb_tree, cb_tree); extern void cb_emit_stop_run (cb_tree); +extern void cb_emit_stop_error (void); + extern void cb_emit_stop_thread (cb_tree); extern void cb_emit_string (cb_tree, cb_tree, cb_tree); diff --git a/cobc/typeck.c b/cobc/typeck.c index 259578c8b..67086252d 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -3770,80 +3770,61 @@ cb_validate_collating (cb_tree collating_sequence) return 0; } -void -cb_validate_program_environment (struct cb_program *prog) +static void +validate_alphabet (cb_tree alphabet) { - cb_tree x; - cb_tree y; - cb_tree l; - cb_tree ls; - struct cb_alphabet_name *ap; - struct cb_class_name *cp; - unsigned char *data; - size_t dupls; - size_t unvals; - size_t count; - int lower; - int upper; - int size; - int n; - int i; - int pos; - int lastval; - int tableval; - int values[256]; - int charvals[256]; - int dupvals[256]; + struct cb_alphabet_name *ap = CB_ALPHABET_NAME (alphabet); + unsigned int n; - /* Check ALPHABET clauses */ - /* Complicated by difference between code set and collating sequence */ - for (l = prog->alphabet_name_list; l; l = CB_CHAIN (l)) { - ap = CB_ALPHABET_NAME (CB_VALUE (l)); - - /* Native */ - if (ap->alphabet_type == CB_ALPHABET_NATIVE) { - for (n = 0; n < 256; n++) { - ap->values[n] = n; - ap->alphachr[n] = n; - } - continue; + /* Native */ + if (ap->alphabet_type == CB_ALPHABET_NATIVE) { + for (n = 0; n < 256; n++) { + ap->values[n] = n; + ap->alphachr[n] = n; } + return; + } - /* ASCII */ - if (ap->alphabet_type == CB_ALPHABET_ASCII) { - for (n = 0; n < 256; n++) { + /* ASCII */ + if (ap->alphabet_type == CB_ALPHABET_ASCII) { + for (n = 0; n < 256; n++) { #ifdef COB_EBCDIC_MACHINE - ap->values[n] = (int)cob_refer_ascii[n]; - ap->alphachr[n] = (int)cob_refer_ascii[n]; + ap->values[n] = (int)cob_refer_ascii[n]; + ap->alphachr[n] = (int)cob_refer_ascii[n]; #else - ap->values[n] = n; - ap->alphachr[n] = n; + ap->values[n] = n; + ap->alphachr[n] = n; #endif - } - continue; } + return; + } - /* EBCDIC */ - if (ap->alphabet_type == CB_ALPHABET_EBCDIC) { - for (n = 0; n < 256; n++) { + /* EBCDIC */ + if (ap->alphabet_type == CB_ALPHABET_EBCDIC) { + for (n = 0; n < 256; n++) { #ifdef COB_EBCDIC_MACHINE - ap->values[n] = n; - ap->alphachr[n] = n; + ap->values[n] = n; + ap->alphachr[n] = n; #else - ap->values[n] = (int)cob_refer_ebcdic[n]; - ap->alphachr[n] = (int)cob_refer_ebcdic[n]; + ap->values[n] = (int)cob_refer_ebcdic[n]; + ap->alphachr[n] = (int)cob_refer_ebcdic[n]; #endif - } - continue; } + return; + } + + /* Custom alphabet */ + { + cb_tree l, x; + size_t count = 0; + int unvals = 0, dupls = 0; + int lastval = 0, tableval = 0; + int pos = 0; + int i; + int values[256]; + int charvals[256]; + int dupvals[256]; - /* Custom alphabet */ - dupls = 0; - unvals = 0; - pos = 0; - count = 0; - lastval = 0; - tableval = 0; for (n = 0; n < 256; n++) { values[n] = -1; charvals[n] = -1; @@ -3853,21 +3834,24 @@ cb_validate_program_environment (struct cb_program *prog) } ap->low_val_char = 0; ap->high_val_char = 255; - for (y = ap->custom_list; y; y = CB_CHAIN (y)) { + for (l = ap->custom_list; l; l = CB_CHAIN (l)) { pos++; if (count > 255) { unvals = pos; break; } - x = CB_VALUE (y); + x = CB_VALUE (l); if (CB_PAIR_P (x)) { /* X THRU Y */ - lower = get_value (CB_PAIR_X (x)); - upper = get_value (CB_PAIR_Y (x)); + int lower = get_value (CB_PAIR_X (x)); + int upper = get_value (CB_PAIR_Y (x)); lastval = upper; if (!count) { ap->low_val_char = lower; } + /* regression in NATIONAL literals as + thpose are unfinished; would be fine + with national alphabet in general */ if (lower < 0 || lower > 255) { unvals = pos; continue; @@ -3902,6 +3886,7 @@ cb_validate_program_environment (struct cb_program *prog) } } } else if (CB_LIST_P (x)) { + cb_tree ls; /* X ALSO Y ... */ if (!count) { ap->low_val_char = get_value (CB_VALUE (x)); @@ -3911,6 +3896,9 @@ cb_validate_program_environment (struct cb_program *prog) if (!CB_CHAIN (ls)) { lastval = n; } + /* regression in NATIONAL literals as + those are unfinished; would be fine + with national alphabet in general */ if (n < 0 || n > 255) { unvals = pos; continue; @@ -3950,23 +3938,49 @@ cb_validate_program_environment (struct cb_program *prog) ap->values[n] = tableval++; count++; } else if (CB_LITERAL_P (x)) { - size = (int)CB_LITERAL (x)->size; - data = CB_LITERAL (x)->data; + int size = (int)CB_LITERAL (x)->size; + unsigned char* data = CB_LITERAL (x)->data; if (!count) { ap->low_val_char = data[0]; } lastval = data[size - 1]; - for (i = 0; i < size; i++) { - n = data[i]; - if (values[n] != -1) { - dupvals[n] = n; - dupls = 1; + if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NATIONAL) { + for (i = 0; i < size; i++) { + n = data[i]; + if (values[n] != -1) { + dupvals[n] = n; + dupls = 1; + } + values[n] = n; + charvals[n] = n; + ap->alphachr[tableval] = n; + ap->values[n] = tableval++; + count++; + } + } else { + for (i = 0; i < size; i++) { + /* assuming we have UTF16BE here */ + if (data[i] == 0) { + /* only checking lower entries, all others, + which are currently only possible with + national-hex literals are not checked + TODO: add a list of values for those and + iterate over the list */ + n = data[++i]; + if (values[n] != -1) { + dupvals[n] = n; + dupls = 1; + } + values[n] = n; + charvals[n] = n; + ap->values[n] = tableval; + } else { + n = data[i++]; + n = n * 255 + data[i]; + } + ap->alphachr[tableval++] = n; + count++; } - values[n] = n; - charvals[n] = n; - ap->alphachr[tableval] = n; - ap->values[n] = tableval++; - count++; } } else { n = get_value (x); @@ -3990,31 +4004,29 @@ cb_validate_program_environment (struct cb_program *prog) } } if (dupls || unvals) { - cb_tree alphabet = CB_VALUE (l); if (dupls) { - /* FIXME: can't handle UTF8 / NATIONAL values */ - char dup_vals[256]; + char errmsg[256]; i = 0; for (n = 0; n < 256; n++) { if (dupvals[n] != -1) { if (i > 240) { - i += sprintf (dup_vals + i, ", ..."); + i += sprintf (&errmsg[i], ", ..."); break; } if (i) { - i += sprintf (dup_vals + i, ", "); + i += sprintf (&errmsg[i], ", "); } if (isprint (n)) { - dup_vals[i++] = (char)n; + errmsg[i++] = (char)n; } else { - i += sprintf (dup_vals + i, "x'%02x'", n); + i += sprintf (&errmsg[i], "x'%02x'", n); } }; } - dup_vals[i] = 0; + errmsg[i] = 0; cb_error_x (alphabet, _("duplicate character values in alphabet '%s': %s"), - ap->name, dup_vals); + ap->name, errmsg); } if (unvals) { cb_error_x (alphabet, @@ -4059,6 +4071,81 @@ cb_validate_program_environment (struct cb_program *prog) } } } +} + +static void +check_class_duplicates (cb_tree class_name) +{ + struct cb_class_name* cp = CB_CLASS_NAME (class_name); + size_t dupls = 0; + int values[256] = { 0 }; + cb_tree l; + +#if 0 /* should not be necessary with init above */ + memset (values, 0, sizeof (values)); +#endif + for (l = cp->list; l; l = CB_CHAIN (l)) { + cb_tree x = CB_VALUE (l); + if (CB_PAIR_P (x)) { + /* X THRU Y */ + int lower = get_value (CB_PAIR_X (x)); + int upper = get_value (CB_PAIR_Y (x)); + int i; + for (i = lower; i <= upper; i++) { + if (values[i]) { + dupls = 1; + } else { + values[i] = 1; + } + } + } else { + int n; + if (CB_NUMERIC_LITERAL_P (x)) { + n = get_value (x); + if (values[n]) { + dupls = 1; + } else { + values[n] = 1; + } + } else if (CB_LITERAL_P (x)) { + int size = (int)CB_LITERAL (x)->size; + unsigned char* data = CB_LITERAL (x)->data; + int i; + for (i = 0; i < size; i++) { + n = data[i]; + if (values[n]) { + dupls = 1; + } else { + values[n] = 1; + } + } + } else { + n = get_value (x); + if (values[n]) { + dupls = 1; + } else { + values[n] = 1; + } + } + } + } + if (dupls) { + cb_warning_x (cb_warn_additional, class_name, + _("duplicate character values in class '%s'"), + cb_name (class_name)); + } +} + +void +cb_validate_program_environment (struct cb_program *prog) +{ + cb_tree l; + + /* Check ALPHABET clauses */ + /* Complicated by difference between code set and collating sequence */ + for (l = prog->alphabet_name_list; l; l = CB_CHAIN (l)) { + validate_alphabet (CB_VALUE (l)); + } /* Reset HIGH/LOW-VALUES */ cb_low = cb_norm_low; @@ -4066,80 +4153,28 @@ cb_validate_program_environment (struct cb_program *prog) /* Check and generate SYMBOLIC clauses */ for (l = prog->symbolic_char_list; l; l = CB_CHAIN (l)) { + cb_tree x; if (CB_VALUE (l)) { - y = cb_ref (CB_VALUE (l)); - if (y == cb_error_node) { + x = cb_ref (CB_VALUE (l)); + if (x == cb_error_node) { continue; } - if (!CB_ALPHABET_NAME_P (y)) { - cb_error_x (y, _("invalid ALPHABET name")); + if (!CB_ALPHABET_NAME_P (x)) { + cb_error_x (x, _("invalid ALPHABET name")); continue; } } else { - y = NULL; + x = NULL; } - cb_build_symbolic_chars (CB_PURPOSE (l), y); + cb_build_symbolic_chars (CB_PURPOSE (l), x); } - /* Check CLASS clauses */ - for (l = prog->class_name_list; l; l = CB_CHAIN (l)) { - cp = CB_CLASS_NAME (CB_VALUE (l)); - /* LCOV_EXCL_START */ - if (cp == NULL) { /* keep the analyzer happy... */ - cobc_err_msg ("invalid CLASS detected"); /* not translated as highly unlikely */ - COBC_ABORT (); - } - /* LCOV_EXCL_STOP */ - dupls = 0; - memset (values, 0, sizeof(values)); - for (y = cp->list; y; y = CB_CHAIN (y)) { - x = CB_VALUE (y); - if (CB_PAIR_P (x)) { - /* X THRU Y */ - lower = get_value (CB_PAIR_X (x)); - upper = get_value (CB_PAIR_Y (x)); - for (i = lower; i <= upper; i++) { - if (values[i]) { - dupls = 1; - } else { - values[i] = 1; - } - } - } else { - if (CB_NUMERIC_LITERAL_P (x)) { - n = get_value (x); - if (values[n]) { - dupls = 1; - } else { - values[n] = 1; - } - } else if (CB_LITERAL_P (x)) { - size = (int)CB_LITERAL (x)->size; - data = CB_LITERAL (x)->data; - for (i = 0; i < size; i++) { - n = data[i]; - if (values[n]) { - dupls = 1; - } else { - values[n] = 1; - } - } - } else { - n = get_value (x); - if (values[n]) { - dupls = 1; - } else { - values[n] = 1; - } - } - } - } - if (dupls) { - cb_warning_x (cb_warn_additional, CB_VALUE(l), - _("duplicate character values in class '%s'"), - cb_name (CB_VALUE(l))); - } + /* Check CLASS clauses for duplicates */ + if (cb_warn_additional) { + for (l = prog->class_name_list; l; l = CB_CHAIN (l)) { + check_class_duplicates (CB_VALUE (l)); } + } /* Resolve the program collating sequences */ if (cb_validate_collating (prog->collating_sequence)) { @@ -4151,7 +4186,7 @@ cb_validate_program_environment (struct cb_program *prog) /* Resolve the program classification */ if (prog->classification && prog->classification != cb_int1) { - x = cb_ref (prog->classification); + cb_tree x = cb_ref (prog->classification); if (!CB_LOCALE_NAME_P (x)) { cb_error_x (prog->classification, _("'%s' is not a locale name"), @@ -4727,7 +4762,7 @@ cb_validate_program_data (struct cb_program *prog) && !cb_odoslide) { xerr = x; cb_error_x (x, - _ ("'%s' cannot have nested OCCURS DEPENDING"), + _("'%s' cannot have nested OCCURS DEPENDING"), cb_name (x)); } odo_level++; @@ -4750,7 +4785,7 @@ cb_validate_program_data (struct cb_program *prog) && x != xerr) { xerr = x; cb_error_x (x, - _ ("'%s' cannot have OCCURS DEPENDING because of '%s'"), + _("'%s' cannot have OCCURS DEPENDING because of '%s'"), cb_name (x), p->sister->name); break; } @@ -7743,6 +7778,7 @@ numeric_children_screen_pos_type (struct cb_field* child) if (!child) return 0; for (; child; child = child->sister) { + if (child->redefines) continue; if (!numeric_screen_pos_type (child)) { return 0; } @@ -8229,10 +8265,7 @@ cb_emit_accept_name (cb_tree var, cb_tree name) switch (CB_SYSTEM_NAME (sys)->token) { case CB_DEVICE_CONSOLE: case CB_DEVICE_SYSIN: - /* possibly others allow this, too, consider adding a config option */ - if (cb_std_define != CB_STD_IBM - && cb_std_define != CB_STD_MVS - && cb_std_define != CB_STD_MF + if (!cb_device_mnemonics && !cb_relaxed_syntax_checks) { cb_warning_x (COBC_WARN_FILLER, name, _("'%s' is not defined in SPECIAL-NAMES"), CB_NAME (name)); @@ -9418,12 +9451,9 @@ cb_build_display_name (cb_tree x) cb_error_x (x, _("'%s' is not an output device"), name); return cb_error_node; } - /* possibly others allow this, too, consider adding a config option */ - if (cb_std_define != CB_STD_IBM - && cb_std_define != CB_STD_MVS - && cb_std_define != CB_STD_MF + if (!cb_device_mnemonics && !cb_relaxed_syntax_checks) { - /* ... especially as this is not allowed and therefore should raise an error... */ + /* TODO: this is not allowed and therefore should raise an error */ cb_warning_x (COBC_WARN_FILLER, x, _("'%s' is not defined in SPECIAL-NAMES"), name); } @@ -13791,6 +13821,12 @@ cb_emit_stop_run (cb_tree x) cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_run", cb_build_cast_int (x))); } +void +cb_emit_stop_error (void) +{ + cb_emit (CB_BUILD_FUNCALL_0 ("cob_stop_error")); +} + void cb_emit_stop_thread (cb_tree handle) { @@ -14020,7 +14056,7 @@ cb_build_unstring_into (cb_tree name, cb_tree delimiter, cb_tree count) delimiter = cb_int0; } if (count == NULL - || error_if_not_int_field_or_has_pic_p ("COUNT", count)) { + || error_if_not_int_field_or_has_pic_p ("COUNT", count)) { count = cb_int0; } return CB_BUILD_FUNCALL_3 ("cob_unstring_into", name, delimiter, count); diff --git a/config/ChangeLog b/config/ChangeLog index 8a33a54da..51b56e6aa 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -17,23 +17,63 @@ * *.conf: changed top-level-occurs-clause "skip" to "unconformable" +2022-07-14 Simon Sobisch + + * general: set defaultbyte to "none" for standard COBOL, 32 to " " + +2022-07-12 Simon Sobisch + + * ibm-strict.conf, mvs-strict.conf, gcos-strict.conf, bs2000-strict.conf: + adjusted defaultbyte to 0 + 2022-07-01 Simon Sobisch * general: removed alias VALUES=VALUE, now a separate word +2022-06-24 Nicolas Berthier + + * general: remove indicator-column option, which is now a flag + +2022-06-17 Nicolas Berthier + + * general: added config option device-mnemonics (boolean) + 2022-06-10 Ron Norman * general: add 'defaultbyte' +2022-05-25 Nicolas Berthier + + * general: added option partial-replacing-with-literal + +2022-03-11 Fabrice Le Fessant + + * general: add a stop-error-statement option to allow configuring + the support of the STOP ERROR statement + +2022-02-07 David Declerck + + * general: add a record-contains-depending-clause option to allow + configuring the support of the DEPENDING clause in RECORD CONTAINS + 2022-02-07 David Declerck * gcos-strict.conf, gcos.conf, gcos.words: added config files for GCOS 7 (Bull) dialect +2022-02-04 David Declerck + + * general: add an indicator-column option to allow customizing + the position of the indicator + +2022-01-27 Nicolas Berthier + + * general: added option control-division + 2021-11-14 Ron Norman * mf.words: Add MF specific names B-EXOR, B-LEFT, B-RIGHT for bit - operations + operations 2021-11-09 Ron Norman @@ -692,7 +732,7 @@ * default.inc, Makefile.am: New files. -Copyright 2003,2005-2007-2010,2014-2021 Free Software Foundation, Inc. +Copyright 2003,2005-2007-2010,2014-2022 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted provided the copyright notice and this notice are preserved. diff --git a/config/acu-strict.conf b/config/acu-strict.conf index 1a4a1cd6b..1708b7eeb 100644 --- a/config/acu-strict.conf +++ b/config/acu-strict.conf @@ -183,6 +183,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: acu @@ -195,6 +198,8 @@ dpc-in-data: xml # verify alter-statement: obsolete comment-paragraphs: obsolete # not verified yet +partial-replacing-with-literal: ok +control-division: unconformable call-overflow: ok data-records-clause: obsolete # not verified yet debugging-mode: ok @@ -217,6 +222,7 @@ padding-character-clause: obsolete # not verified yet section-segments: ignore # not verified yet stop-literal-statement: obsolete # not verified yet stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -271,9 +277,10 @@ assign-ext-dyn: ok assign-disk-from: unconformable vsam-status: ignore self-call-recursive: skip -align-record: 4 +record-contains-depending-clause: unconformable +align-record: 4 align-opt: no -defaultbyte: 32 +defaultbyte: " " # use fixed word list, synonyms and exceptions specified there reserved-words: ACU diff --git a/config/bs2000-strict.conf b/config/bs2000-strict.conf index 8ac9d4719..50e6f8792 100644 --- a/config/bs2000-strict.conf +++ b/config/bs2000-strict.conf @@ -180,6 +180,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -192,6 +195,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: unconformable +control-division: unconformable +partial-replacing-with-literal: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -214,6 +219,7 @@ padding-character-clause: ignore section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # TYPEDEF is reserved but unused usage-type: unconformable @@ -268,9 +274,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip -align-record: 8 +record-contains-depending-clause: unconformable +align-record: 8 align-opt: no -defaultbyte: ignore +defaultbyte: 0 # not verified yet, but likely to be as IBM # use fixed word list, synonyms and exceptions specified there reserved-words: BS2000 diff --git a/config/cobol2002.conf b/config/cobol2002.conf index 7e0403bf1..b8998266a 100644 --- a/config/cobol2002.conf +++ b/config/cobol2002.conf @@ -179,6 +179,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -191,6 +194,8 @@ dpc-in-data: xml alter-statement: unconformable comment-paragraphs: unconformable +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: archaic data-records-clause: unconformable debugging-mode: obsolete @@ -213,6 +218,7 @@ padding-character-clause: obsolete section-segments: unconformable stop-literal-statement: unconformable stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok usage-type: unconformable @@ -266,9 +272,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: none # "undefined" # archaic in COBOL2002 and currently not available as dialect features: # 1: MOVE of alphanumeric figurative constants to numeric items diff --git a/config/cobol2014.conf b/config/cobol2014.conf index 2779f2759..88763ff8e 100644 --- a/config/cobol2014.conf +++ b/config/cobol2014.conf @@ -179,6 +179,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -191,6 +194,8 @@ dpc-in-data: xml alter-statement: unconformable comment-paragraphs: unconformable +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: archaic data-records-clause: unconformable debugging-mode: unconformable @@ -214,6 +219,7 @@ padding-character-clause: unconformable section-segments: unconformable stop-literal-statement: unconformable stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok usage-type: unconformable @@ -266,9 +272,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: none # "undefined" # use fixed word list, synonyms and exceptions specified there reserved-words: COBOL2014 diff --git a/config/cobol85.conf b/config/cobol85.conf index c02e9fff1..c80328182 100644 --- a/config/cobol85.conf +++ b/config/cobol85.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2021 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -179,6 +179,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -191,6 +194,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -213,6 +218,7 @@ padding-character-clause: ok section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -266,9 +272,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: none # "undefined" # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/config/default.conf b/config/default.conf index cecc93c15..4117cee6a 100644 --- a/config/default.conf +++ b/config/default.conf @@ -199,6 +199,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: gc @@ -211,6 +214,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: obsolete call-overflow: archaic data-records-clause: obsolete debugging-mode: ok @@ -234,6 +239,7 @@ occurs-max-length-without-subscript: no section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: obsolete +stop-error-statement: unconformable same-as-clause: ok type-to-clause: ok usage-type: ok @@ -288,9 +294,10 @@ assign-ext-dyn: ok assign-disk-from: ok vsam-status: ignore self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: init # use complete word list; synonyms and exceptions are specified below reserved-words: default diff --git a/config/gcos-strict.conf b/config/gcos-strict.conf index 9da8b3b44..38e3cb776 100644 --- a/config/gcos-strict.conf +++ b/config/gcos-strict.conf @@ -181,6 +181,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -193,6 +196,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: ok +partial-replacing-with-literal: ok call-overflow: archaic data-records-clause: obsolete debugging-mode: ok @@ -216,6 +221,7 @@ padding-character-clause: ok section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: ok same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -268,9 +274,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: obsolete align-record: 0 # TODO: verify align-opt: no # TODO: verify -defaultbyte: ignore +defaultbyte: 0 # use fixed word list, synonyms and exceptions specified there reserved-words: GCOS diff --git a/config/ibm-strict.conf b/config/ibm-strict.conf index da8d4379d..7de96d8d2 100644 --- a/config/ibm-strict.conf +++ b/config/ibm-strict.conf @@ -178,6 +178,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -190,6 +193,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -213,6 +218,7 @@ padding-character-clause: obsolete section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -265,9 +271,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 8 align-opt: yes -defaultbyte: ignore +defaultbyte: 0 # use fixed word list, synonyms and exceptions specified there reserved-words: IBM diff --git a/config/lax.conf-inc b/config/lax.conf-inc index 1c34a1c9e..96039f63c 100644 --- a/config/lax.conf-inc +++ b/config/lax.conf-inc @@ -65,6 +65,7 @@ screen-section-rules: gc alter-statement: +obsolete comment-paragraphs: ok +control-division: +obsolete call-overflow: ok data-records-clause: +obsolete debugging-mode: ok diff --git a/config/mf-strict.conf b/config/mf-strict.conf index 3a91afa0a..621e071ac 100644 --- a/config/mf-strict.conf +++ b/config/mf-strict.conf @@ -181,6 +181,9 @@ move-non-numeric-lit-to-numeric-is-zero: yes # match an existing data item. implicit-assign-dynamic-var: yes +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: mf @@ -193,6 +196,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -215,6 +220,7 @@ padding-character-clause: obsolete section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable # only supports USAGE type-name usage-type: ok @@ -269,9 +275,10 @@ assign-ext-dyn: ok assign-disk-from: ok vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 8 align-opt: yes -defaultbyte: 32 +defaultbyte: " " # use fixed word list, synonyms and exceptions specified there reserved-words: MF diff --git a/config/mvs-strict.conf b/config/mvs-strict.conf index f090c69c4..2519c6c35 100644 --- a/config/mvs-strict.conf +++ b/config/mvs-strict.conf @@ -178,6 +178,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: yes + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: std @@ -190,6 +193,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +partial-replacing-with-literal: unconformable +control-division: unconformable call-overflow: ok # not verified yet data-records-clause: obsolete debugging-mode: ok @@ -212,6 +217,7 @@ padding-character-clause: obsolete section-segments: ignore stop-literal-statement: obsolete stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -265,9 +271,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 8 align-opt: yes -defaultbyte: ignore +defaultbyte: 0 # not verified yet, but likely to be as IBM # use fixed word list, synonyms and exceptions specified there reserved-words: MVS diff --git a/config/realia-strict.conf b/config/realia-strict.conf index f9cf2a67e..a5789d6a4 100644 --- a/config/realia-strict.conf +++ b/config/realia-strict.conf @@ -183,6 +183,9 @@ move-non-numeric-lit-to-numeric-is-zero: yes # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -195,6 +198,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: ok +control-division: unconformable # not verified yet +partial-replacing-with-literal: unconformable # not verified yet call-overflow: ok data-records-clause: ignore debugging-mode: unconformable @@ -217,6 +222,7 @@ padding-character-clause: ignore section-segments: unconformable stop-literal-statement: ok stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -271,9 +277,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: ok self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 0 align-opt: no -defaultbyte: ignore +defaultbyte: " " # not verified, but possibly like ACU/MF # use fixed word list, synonyms and exceptions specified there reserved-words: realia diff --git a/config/rm-strict.conf b/config/rm-strict.conf index 3156b34de..47878c71a 100644 --- a/config/rm-strict.conf +++ b/config/rm-strict.conf @@ -184,6 +184,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # not verified yet # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: rm @@ -196,6 +199,8 @@ dpc-in-data: xml alter-statement: obsolete comment-paragraphs: obsolete +control-division: unconformable +partial-replacing-with-literal: unconformable # not verified yet call-overflow: ok data-records-clause: obsolete debugging-mode: ok @@ -218,6 +223,7 @@ padding-character-clause: ok section-segments: obsolete stop-literal-statement: obsolete stop-identifier-statement: ok +stop-error-statement: unconformable same-as-clause: ok type-to-clause: unconformable usage-type: unconformable @@ -272,9 +278,10 @@ assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable self-call-recursive: skip +record-contains-depending-clause: unconformable align-record: 4 align-opt: no -defaultbyte: ignore +defaultbyte: " " # not verified, but possibly like ACU/MF # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/config/xopen.conf b/config/xopen.conf index 0181ac52d..0d450e97b 100644 --- a/config/xopen.conf +++ b/config/xopen.conf @@ -1,6 +1,6 @@ # GnuCOBOL compiler configuration # -# Copyright (C) 2001-2012, 2014-2021 Free Software Foundation, Inc. +# Copyright (C) 2001-2012, 2014-2022 Free Software Foundation, Inc. # Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart, # Ron Norman # @@ -183,6 +183,9 @@ move-non-numeric-lit-to-numeric-is-zero: no # match an existing data item. implicit-assign-dynamic-var: no +# If yes, ACCEPT and DISPLAY statements accept device names using mnemonics +device-mnemonics: no + # What rules to apply to SCREEN SECTION items clauses screen-section-rules: xopen @@ -200,6 +203,8 @@ dpc-in-data: xml alter-statement: warning # should not be used ... comment-paragraphs: warning # should not be used ... +partial-replacing-with-literal: unconformable +control-division: unconformable call-overflow: ok data-records-clause: warning # should not be used ... debugging-mode: ok @@ -223,6 +228,7 @@ section-segments: unconformable # complete module removed # reportwriter and communication: complete modules removed stop-literal-statement: warning # should not be used ... stop-identifier-statement: unconformable +stop-error-statement: unconformable same-as-clause: unconformable type-to-clause: unconformable usage-type: unconformable @@ -275,10 +281,11 @@ assign-using-variable: unconformable assign-ext-dyn: unconformable assign-disk-from: unconformable vsam-status: unconformable +self-call-recursive: skip +record-contains-depending-clause: obsolete align-record: 0 align-opt: no -defaultbyte: ignore -self-call-recursive: skip +defaultbyte: none # "not specifically defined in Standard COBOL" # obsolete in COBOL85 and currently not available as dialect features: # 1: All literal with numeric or numeric edited item diff --git a/doc/ChangeLog b/doc/ChangeLog index 0e4f7cdf1..2011550ce 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,4 +1,8 @@ +2022-07-04 Nicolas Berthier + + * gnucobol.texi: document newly supported source formats + 2022-06-28 Simon Sobisch * gnucobol.texi: minor additions diff --git a/doc/gnucobol.texi b/doc/gnucobol.texi index 52801b651..2f4395f3e 100644 --- a/doc/gnucobol.texi +++ b/doc/gnucobol.texi @@ -418,26 +418,63 @@ Place the output into @var{file}. @node Source format @subsection Source format -GnuCOBOL supports both fixed and free source format. -The default format is the fixed format. -This can be overridden either by the -@code{>>SOURCE [FORMAT] [IS] @{FIXED|FREE@}} directive, -or by one of the following options: +GnuCOBOL supports fixed, free, Microfocus' Variable, X/Open Free-form, +ICOBOL xCard and Free-form, ACUCOBOL-GT Terminal, and COBOLX source +formats. The default format is the fixed format. This can be +overridden either by the @code{>>SOURCE [FORMAT] [IS] +@{FIXED|FREE|VARIABLE|XOPEN|XCARD|CRT|TERMINAL|COBOLX@}} directive, or +by one of the following options: @table @code -@item -free, -F +@item -free, -F, -fformat=free Free format. The program-text area starts in column 1 and continues till the end of line (effectively 255 characters in GnuCOBOL). -@item -fixed +@item -fixed, -fformat=fixed Fixed format. Source code is divided into: columns 1-6, the sequence number area; column 7, the indicator area; columns 8-72, the program-text area; and columns 72-80 as the reference area.@footnote{Historically, fixed format was based on 80-character punch cards.} +@item -fformat=variable +Microfocus' Variable format. Identical to the fixed format above except +for the program-text area which extends up to column 250 instead of 72. + +@item -fformat=xopen +X/Open Free-form format. The program-text area may start in column 1 +unless an indicator is present, and lines may contain up to 80 +characters. Indicator for debugging lines is @code{D } instead of +@code{D} or @code{d}. + +@item -fformat=xcard +ICOBOL xCard format. Variable format with right margin set at column +255 instead of 250. + +@item -fformat=crt +ICOBOL Free-form format (CRT). Similar to the X/Open format above, with +lines containing up to 320 characters and single-character debugging +line indicators (@code{D} or @code{d}). + +@item -fformat=terminal +ACUCOBOL-GT Terminal format. Similar to the CRT format above, with +indicator for debugging lines being @code{\D} instead of @code{D} or +@code{d}. This format is mostly compatible with VAX COBOL terminal +source format. + +@item -fformat=cobolx +COBOLX format. This format is similar to the CRT format above, except +that the indicator area is always present in column 1; the program-text +area starts in column 2 and extends up to the end of the record. Lines +may contain up to 255 characters. + @end table +Note that with source formats @code{XOPEN}, @code{CRT}, @code{TERMINAL}, +and @code{COBOLX}, missing spaces are not inserted within continued +alphanumeric literals that are truncated before the right margin. + + @node Warning options @subsection Warning options diff --git a/libcob/ChangeLog b/libcob/ChangeLog index 285bd686c..17beaed68 100644 --- a/libcob/ChangeLog +++ b/libcob/ChangeLog @@ -239,6 +239,13 @@ error status and fatal exception (no runtime exit) along with a warning if the runtime is not configured for XML / JSON +2022-07-15 Simon Sobisch + + * call.c (cob_resolve_internal): added check for module name length, + fixed compiler warnings + * call.c (cob_call): switched argument table from dynamic allocation + to stack allocation + 2022-07-10 Simon Sobisch * screenio.c [__PDCURSES__] (cob_exit_screen): execute @@ -248,11 +255,20 @@ * common.c, coblocal.h, screenio.c (cob_exit_screen_from_signal): only minimal screenio exit from signal handler +2022-07-08 Simon Sobisch + + * call.c (cob_cancel): preparation for CANCEL ALL + 2022-07-04 Ron Norman * Updated Copyright date to include 2022 * Reverted back to using D-ISAM and V-ISAM names +2022-06-23 Simon Sobisch + + * strings.c (cob_unstring_into): minor performance-tweak + for UNSTRING with a single DELIMITED BY phrase + 2022-06-21 Simon Sobisch * Makefile.am: always build INDEXED handlers as separate libraries @@ -360,6 +376,7 @@ check and marker range before checking all marker bytes in range * strings.c: increase use of direct pointer comparisons instead of accessing char arrays or its positions for INSPECT + 2022-04-29 Simon Sobisch * screenio.c: adjustments for XCurses defines @@ -389,6 +406,10 @@ compiler into directory different that declared when compiler was built +2022-03-11 Fabrice Le Fessant + + * common.c, common.h: add support for the STOP ERROR statement + 2022-02-21 Ron Norman * move.c (cob_move_display_to_packed): If P used in PIC adjust data move diff --git a/libcob/call.c b/libcob/call.c index d4eb5f89e..83f812955 100644 --- a/libcob/call.c +++ b/libcob/call.c @@ -767,7 +767,7 @@ cob_encode_invalid_chars (const unsigned char* const name, /** encode given name \param name to encode - \param name_buff to place the encoded name to + \param name_buff to place the encoded name to (unchanged, when no encoding necessary) \param buff_size available \param fold_case may be COB_FOLD_UPPER or COB_FOLD_LOWER \return size of the encoded name, negative if the buffer size would be exceeded @@ -818,13 +818,13 @@ static void * cob_resolve_internal (const char *name, const char *dirent, const int fold_case, int module_type) { - const unsigned char *s; void *func; struct struct_handle *preptr; lt_dlhandle handle; size_t i; - char call_entry_buff[COB_MINI_BUFF]; - unsigned char call_entry2_buff[COB_MINI_BUFF]; + char call_entry_buff[COB_MINI_BUFF]; /* entry name, possibly encoded */ + unsigned char call_module_buff[COB_MAX_NAMELEN + 1]; + const unsigned char *s; /* LCOV_EXCL_START */ if (!cobglobptr) { @@ -839,10 +839,21 @@ cob_resolve_internal (const char *name, const char *dirent, return func; } - s = (const unsigned char *)name; + if (strlen (name) > COB_MAX_NAMELEN) { + /* note: we allow up to COB_MAX_WORDLEN for relaxed syntax... */ + snprintf (resolve_error_buff, (size_t)CALL_BUFF_MAX, + module_type == COB_MODULE_TYPE_PROGRAM + ? _("%s: PROGRAM name exceeds %d characters") + : _("%s: FUNCTION name exceeds %d characters"), + name, COB_MAX_NAMELEN); + set_resolve_error (module_type); + return NULL; + } - /* Encode program name, including case folding */ - cob_encode_program_id (s, (unsigned char *)call_entry_buff, + /* Encode program name, including case folding, + put to call_entry_buff, may tripple the size */ + cob_encode_program_id ((const unsigned char *)name, + (unsigned char *)call_entry_buff, COB_MINI_MAX, fold_case); #ifndef COB_BORKED_DLOPEN @@ -893,29 +904,10 @@ cob_resolve_internal (const char *name, const char *dirent, } #endif #endif - - s = (const unsigned char *)name; - - /* Check if name needs conversion */ - if (cobsetptr->name_convert != 0) { - unsigned char *p = call_entry2_buff; - for (; *s; ++s, ++p) { - if (cobsetptr->name_convert == 1 && isupper (*s)) { - *p = (cob_u8_t) tolower (*s); - } else if (cobsetptr->name_convert == 2 && islower (*s)) { - *p = (cob_u8_t) toupper (*s); - } else { - *p = *s; - } - } - *p = 0; - s = call_entry2_buff; - } - /* Search external modules */ resolve_error_buff[CALL_BUFF_MAX] = 0; #ifdef __OS400__ - strcpy (call_filename_buff, s); + strcpy (call_filename_buff, name); for (p = call_filename_buff; *p; ++p) { *p = (cob_u8_t)toupper(*p); } @@ -931,6 +923,26 @@ cob_resolve_internal (const char *name, const char *dirent, } } #else + /* Check if *module name* needs conversion */ + /* CHECKME: why do we separate this by COB_LOAD_CASE + from the entry points, which are a compile-time setup only? */ + if (cobsetptr->name_convert != 0) { + cob_u8_t* p = call_module_buff; + for (s = (const unsigned char *)name; *s; ++s, ++p) { + if (cobsetptr->name_convert == 1 && isupper (*s)) { + *p = (cob_u8_t)tolower (*s); + } else if (cobsetptr->name_convert == 2 && islower (*s)) { + *p = (cob_u8_t)toupper (*s); + } else { + *p = *s; + } + } + *p = 0; + s = call_module_buff; + } else { + s = (const unsigned char *)name; + } + if (dirent) { snprintf (call_filename_buff, (size_t)COB_NORMAL_MAX, "%s%s.%s", dirent, (char *)s, COB_MODULE_EXT); @@ -1303,6 +1315,17 @@ cob_cancel (const char *name) cob_hard_failure (); } /* LCOV_EXCL_STOP */ + + /* CANCEL ALL (acu extension) */ + if (strcmp (name, "CANCEL ALL") == 0) { + /* TODO: add list of all modules in CALL (with marker preloaded or not) + then when setting the COB_MODULE_PTR via cob_module_global_enter add + it also to this new list; + then drop in CANCEL and use here canceling non-active COBOL + and - for physical cancel only - also the "not COBOL" ones */ + return; + } + entry = cob_chk_dirp (name); #ifdef COB_ALT_HASH @@ -1365,7 +1388,7 @@ cob_cancel_field (const cob_field *f, const struct cob_call_struct *cs) int cob_call (const char *name, const int argc, void **argv) { - void **pargv; + void *pargv[MAX_CALL_FIELD_PARAMS] = { 0 }; cob_call_union unifunc; int i; @@ -1383,7 +1406,6 @@ cob_call (const char *name, const int argc, void **argv) } /* LCOV_EXCL_STOP */ unifunc.funcvoid = cob_resolve_cobol (name, 0, 1); - pargv = cob_malloc (MAX_CALL_FIELD_PARAMS * sizeof(void *)); /* Set number of parameters */ cobglobptr->cob_call_params = argc; cobglobptr->cob_call_from_c = 1; @@ -1474,7 +1496,6 @@ cob_call (const char *name, const int argc, void **argv) #endif #endif ); - cob_free (pargv); return i; } diff --git a/libcob/common.c b/libcob/common.c index ccfa731f9..26eb5d1a8 100644 --- a/libcob/common.c +++ b/libcob/common.c @@ -3187,6 +3187,13 @@ handle_core_on_error () return core_on_error; } +void +cob_stop_error (void) +{ + cob_runtime_error ("STOP ERROR"); + cob_hard_failure (); +} + void cob_hard_failure () { diff --git a/libcob/common.h b/libcob/common.h index c1d46f3bf..61569c0b6 100644 --- a/libcob/common.h +++ b/libcob/common.h @@ -1876,6 +1876,7 @@ COB_EXPIMP void cob_module_leave (cob_module *); COB_EXPIMP void cob_module_free (cob_module **); DECLNORET COB_EXPIMP void cob_stop_run (const int) COB_A_NORETURN; +DECLNORET COB_EXPIMP void cob_stop_error (void) COB_A_NORETURN; DECLNORET COB_EXPIMP void cob_fatal_error (const enum cob_fatal_error) COB_A_NORETURN; DECLNORET COB_EXPIMP void cob_hard_failure_internal (const char *) COB_A_NORETURN; DECLNORET COB_EXPIMP void cob_hard_failure (void) COB_A_NORETURN; diff --git a/libcob/intrinsic.c b/libcob/intrinsic.c index d5f8b44f5..644bfb45a 100644 --- a/libcob/intrinsic.c +++ b/libcob/intrinsic.c @@ -3580,6 +3580,7 @@ cob_intr_binop (cob_field *f1, const int op, cob_field *f2) /* Intrinsics */ +/* FUNCTION LENGTH - amount of positions */ cob_field * cob_intr_length (cob_field *srcfield) { @@ -3600,6 +3601,8 @@ cob_intr_length (cob_field *srcfield) return curr_field; } + +/* FUNCTION BYTE-LENGTH (or, as an extension: LENGTH-AN) - amount of bytes */ cob_field * cob_intr_byte_length (cob_field *srcfield) { diff --git a/libcob/strings.c b/libcob/strings.c index 58fee3d6f..5629e8d34 100644 --- a/libcob/strings.c +++ b/libcob/strings.c @@ -512,7 +512,7 @@ cob_inspect_init (cob_field *var, const cob_u32_t replacing) one-time cob_inspect_init_converting --> cob_inspect_init_common (setting up memory) multiple: - cob_inspect_start (setting inspect_start/end) + cob_inspect_start (setting inspect_start/end) cob_inspect_before (optional, adjusting inspect_end) cob_inspect_after (optional, adjusting inspect_start) one-time cob_inspect_converting (actual converstion) */ @@ -830,6 +830,16 @@ cob_string_finish (void) } /* UNSTRING */ +/* an UNSTRING is split into multiple parts: + one-time cob_unstring_init (setting up memory and static variables) + 0..n : + cob_unstring_delimited (setting delimiter struct entries) + 1..n: + cob_unstring_into (to handle a single target + [optional with counter and/or delimiter]) + optional: + cob_unstring_tallying setting TALLYING (amount of targets set) + one-time cob_unstring_finish (setting the string pointer / overflow exception) */ void cob_unstring_init (cob_field *src, cob_field *ptr, const size_t num_dlm) @@ -877,78 +887,122 @@ cob_unstring_delimited (cob_field *dlm, const cob_u32_t all) void cob_unstring_into (cob_field *dst, cob_field *dlm, cob_field *cnt) { - unsigned char *p; - unsigned char *dp; - unsigned char *s; unsigned char *dlm_data; unsigned char *start; size_t dlm_size = 0; - int i; - int srsize; - int dlsize; int match_size = 0; if (cobglobptr->cob_exception_code) { + /* commonly COB_EC_OVERFLOW_UNSTRING: the specified WITH POINTER was + too big, all other functions must be returned early; + TODO: adjust cobc to only call if cob_unstring_init was + sucessfull / has no exception */ return; } - if (unstring_offset >= (int)unstring_src->size) { + if (unstring_offset >= unstring_src->size) { + /* overflow from the last iteration (multiple INTO targets) */ return; } - start = unstring_src->data + unstring_offset; dlm_data = NULL; + start = unstring_src->data + unstring_offset; + + /* no delimiter - just split into DELIMITED BY SIZE */ if (unstring_ndlms == 0) { + /* necessary for correct unstring offset: minimal size */ + /* Note: field->size and therefore offset + are guaranteed to be < INT_MAX by cobc */ match_size = cob_min_int ((int)COB_FIELD_SIZE (dst), (int)unstring_src->size - unstring_offset); cob_str_memcpy (dst, start, match_size); unstring_offset += match_size; + + /* DELIMITED BY [ALL] x [.. OR [ALL] z] */ } else { - int brkpt = 0; - srsize = (int) unstring_src->size; - s = unstring_src->data + srsize; - for (p = start; p < s; ++p) { - for (i = 0; i < unstring_ndlms; ++i) { - dlsize = (int) dlm_list[i].uns_dlm.size; - dp = dlm_list[i].uns_dlm.data; - if (p + dlsize > s) { - continue; - } - if (!memcmp (p, dp, (size_t)dlsize)) { /* delimiter equal */ + + const int srsize = (int)unstring_src->size; + unsigned char *p; + unsigned char *dp; + int found = 0; + + /* note: duplicate code for performance as most cases + have either none or a single delimiter */ + if (unstring_ndlms == 1) { + const struct dlm_struct dlms = dlm_list[0]; + const int dlsize = (int) dlms.uns_dlm.size; + const unsigned char *s = unstring_src->data + srsize - dlsize + 1; + dp = dlms.uns_dlm.data; + + for (p = start; p < s; ++p) { + if (!memcmp (p, dp, (size_t)dlsize)) { /* delimiter matches */ match_size = (int)(p - start); /* count in */ cob_str_memcpy (dst, start, match_size); /* into */ unstring_offset += match_size + dlsize; /* with pointer */ dlm_data = dp; dlm_size = dlsize; - if (dlm_list[i].uns_all) { /* delimited by all */ - for (p += dlsize ; p < s; p += dlsize) { - if (p + dlsize > s) { - break; - } + if (dlms.uns_all) { /* delimited by all */ + for (p += dlsize; p < s; p += dlsize) { if (memcmp (p, dp, (size_t)dlsize)) { break; } unstring_offset += dlsize; } } - brkpt = 1; + found = 1; break; } } - if (brkpt) { - break; + } else { + const unsigned char *s = unstring_src->data + srsize; + int i; + for (p = start; p < s; ++p) { + for (i = 0; i < unstring_ndlms; ++i) { + const struct dlm_struct dlms = dlm_list[i]; + const int dlsize = (int)dlms.uns_dlm.size; + const unsigned char *s2 = s - dlsize + 1; + if (p > s2) { + continue; + } + dp = dlms.uns_dlm.data; + if (!memcmp (p, dp, (size_t)dlsize)) { /* delimiter matches */ + match_size = (int)(p - start); /* count in */ + cob_str_memcpy (dst, start, match_size); /* into */ + unstring_offset += match_size + dlsize; /* with pointer */ + dlm_data = dp; + dlm_size = dlsize; + if (dlms.uns_all) { /* delimited by all */ + for (p += dlsize; p < s2; p += dlsize) { + if (memcmp (p, dp, (size_t)dlsize)) { + break; + } + unstring_offset += dlsize; + } + } + found = 1; + break; + } + } + if (found) { + break; + } } } - if (!brkpt) { - /* No match */ + + /* if none of the delimiters matched, match to end */ + if (!found) { match_size = (int)(unstring_src->size - unstring_offset); cob_str_memcpy (dst, start, match_size); unstring_offset = (int) unstring_src->size; - dlm_data = NULL; } } unstring_count++; + /* note: per any known dialect both DELIMITER IN and COUNT IN are only + allowed if there is a DELIMITED BY phrase; the GnuCOBOL parser + does allow this (did so since the first implementation) */ + + /* set DELIMITER IN */ if (dlm) { if (dlm_data) { cob_str_memcpy (dlm, dlm_data, (int) dlm_size); @@ -959,6 +1013,7 @@ cob_unstring_into (cob_field *dst, cob_field *dlm, cob_field *cnt) } } + /* set COUNT IN */ if (cnt) { cob_set_int (cnt, match_size); } @@ -974,6 +1029,7 @@ void cob_unstring_finish (void) { if (unstring_offset < (int)unstring_src->size) { + /* overflow from any iteration -> overflow exception */ cob_set_exception (COB_EC_OVERFLOW_UNSTRING); } diff --git a/tests/testsuite.src/configuration.at b/tests/testsuite.src/configuration.at index f1981ddf8..eece758a3 100644 --- a/tests/testsuite.src/configuration.at +++ b/tests/testsuite.src/configuration.at @@ -1,4 +1,4 @@ -## Copyright (C) 2014-2021 Free Software Foundation, Inc. +## Copyright (C) 2014-2022 Free Software Foundation, Inc. ## Written by Simon Sobisch ## ## This file is part of GnuCOBOL. @@ -409,7 +409,7 @@ name: "Empty Conf" ]) # check if incomplete configuration result in error -AT_CHECK([$COMPILE_ONLY -conf=test.conf prog.cob], [1], [], +AT_CHECK([$COMPILE_ONLY -conf=test.conf prog.cob], [97], [], [configuration error: test.conf: missing definitions: no definition of 'reserved-words' @@ -419,10 +419,10 @@ test.conf: missing definitions: no definition of 'word-length' no definition of 'literal-length' no definition of 'numeric-literal-length' - no definition of 'defaultbyte' no definition of 'align-record' no definition of 'keycompress' no definition of 'align-opt' + no definition of 'defaultbyte' no definition of 'standard-define' no definition of 'binary-size' no definition of 'binary-byteorder' @@ -457,7 +457,10 @@ test.conf: missing definitions: no definition of 'numeric-pointer' no definition of 'move-non-numeric-lit-to-numeric-is-zero' no definition of 'implicit-assign-dynamic-var' + no definition of 'device-mnemonics' no definition of 'comment-paragraphs' + no definition of 'control-division' + no definition of 'partial-replacing-with-literal' no definition of 'memory-size-clause' no definition of 'multiple-file-tape-clause' no definition of 'label-records-clause' @@ -473,6 +476,7 @@ test.conf: missing definitions: no definition of 'goto-statement-without-name' no definition of 'stop-literal-statement' no definition of 'stop-identifier-statement' + no definition of 'stop-error-statement' no definition of 'debugging-mode' no definition of 'use-for-debugging' no definition of 'padding-character-clause' @@ -535,6 +539,10 @@ test.conf: missing definitions: no definition of 'assign-disk-from' no definition of 'vsam-status' no definition of 'self-call-recursive' + no definition of 'record-contains-depending-clause' +cobc: too many errors + +cobc: aborting ]) AT_CLEANUP @@ -819,3 +827,52 @@ cobc: error: please check environment variables as noted above ) AT_CLEANUP + + +AT_SETUP([cobc configuration: source format]) +AT_KEYWORDS([configuration misc format]) + +AT_DATA([fixed.cob], [ + *Example prog in fixed format (the default) + IDENTIFICATION DIVISION. + PROGRAM-ID. fixed. + DATA DIVISION. + WORKING-STORAGE SECTION. + / + PROCEDURE DIVISION. + D DISPLAY 'START' + DISPLAY ' 20 30 40 50 60 ' + DISPLAY ' 20 30 40 50 60 + - ' 70' + D DISPLAY 'STOP' + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY -fformat=unknown fixed.cob], [1], [], +[cobc: error: invalid parameter: -fformat +]) +AT_CHECK([$COMPILE_ONLY -fixed fixed.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -fformat=fixed fixed.cob], [0], [], []) + +AT_DATA([wide.cob], [ + *Example prog in fixed format with wider record length + IDENTIFICATION DIVISION. + PROGRAM-ID. wide. + DATA DIVISION. + WORKING-STORAGE SECTION. + / + PROCEDURE DIVISION. + DISPLAY ' 20 30 40 50 60 70 ' + DISPLAY ' 20 30 40 50 60 70 + - ' 80' + STOP RUN. +]) +AT_CHECK([$COMPILE_ONLY -fformat=fixed wide.cob], [1], [], +[wide.cob:10: error: continuation character expected +wide.cob:9: error: invalid literal: ' ...' +wide.cob:9: error: missing terminating ' character +wide.cob:9: error: syntax error, unexpected end of file +]) +AT_CHECK([$COMPILE_ONLY -ftext-column=80 wide.cob], [0], [], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/run_extensions.at b/tests/testsuite.src/run_extensions.at index 874eef4ba..28c788a1c 100644 --- a/tests/testsuite.src/run_extensions.at +++ b/tests/testsuite.src/run_extensions.at @@ -5467,6 +5467,35 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP +AT_SETUP([Invalid source format]) +AT_KEYWORDS([extensions runmisc]) + +AT_DATA([unknown.cob], [ + >>SOURCE FORMAT UNKNOWN + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + STOP RUN. +]) +AT_DATA([lit.cob], [ + >>SOURCE FORMAT "literal" + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE unknown.cob], [1], [], +[unknown.cob:2: error: invalid SOURCE directive option 'UNKNOWN' +]) +AT_CHECK([$COMPILE lit.cob], [1], [], +[lit.cob:2: error: invalid SOURCE directive option +lit.cob:2: error: PROGRAM-ID header missing +]) + +AT_CLEANUP + + AT_SETUP([Variable format]) AT_KEYWORDS([extensions runmisc]) @@ -5486,6 +5515,195 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [Hello! ]) +# Check that manually setting -ftext-column in combination with +# variable source format isstill allowed: -ftext-column now impacts +# fixed format only; 250 is the default right margin for variable +# format. +AT_DATA([fit.cob], [ +000010 IDENTIFICATION DIVISION. +000020 PROGRAM-ID. fit. +000040 PROCEDURE DIVISION. +000050 DISPLAY "Hello!" +000060 STOP RUN. +]) +AT_CHECK([$COMPILE -fformat=variable -ftext-column=250 fit.cob], [0], [], []) +AT_CHECK([$COMPILE -fformat=variable -ftext-column=72 -o fit fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[Hello! +]) + +AT_CLEANUP + + +AT_SETUP([COBOLX format]) +AT_KEYWORDS([extensions runmisc]) + +AT_DATA([prog.cob], [ + >>SOURCE FORMAT COBOLX + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. +* area B can extend up to character position 255 + PROCEDURE DIVISION. +/ + DISPLAY "Hello!" + DISPLAY "Hi!" +DDISPLAY "Hey!" +D DISPLAY "Bye!" +* trucated alphanumeric literals are not padded with spaces + DISPLAY " 20 30 40 50 60 70 80 90 100 110 120 130 +- " 140 150 160 170 180 190 200 210 220 230 240 250" + . +]) +# " (closing quote) + +AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[Hello! +Hi! + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 +]) +AT_CHECK([$COMPILE -fdebugging-line -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], +[Hello! +Hi! +Hey! +Bye! + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 +]) + +AT_CLEANUP + + +AT_SETUP([X/Open free-form format]) +AT_KEYWORDS([fundamental xopen extensions]) + +AT_DATA([prog.cob], [ +* Sample program in X/Open free-form format. + +IDENTIFICATION DIVISION. +PROGRAM-ID. prog. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. +/ Beginning of the code +DISPLAY "OK" NO ADVANCING +* If debug: +D DISPLAY "KO" NO ADVANCING +STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=xopen prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE -fformat=xopen -fdebugging-line -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKKO], []) + +AT_DATA([fit.cob], [ +* Sample program in X/Open format, and with longer lines and truncated literals. + +IDENTIFICATION DIVISION. +PROGRAM-ID. fit. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. +DISPLAY ' 20 30 40 50 60 70 79' +D DISPLAY ' 20 30 40 50 60 70 79' +STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=xopen fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 79 +], []) +AT_CHECK([$COMPILE -fformat=xopen -fdebugging-line -o fit fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 79 + 20 30 40 50 60 70 79 +], []) + +AT_CLEANUP + + +AT_SETUP([TERMINAL format]) +AT_KEYWORDS([fundamental extensions]) + +# FIXME: For now, only comment paragraphs can be used to check proper +# handling of margin B w.r.t indicators; better tests shall be +# implemented once area A/B checking will be available + +AT_DATA([prog.cob], [ +* Sample program in ACU terminal format. + +IDENTIFICATION DIVISION. +PROGRAM-ID. prog. +AUTHOR. + Somebody. +\D Somebody else. + One last author. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. + DISPLAY "OK" NO ADVANCING + END-DISPLAY. +\D DISPLAY "KO" NO ADVANCING +\D END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=terminal -fcomment-paragraphs=ok prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE -fformat=terminal -fcomment-paragraphs=ok -fdebugging-line -o prog prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKKO], []) + +AT_DATA([marginberr.cob], [ +IDENTIFICATION DIVISION. +PROGRAM-ID. marginberr. +AUTHOR. +* Comment paragraph where margin B depends on indicator width: + Somebody +\D Somebody else. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. + DISPLAY "OK" NO ADVANCING + STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=terminal -fcomment-paragraphs=ok -fdebugging-line marginberr.cob], [1], [], +[marginberr.cob:7: error: ENVIRONMENT DIVISION header missing +marginberr.cob:7: error: CONFIGURATION SECTION header missing +marginberr.cob:7: error: SPECIAL-NAMES header missing +marginberr.cob:7: error: invalid system-name 'Somebody' +marginberr.cob:7: error: syntax error, unexpected ELSE, expecting CRT or Identifier +]) + +AT_DATA([fit.cob], [ +* Sample program in ACU terminal format, and with longer lines and truncated literals. + +IDENTIFICATION DIVISION. +PROGRAM-ID. fit. +DATA DIVISION. +WORKING-STORAGE SECTION. +PROCEDURE DIVISION. + DISPLAY ' 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319' +\D DISPLAY ' 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319' +\D END-DISPLAY. + DISPLAY ' 20 30 40 50 60 70 80 90 100 110 120 130 +- ' 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319' + STOP RUN. +]) + +AT_CHECK([$COMPILE -fformat=terminal fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 +], []) +AT_CHECK([$COMPILE -fformat=terminal -fdebugging-line -o fit fit.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./fit], [0], +[ 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 + 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200 210 220 230 240 250 260 270 280 290 300 310 319 +], []) + AT_CLEANUP diff --git a/tests/testsuite.src/run_functions.at b/tests/testsuite.src/run_functions.at index e92050833..9e600cece 100644 --- a/tests/testsuite.src/run_functions.at +++ b/tests/testsuite.src/run_functions.at @@ -1,4 +1,4 @@ -## Copyright (C) 2003-2012, 2014-2020 Free Software Foundation, Inc. +## Copyright (C) 2003-2012, 2014-2022 Free Software Foundation, Inc. ## Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart ## ## This file is part of GnuCOBOL. @@ -416,6 +416,8 @@ AT_DATA([prog.cob], [ 01 Y PIC X(4) VALUE "HI.". 01 BIN PIC 9(9) BINARY VALUE 12. 01 PAC PIC 9(5) COMP-3 VALUE 1234. + 01 N9 PIC 9(2) USAGE NATIONAL VALUE 12. + 01 NX PIC N(2) VALUE N"!". 01 HEXX PIC X(10). 88 HEXX-FILLER VALUE ALL "-". PROCEDURE DIVISION. @@ -459,6 +461,36 @@ AT_DATA([prog.cob], [ >> END-IF DISPLAY "UNEXPECTED HEX-VALUE OF z'01': " HEXX. + SET HEXX-FILLER TO TRUE + STRING FUNCTION HEX-OF (' ') DELIMITED BY SIZE INTO HEXX. + IF HEXX NOT = "20--------" + DISPLAY "UNEXPECTED HEX-VALUE OF ' ': " HEXX. + + SET HEXX-FILLER TO TRUE + STRING FUNCTION HEX-OF (n' ') DELIMITED BY SIZE INTO HEXX. + IF HEXX NOT = "0020------" + DISPLAY "UNEXPECTED HEX-VALUE OF n' ': " HEXX. + + *> FIXME: Failing with "3132------" -> missing padding + *> -> codegen issue for initialization / move + *> and libcob issue at least for MOVE + *> SET HEXX-FILLER TO TRUE + *> STRING FUNCTION HEX-OF (N9) DELIMITED BY SIZE INTO HEXX. + *> IF HEXX NOT = "00310032--" + *> DISPLAY "UNEXPECTED HEX-VALUE OF N9: " HEXX. + + *> FIXME: Failing with "00212020--" -> bad padding + *> -> codegen issue for initialization / move + *> and libcob issue at least for MOVE + *> SET HEXX-FILLER TO TRUE + *> STRING FUNCTION HEX-OF (NX) DELIMITED BY SIZE INTO HEXX. + *> IF HEXX NOT = "00210020--" + *> DISPLAY "UNEXPECTED HEX-VALUE OF NX: " HEXX. + + *> setting up test data: + SET HEXX-FILLER TO TRUE + STRING FUNCTION HEX-OF (z"01") DELIMITED BY SIZE INTO HEXX. + IF FUNCTION HEX-TO-CHAR (HEXX(1:6)) NOT = z"01" DISPLAY "UNEXPECTED CHAR VALUE, does not match z'01': " HEXX (1:6). @@ -477,7 +509,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) +AT_CHECK([$COMPILE -Wno-unfinished prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP @@ -1748,6 +1780,9 @@ AT_DATA([prog.cob], [ 01 X PIC S9(4)V9(4) VALUE -1.5. 01 N PIC N(9). 01 TEST-FLD PIC S9(04)V9(02). + 01 TEST-TAB. + 05 T-ENTRIES PIC 99 VALUE 10. + 05 TEST-ENTRY PIC X OCCURS 1 TO 10 DEPENDING ON T-ENTRIES. PROCEDURE DIVISION. MOVE FUNCTION LENGTH ( X ) TO TEST-FLD @@ -1793,13 +1828,24 @@ AT_DATA([prog.cob], [ DISPLAY 'LENGTH n"a0" wrong: ' TEST-FLD END-DISPLAY END-IF + MOVE 10 TO T-ENTRIES + MOVE FUNCTION LENGTH ( TEST-TAB) + TO TEST-FLD + IF TEST-FLD NOT = 12 + DISPLAY 'LENGTH TEST-TAB (10 entries): ' TEST-FLD + END-DISPLAY + END-IF + MOVE 1 TO T-ENTRIES + MOVE FUNCTION LENGTH ( TEST-TAB) + TO TEST-FLD + IF TEST-FLD NOT = 3 + DISPLAY 'LENGTH TEST-TAB (1 entry): ' TEST-FLD + END-DISPLAY + END-IF STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], -[prog.cob:7: warning: handling of USAGE NATIONAL is unfinished; implementation is likely to be changed -prog.cob:48: warning: handling of national literal is unfinished; implementation is likely to be changed -]) +AT_CHECK([$COMPILE -Wno-unfinished prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) AT_CLEANUP diff --git a/tests/testsuite.src/run_initialize.at b/tests/testsuite.src/run_initialize.at index f64c8a8cf..b034a233a 100644 --- a/tests/testsuite.src/run_initialize.at +++ b/tests/testsuite.src/run_initialize.at @@ -253,7 +253,7 @@ AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. - *01 FAILED PIC 9(4) COMP-5 VALUE ZERO. + 01 FAILED PIC 9(4) COMP-5 VALUE ZERO. 01 G. 02 G2 OCCURS 3. 03 X PIC 9 VALUE ZERO. @@ -267,30 +267,31 @@ AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. DISPLAY "Compile failed: " G "." DISPLAY " should be: " "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ." - * ADD 1 TO FAILED + ADD 1 TO FAILED END-IF. INITIALIZE G. IF G NOT = "00 0 0 0 0 00 0 0 0 0 00 0 0 0 0 " DISPLAY "INITIALIZE failed: " G "." DISPLAY " should be: " "00 0 0 0 0 00 0 0 0 0 00 0 0 0 0 ." - * ADD 1 TO FAILED + ADD 1 TO FAILED END-IF. INITIALIZE G ALL TO VALUE. IF G NOT = "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ" DISPLAY "INIT VALUE failed: " G "." DISPLAY " should be: " "09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ09Y9Y9Y9Y9YZ." - * ADD 1 TO FAILED + ADD 1 TO FAILED + END-IF. + IF FAILED = ZERO + DISPLAY "All INITIALIZE tests passed." END-IF. - * IF FAILED = ZERO - * DISPLAY "All INITIALIZE tests passed." - * END-IF STOP RUN. ]) -AT_CHECK([$COMPILE prog.cob], [0], [], []) -AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [], []) +AT_CHECK([$COMPILE -std=default prog.cob ], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [All INITIALIZE tests passed. +], []) AT_CLEANUP diff --git a/tests/testsuite.src/run_misc.at b/tests/testsuite.src/run_misc.at index e4272737a..b4edb8879 100644 --- a/tests/testsuite.src/run_misc.at +++ b/tests/testsuite.src/run_misc.at @@ -5273,6 +5273,31 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [1]) AT_CLEANUP +AT_SETUP([STOP ERROR]) +AT_KEYWORDS([runmisc]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + CALL "prog2". + DISPLAY "Whatever". + STOP RUN. + END PROGRAM prog. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + PROCEDURE DIVISION. + STOP ERROR. +]) + +AT_CHECK([$COMPILE prog.cob -fstop-error-statement=ok], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [1], [], +[libcob: prog.cob:12: error: STOP ERROR +]) + +AT_CLEANUP + + AT_SETUP([SYMBOLIC clause]) AT_KEYWORDS([runmisc ALPHABET]) diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index 6e03a7f91..2b354aaad 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -523,6 +523,80 @@ AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKOK]) AT_CLEANUP +AT_SETUP([COPY: partial replacement with literals]) +AT_KEYWORDS([copy gcos]) + +AT_DATA([copy.inc], [ + 01 TEST-VAR PIC X(2) VALUE "OK". + 01 NORM-VAR PIC X(2) VALUE "OK". +]) + +AT_DATA([copy2.inc], [ + 01 TEST-FIRST PIC X(2) VALUE "OK". + 01 TEST-SECOND PIC X(2) VALUE "OK". +]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + COPY "copy.inc" + REPLACING LEADING "TEST" BY "FIRST" + LEADING "NORM" BY "SECOND". + COPY "copy2.inc" + REPLACING TRAILING "FIRST" BY "VAR1" + TRAILING "SECOND" BY "VAR2". + PROCEDURE DIVISION. + DISPLAY FIRST-VAR NO ADVANCING + END-DISPLAY. + DISPLAY SECOND-VAR NO ADVANCING + END-DISPLAY. + DISPLAY TEST-VAR1 NO ADVANCING + END-DISPLAY. + DISPLAY TEST-VAR2 NO ADVANCING + END-DISPLAY. + STOP RUN. +]) +AT_CHECK([$COMPILE -fpartial-replacing-with-literal=ok prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OKOKOKOK]) +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=error prog.cob], [1], [], +[prog.cob:7: error: partial replacing with literal used +prog.cob:7: error: partial replacing with literal used +prog.cob:8: error: partial replacing with literal used +prog.cob:8: error: partial replacing with literal used +prog.cob:10: error: partial replacing with literal used +prog.cob:10: error: partial replacing with literal used +prog.cob:11: error: partial replacing with literal used +prog.cob:11: error: partial replacing with literal used +]) + +AT_DATA([prog_err.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + COPY "copy.inc" + REPLACING LEADING TEST BY "FIRST" + LEADING "NORM" BY SECOND. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog_err.cob], [1], [], +[prog_err.cob:7: error: unexpected COBOL word in partial replacement phrase +prog_err.cob:8: error: unexpected COBOL word in partial replacement phrase +]) +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=unconformable prog_err.cob], [1], [], +[prog_err.cob:7: error: unexpected COBOL word in partial replacement phrase +prog_err.cob:7: error: partial replacing with literal does not conform to GnuCOBOL +prog_err.cob:8: error: partial replacing with literal does not conform to GnuCOBOL +prog_err.cob:8: error: unexpected COBOL word in partial replacement phrase +]) + +AT_CLEANUP + + AT_SETUP([COPY: recursive replacement]) AT_KEYWORDS([copy]) @@ -577,3 +651,33 @@ AT_CHECK([$COMPILE -free prog.cob], [0], [], []) AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) AT_CLEANUP + + +AT_SETUP([REPLACE: partial replacement with SPACES figurative constant]) +AT_KEYWORDS([replace gcos acu]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + REPLACE LEADING "PREFIX-" BY SPACES + TRAILING "-SUFFIX" BY SPACE. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 PREFIX-VAR1 PIC X(2) VALUE "OK". + 01 VAR2-SUFFIX PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR1 NO ADVANCING. + DISPLAY VAR2 NO ADVANCING. + STOP RUN. +]) + +AT_DATA([prog_err.cob], [ + COPY prog REPLACING LEADING SPACES BY "PREFIX-". +]) + +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog.cob], [0], [], []) +AT_CHECK([$COMPILE_ONLY -fpartial-replacing-with-literal=ok prog_err.cob], [1], [], +[prog_err.cob:2: error: unexpected COBOL word in partial replacement phrase +]) + +AT_CLEANUP diff --git a/tests/testsuite.src/syn_file.at b/tests/testsuite.src/syn_file.at index 252f26060..c1b24c960 100644 --- a/tests/testsuite.src/syn_file.at +++ b/tests/testsuite.src/syn_file.at @@ -862,6 +862,27 @@ 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 TO 'FILE-TEST' + ORGANIZATION IS SEQUENTIAL. + DATA DIVISION. + FILE SECTION. + FD TEST-FILE + RECORD CONTAINS 12 TO 125 CHARACTERS + DEPENDING ON RECORDSIZE. + 01 TEST-REC. + 05 FILLER PIC X(40). + PROCEDURE DIVISION. + OPEN INPUT TEST-FILE. + CLOSE TEST-FILE. + STOP RUN. +]) + # FIXME: the check misses "prog.cob:40: error: RECORD DEPENDING item must be unsigned numeric" AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:20: error: 'RECORDSIZE' is not defined @@ -875,6 +896,13 @@ prog.cob:26: error: RECORD DEPENDING must reference a data-item prog.cob:34: warning: RECORD DEPENDING item 'RECORDSIZE3' should be defined in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE SECTION prog.cob:40: warning: RECORD DEPENDING item 'RECORDSIZE4' should be defined in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE SECTION ]) +AT_CHECK([$COMPILE_ONLY -frecord-contains-depending-clause=error prog2.cob], [1], [], +[prog2.cob:13: error: RECORD CONTAINS DEPENDING used +prog2.cob:13: error: 'RECORDSIZE' is not defined +]) +AT_CHECK([$COMPILE_ONLY -frecord-contains-depending-clause=ok prog2.cob], [1], [], +[prog2.cob:13: error: 'RECORDSIZE' is not defined +]) AT_CLEANUP diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 5712541bb..d069a28f0 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -6938,13 +6938,13 @@ AT_DATA([prog.cob], [ 01 n PIC 9. PROCEDURE DIVISION. - MOVE X'' TO x - MOVE H'' TO x - MOVE Z'' TO x - MOVE L'' TO x - MOVE N"" TO nat + MOVE X'' TO x + MOVE H'' TO n + MOVE Z'' TO x + MOVE L'' TO x + MOVE N"" TO nat MOVE NX'' TO nat - MOVE B"" TO n + MOVE B"" TO n MOVE BX"" TO n . ]) @@ -8689,3 +8689,176 @@ AT_CLEANUP # TODO: add missing tests for syntax errors in >>IF/ELSE/END + +AT_SETUP([CONTROL DIVISION]) +AT_KEYWORDS([control gcos]) + +AT_DATA([empty.cob], [ + CONTROL DIVISION. + IDENTIFICATION DIVISION. + PROGRAM-ID. empty. +]) + +AT_CHECK([$COMPILE_ONLY -fcontrol-division=ok empty.cob], [0], [], []) + +AT_DATA([replace.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + REPLACE ==TEST-VAR== BY ==VAR==. + IDENTIFICATION DIVISION. + PROGRAM-ID. replace. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TEST-VAR PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok replace.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./replace], [0], [OK], []) +AT_CHECK([$COMPILE replace.cob], [1], [], +[replace.cob:2: error: CONTROL DIVISION does not conform to GnuCOBOL +]) + +AT_CLEANUP + + +AT_SETUP([CONTROL: empty default section]) +AT_KEYWORDS([control gcos]) + +AT_DATA([prog.cob], [ + CONTROL DIVISION. + DEFAULT SECTION. + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok prog.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE prog.cob], [1], [], +[prog.cob:2: error: CONTROL DIVISION does not conform to GnuCOBOL +]) + +AT_CLEANUP + + +AT_SETUP([CONTROL: default section]) +AT_KEYWORDS([control gcos]) + +AT_DATA([prog.cob], [ + CONTROL DIVISION. + DEFAULT SECTION. + ACCEPT ALTERNATE CONSOLE + DISPLAY IS TERMINAL + . + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok prog.cob], [0], [], +[prog.cob:4: warning: ACCEPT statement in DEFAULT SECTION is not implemented +prog.cob:5: warning: DISPLAY statement in DEFAULT SECTION is not implemented +]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) +AT_CHECK([$COMPILE prog.cob], [1], [], +[prog.cob:2: error: CONTROL DIVISION does not conform to GnuCOBOL +prog.cob:4: warning: ACCEPT statement in DEFAULT SECTION is not implemented +prog.cob:5: warning: DISPLAY statement in DEFAULT SECTION is not implemented +]) + +AT_CLEANUP + + +AT_SETUP([CONTROL: substitution & default section]) +AT_KEYWORDS([control gcos]) + +AT_DATA([empties.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + DEFAULT SECTION. + IDENTIFICATION DIVISION. + PROGRAM-ID. empties. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok empties.cob], [0], [], []) + +AT_DATA([empty0.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + DEFAULT SECTION. + ACCEPT ALTERNATE CONSOLE + . + IDENTIFICATION DIVISION. + PROGRAM-ID. empty0. + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok empty0.cob], [0], [], +[empty0.cob:5: warning: ACCEPT statement in DEFAULT SECTION is not implemented +]) + +AT_DATA([empty1.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + REPLACE "KO" BY "OK". + DEFAULT SECTION. + IDENTIFICATION DIVISION. + PROGRAM-ID. empty1. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "KO". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok empty1.cob], [0], [], []) +AT_CHECK([$COBCRUN_DIRECT ./empty1], [0], [OK], []) + +AT_DATA([prog.cob], [ + CONTROL DIVISION. + SUBSTITUTION SECTION. + REPLACE IISS BY IS + TERM BY TERMINAL + "KO" BY "OK". + DEFAULT SECTION. + ACCEPT ALTERNATE CONSOLE + DISPLAY IISS TERM + . + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAR PIC X(2) VALUE "KO". + PROCEDURE DIVISION. + DISPLAY VAR NO ADVANCING + END-DISPLAY. + STOP RUN. +]) + +AT_CHECK([$COMPILE -fcontrol-division=ok prog.cob], [0], [], +[prog.cob:8: warning: ACCEPT statement in DEFAULT SECTION is not implemented +prog.cob:9: warning: DISPLAY statement in DEFAULT SECTION is not implemented +]) +AT_CHECK([$COBCRUN_DIRECT ./prog], [0], [OK], []) + +AT_CLEANUP diff --git a/tests/testsuite.src/syn_screen.at b/tests/testsuite.src/syn_screen.at index 13ddba744..c8d9fe35c 100644 --- a/tests/testsuite.src/syn_screen.at +++ b/tests/testsuite.src/syn_screen.at @@ -1,4 +1,4 @@ -## Copyright (C) 2014-2021 Free Software Foundation, Inc. +## Copyright (C) 2014-2022 Free Software Foundation, Inc. ## Written by Simon Sobisch, Edward Hart, Ron Norman ## ## This file is part of GnuCOBOL. @@ -137,11 +137,21 @@ AT_DATA([prog.cob], [ 01 curs-4 PIC 9(8) VALUE 0101. 01 curs-5 PIC X(4). + 01 SCREEN-POS. + 03 SPOS PIC 9(04) VALUE ZERO. + 03 WS2-CURS REDEFINES SPOS. + 05 SLIN PIC 9(02). + 05 SCOL PIC 9(02). + PROCEDURE DIVISION. *> Valid AT clauses DISPLAY "a" AT curs-1 DISPLAY "a" AT curs-2 DISPLAY "a" AT posc + DISPLAY "a" AT posc + DISPLAY "a" AT SPOS + DISPLAY "a" AT WS2-CURS + DISPLAY "a" AT SCREEN-POS *> Invalid AT clauses DISPLAY "a" AT curs-3 @@ -153,11 +163,11 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], -[prog.cob:24: error: value in AT clause must have 4 or 6 digits -prog.cob:25: error: value in AT clause must have 4 or 6 digits -prog.cob:26: error: value in AT clause is not numeric -prog.cob:27: error: value in AT clause must have 4 or 6 digits -prog.cob:29: error: cannot specify figurative constant ZERO in AT clause +[prog.cob:34: error: value in AT clause must have 4 or 6 digits +prog.cob:35: error: value in AT clause must have 4 or 6 digits +prog.cob:36: error: value in AT clause is not numeric +prog.cob:37: error: value in AT clause must have 4 or 6 digits +prog.cob:39: error: cannot specify figurative constant ZERO in AT clause ]) AT_CLEANUP @@ -827,3 +837,23 @@ prog.cob:13: warning: 'FILLER' has FROM, TO or USING without PIC; PIC will be im ]) AT_CLEANUP + + +AT_SETUP([DISPLAY WITH CONVERSION]) +AT_KEYWORDS([DISPLAY]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + DISPLAY WITH CONVERSION "Whatever". + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], +[prog.cob:7: warning: DISPLAY WITH CONVERSION is not implemented +]) + +AT_CLEANUP diff --git a/tests/testsuite.src/used_binaries.at b/tests/testsuite.src/used_binaries.at index 0a71e2854..655c917b2 100644 --- a/tests/testsuite.src/used_binaries.at +++ b/tests/testsuite.src/used_binaries.at @@ -746,9 +746,19 @@ AT_CHECK([$COBCRUN noprog], [1], [], AT_CHECK([$COBCRUN -q -M], [1], [], [cobcrun: option requires an argument -- 'M' ]) -# FIXME - The following doesn't seem to work correct, -# we expect an error about missing module name -#AT_CHECK([$COBCRUN -q -M noprog], [1], [], []) +AT_CHECK([$COBCRUN -q -M noprog], [1], [], +[cobcrun: missing PROGRAM name +Try 'cobcrun --help' for more information. +]) +# this was previously checked in cobcrun, now only done in the runtime +AT_CHECK([$COBCRUN ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL], [1], [], +[libcob: error: ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL: PROGRAM name exceeds 31 characters +]) +# it would be allowed for preloading +# this was previously checked in cobcrun, now only done in the runtime +AT_CHECK([$COBCRUN -q -M ThisIsANameThatIsReallyNotAllowedAsProgIdInCOBOL noprog], [1], [], +[libcob: error: module 'noprog' not found +]) AT_CLEANUP