diff --git a/NEWS b/NEWS index b55061166..e8eef8483 100644 --- a/NEWS +++ b/NEWS @@ -257,6 +257,12 @@ Open Plans: callee modules that use BY VALUE must be compiled with the same version of GnuCOBOL, either prior this release, or since. +** cobc now uses a two-pass preprocessing algorithm, where replacements for + COPY-REPLACING are done in a first pass, and the replacements for + REPLACE are done in a second pass. Note that, however, both + statements are parsed before the first replacement pass, so + COPY-REPLACING cannot impact a REPLACE statement itself. + * Changes to the COBOL compiler (cobc) options: ** new -fformat dialect option, and extended SOURCE FORMAT directives, @@ -386,7 +392,9 @@ Open Plans: and fatality `cobc --list-exceptions` ** new compiler command line option -ftcmd to enable printing of the command - line in the source listing + line in the source listing, -fno-timestamp to suppress printing of the time + and -ftittle to set a title instead of GnuCOBOL and version (_ chars are + replaced by spaces in the title) ** new compiler command line option --coverage to instrument binaries for coverage checks @@ -414,6 +422,8 @@ Open Plans: the option -fdiagnostics-plain-output was added to request that diagnostic output look as plain as possible and stay more stable over time +** the -P flag accepts - as argument for stdout + * Important Bugfixes: ** for dialects other than the GnuCOBOL default different reserved "alias" words diff --git a/build_windows/ChangeLog.txt b/build_windows/ChangeLog.txt index 76ef8e9d2..32fd8965d 100644 --- a/build_windows/ChangeLog.txt +++ b/build_windows/ChangeLog.txt @@ -8,6 +8,11 @@ * makedist.cmd: cater for new different library names * version_cobc.rc, version_libcob.rc: updated date + rev +2023-07-07 Simon Sobisch + + * general for cobc: include new replace.c + * version_cobc.rc: updated date + rev + 2023-06-30 Simon Sobisch * config.h.in: updated for OrangeC 6.0.70.2 diff --git a/build_windows/ocide/cobc.exe.cpj b/build_windows/ocide/cobc.exe.cpj index fb3294e01..d00d2f4b8 100644 --- a/build_windows/ocide/cobc.exe.cpj +++ b/build_windows/ocide/cobc.exe.cpj @@ -87,6 +87,7 @@ + diff --git a/build_windows/vs2008/cobc.vcproj b/build_windows/vs2008/cobc.vcproj index e5e50c182..06f52e30d 100644 --- a/build_windows/vs2008/cobc.vcproj +++ b/build_windows/vs2008/cobc.vcproj @@ -291,6 +291,10 @@ RelativePath="..\..\cobc\sqlxfdgen.c" > + + diff --git a/build_windows/vs2010/cobc.vcxproj b/build_windows/vs2010/cobc.vcxproj index 51a227da3..be4a1a189 100644 --- a/build_windows/vs2010/cobc.vcxproj +++ b/build_windows/vs2010/cobc.vcxproj @@ -193,6 +193,7 @@ + diff --git a/build_windows/vs2010/cobc.vcxproj.filters b/build_windows/vs2010/cobc.vcxproj.filters index 732e84b6f..e3713148f 100644 --- a/build_windows/vs2010/cobc.vcxproj.filters +++ b/build_windows/vs2010/cobc.vcxproj.filters @@ -51,6 +51,9 @@ Source Files + + Source Files + Source Files diff --git a/build_windows/vs2012/cobc.vcxproj b/build_windows/vs2012/cobc.vcxproj index 6169e8f51..e4cf766dc 100644 --- a/build_windows/vs2012/cobc.vcxproj +++ b/build_windows/vs2012/cobc.vcxproj @@ -197,6 +197,7 @@ + diff --git a/build_windows/vs2012/cobc.vcxproj.filters b/build_windows/vs2012/cobc.vcxproj.filters index 732e84b6f..e3713148f 100644 --- a/build_windows/vs2012/cobc.vcxproj.filters +++ b/build_windows/vs2012/cobc.vcxproj.filters @@ -51,6 +51,9 @@ Source Files + + Source Files + Source Files diff --git a/build_windows/vs2013/cobc.vcxproj b/build_windows/vs2013/cobc.vcxproj index 303b4dc18..9e9d563c5 100644 --- a/build_windows/vs2013/cobc.vcxproj +++ b/build_windows/vs2013/cobc.vcxproj @@ -199,6 +199,7 @@ + diff --git a/build_windows/vs2013/cobc.vcxproj.filters b/build_windows/vs2013/cobc.vcxproj.filters index 732e84b6f..e3713148f 100644 --- a/build_windows/vs2013/cobc.vcxproj.filters +++ b/build_windows/vs2013/cobc.vcxproj.filters @@ -51,6 +51,9 @@ Source Files + + Source Files + Source Files diff --git a/build_windows/vs2015/cobc.vcxproj b/build_windows/vs2015/cobc.vcxproj index 45190313f..61d442795 100644 --- a/build_windows/vs2015/cobc.vcxproj +++ b/build_windows/vs2015/cobc.vcxproj @@ -197,6 +197,7 @@ + diff --git a/build_windows/vs2015/cobc.vcxproj.filters b/build_windows/vs2015/cobc.vcxproj.filters index 3bb3682aa..e717651cc 100644 --- a/build_windows/vs2015/cobc.vcxproj.filters +++ b/build_windows/vs2015/cobc.vcxproj.filters @@ -51,6 +51,9 @@ Source Files + + Source Files + Source Files diff --git a/build_windows/vs2017/cobc.vcxproj b/build_windows/vs2017/cobc.vcxproj index e7a1f930c..b56912d85 100644 --- a/build_windows/vs2017/cobc.vcxproj +++ b/build_windows/vs2017/cobc.vcxproj @@ -199,6 +199,7 @@ + diff --git a/build_windows/vs2017/cobc.vcxproj.filters b/build_windows/vs2017/cobc.vcxproj.filters index 3bb3682aa..e717651cc 100644 --- a/build_windows/vs2017/cobc.vcxproj.filters +++ b/build_windows/vs2017/cobc.vcxproj.filters @@ -51,6 +51,9 @@ Source Files + + Source Files + Source Files diff --git a/build_windows/vs2019/cobc.vcxproj b/build_windows/vs2019/cobc.vcxproj index 7b6d60932..23c283dda 100644 --- a/build_windows/vs2019/cobc.vcxproj +++ b/build_windows/vs2019/cobc.vcxproj @@ -199,6 +199,7 @@ + diff --git a/build_windows/vs2019/cobc.vcxproj.filters b/build_windows/vs2019/cobc.vcxproj.filters index 3bb3682aa..e717651cc 100644 --- a/build_windows/vs2019/cobc.vcxproj.filters +++ b/build_windows/vs2019/cobc.vcxproj.filters @@ -51,6 +51,9 @@ Source Files + + Source Files + Source Files diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 2e14f6350..93b64251b 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -37,6 +37,30 @@ * error.c, cobc.c (print_program_trailer), flag.def: implemented -fmax-errors=0 as unlimited +2023-07-07 Simon Sobisch + + common preparser cleanup + * ppparse.y: error recovery for COPY and REPLACE (consume until DOT + instead of until EOF) + * ppparse.y: renamed "TOKEN" from "Identifier" to "Word", adjust + some terminals prefixing it with leading underscore as optional + Bug #890 wrong reference in COPY diagnostic + * ppparse.y: switch to new buffer after parsing DOT, not before + Bug #23 several replacement values create parser errors + * pplex.l: split REPLACE_STATE and REPLACING_STATE from COPY_STATE + to limit their reserved word list to the applicable ones and to + improve error handling + * ppparse.y: explicit parse IN and OF as single replacement words + +2023-07-06 Fabrice Le Fessant + + * replace.c: rewrite the code for preprocessing with a two-phase + algorithm. The first phase performs COPY REPLACING on the stream + of tokens, while the second phase perform REPLACE on the resulting + stream of tokens. This rewriting is closer to the COBOL standard + and fixes bug #831 partially. + * cobc.c: flag -P now accepts - as argument to mean stdout + 2023-07-05 Fabrice Le Fessant * flag.def/cobc.c: new flags -fno-ttimestamp to suppress timestamp @@ -47,6 +71,13 @@ CB_FLAG_GETOPT_. Remove unused 'case 6:' for -fdefaultbyte that is now handled in config.c +2023-07-02 Fabrice Le Fessant + + * pplex.l (ppecho, ppecho_direct): replace alt_space by passing a + second equivalent token + * pplex.l, replace.c: move the preprocessing code performing + COPY REPLACING and REPLACE from pplex.l to replace.c + 2023-07-04 Simon Sobisch * codegen.c (output_char): extracted usage of disabled code for @@ -347,11 +378,26 @@ * typeck.c (cb_build_move_field): generate optimized code for reference-modification with same ref-mod length + * parser.y: fix several possible bad uses of "ALLOCATE identifier", + including "no identifier at all" and use of subscripting / ref-mod + which previously were all silently ignored 2023-03-08 Emilien Lemaire * reserved.c (get_user_specified_reserved_word): add check for context sensitivity in aliases + * parser.y (begin_statement_internal): extracted from begin_statement and + begin_statement_from_backup_pos + * parser.y: explicit creation of "comment note" tokens to store the start + position for tokens used later, either direct for diagnostics or by + assigning it with the new function copy_pos instead of using a global + "backup position" or using the current position + * parser.y: explicit check for missing imperative statements in several + places that need one to generate a clean error + * parser.y (emit_entry): removed unused parameter override_source_line + * typeck.c (cb_emit_call), tree.h, parser.y: remove passing the CALL's + original line number as extra parameter, instead use the statement's + (now correct) position 2023-03-03 Simon Sobisch @@ -359,6 +405,9 @@ ZEROES up to COB_ZEROES_ALPHABETIC_BYTE_LENGTH * pplex.l (ppopen): fixes for auto-detection of reference-format FR #45 handling tabs, dos eol and empty lines correctly + * parser.y (check_non_area_a_of): new function used to do the area check + for all terminators and during error recovery + * parser.y: check area A for END FUNCTION 2023-02-28 Simon Sobisch diff --git a/cobc/Makefile.am b/cobc/Makefile.am index 1646fefeb..7eddd00df 100644 --- a/cobc/Makefile.am +++ b/cobc/Makefile.am @@ -23,7 +23,7 @@ bin_PROGRAMS = cobc cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.c parser.y scanner.c \ config.c reserved.c error.c tree.c tree.h field.c typeck.c \ codegen.c help.c sqlxfdgen.c config.def flag.def warning.def \ - codeoptim.def ppparse.def codeoptim.c + codeoptim.def ppparse.def codeoptim.c replace.c #cobc_SOURCES = cobc.c cobc.h ppparse.y pplex.l parser.y scanner.l config.c diff --git a/cobc/cobc.c b/cobc/cobc.c index 1a19d4ac9..6f1b27edb 100644 --- a/cobc/cobc.c +++ b/cobc/cobc.c @@ -471,7 +471,7 @@ static const char *const cob_csyns[] = { #define COB_NUM_CSYNS sizeof(cob_csyns) / sizeof(cob_csyns[0]) -static const char short_options[] = "hVivqECScbmxjdFOPgGwo:t:T:I:L:l:D:K:k:"; +static const char short_options[] = "hVivqECScbmxjdFOgGwo:P:t:T:I:L:l:D:K:k:"; #define CB_NO_ARG no_argument #define CB_RQ_ARG required_argument @@ -1240,6 +1240,50 @@ cobc_plex_strdup (const char *dupstr) return p; } +/* Return a newly allocated zero-terminated string with only the first + * len chars of the first argument */ +void * +cobc_plex_strsub (const char *s, const int len) +{ + void *p; + int n; + + n = strlen (s); + +#ifdef COB_TREE_DEBUG + /* LCOV_EXCL_START */ + if ( len>n ) { + cobc_err_msg ("call to %s with bad argument len=%d>%d=strlen(s)", + "cobc_plex_strsub", len, n); + cobc_abort_terminate (1); + } + /* LCOV_EXCL_STOP */ +#endif + + p = cobc_plex_malloc (len + 1); + memcpy (p, s, len); + return p; +} + +/* Returns a newly allocated zero-terminated string containing the + * concatenation of str1 and str2. str1 and str2 may be freed + * afterwards. + */ +char * +cobc_plex_stradd (const char *str1, const char *str2) +{ + char *p; + size_t m, n; + + m = strlen (str1); + n = strlen (str2); + p = cobc_plex_malloc (m + n + 1); + memcpy (p, str1, m); + memcpy (p + m, str2, n); + return p; +} + + /* variant of strcpy which copies max 'max_size' bytes from 'src' to 'dest', if the size of 'src' is too long only its last/last bytes are copied and an eliding "..." is placed in front or at end depending on 'elide_at_end' */ @@ -9256,6 +9300,9 @@ main (int argc, char **argv) memset (cb_listing_header, 0, sizeof (cb_listing_header)); /* If -P=file specified, all lists go to this file */ if (cobc_list_file) { + if (strcmp (cobc_list_file, COB_DASH) == 0) { + cb_listing_file = stdout; + } else if (cb_unix_lf) { cb_listing_file = fopen (cobc_list_file, "wb"); } else { @@ -9344,7 +9391,10 @@ main (int argc, char **argv) } if (cobc_list_file) { - fclose (cb_listing_file); + if (cb_listing_file != stdout) + fclose (cb_listing_file); + else + fflush (stdout); cb_listing_file = NULL; } diff --git a/cobc/cobc.h b/cobc/cobc.h index c7035e591..f14538442 100644 --- a/cobc/cobc.h +++ b/cobc/cobc.h @@ -477,6 +477,8 @@ extern void cobc_parse_free (void *); extern void *cobc_plex_malloc (const size_t); extern void *cobc_plex_strdup (const char *); +extern void *cobc_plex_strsub (const char *, const int len); +extern char *cobc_plex_stradd (const char *str1, const char *str2); extern void *cobc_check_string (const char *); extern void cobc_err_msg (const char *, ...) COB_A_FORMAT12; diff --git a/cobc/parser.y b/cobc/parser.y index e69000e86..119ccfff5 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -286,8 +286,7 @@ static enum cb_ml_suppress_category ml_suppress_category; static int term_array[TERM_MAX]; static cb_tree eval_check[EVAL_DEPTH][EVAL_DEPTH]; -static const char *backup_source_file = NULL; -static int backup_source_line = 0; +static int last_source_line = 0; /* Defines for header presence */ @@ -326,17 +325,25 @@ check_area_a (cb_tree word) { static COB_INLINE void check_area_a_of (const char * const item) { if (!cobc_in_area_a && cobc_areacheck) { - (void) cb_syntax_check (_("'%s' should start in Area A"), item); + (void) cb_syntax_check (_("%s should start in Area A"), item); + } +} + +static COB_INLINE void +check_non_area_a_of (const char * const item) { + if (cobc_in_area_a && cobc_areacheck) { + (void) cb_syntax_check (_("%s should not start in Area A"), item); } } static COB_INLINE void check_non_area_a (cb_tree stmt) { if (cobc_in_area_a && cobc_areacheck) { - if (stmt) + if (stmt) { (void) cb_syntax_check_x (stmt, _("start of statement in Area A")); - else + } else { (void) cb_syntax_check (_("start of statement in Area A")); + } } } @@ -353,11 +360,11 @@ enum cb_colseq cb_default_colseq = CB_COLSEQ_NATIVE; /* Decipher character conversion table names */ int cb_deciph_default_colseq_name (const char * const name) { - if (! cb_strcasecmp (name, "ASCII")) { + if (!cb_strcasecmp (name, "ASCII")) { cb_default_colseq = CB_COLSEQ_ASCII; - } else if (! cb_strcasecmp (name, "EBCDIC")) { + } else if (!cb_strcasecmp (name, "EBCDIC")) { cb_default_colseq = CB_COLSEQ_EBCDIC; - } else if (! cb_strcasecmp (name, "NATIVE")) { + } else if (!cb_strcasecmp (name, "NATIVE")) { cb_default_colseq = CB_COLSEQ_NATIVE; } else { return 1; @@ -406,48 +413,44 @@ build_colseq (enum cb_colseq colseq) /* Statements */ static void -begin_statement (enum cob_statement statement, const unsigned int term) +begin_statement_internal (enum cob_statement statement, const unsigned int term, + const char *file, const int line) { - if (check_unreached) { - cb_warning (cb_warn_unreachable, - _("unreachable statement '%s'"), - cb_statement_name[statement]); - } - current_paragraph->flag_statement = 1; + cb_tree stmt_tree; current_statement = cb_build_statement (statement); - CB_TREE (current_statement)->source_file = cb_source_file; - CB_TREE (current_statement)->source_line = cb_source_line; + current_paragraph->flag_statement = 1; + stmt_tree = CB_TREE (current_statement); + stmt_tree->source_file = file; + stmt_tree->source_line = line; current_statement->flag_in_debug = in_debugging; - check_non_area_a (CB_TREE (current_statement)); - emit_statement (CB_TREE (current_statement)); + emit_statement (stmt_tree); if (term) { term_array[term]++; } + check_non_area_a (stmt_tree); + if (check_unreached) { + cb_warning_x (cb_warn_unreachable, stmt_tree, + _("unreachable statement '%s'"), + cb_statement_name[statement]); + } } -static void -restore_backup_pos (cb_tree item) +static COB_INLINE void +begin_statement (enum cob_statement statement, const unsigned int term) { - item->source_file = backup_source_file; - item->source_line = backup_source_line; + begin_statement_internal (statement, term, cb_source_file, cb_source_line); } -static void -begin_statement_from_backup_pos (enum cob_statement statement, const unsigned int term) +/* begin statement, starting in "pos"; + note: to be able to check for area A, pos->source_column must be temporarily set to -1 + at the place where the tree is created, if cobc_in_area_a was true */ +static COB_INLINE void +begin_statement_at_tree_pos (enum cob_statement statement, const unsigned int term, cb_tree pos) { - current_paragraph->flag_statement = 1; - current_statement = cb_build_statement (statement); - restore_backup_pos (CB_TREE (current_statement)); - current_statement->flag_in_debug = in_debugging; - emit_statement (CB_TREE (current_statement)); - if (term) { - term_array[term]++; - } - if (check_unreached) { - cb_warning_x (cb_warn_unreachable, CB_TREE (current_statement), - _("unreachable statement '%s'"), - cb_statement_name[statement]); - } + const int backup_in_area_a = cobc_in_area_a; + cobc_in_area_a = pos->source_column == -1; + begin_statement_internal (statement, term, pos->source_file, pos->source_line); + cobc_in_area_a = backup_in_area_a; } /* create a new statement with base attributes of current_statement @@ -483,26 +486,26 @@ print_bits (cob_flags_t num) } #endif -/* functions for storing current position and - assigning it to a cb_tree after its parsing is finished */ -static COB_INLINE void -backup_current_pos (void) +/* general functions */ + +static void +copy_pos (cb_tree item, cb_tree source) { - backup_source_file = cb_source_file; - backup_source_line = cb_source_line; + item->source_file = source->source_file; + item->source_line = source->source_line; } -#if 0 /* currently not used */ -static COB_INLINE void -set_pos_from_backup (cb_tree x) -{ - x->source_file = backup_source_file; - x->source_line = backup_source_line; +static COB_INLINE int +is_valid_statement_tree (cb_tree tree) { + if ( tree == cb_error_node + || (CB_LIST_P (tree) && CB_VALUE (tree) == cb_error_node)) { + return 0; + } + return 1; } -#endif static void -emit_entry (const char *name, const int encode, cb_tree using_list, cb_tree convention, int override_source_line) +emit_entry (const char *name, const int encode, cb_tree using_list, cb_tree convention) { cb_tree l; cb_tree label; @@ -520,9 +523,6 @@ emit_entry (const char *name, const int encode, cb_tree using_list, cb_tree conv } CB_LABEL (label)->flag_begin = 1; CB_LABEL (label)->flag_entry = 1; - if (override_source_line) { - label->source_line = override_source_line; - } emit_statement (label); if (current_program->flag_debugging) { @@ -562,9 +562,9 @@ emit_main_entry (struct cb_program *program, cb_tree using_list) program->num_proc_params = cb_list_length (using_list); } - emit_entry (program->program_id, 0, using_list, NULL, 0); + emit_entry (program->program_id, 0, using_list, NULL); if (program->source_name) { - emit_entry (program->source_name, 1, using_list, NULL, 0); + emit_entry (program->source_name, 1, using_list, NULL); } } @@ -582,7 +582,9 @@ emit_entry_goto (const char *name) CB_LABEL (label)->flag_begin = 1; CB_LABEL (label)->flag_entry = 1; CB_LABEL (label)->flag_entry_for_goto = 1; - label->source_line = backup_source_line; /* CHECKME: is that correct? */ +#if 0 /* seems to be not necessary */ + copy_pos (label, current_statement); +#endif emit_statement (label); for (l = current_program->entry_list_goto; l; l = CB_CHAIN (l)) { @@ -1240,7 +1242,7 @@ end_scope_of_program_name (struct cb_program *program, const unsigned char type) emit_main_entry (program, NULL); } } - program->last_source_line = backup_source_line; + program->last_source_line = last_source_line; if (program->nested_level == 0 || defined_prog_list == NULL) { @@ -1294,7 +1296,7 @@ end_scope_of_program_name (struct cb_program *program, const unsigned char type) static void setup_registers (void) { - backup_source_file = cb_source_file; + const char *backup_source_file = cb_source_file; cb_source_file = "register-definition"; cb_set_intr_when_compiled (); cb_build_registers (); @@ -1325,13 +1327,9 @@ setup_program (cb_tree id, cb_tree as_literal, const enum cob_module_type type, setup_program_start (); - if (first_prog) { - /* in this case we had setup an "empty" current_program - along with registers before (on start) and now only "add" - to that */ - first_prog = 0; - } else { - /* finish last program/function */ + /* finish last program/function */ + if (!first_prog) { + const char *backup_source_file = cb_source_file; if (!current_program->flag_validated) { current_program->flag_validated = 1; cb_validate_program_body (current_program); @@ -1343,7 +1341,13 @@ setup_program (cb_tree id, cb_tree as_literal, const enum cob_module_type type, if (depth) { build_words_for_nested_programs(); } + cb_source_file = backup_source_file; setup_registers (); + } else { + /* in this case we had setup an "empty" current_program + along with registers before (on start) and now only "add" + to that */ + first_prog = 0; } /* set internal name */ @@ -1753,7 +1757,7 @@ setup_external_definition_type (cb_tree x) /* verifies that no conflicting clauses are used and inherits the definition of the original field specified - by SAME AS or by type_name */ + by SAME AS or by type_name into the current_field */ static void inherit_external_definition (const int lvl) { @@ -1791,9 +1795,9 @@ get_finalized_description_tree (void) { struct cb_field *p; - /* finalize last field if target of SAME AS / TYPEDEF */ + /* finalize last field if target of SAME AS / TYPEDEF */ if (current_field && !CB_INVALID_TREE (current_field->external_definition)) { - inherit_external_definition (0); + inherit_external_definition (0); } /* validate the complete current "block" */ @@ -2115,10 +2119,8 @@ check_not_88_level (cb_tree x) { struct cb_field *f; - if (x == cb_error_node) { - return cb_error_node; - } if (!CB_REF_OR_FIELD_P(x)) { + /* note: this also applies to cb_error_node */ return x; } @@ -3552,6 +3554,9 @@ set_record_size (cb_tree min, cb_tree max) start: { + const char *backup_source_file = cb_source_file; + + clear_initial_values (); defined_prog_list = NULL; cobc_cs_check = 0; main_flag_set = 0; @@ -3559,7 +3564,11 @@ start: clear_initial_values (); current_program = cb_build_program (NULL, 0); - setup_registers (); + cb_source_file = "register-definition"; + cb_set_intr_when_compiled (); + cb_build_registers (); + cb_add_external_defined_registers (); + cb_source_file = backup_source_file; } compilation_group { @@ -3583,7 +3592,8 @@ start: ; compilation_group: - simple_prog /* extension: single program without PROCEDURE DIVISION */ + simple_prog /* extension: single program + without PROGRAM-ID, possibly also without PROCEDURE DIVISION */ | nested_list ; @@ -3616,7 +3626,7 @@ simple_prog: _program_body /* do cleanup */ { - backup_current_pos (); + last_source_line = cb_source_line; clean_up_program (NULL, COB_MODULE_TYPE_PROGRAM); } ; @@ -3642,7 +3652,7 @@ function_definition: _end_program_list: /* empty (still do cleanup) */ { - backup_current_pos (); + last_source_line = cb_source_line; clean_up_program (NULL, COB_MODULE_TYPE_PROGRAM); } | end_program_list @@ -3656,8 +3666,8 @@ end_program_list: end_program: END_PROGRAM { + last_source_line = cb_source_line; check_area_a_of ("END PROGRAM"); - backup_current_pos (); } end_program_name _dot { @@ -3669,7 +3679,8 @@ end_program: end_function: END_FUNCTION { - backup_current_pos (); + last_source_line = cb_source_line; + check_area_a_of ("END FUNCTION"); } end_program_name _dot { @@ -10901,9 +10912,9 @@ _procedure_division: ; procedure_division: - PROCEDURE { check_area_a_of ("PROCEDURE DIVISION"); } - DIVISION + PROCEDURE { + check_area_a_of ("PROCEDURE DIVISION"); current_section = NULL; current_paragraph = NULL; check_pic_duplicate = 0; @@ -10911,16 +10922,17 @@ procedure_division: cobc_in_procedure = 1U; cobc_in_data_division = 0; cb_set_system_names (); - backup_current_pos (); + last_source_line = cb_source_line; } + DIVISION _mnemonic_conv _conv_linkage _procedure_using_chaining _procedure_returning { - cb_tree call_conv = $5; - if ($6) { - call_conv = $6; - if ($5) { - /* note: $4 is likely to be a reference to SPECIAL-NAMES */ - cb_error_x ($6, _("%s and %s are mutually exclusive"), + cb_tree call_conv = $4; + if ($5) { + call_conv = $5; + if ($4) { + /* note: $3 is likely to be a reference to SPECIAL-NAMES */ + cb_error_x ($5, _("%s and %s are mutually exclusive"), "CALL-CONVENTION", "WITH LINKAGE"); } } @@ -10938,7 +10950,7 @@ procedure_division: _dot_or_else_area_a _procedure_declaratives { - emit_main_entry (current_program, $7); + emit_main_entry (current_program, $6); cb_check_definition_matches_prototype (current_program); } @@ -11231,6 +11243,7 @@ _procedure_returning: ; _procedure_declaratives: + /* empty */ | DECLARATIVES { check_area_a_of ("DECLARATIVES"); @@ -11476,7 +11489,18 @@ statement_list: { /* push exec_list on the stack ($1), then unset */ $$ = current_program->exec_list; - current_program->exec_list = NULL; + if (!skip_statements) { + current_program->exec_list = NULL; + } else { + /* Provide "something" in case we never add statements + to the program while parsing it below in "statements" + to not break checks for "do we have any statements" + by "callers". + Not adding statements which are parsed will for example + happen in DECLARATIVES with not-active USE FOR DEBUGGING. */ + cb_tree note = cb_build_comment ("skipped statements"); + current_program->exec_list = CB_BUILD_CHAIN (note, NULL); + } check_unreached = 0; } { @@ -11621,11 +11645,15 @@ statement: label = cb_build_reference (name); next_label_list = cb_list_add (next_label_list, label); emit_statement (cb_build_goto (label, NULL)); + } else { + cb_tree note = cb_build_comment ("skipped NEXT SENTENCE"); + emit_statement (note); } check_unreached = 0; } | error error_stmt_recover { + emit_statement (cb_error_node); yyerrok; cobc_cs_check = 0; } @@ -11920,40 +11948,50 @@ lines_or_number: ; at_line_column: - _at line_number + _at + { + $$ = cb_build_comment ("AT"); /* for position only */ + } + line_number { set_attr_with_conflict ("LINE", SYN_CLAUSE_1, _("AT screen-location"), SYN_CLAUSE_3, 1, &check_line_col_duplicate); - if ((CB_LITERAL_P ($2) && cb_get_int ($2) == 0) || $2 == cb_zero) { - cb_verify (cb_accept_display_extensions, "LINE 0"); + if (((CB_LITERAL_P ($3) || CB_INTEGER_P ($3)) && cb_get_int ($3) == 0) + || $3 == cb_zero) { + cb_verify_x ($2, cb_accept_display_extensions, "LINE 0"); } if (!line_column) { - line_column = CB_BUILD_PAIR ($2, cb_int0); + line_column = CB_BUILD_PAIR ($3, cb_int0); } else if (CB_PAIR_P (line_column)) { /* note: if line_column is set but no pair, we already raised a conflict error as AT pos was used before */ - CB_PAIR_X (line_column) = $2; + CB_PAIR_X (line_column) = $3; } } -| _at column_number +| _at + { + $$ = cb_build_comment ("AT"); /* for position only */ + } + column_number { set_attr_with_conflict ("COLUMN", SYN_CLAUSE_2, _("AT screen-location"), SYN_CLAUSE_3, 1, &check_line_col_duplicate); - if ((CB_LITERAL_P ($2) && cb_get_int ($2) == 0) || $2 == cb_zero) { + if (((CB_LITERAL_P ($3) || CB_INTEGER_P ($3)) && cb_get_int ($3) == 0) + || $3 == cb_zero) { cb_verify_x ($2, cb_accept_display_extensions, "COLUMN 0"); } if (!line_column) { - line_column = CB_BUILD_PAIR (cb_int0, $2); + line_column = CB_BUILD_PAIR (cb_int0, $3); } else if (CB_PAIR_P (line_column)) { /* note: if line_column is set but no pair, we already raised a conflict error as AT pos was used before */ - CB_PAIR_Y (line_column) = $2; + CB_PAIR_Y (line_column) = $3; } } | AT num_id_or_lit @@ -12251,6 +12289,7 @@ _end_accept: } | END_ACCEPT { + check_non_area_a_of ("END-ACCEPT"); TERMINATOR_CLEAR ($-2, ACCEPT); # if 0 /* activate only for debugging purposes for attribs FIXME: Replace by DEBUG_LOG function */ @@ -12310,6 +12349,7 @@ _end_add: } | END_ADD { + check_non_area_a_of ("END-ADD"); TERMINATOR_CLEAR ($-2, ADD); } ; @@ -12398,7 +12438,6 @@ call_statement: cobc_cs_check = CB_CS_CALL; call_nothing = 0; cobc_allow_program_name = 1; - backup_current_pos (); } call_body _end_call @@ -12486,7 +12525,7 @@ call_body: call_conv |= CB_CONV_NO_RET_UPD; } cb_emit_call ($3, $7, $8, CB_PAIR_X ($9), CB_PAIR_Y ($9), - cb_int (call_conv), $2, $5, backup_source_line); + cb_int (call_conv), $2, $5); } ; @@ -12499,12 +12538,12 @@ _conv_linkage: { /* FIXME: hack - fake cs for context-sensitive WITH ... LINKAGE */ cobc_cs_check |= CB_CS_OPTIONS; - backup_current_pos (); + $$ = cb_build_comment ("WITH"); /* for position only */ } conv_linkage_option LINKAGE { $$ = $3; - restore_backup_pos ($$); + copy_pos ($$, $2); cobc_cs_check ^= CB_CS_OPTIONS; cb_verify_x ($$, cb_call_convention_linkage, "WITH ... LINKAGE"); } @@ -12664,7 +12703,8 @@ call_param: { if (call_mode != CB_CALL_BY_REFERENCE) { cb_error_x (CB_TREE (current_statement), - _("%s only allowed when arguments are passed %s"), "OMITTED", "BY REFERENCE"); + _("%s only allowed when arguments are passed %s"), + "OMITTED", "BY REFERENCE"); } $$ = CB_BUILD_PAIR (cb_int (call_mode), cb_null); } @@ -12685,7 +12725,8 @@ call_param: { if (call_type != CB_CALL_BY_VALUE) { cb_error_x ($2 /* or CB_TREE (current_statement) ? * /, - _("%s only allowed when arguments are passed %s", "SIZE IS", "BY VALUE")); + _("%s only allowed when arguments are passed %s", + "SIZE IS", "BY VALUE")); } $$ = cb_build_call_parameter ($2, call_mode, size_mode); / * note: ... while the MF extension is only given for the previous integer * / @@ -12845,6 +12886,7 @@ _end_call: } | END_CALL { + check_non_area_a_of ("END-CALL"); TERMINATOR_CLEAR ($-2, CALL); } ; @@ -12975,6 +13017,7 @@ _end_compute: } | END_COMPUTE { + check_non_area_a_of ("END-COMPUTE"); TERMINATOR_CLEAR ($-2, COMPUTE); } ; @@ -12996,7 +13039,10 @@ commit_statement: continue_statement: CONTINUE { - backup_current_pos (); + $$ = cb_build_comment ("CONTINUE"); + if (cobc_in_area_a) { + $$->source_column = -1; + } } _continue_after_phrase { @@ -13004,11 +13050,11 @@ continue_statement: /* Do not check unreached for CONTINUE without after phrase */ unsigned int save_unreached = check_unreached; check_unreached = 0; - begin_statement_from_backup_pos (STMT_CONTINUE, 0); + begin_statement_at_tree_pos (STMT_CONTINUE, 0, $2); cb_emit_continue (NULL); check_unreached = save_unreached; } else { - begin_statement_from_backup_pos (STMT_CONTINUE_AFTER, 0); + begin_statement_at_tree_pos (STMT_CONTINUE_AFTER, 0, $2); cb_emit_continue ($3); } } @@ -13101,6 +13147,7 @@ _end_delete: } | END_DELETE { + check_non_area_a_of ("END-DELETE"); TERMINATOR_CLEAR ($-2, DELETE); } ; @@ -13392,7 +13439,7 @@ field_or_literal_or_erase: display_message_box: MESSAGE _box x_list { - CB_UNFINISHED_X (CB_TREE(current_statement), "DISPLAY MESSAGE"); + CB_UNFINISHED_X (CB_TREE (current_statement), "DISPLAY MESSAGE"); upon_value = NULL; } _display_message_clauses @@ -13780,6 +13827,7 @@ _end_display: } | END_DISPLAY { + check_non_area_a_of ("END-DISPLAY"); TERMINATOR_CLEAR ($-2, DISPLAY); } ; @@ -13826,6 +13874,7 @@ _end_divide: } | END_DIVIDE { + check_non_area_a_of ("END-DIVIDE"); TERMINATOR_CLEAR ($-2, DIVIDE); } ; @@ -13844,22 +13893,26 @@ enable_statement: /* ENTRY statement */ -entry: ENTRY { check_non_area_a ($1); }; +entry: ENTRY {check_area_a_of ("ENTRY"); }; entry_statement: entry { check_unreached = 0; begin_statement (STMT_ENTRY, 0); - backup_current_pos (); } entry_body -| entry FOR GO TO +| entry { check_unreached = 0; begin_statement (STMT_ENTRY_FOR_GO_TO, 0); - backup_current_pos (); } - entry_goto_body + FOR GO TO + LITERAL + { + if (cb_verify_x (CB_TREE (current_statement), cb_goto_entry, "ENTRY FOR GO TO")) { + emit_entry_goto ((char *)(CB_LITERAL ($6)->data)); + } + } ; entry_body: @@ -13880,21 +13933,12 @@ entry_body: } } if (!cobc_check_valid_name ((char *)(CB_LITERAL ($2)->data), ENTRY_NAME)) { - emit_entry ((char *)(CB_LITERAL ($2)->data), 1, $4, call_conv, 0); + emit_entry ((char *)(CB_LITERAL ($2)->data), 1, $4, call_conv); } } } ; -entry_goto_body: - LITERAL - { - if (cb_verify (cb_goto_entry, "ENTRY FOR GO TO")) { - emit_entry_goto ((char *)(CB_LITERAL ($1)->data)); - } - } -; - /* EVALUATE statement */ @@ -13999,14 +14043,24 @@ evaluate_case_list: evaluate_case { $$ = cb_list_add ($1, $2); } ; +end_evaluate: + END_EVALUATE { check_non_area_a_of ("END-EVALUATE"); } +; + evaluate_case: evaluate_when_list statement_list { + /* FIXME: build STMT_WHEN directly in the parser instead of + in cb_build_evaluate, this will also provide the correct + source location directly */ $$ = CB_BUILD_CHAIN ($2, $1); + if (!is_valid_statement_tree ($2)) { + cb_error_x ($1, _("%s without imperative statement"), "WHEN"); + } eval_inc2 = 0; } -| evaluate_when_list END_EVALUATE +| evaluate_when_list end_evaluate { eval_inc2 = 0; cb_verify (cb_missing_statement, @@ -14027,27 +14081,40 @@ evaluate_case: } ; -evaluate_other: +when_other: WHEN OTHER + { + /* FIXME: build STMT_WHEN_OTHER directly in the parser instead of + in cb_build_evaluate */ + check_non_area_a_of ("WHEN OTHER"); + $$ = cb_build_comment ("WHEN OTHER"); + } +; + +evaluate_other: + when_other statement_list { - $$ = CB_BUILD_CHAIN ($3, NULL); + $$ = CB_BUILD_CHAIN ($2, NULL); + if (!is_valid_statement_tree ($2)) { + cb_error_x ($1, _("%s without imperative statement"), "WHEN OTHER"); + } eval_inc2 = 0; } -| WHEN OTHER END_EVALUATE +| when_other end_evaluate { eval_inc2 = 0; - cb_verify (cb_missing_statement, + cb_verify_x ($1, cb_missing_statement, _("WHEN OTHER without imperative statement")); /* Note: we don't clear the EVALUATE terminator here as we'd have to skip this later [side effect: possible warning about missing terminator] */ $$ = NULL; } -| WHEN OTHER TOK_DOT +| when_other TOK_DOT { eval_inc2 = 0; - cb_verify (cb_missing_statement, + cb_verify_x ($1, cb_missing_statement, _("WHEN OTHER without imperative statement")); /* Put the dot token back into the stack for reparse */ cb_unput_dot (); @@ -14055,26 +14122,30 @@ evaluate_other: } ; -evaluate_when_list: +when: WHEN { - backup_current_pos (); + /* FIXME: build STMT_WHEN directly in the parser instead of + in cb_build_evaluate */ + check_non_area_a_of ("WHEN"); + $$ = cb_build_comment ("WHEN"); } +; + +evaluate_when_list: + when evaluate_object_list { - $$ = CB_LIST_INIT ($3); - restore_backup_pos ($$); + $$ = CB_LIST_INIT ($2); + copy_pos ($$, $1); eval_inc2 = 0; } | evaluate_when_list - WHEN - { - backup_current_pos (); - } + when evaluate_object_list { - $$ = cb_list_add ($1, $4); - restore_backup_pos ($$); + $$ = cb_list_add ($1, $3); + copy_pos ($$, $2); eval_inc2 = 0; } ; @@ -14177,7 +14248,7 @@ _end_evaluate: { TERMINATOR_WARNING ($-2, EVALUATE); } -| END_EVALUATE +| end_evaluate { TERMINATOR_CLEAR ($-2, EVALUATE); } @@ -14541,20 +14612,41 @@ if_statement: _end_if ; +else: + ELSE + { + check_non_area_a_of ("ELSE"); + $$ = cb_build_comment ("ELSE"); + } + if_else_statements: - if_true statement_list ELSE if_false statement_list + if_true statement_list else if_false statement_list { - cb_emit_if ($-1, $2, $5); + if (is_valid_statement_tree ($5)) { + cb_emit_if ($-1, $2, $5); + } else { + cb_error_x ($3, _("%s without imperative statement"), "ELSE"); + } } -| ELSE if_false statement_list +| else if_false statement_list { - cb_emit_if ($-1, NULL, $3); - cb_verify (cb_missing_statement, + cb_verify_x (CB_TREE (current_statement), + cb_missing_statement, _("IF without imperative statement")); + if (is_valid_statement_tree ($3)) { + cb_emit_if ($-1, NULL, $3); + } else { + cb_error_x ($1, _("%s without imperative statement"), "ELSE"); + } } | if_true statement_list %prec SHIFT_PREFER { - cb_emit_if ($-1, $2, NULL); + if (is_valid_statement_tree ($2)) { + cb_emit_if ($-1, $2, NULL); + } else { + cb_error_x (CB_TREE (current_statement), + _("%s without imperative statement"), "IF"); + } } ; @@ -14564,6 +14656,7 @@ _if_then: } | THEN { + check_non_area_a_of ("THEN"); cb_save_cond (); } ; @@ -14588,6 +14681,7 @@ _end_if: } | END_IF { + check_non_area_a_of ("END-IF"); TERMINATOR_CLEAR ($-4, IF); cb_terminate_cond (); } @@ -14781,7 +14875,7 @@ examine_statement: examine_format_variant: TALLYING { - cb_tree tally = cb_build_identifier (cb_build_reference ("TALLY"), 0); + cb_tree tally = cb_ref (cb_build_reference ("TALLY")); cb_emit_move (cb_zero, CB_LIST_INIT (tally)); cb_init_tallying (); cb_build_tallying_data (tally); @@ -15200,6 +15294,7 @@ _end_modify: } | END_MODIFY { + check_non_area_a_of ("END-MODIFY"); TERMINATOR_CLEAR ($-2, MODIFY); } ; @@ -15256,6 +15351,7 @@ _end_multiply: } | END_MULTIPLY { + check_non_area_a_of ("END-MULTIPLY"); TERMINATOR_CLEAR ($-2, MULTIPLY); } ; @@ -15473,6 +15569,7 @@ _end_perform: } | END_PERFORM { + check_non_area_a_of ("END-PERFORM"); TERMINATOR_CLEAR ($-6, PERFORM); } ; @@ -15480,6 +15577,7 @@ _end_perform: end_perform_or_dot: END_PERFORM { + check_non_area_a_of ("END-PERFORM"); TERMINATOR_CLEAR ($-5, PERFORM); } | TOK_DOT @@ -15814,6 +15912,7 @@ _end_read: } | END_READ { + check_non_area_a_of ("END-READ"); TERMINATOR_CLEAR ($-2, READ); } ; @@ -15881,6 +15980,7 @@ _end_receive: } | END_RECEIVE { + check_non_area_a_of ("END-RECEIVE"); TERMINATOR_CLEAR ($-2, RECEIVE); } ; @@ -15938,6 +16038,7 @@ _end_return: } | END_RETURN { + check_non_area_a_of ("END-RETURN"); TERMINATOR_CLEAR ($-2, RETURN); } ; @@ -15991,6 +16092,7 @@ _end_rewrite: } | END_REWRITE { + check_non_area_a_of ("END-REWRITE"); TERMINATOR_CLEAR ($-2, REWRITE); } ; @@ -16091,14 +16193,14 @@ _end_search: } | END_SEARCH end_search_pos_token { - cb_tree x = $-0; - if (x) { + if ($-0) { struct cb_search *p = CB_SEARCH ($-0); if (p->at_end == NULL) { cb_tree brk = cb_build_direct ("break;", 0); p->at_end = CB_BUILD_PAIR ($2, brk); } } + check_non_area_a_of ("END-SEARCH"); TERMINATOR_CLEAR ($-2, SEARCH); } ; @@ -16696,6 +16798,7 @@ _end_start: } | END_START { + check_non_area_a_of ("END-START"); TERMINATOR_CLEAR ($-2, START); } ; @@ -16889,6 +16992,7 @@ _end_string: } | END_STRING { + check_non_area_a_of ("END-STRING"); TERMINATOR_CLEAR ($-2, STRING); } ; @@ -16932,6 +17036,7 @@ _end_subtract: } | END_SUBTRACT { + check_non_area_a_of ("END-SUBTRACT"); TERMINATOR_CLEAR ($-2, SUBTRACT); } ; @@ -17097,6 +17202,7 @@ _end_unstring: } | END_UNSTRING { + check_non_area_a_of ("END-UNSTRING"); TERMINATOR_CLEAR ($-2, UNSTRING); } ; @@ -17386,13 +17492,13 @@ program_start_end: { emit_statement (cb_build_comment ("USE AT PROGRAM START")); CB_PENDING ("USE AT PROGRAM START"); - /* emit_entry ("_AT_START", 0, NULL, NULL, 0); */ + /* emit_entry ("_AT_START", 0, NULL, NULL); */ } | END { emit_statement (cb_build_comment ("USE AT PROGRAM END")); CB_PENDING ("USE AT PROGRAM END"); - /* emit_entry ("_AT_END", 0, NULL, NULL, 0); */ + /* emit_entry ("_AT_END", 0, NULL, NULL); */ } ; @@ -17526,6 +17632,7 @@ _end_write: } | END_WRITE { + check_non_area_a_of ("END-WRITE"); TERMINATOR_CLEAR ($-2, WRITE); } ; @@ -17814,6 +17921,7 @@ _end_xml: } | END_XML { + check_non_area_a_of ("END-XML"); TERMINATOR_CLEAR ($-2, XML); } ; @@ -17932,12 +18040,16 @@ accp_on_exception: { current_statement->handler_type = ACCEPT_HANDLER; current_statement->ex_handler = $3; + if (!is_valid_statement_tree ($3)) { + cb_error (_("%s without imperative statement"), + $1 == cb_int0 ? "ON ESCAPE" : "ON EXCEPTION"); + } } ; escape_or_exception: - on_escape -| on_exception + on_escape { $$ = cb_int0; } +| on_exception { $$ = cb_int1; } ; _accp_not_on_exception: @@ -17950,12 +18062,16 @@ accp_not_on_exception: { current_statement->handler_type = ACCEPT_HANDLER; current_statement->not_ex_handler = $2; + if (!is_valid_statement_tree ($2)) { + cb_error (_("%s without imperative statement"), + $1 == cb_int0 ? "NOT ON ESCAPE" : "NOT ON EXCEPTION"); + } } ; not_escape_or_not_exception: - NOT_ON_ESCAPE -| NOT_ON_EXCEPTION + NOT_ON_ESCAPE { $$ = cb_int0; } +| NOT_ON_EXCEPTION { $$ = cb_int0; } ; /* Generic [NOT] ON EXCEPTION */ @@ -17987,6 +18103,9 @@ except_on_exception: { current_statement->handler_type = get_handler_type_from_statement(current_statement); current_statement->ex_handler = $2; + if (!is_valid_statement_tree ($2)) { + cb_error (_("%s without imperative statement"), "ON EXCEPTION"); + } } ; @@ -18000,6 +18119,9 @@ except_not_on_exception: { current_statement->handler_type = get_handler_type_from_statement (current_statement); current_statement->not_ex_handler = $2; + if (!is_valid_statement_tree ($2)) { + cb_error (_("%s without imperative statement"), "NOT ON EXCEPTION"); + } } ; @@ -18007,6 +18129,9 @@ except_not_on_exception: on_size_error_phrases: %prec SHIFT_PREFER + { + /* no [NOT] ON SIZE ERROR is specified (= no explicit handling) */ + } | on_size_error _not_on_size_error | not_on_size_error _on_size_error { @@ -18032,7 +18157,11 @@ on_size_error: SIZE_ERROR statement_list { current_statement->handler_type = SIZE_ERROR_HANDLER; - current_statement->ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "ON SIZE ERROR"); + } } ; @@ -18045,7 +18174,11 @@ not_on_size_error: NOT_SIZE_ERROR statement_list { current_statement->handler_type = SIZE_ERROR_HANDLER; - current_statement->not_ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->not_ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "NOT ON SIZE ERROR"); + } } ; @@ -18078,7 +18211,11 @@ on_overflow: TOK_OVERFLOW statement_list { current_statement->handler_type = OVERFLOW_HANDLER; - current_statement->ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "ON OVERFLOW"); + } } ; @@ -18091,7 +18228,11 @@ not_on_overflow: NOT_ON_OVERFLOW statement_list { current_statement->handler_type = OVERFLOW_HANDLER; - current_statement->not_ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->not_ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "NOT ON OVERFLOW"); + } } ; @@ -18137,7 +18278,11 @@ at_end_clause: at_end statement_list { current_statement->handler_type = AT_END_HANDLER; - current_statement->ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "AT END"); + } } ; @@ -18150,7 +18295,11 @@ not_at_end_clause: NOT_AT_END statement_list { current_statement->handler_type = AT_END_HANDLER; - current_statement->not_ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->not_ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "NOT AT END"); + } } ; @@ -18182,7 +18331,11 @@ at_eop_clause: EOP statement_list { current_statement->handler_type = EOP_HANDLER; - current_statement->ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "AT END OF PAGE"); + } } ; @@ -18195,7 +18348,11 @@ not_at_eop_clause: NOT_EOP statement_list { current_statement->handler_type = EOP_HANDLER; - current_statement->not_ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->not_ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "NOT AT END OF PAGE"); + } } ; @@ -18232,7 +18389,11 @@ invalid_key_sentence: INVALID_KEY statement_list { current_statement->handler_type = INVALID_KEY_HANDLER; - current_statement->ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "INVALID KEY"); + } } ; @@ -18245,7 +18406,11 @@ not_invalid_key_sentence: NOT_INVALID_KEY statement_list { current_statement->handler_type = INVALID_KEY_HANDLER; - current_statement->not_ex_handler = $2; + if (is_valid_statement_tree ($2)) { + current_statement->not_ex_handler = $2; + } else { + cb_error (_("%s without imperative statement"), "NOT INVALID KEY"); + } } ; @@ -19486,21 +19651,34 @@ target_identifier_1: ; target_identifier_single: -| qualified_word %prec SHIFT_PREFER + data_name_without_sub_or_refmod { $$ = $1; - if (CB_REFERENCE_P ($1)) { + if ($1 != cb_error_node) { CB_REFERENCE ($1)->flag_target = 1; if (cb_listing_xref) { cobc_xref_set_receiving ($1); } + if (start_debug) { + cb_check_field_debug ($1); + } } - if (start_debug) { - cb_check_field_debug ($1); + } +; + +data_name_without_sub_or_refmod: + qualified_word + { + cb_tree x = cb_ref ($1); + if (!CB_FIELD_P (x)) { + $$ = cb_error_node; + } else { + $$ = $1; } } ; + display_identifier_or_alphabet_name: identifier_1 { @@ -20113,14 +20291,16 @@ error_stmt_recover: } | verb { + check_non_area_a ($1); cobc_repeat_last_token = 1; } -| ELSE +| else { cobc_repeat_last_token = 0; } | scope_terminator { + check_non_area_a_of (_("terminator")); cobc_repeat_last_token = 0; } ; @@ -20209,7 +20389,7 @@ scope_terminator: _dot: TOK_DOT | { - if (! cb_verify (cb_missing_period, _("optional period"))) { + if (!cb_verify (cb_missing_period, _("optional period"))) { YYERROR; } } @@ -20219,7 +20399,7 @@ dot_or_else_end_of_file_control: TOK_DOT | file_control_end_delimiter { - if (! cb_verify (cb_missing_period, _("optional period"))) { + if (!cb_verify (cb_missing_period, _("optional period"))) { YYERROR; } cobc_repeat_last_token = 1; @@ -20240,7 +20420,7 @@ dot_or_else_end_of_file_description: | level_number_in_area_a /* repeats last token */ | file_description_end_delimiter { - if (! cb_verify (cb_missing_period, _("optional period"))) { + if (!cb_verify (cb_missing_period, _("optional period"))) { YYERROR; } cobc_repeat_last_token = 1; @@ -20261,7 +20441,7 @@ dot_or_else_end_of_record_description: | level_number_in_area_a /* repeats last token */ | record_description_end_delimiter { - if (! cb_verify (cb_missing_period, _("optional period"))) { + if (!cb_verify (cb_missing_period, _("optional period"))) { YYERROR; } cobc_repeat_last_token = 1; @@ -20281,7 +20461,7 @@ _dot_or_else_area_a: /* in PROCEDURE DIVISION */ TOK_DOT | TOKEN_EOF { - if (! cb_verify (cb_missing_period, _("optional period"))) { + if (!cb_verify (cb_missing_period, _("optional period"))) { YYERROR; } } diff --git a/cobc/pplex.l b/cobc/pplex.l index c345f1912..97090a113 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -160,30 +160,20 @@ static int emit_area_a_tokens = 0; static char display_msg[PPLEX_BUFF_LEN]; -static struct cb_replace_list *current_replace_list = NULL; -static struct cb_replace_list *save_current_replace = NULL; -static struct cb_replace_list *base_replace_list = NULL; - -static struct cb_text_list *text_queue = NULL; -static size_t check_partial_match = 0; - static struct copy_info *copy_stack = NULL; static struct plex_stack plex_cond_stack[PLEX_COND_DEPTH]; /* Function declarations */ static int ppinput (char *, const size_t); -static void ppecho (const char *, const cob_u32_t, - const int); -static void ppecho_direct (const char *); -static int ppecho_replace (struct cb_replace_list *); +static void ppecho (const char *text, const char *token ); + static void switch_to_buffer (const int, const char *, const YY_BUFFER_STATE); static void check_listing (const char *, const unsigned int); static void skip_to_eol (void); static void count_newlines (const char *); static void display_finish (void); -static void set_print_replace_list (struct cb_replace_list *); static void get_new_listing_file (void); static struct cb_text_list *pp_text_list_add (struct cb_text_list *, @@ -205,7 +195,9 @@ MAYBE_AREA_A [ ]?#? %x CALL_DIRECTIVE_STATE %x COBOL_WORDS_DIRECTIVE_STATE %x COPY_STATE +%x REPLACING_STATE %x PSEUDO_STATE +%x REPLACE_STATE %x CONTROL_DIVISION_STATE %x SUBSTITUTION_SECTION_STATE %x SOURCE_DIRECTIVE_STATE @@ -229,7 +221,7 @@ MAYBE_AREA_A [ ]?#? /* 2002+: inline comment */ #if 0 /* RXWRXW - Directive state */ if (YY_START != DIRECTIVE_STATE && YY_START != SET_DIRECTIVE_STATE) { - ppecho (" ", 0, 1); + ppecho (" ", NULL); } #endif } @@ -489,7 +481,7 @@ MAYBE_AREA_A [ ]?#? } "REPLACE"/[ ,;\n] { - yy_push_state (COPY_STATE); + yy_push_state (REPLACE_STATE); return REPLACE; } @@ -519,7 +511,7 @@ MAYBE_AREA_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); + ppecho (yytext, NULL); yy_push_state (CONTROL_DIVISION_STATE); return CONTROL_DIVISION; } @@ -531,7 +523,7 @@ MAYBE_AREA_A [ ]?#? } \. { /* Pass dots to the parser to handle DEFAULT SECTION. */ - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); return DOT; } } @@ -539,7 +531,7 @@ MAYBE_AREA_A [ ]?#? { "REPLACE" { - yy_push_state (COPY_STATE); + yy_push_state (REPLACE_STATE); return REPLACE; } } @@ -557,7 +549,7 @@ SUBSTITUTION_SECTION_STATE>{ while (YY_START == CONTROL_DIVISION_STATE || YY_START == SUBSTITUTION_SECTION_STATE) yy_pop_state (); - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); } [,;]?\n { ECHO; @@ -577,25 +569,25 @@ SUBSTITUTION_SECTION_STATE> yy_pop_state (); /* Allow comment sentences/paragraphs */ comment_allowed = 1; - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); } "PROGRAM-ID"/[ .,;\n] { /* Allow comment sentences/paragraphs */ comment_allowed = 1; - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); } "DIVISION"/[ .,;\n] { /* Disallow comment sentences/paragraphs */ comment_allowed = 0; - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); } "SECTION"/[ .,;\n] { /* Disallow comment sentences/paragraphs */ comment_allowed = 0; - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); } ^{MAYBE_AREA_A}[ ]*"EJECT"([ ]*\.)? | @@ -644,43 +636,43 @@ SUBSTITUTION_SECTION_STATE> /* Pick up early - Also activates debugging lines */ cb_verify (cb_debugging_mode, "DEBUGGING MODE"); cb_flag_debugging_line = 1; - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); } [,;]?\n { - ppecho ("\n", 0, 1); + ppecho ("\n", NULL); cb_source_line++; } [;]?[ ]+ { - ppecho (" ", 1U, 1); + ppecho (" ", yytext); } [,]?[ ]+ { if (inside_bracket) { - ppecho (", ", 0, 2); + ppecho (", ", NULL); } else { - ppecho (" ", 1U, 1); + ppecho (" ", yytext); } } "(" { - inside_bracket++; - ppecho ("(", 0, 1); + inside_bracket++; + ppecho (yytext, NULL); } ")" { if (inside_bracket) { inside_bracket--; } - ppecho (")", 0, 1); + ppecho (yytext, NULL); } {WORD} | {NUMRIC_LITERAL} | {ALNUM_LITERAL} | . { - ppecho (yytext, 0, (int)yyleng); + ppecho (yytext, NULL); } { return TEXT_NAME; } \. { + /* note: if we get into the REPLACING state, then + that one handles the dot and pops this state */ yy_pop_state (); return DOT; } - "==" { yy_push_state (PSEUDO_STATE); return EQEQ; } - "(" { return '('; } - ")" { return ')'; } - "BY" { return BY; } + /* for COPY IN/OF lib */ "IN" { return IN; } "OF" { return OF; } - "OFF" { return OFF; } + "SUPPRESS" { return SUPPRESS; } "PRINTING" { return PRINTING; } - "REPLACING" { return REPLACING; } - "LEADING" { return LEADING; } - "TRAILING" { return TRAILING; } + "REPLACING" { yy_push_state (REPLACING_STATE); return REPLACING; } "ALSO" { return ALSO; } "LAST" { return LAST; } + + /* for error handling only, only used in REPLACING state */ + "LEADING" { return LEADING; } + "TRAILING" { return TRAILING; } + "==" { return EQEQ; } + "BY" { return BY; } + {WORD} | {NUMRIC_LITERAL} | {ALNUM_LITERAL} | @@ -1048,6 +1044,41 @@ ENDIF_DIRECTIVE_STATE>{ } } +{ + [,;]?\n { + ECHO; + check_listing (yytext, 0); + cb_source_line++; + } + [,;]?[ ]+ { /* ignore */ } + + "LEADING" { return LEADING; } + "TRAILING" { return TRAILING; } + "==" { yy_push_state (PSEUDO_STATE); return EQEQ; } + "BY" { return BY; } + \. { + yy_pop_state (); + yy_pop_state (); + return DOT; + } + /* for qualification and subscripting */ + "IN" { return IN; } + "OF" { return OF; } + "(" { return '('; } + ")" { return ')'; } + + /* for error handling only, only used in COPY state */ + "REPLACING" { return REPLACING; } + + {WORD} | + {NUMRIC_LITERAL} | + {ALNUM_LITERAL} | + . { + pplval.s = cobc_plex_strdup (yytext); + return TOKEN; + } +} + { [,;]?\n { ECHO; @@ -1074,6 +1105,40 @@ ENDIF_DIRECTIVE_STATE>{ } } +{ + [,;]?\n { + ECHO; + check_listing (yytext, 0); + cb_source_line++; + } + [,;]?[ ]+ { /* ignore */ } + \. { + yy_pop_state (); + return DOT; + } + /* for qualification and subscripting */ + "IN" { return IN; } + "OF" { return OF; } + "(" { return '('; } + ")" { return ')'; } + + "LEADING" { return LEADING; } + "TRAILING" { return TRAILING; } + "==" { yy_push_state (PSEUDO_STATE); return EQEQ; } + "BY" { return BY; } + "ALSO" { return ALSO; } + "LAST" { return LAST; } + "OFF" { return OFF; } + + {WORD} | + {NUMRIC_LITERAL} | + {ALNUM_LITERAL} | + . { + pplval.s = cobc_plex_strdup (yytext); + return TOKEN; + } +} + <> { struct copy_info *current_copy_info = copy_stack; @@ -1097,10 +1162,7 @@ ENDIF_DIRECTIVE_STATE>{ newline_count = 0; inside_bracket = 0; comment_allowed = 1; - current_replace_list = NULL; - base_replace_list = NULL; - save_current_replace = NULL; - text_queue = NULL; + cb_free_replace (); copy_stack = NULL; quotation_mark = 0; consecutive_quotation = 0; @@ -1122,7 +1184,7 @@ ENDIF_DIRECTIVE_STATE>{ current_copy_info->buffer); /* Restore variables */ - current_replace_list = current_copy_info->replacing; + cb_set_copy_replacing_list (current_copy_info->replacing); quotation_mark = current_copy_info->quotation_mark; cobc_set_source_format (current_copy_info->source_format); @@ -1135,35 +1197,6 @@ ENDIF_DIRECTIVE_STATE>{ /* Global functions */ -void -pp_set_replace_list (struct cb_replace_list *list, const cob_u32_t is_pushpop) -{ - /* Handle REPLACE verb */ - if (!list) { - /* REPLACE [LAST] OFF */ - if (!is_pushpop) { - base_replace_list = NULL; - return; - } - if (!base_replace_list) { - return; - } - base_replace_list = base_replace_list->prev; - return; - } - /* REPLACE [ALSO] ... */ - if (base_replace_list && is_pushpop) { - list->last->next = base_replace_list; - list->prev = base_replace_list; - } else { - list->prev = NULL; - } - base_replace_list = list; - if (cb_src_list_file) { - set_print_replace_list (list); - } -} - static int is_fixed_indicator (char c){ switch (c){ /* same indicators as in ppinput() */ @@ -1201,23 +1234,23 @@ ppopen_get_file (const char *name) /* check for recursive inclusion */ for (current_copy_info = copy_stack; current_copy_info; current_copy_info = current_copy_info->next) { /* FIXME: for WIN32 compare with cleaning / and \ (COPY "lib/file" vs COPY "lib\file"), - * ideally open first, then check if we have the same physical file - * (would also fix recursion check for symlinked files) */ + ideally open first, then check if we have the same physical file + (would also fix recursion check for symlinked files) */ if (!strcmp (name, current_copy_info->dname)) { - struct cb_tree_common loc; - for (current_copy_info = current_copy_info->next; current_copy_info; current_copy_info = current_copy_info->prev) { - int line; - if (current_copy_info->prev) { - line = current_copy_info->prev->line; - } else { - line = cb_source_line; - } - cb_inclusion_note (current_copy_info->dname, line); + struct cb_tree_common loc; + for (current_copy_info = current_copy_info->next; current_copy_info; current_copy_info = current_copy_info->prev) { + int line; + if (current_copy_info->prev) { + line = current_copy_info->prev->line; + } else { + line = cb_source_line; } - loc.source_file = name; - loc.source_line = -1; - cb_error_x (&loc, _("recursive inclusion")); - return 0; + cb_inclusion_note (current_copy_info->dname, line); + } + loc.source_file = name; + loc.source_line = -1; + cb_error_x (&loc, _("recursive inclusion")); + return 0; } } @@ -1300,6 +1333,7 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) { struct copy_info *current_copy_info; char *dname; + struct cb_replace_list *current_replace_list; if (ppin) { for (; newline_count > 0; newline_count--) { @@ -1335,6 +1369,7 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) } /* preserve the current buffer */ + current_replace_list = cb_get_copy_replacing_list(); current_copy_info = cobc_malloc (sizeof (struct copy_info)); current_copy_info->file = cb_source_file; current_copy_info->buffer = YY_CURRENT_BUFFER; @@ -1358,9 +1393,9 @@ ppopen (const char *name, struct cb_replace_list *replacing_list) replacing_list->last->next = current_replace_list; replacing_list->last = current_replace_list->last; } - current_replace_list = replacing_list; + cb_set_copy_replacing_list (replacing_list); if (cb_src_list_file) { - set_print_replace_list (replacing_list); + cb_set_print_replace_list (replacing_list); } } @@ -1877,8 +1912,8 @@ get_new_listing_file (void) cb_current_file = newfile; } -static void -set_print_replace_list (struct cb_replace_list *list) +void +cb_set_print_replace_list (struct cb_replace_list *list) { struct cb_replace_list *r; const struct cb_text_list *l; @@ -1930,12 +1965,6 @@ switch_to_buffer (const int line, const char *file, const YY_BUFFER_STATE buffer yy_switch_to_buffer (buffer); } -static COB_INLINE COB_A_INLINE int -is_space_or_nl (const char c) -{ - return c == ' ' || c == '\n'; -} - static COB_INLINE COB_A_INLINE int is_cobol_word_char (const char c) { @@ -2023,6 +2052,11 @@ next_word_is_comment_paragraph_name (const char *buff) return 1; } +static COB_INLINE COB_A_INLINE int +is_space_or_nl (const char c) +{ + return c == ' ' || c == '\n'; +} /* FIXME: try to optimize as this function used 25-10% (according to callgrind) of the complete time spent in a sample run with @@ -2625,7 +2659,7 @@ start: static struct cb_text_list * pp_text_list_add (struct cb_text_list *list, const char *text, - const size_t size) + const size_t size) { struct cb_text_list *p; void *tp; @@ -2644,204 +2678,9 @@ pp_text_list_add (struct cb_text_list *list, const char *text, } static void -ppecho (const char *text, const cob_u32_t alt_space, const int textlen) +ppecho (const char *text, const char *token) { - /* performance note (last verified with GnuCOBOL 2.2): - while this function used 5% (according to callgrind) - of the complete time spent in a sample run with - -fsyntax-only on 880 production code files (2,500,000 LOC), - 3.8% of this time is spent in fwrite, therefore not much potential - for optimization */ - - struct cb_replace_list *save_ptr; - const char *s; - struct cb_text_list *save_ptr_text_queue; - int status, save_status; - -#if 0 /* Simon: disabled until found necessary, as this takes together with frwite - a big part of the parsing phase of cobc, increasing the IO cost by numbers */ - /* ensure nothing is in the stream buffer */ - fflush (ppout); -#endif - - /* Check for replacement text before outputting */ - if (alt_space) { - s = yytext; - } else { - s = text; - } - - if (text_queue == NULL && (text[0] == ' ' || text[0] == '\n')) { - /* No replacement */ - fwrite (text, (size_t)textlen, (size_t)1, ppout); - /* TODO: instead of \n (empty line: set "needs source-loc" flag and - before first non-empty line output a #line directive, saving - quite some file io [keep 1 empty line]) */ - if (cb_listing_file) { - check_listing (s, 0); - } - return; - } - if (!current_replace_list && !base_replace_list) { - /* Output queue */ - for (; text_queue; text_queue = text_queue->next) { - fputs (text_queue->text, ppout); - } - fwrite (text, (size_t)textlen, (size_t)1, ppout); - if (cb_listing_file) { - check_listing (s, 0); - } - return; - } - if (!current_replace_list) { - current_replace_list = base_replace_list; - save_ptr = NULL; - } else { - current_replace_list->last->next = base_replace_list; - save_ptr = current_replace_list->last; - } - - /* Do replacement */ - text_queue = pp_text_list_add (text_queue, text, (size_t)textlen); - - save_ptr_text_queue = text_queue; - status = ppecho_replace (save_ptr); - /* Search another replacement when have a Partial Match in the last ppecho call */ - if (check_partial_match && status != -1) { - save_status = status; - text_queue = save_ptr_text_queue; - while (text_queue && check_partial_match) { - if (is_space_or_nl (text_queue->text[0])) { - ppecho_direct (text_queue->text); - text_queue = text_queue->next; - continue; - } - status = ppecho_replace (save_ptr); - if (status > save_status) { - save_status = status; - } - if (text_queue) { - /* Write text_queue if is not replaced */ - if (status != -1 && check_partial_match) { - ppecho_direct (text_queue->text); - } - text_queue = text_queue->next; - } - } - status = save_status; - } - /* Manage Partial Match */ - if (status == -1) { - check_partial_match = save_ptr_text_queue != NULL; - return; - } - if (!status) { - current_replace_list = NULL; - } else { - save_ptr->next = NULL; - } - - /* No match */ - for (; text_queue; text_queue = text_queue->next) { - ppecho_direct (text_queue->text); - } -} - -/* handle all kinds of COPY REPLACING and REPLACE */ -static int -ppecho_replace (struct cb_replace_list *save_ptr) -{ - char *temp_ptr; - size_t size; - size_t size2; - struct cb_text_list *queue; - struct cb_text_list *save_queue; - const struct cb_text_list *lno; - struct cb_replace_list *r; - - save_queue = NULL; - size = 0; - size2 = 0; - for (r = current_replace_list; r; r = r->next) { - queue = text_queue; - /* The LEADING/TRAILING code looks peculiar as we use */ - /* variables after breaking out of the loop BUT */ - /* ppparse.y guarantees that we have only one token */ - /* and therefore only one iteration of this loop */ - for (lno = r->src->text_list; lno; lno = lno->next) { - if (is_space_or_nl (lno->text[0])) { - continue; - } - while (queue && is_space_or_nl (queue->text[0])) { - queue = queue->next; - } - if (queue == NULL) { - /* Partial match */ - if (!save_ptr) { - current_replace_list = NULL; - } else { - save_ptr->next = NULL; - } - return -1; - } - if (r->src->lead_trail == CB_REPLACE_LEADING) { - /* Check leading text */ - size = strlen (lno->text); - if ((r->src->strict && strlen (queue->text) == size) - || strncasecmp (lno->text, queue->text, size)) { - /* No match */ - break; - } - save_queue = queue; - } else if (r->src->lead_trail == CB_REPLACE_TRAILING) { - /* Check trailing text */ - size = strlen (lno->text); - size2 = strlen (queue->text); - if (size2 < size - || (r->src->strict && size2 == size)) { - /* No match */ - break; - } - size2 -= size; - if (strncasecmp (lno->text, queue->text + size2, size)) { - /* No match */ - break; - } - save_queue = queue; - } else if (strcasecmp (lno->text, queue->text)) { - /* No match */ - break; - } - queue = queue->next; - } - if (lno == NULL) { - /* Match */ - if (r->src->lead_trail == CB_REPLACE_TRAILING - && save_queue /* <- silence warnings */) { - /* Non-matched part of original text */ - fprintf (ppout, "%*.*s", (int)size2, (int)size2, - save_queue->text); - if (cb_listing_file) { - temp_ptr = cobc_strdup (save_queue->text); - *(temp_ptr + size2) = 0; - check_listing (temp_ptr, 0); - cobc_free (temp_ptr); - } - } - for (lno = r->new_text; lno; lno = lno->next) { - ppecho_direct (lno->text); - } - if (r->src->lead_trail == CB_REPLACE_LEADING - && save_queue /* <- silence warnings */) { - /* Non-matched part of original text */ - ppecho_direct (save_queue->text + size); - } - check_partial_match = 0; - text_queue = queue; - continue; - } - } - return (save_ptr ? 1 : 0); + cb_ppecho_copy_replace (text, token); } static void @@ -2882,12 +2721,11 @@ display_finish (void) unput ('\n'); } -static void -ppecho_direct (const char *text) +void cb_ppecho_direct (const char *text, const char *token ) { fputs (text, ppout); if (cb_listing_file) { - check_listing (text, 0); + check_listing (token != NULL ? token : text, 0); } } diff --git a/cobc/ppparse.y b/cobc/ppparse.y index fccb06ef9..25b2380f0 100644 --- a/cobc/ppparse.y +++ b/cobc/ppparse.y @@ -1,5 +1,5 @@ /* - Copyright (C) 2001-2012, 2015-2022 Free Software Foundation, Inc. + Copyright (C) 2001-2012, 2015-2023 Free Software Foundation, Inc. Written by Keisuke Nishida, Roger While, Simon Sobisch, Edward Hart This file is part of GnuCOBOL. @@ -736,12 +736,12 @@ ppparse_clear_vars (const struct cb_define_struct *p) %token TERMINATOR "end of line" -%token TOKEN "Identifier or Literal" +%token TOKEN "Word or Literal" %token TEXT_NAME "Text-Name" %token VARIABLE_NAME "Variable" %token LITERAL "Literal" -%type copy_in +%type _copy_in %type copy_source %type _literal @@ -762,7 +762,7 @@ ppparse_clear_vars (const struct cb_define_struct *p) %type ec_list %type unquoted_literal -%type copy_replacing +%type _copy_replacing %type replacing_list %type object_id @@ -812,11 +812,11 @@ statement_no_replace_list: statement: statement_no_replace -| replace_statement DOT +| replace_statement_with_dot ; statement_no_replace: - copy_statement DOT + copy_statement | directive TERMINATOR | listing_statement | CONTROL_STATEMENT control_options _dot TERMINATOR @@ -1585,11 +1585,15 @@ condition_clause: ; copy_statement: - COPY copy_source copy_in copy_suppress copy_replacing + COPY copy_source _copy_in _copy_suppress _copy_replacing DOT { fputc ('\n', ppout); ppcopy ($2, $3, $5); } +| COPY error DOT + { + yyerrok; + } ; copy_source: @@ -1613,7 +1617,7 @@ copy_source: } ; -copy_in: +_copy_in: /* nothing */ { $$ = NULL; @@ -1629,11 +1633,12 @@ in_or_of: | OF ; -copy_suppress: +_copy_suppress: + /* nothing */ | SUPPRESS _printing ; -copy_replacing: +_copy_replacing: /* nothing */ { $$ = NULL; @@ -1644,14 +1649,22 @@ copy_replacing: } ; +replace_statement_with_dot: + replace_statement DOT +| replace_statement error DOT + { + yyerrok; + } +; + replace_statement: REPLACE _also replacing_list { - pp_set_replace_list ($3, $2); + cb_set_replace_list ($3, $2); } | REPLACE _last OFF { - pp_set_replace_list (NULL, $2); + cb_set_replace_list (NULL, $2); } ; @@ -1682,6 +1695,24 @@ text_src: | identifier { $$ = ppp_replace_src ($1, 0); +/* CHECKME later (parser conflict) + } +| IN + { + / * as we need this word, which is valid as replacement, + also for qualification, we need to explicit make it + a word if given alone * / + $$ = ppp_list_add (NULL, "IN"); + $$ = ppp_replace_src ($$, 0); + } +| OF + { + / * as we need this word, which is valid as replacement, + also for qualification, we need to explicit make it + a word if given alone * / + $$ = ppp_list_add (NULL, "OF"); + $$ = ppp_replace_src ($$, 0); +*/ } ; @@ -1698,6 +1729,20 @@ text_dst: { $$ = $1; } +| IN + { + /* as we need this word, which is valid as replacement, + also for qualification, we need to explicit make it + a word if given alone */ + $$ = ppp_list_add (NULL, "IN"); + } +| OF + { + /* as we need this word, which is valid as replacement, + also for qualification, we need to explicit make it + a word if given alone */ + $$ = ppp_list_add (NULL, "OF"); + } ; text_partial_src: diff --git a/cobc/replace.c b/cobc/replace.c new file mode 100644 index 000000000..42e44f80a --- /dev/null +++ b/cobc/replace.c @@ -0,0 +1,852 @@ +/* + Copyright (C) 2001-2023 Free Software Foundation, Inc. + + Authors: + Keisuke Nishida, Roger While, Ron Norman, Simon Sobisch, Brian Tiffin, + Edward Hart, Dave Pitts, Fabrice Le Fessant + + This file is part of GnuCOBOL. + + The GnuCOBOL compiler is free software: you can redistribute it + and/or modify it under the terms of the GNU General Public License + as published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + GnuCOBOL is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GnuCOBOL. If not, see . +*/ + +#include "tarstamp.h" +#include "config.h" + +#include +#include +#include +#include +#include +#ifdef HAVE_STRINGS_H +#include +#endif +#include +#include +#include + +#include "cobc.h" +#include "tree.h" + +/* This is an implementation of the *two* phases of COPY-REPLACING and + REPLACE on a stream of tokens: the stream of tokens generated by the + pplex.l/parser.y goes first through COPY-REPLACING replacements, + and then through REPLACE replacements, as expected by the COBOL + standard. + + However, it does not fully conform to the standard, as REPLACE are + parsed on the input stream *before* any COPY-REPLACING could have + been applied. + + The general entry point is `add_text_to_replace(stream, prequeue, + token)`, it adds `token` to `stream`, `prequeue` is 1 if the + token should not be treated immediately (because it may be merged + with other following tokens if they are of the same kind), 0 + otherwise. + + Initially, `pp_echo()` in `pplex.l` will use + `cb_ppecho_copy_replace()` to add tokens to the first stream + `copy_repls` (using `add_text_to_replace`), i.e. the stream of + copy-replacing. + + Once copy-replacing operations have been performed in this stream, + `ppecho_replace()` is used to add tokens to the second stream + `replace_repls` (using again `add_text_to_replace`), i.e. the + stream of `replace`. + + Once replace operations have been performed on this second stream, + `cb_ppecho_direct()` (in pplex.l) is used to output the final + tokens. + + The states of both streams are stored in a struct + `cb_replacement_state`, and `add_text_to_replace` calls the + function `do_replace()` to perform the replacement on a given + stream. + */ + +/* Uncomment the following lines to have a trace of replacements. + It uses macros WITH_DEPTH that adds an additional argument to every + function to keep the depth of the recursion. */ + +/* #define DEBUG_REPLACE_TRACE */ +/* #define DEBUG_REPLACE */ + +#ifdef DEBUG_REPLACE_TRACE +#define DEBUG_REPLACE +#endif + +struct cb_token_list { + struct cb_token_list *next; /* next pointer */ + struct cb_token_list *last; + + /* The text in the source to be matched. Most of the time, it + * directly what appears in the source file, but it may also + * be a simplified version, typically for spaces, in which + * case the exact text is stored in the `token` field (to be + * used if no replacement is performed) */ + const char *text; + + /* NULL most of the time, non-NULL only if the `text` was + * replaced by a simplified version, i.e. space to easy + * testing. */ + const char *token; +}; + +/* types */ +enum cb_ppecho { + CB_PPECHO_DIRECT = 0, /* direct output */ + CB_PPECHO_REPLACE = 1, /* output to REPLACE */ +}; + +struct cb_replacement_state { + + /* The list of tokens that are currently being checked for + * replacements. Empty, unless a partial match occurred. */ + struct cb_token_list *token_queue ; + + /* We don't queue WORD tokens immediately, because + * preprocessing could create larger words. Instead, we buffer + * WORD tokens (and merge them) until another kind of token + * (SPACE,DELIM,etc.) is received. */ + const char *text_prequeue ; + + /* Current list of replacements specified in COPY-REPLACING or + * REPLACE */ + struct cb_replace_list *replace_list ; + + /* List of replacements after a partial match that still need + * to be tested. */ + const struct cb_replace_list *current_list ; + + /* The next pass to which generated tokens should be passed + * (either REPLACE pass or direct output */ + enum cb_ppecho ppecho ; + +#ifdef DEBUG_REPLACE + const char* name ; +#endif +}; + + +#ifdef DEBUG_REPLACE_TRACE + +#define WITH_DEPTH int depth, +#define INIT_DEPTH 1, +#define MORE_DEPTH depth+1, + +#define MAX_DEPTH 100 +char depth_buffer[MAX_DEPTH+1]; +#define DEPTH depth_buffer + ( MAX_DEPTH-depth ) + +#else /* DEBUG_REPLACE_TRACE */ + +#define WITH_DEPTH +#define DEPTH +#define INIT_DEPTH +#define MORE_DEPTH + +#endif /* DEBUG_REPLACE_TRACE */ + + +#ifdef DEBUG_REPLACE + +#define MAX_TEXT_LIST_STRING 10000 +char text_list_string[MAX_TEXT_LIST_STRING]; + +/* In debugging mode only, stores a list of text/tokens into a + preallocated string for easy display */ +#define STRING_OF_LIST(kind) \ +static \ +char * string_of_##kind##_list(const struct cb_##kind##_list *list) \ +{ \ + int pos = 1; \ + text_list_string[0] = '['; \ + \ + for(; list != NULL; list = list->next){ \ + size_t len = strlen(list->text); \ + text_list_string[pos++] = '"'; \ + memcpy( text_list_string + pos, list->text, len ); \ + pos += len; \ + text_list_string[pos++] = '"'; \ + text_list_string[pos++] = ','; \ + text_list_string[pos++] = ' '; \ + } \ + \ + text_list_string[pos] = ']'; \ + text_list_string[pos+1]=0; \ + return text_list_string; \ +} + +/* string_of_token_list (...) */ +STRING_OF_LIST(token) +/* string_of_text_list (...) */ +STRING_OF_LIST(text) + +#endif /* DEBUG_REPLACE */ + +/* global state */ +static struct cb_replacement_state * replace_repls; +static struct cb_replacement_state * copy_repls; + +/* forward definitions */ +static void ppecho_replace (WITH_DEPTH const char *text, const char* token); +static void do_replace (WITH_DEPTH struct cb_replacement_state* repls); +static void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls); +static void check_replace_all (WITH_DEPTH struct cb_replacement_state *repls, + const struct cb_text_list *new_text, + struct cb_token_list *texts, + const struct cb_text_list *src, + const struct cb_replace_list *replace_list); + +static struct cb_token_list * +token_list_add (WITH_DEPTH struct cb_token_list *list, + const char *text, + const char *token); + +/* This specific token_list_add function does a standard append on + list, without expecting `last` field to be correctly set. This is + important as `pp_token_list_add` only correctly works when always + adding on the same head, other `last` fields in the middle of the + list not being correctly updated... + */ +static +struct cb_token_list * +token_list_add (WITH_DEPTH struct cb_token_list *list, + const char *text, const char *token) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%stoken_list_add(%s,'%s')\n", + DEPTH, string_of_token_list(list), text); +#endif + struct cb_token_list *p; + + p = cobc_plex_malloc (sizeof (struct cb_token_list)); + p->text = cobc_plex_strdup (text); + if (token == NULL) { + p->token = NULL; + } else { + p->token = cobc_plex_strdup (token); + } + + p->next = NULL; + if (list==NULL) { + return p; + } else { + struct cb_token_list *cursor = list; + for(;cursor->next != NULL; cursor = cursor->next); + cursor->next = p; + return list; + } +} + + + +static +const void pop_token (WITH_DEPTH struct cb_replacement_state *repls, + const char **text, const char **token) +{ + const struct cb_token_list *q = repls->token_queue ; + repls->token_queue = q->next ; +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%spop_token(%s) -> '%s'\n", + DEPTH, repls->name, q->text); +#endif + if (text) *text = q->text ; + if (token) *token = q->token ; +} + +static +void ppecho_switch (WITH_DEPTH struct cb_replacement_state *repls, + const char* text, const char* token) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sppecho_switch(%s, '%s')\n", + DEPTH, repls->name, text); +#endif + switch( repls->ppecho ){ + case CB_PPECHO_DIRECT: +#ifdef DEBUG_REPLACE + fprintf(stderr, "%s ppecho_direct('%s')\n", DEPTH, text); +#endif + return cb_ppecho_direct (text, token); + case CB_PPECHO_REPLACE: + return ppecho_replace (MORE_DEPTH text, token); + } +} + +static +void ppecho_switch_text_list (WITH_DEPTH struct cb_replacement_state *repls, + const struct cb_text_list *p) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sppecho_switch_text_list(%s, %s)\n", + DEPTH, repls->name, string_of_text_list(p)); +#endif + + for (;p;p=p->next){ + ppecho_switch (MORE_DEPTH repls, p->text, NULL); + } +} + + +static +void ppecho_switch_token_list (WITH_DEPTH struct cb_replacement_state *repls, + const struct cb_token_list *p) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sppecho_switch_token_list(%s, %s)\n", + DEPTH, repls->name, string_of_token_list(p)); +#endif + + for (;p;p=p->next){ + ppecho_switch (MORE_DEPTH repls, p->text, p->token); + } +} + +static +int is_leading_or_trailing (WITH_DEPTH int leading, + const char* src_text, + const char* text, + int strict) +{ + + const size_t src_len = strlen (src_text); + const size_t text_len = strlen(text); + int result ; + if( text_len > src_len || ( !strict && text_len == src_len ) ){ + int pos = leading ? 0 : text_len - src_len ; + if( strncasecmp (src_text, text+pos, src_len) ){ + result = 0; + } else { + result = 1; + } + } else { + result = 0; + } +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, + "%sis_leading_or_trailing(%d, '%s', input='%s', %d) -> %d\n", + DEPTH, leading, src_text, text, strict, result); +#endif + return result; +} + +/* after a LEADING or TRAILING match, perform the replacement within + the text, and pass the resulting new text to the next stream */ +static +void ppecho_leading_or_trailing (WITH_DEPTH struct cb_replacement_state *repls, + int leading, + const char *src_text, + const char *text, + const struct cb_text_list * new_text) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, + "%sppecho_leading_or_trailing(%s, %d, '%s', input='%s', ...)\n", + DEPTH, repls->name, leading, src_text, text); +#endif + + size_t src_len = strlen (src_text); + size_t text_len = strlen (text); + + if (!leading && text_len > src_len) { + /* For TRAILING, we have to keep only the non-matched + * prefix part of the matching text */ + const char* remaining_text = + cobc_plex_strsub (text, + text_len - src_len); + ppecho_switch (MORE_DEPTH repls, remaining_text, NULL); + } + + ppecho_switch_text_list (MORE_DEPTH repls, new_text); + + if (leading && text_len > src_len) { + const char* remaining_text = + cobc_plex_strsub (text+src_len, + text_len - src_len); + ppecho_switch (MORE_DEPTH repls, remaining_text, NULL); + } +} + +/* `check_replace( repls, replace_list )`: check if one of the + * replacements in the list `replace_list` applies on the stream + * `repls`. + * * `repls`: the current stream + * * `replace_list`: the current list of possible replacements on check + */ + +static +void check_replace (WITH_DEPTH struct cb_replacement_state* repls, + const struct cb_replace_list *replace_list) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%scheck_replace(%s, ...)\n", DEPTH, + repls->name); +#endif + repls->current_list = replace_list; + + if (replace_list == NULL){ + + /* NO MATCH: no possible replacement on this text */ + + /* remove the text from the current stream */ + const char* text; + const char* token; + pop_token (MORE_DEPTH repls, &text, &token); + + /* pass it to the next stream */ + ppecho_switch (MORE_DEPTH repls, text, token); + + /* restart replacements on this stream */ + check_replace_after_match (MORE_DEPTH repls); + + } else { + const struct cb_replace_src *src = replace_list->src; + const struct cb_text_list *new_text = replace_list->new_text; + replace_list = replace_list->next; + + if (src->lead_trail == CB_REPLACE_LEADING + || src->lead_trail == CB_REPLACE_TRAILING){ + /* LEADING and TRAILING replacements are + * different: they match only on one text, so + * we just need one test to decide if it is a + * match or a failure */ + int leading = (src->lead_trail == CB_REPLACE_LEADING); + unsigned int strict = src->strict; + const char *src_text = src->text_list->text; + const char *text = repls->token_queue->text; + + if (is_leading_or_trailing (MORE_DEPTH leading, + src_text,text,strict)){ + + /* MATCH */ + /* remove the text from the current stream */ + pop_token (MORE_DEPTH repls, NULL, NULL); + + /* perform a partial replacement on the text, + and pass it to the next stream */ + ppecho_leading_or_trailing (MORE_DEPTH repls, + leading, + src_text,text, + new_text) ; + + /* restart replacements on this stream */ + check_replace_after_match (MORE_DEPTH repls); + } else { + check_replace (MORE_DEPTH repls,replace_list); + } + } else { + /* we need to compare a list of texts from + * this stream with a list of texts from the + * replacement */ + check_replace_all (MORE_DEPTH repls,new_text, + repls->token_queue, + src->text_list, + replace_list); + } + } +} + +static COB_INLINE COB_A_INLINE int +is_space_or_nl (const char c) +{ + return c == ' ' || c == '\n'; +} + +/* `check_replace_all( repls, new_text, texts, src, replace_list )`: + * checks whether a particular replacement is possible on the current + * list of texts. + * * `repls` is the current stream state + * * `new_text` is the text by which the texts should be replace in case of match + * * `texts` is the list of texts found in the source that remains to be matched + * * `src` is the list of texts from the replacement to be matched + * * `replace_list` is the next replacements to try in case of failure + */ +static +void check_replace_all (WITH_DEPTH + struct cb_replacement_state *repls, + const struct cb_text_list *new_text, + struct cb_token_list *texts, + const struct cb_text_list *src, + const struct cb_replace_list *replace_list) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%scheck_replace_all(%s,", + DEPTH, repls->name); + fprintf(stderr, "%s new_text = %s,\n", DEPTH, + string_of_text_list(new_text)); + fprintf(stderr, "%s texts = %s,\n", DEPTH, + string_of_token_list(texts)); + fprintf(stderr, "%s src = %s,\n", DEPTH, + string_of_text_list(src)); + fprintf(stderr, "%s)\n", DEPTH); +#endif + + if (src==NULL){ + /* MATCH */ + /* pass the new text to the next stream */ + ppecho_switch_text_list (MORE_DEPTH repls, new_text) ; + /* keep only in this stream the remaining texts that have not been matched */ + repls->token_queue = texts ; + /* restart replacements on the stream */ + check_replace_after_match (MORE_DEPTH repls); + } else { + const char* src_text = src->text; + if ( is_space_or_nl(src_text[0]) ){ + /* skip spaces in replacement */ + check_replace_all (MORE_DEPTH repls,new_text,texts, + src->next, replace_list); + } else { + if (texts == NULL){ + /* PARTIAL MATCH, we have emptied the + * list of texts, but there are still + * texts in the replacement, so wait + * for more texts to be added on the + * stream */ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%s check_replace_all --> PARTIAL MATCH\n", DEPTH); +#endif + } else { + const char* text = texts->text; + texts = texts->next; + if ( is_space_or_nl(text[0]) ){ + /* skip spaces in texts */ + check_replace_all (MORE_DEPTH repls, + new_text, + texts, src, + replace_list); + } else { + if (!strcasecmp(src_text,text)){ + /* We could match one + * text from the + * stream with a text + * from the + * replacement, so + * move on to the next + * text */ + check_replace_all( + MORE_DEPTH repls, + new_text, + texts,src->next, + replace_list); + } else { + /* match failed, move + * on to the next + * potential + * replacement */ + check_replace ( + MORE_DEPTH repls, + replace_list); + } + } + } + } + } +} + +static +void check_replace_after_match (WITH_DEPTH struct cb_replacement_state *repls) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%scheck_replace_after_match(%s)\n", + DEPTH, repls->name); +#endif + repls->current_list = NULL; + if (repls->token_queue != NULL){ + if( is_space_or_nl (repls->token_queue->text[0]) ){ + ppecho_switch (MORE_DEPTH repls, + repls->token_queue->text, + repls->token_queue->token); + repls->token_queue = repls->token_queue->next; + check_replace_after_match (MORE_DEPTH repls); + } else { + do_replace (MORE_DEPTH repls); + } + } +} + +static +void do_replace (WITH_DEPTH struct cb_replacement_state* repls) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sdo_replace(%s)\n",DEPTH, repls->name); +#endif + if (repls->current_list == NULL){ + if (repls->replace_list == NULL){ + + /* Beware: this is incorrect if a REPLACE is + * withing the queue, as it has already been + * parsed before any COPY-REPLACING + * substitution. */ + ppecho_switch_token_list (MORE_DEPTH repls, + repls->token_queue); + repls->token_queue = NULL; + } else { + check_replace (MORE_DEPTH repls, repls->replace_list); + } + } else { + check_replace (MORE_DEPTH repls, repls->current_list); + } +} + +/* Whether a word matches the definition of WORD in pplex.l */ +static +int is_word (WITH_DEPTH const char* s){ + int i; + size_t len = strlen (s); + + + for( i = 0; i= '0' && c <= '9' ) + || ( c >= 'A' && c <= 'Z' ) + || ( c >= 'a' && c <= 'z' ) + || ( c >= 128 && c <= 255 ) + ){ + + } else { +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sis_word('%s') -> 0\n", DEPTH, s); +#endif + return 0; + } + } +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sis_word('%s') -> 1\n", DEPTH, s); +#endif + return 1; +} + +static void add_text_to_replace (WITH_DEPTH struct cb_replacement_state *repls, + int prequeue, + const char* text, + const char* token + ) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "%sadd_text_to_replace(%s%s, '%s')\n", DEPTH, + repls->name, prequeue ? ", PREQUEUE" : "", text); +#endif + if( prequeue ){ + + if( is_word (MORE_DEPTH text) ) { + + if( repls->text_prequeue == NULL ){ + /* a word should be kept in the prequeue */ + repls->text_prequeue = + cobc_plex_strdup (text); + } else { + /* two following words should be + * merged, and keep waiting in the + * prequeue */ + repls->text_prequeue = + cobc_plex_stradd (repls->text_prequeue, + text); + } + } else { + if( repls->text_prequeue == NULL ){ + /* not a word, and empty prequeue, + * just perform replacements */ + add_text_to_replace(MORE_DEPTH repls, 0, text, token); + } else { + /* not a word, one word in the + * prequeue, flush the word from the + * prequeue and pass the current text + * to the replacements */ + const char* pretext = repls->text_prequeue; + repls->text_prequeue = NULL; + add_text_to_replace(MORE_DEPTH repls, + 0, pretext, NULL); + add_text_to_replace(MORE_DEPTH repls, + 0, text, token); + } + } + } + else { + if( repls->token_queue == NULL && + ( is_space_or_nl (text[0])) ) { + ppecho_switch (MORE_DEPTH repls, text, token); + } else { +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, + "%s add_text_to_replace() -> push_text()\n", + DEPTH); +#endif + repls->token_queue = + token_list_add(MORE_DEPTH repls->token_queue, + text, token); + + do_replace (MORE_DEPTH repls); + } + } +} + +/* pass a text to the replace stream (called from the copy-replacing + stream). Use prequeue = 1 so that texts of the same kind are + merged into a single text. + */ +static void ppecho_replace (WITH_DEPTH const char *text, const char *token) +{ +#ifdef DEBUG_REPLACE + fprintf(stderr, "%sppecho_replace('%s')\n", DEPTH, text); +#endif + add_text_to_replace(MORE_DEPTH replace_repls, 1, text, token); +} + +/* pass a text to the copy-replacing stream (called from ppecho() in + pplex.l). Use prequeue = 0 as texts of the same kind from the + source file should not be merged. + */ +void cb_ppecho_copy_replace (const char *text, const char *token) +{ +#ifdef DEBUG_REPLACE + fprintf(stderr, "cb_ppecho_copy_replace('%s')\n", text); +#endif + add_text_to_replace(INIT_DEPTH copy_repls, 0, text, token); +} + + +static +struct cb_replacement_state * create_replacements( enum cb_ppecho ppecho ) +{ + struct cb_replacement_state * s; + + s = cobc_malloc (sizeof(struct cb_replacement_state)); + + s->text_prequeue = NULL; + s->token_queue = NULL; + s->replace_list = NULL ; + s->current_list = NULL ; + s->ppecho = ppecho; + +#ifdef DEBUG_REPLACE + if( ppecho == CB_PPECHO_REPLACE ){ + s->name = "COPY-REPLACING"; + } else { + s->name = "REPLACE"; + } +#endif + + return s; +} + +static void reset_replacements( struct cb_replacement_state * s ) +{ + s->text_prequeue = NULL; + s->token_queue = NULL; + s->replace_list = NULL ; + s->current_list = NULL ; +} + +static +void init_replace( void ) +{ +#ifdef DEBUG_REPLACE_TRACE + for(int i=0; ireplace_list ; +} + +/* Called by pplex.l, either at the end of a file to restore the +previous stack of active copy-replacing, or when a new file is open to +set additional copy replacing */ +void cb_set_copy_replacing_list (struct cb_replace_list *list) +{ + copy_repls->current_list = NULL; + copy_repls->replace_list = list ; +#ifdef DEBUG_REPLACE + fprintf(stderr, "set_copy_replacing_list(\n"); + for(;list != NULL; list=list->next){ + fprintf(stderr, " repl = {\n"); + fprintf(stderr, " src = %s\n", + string_of_text_list(list->src->text_list)); + fprintf(stderr, " leading = %d\n", + list->src->lead_trail); + fprintf(stderr, " new_text = %s\n", + string_of_text_list(list->new_text)); + fprintf(stderr, " };\n"); + } + fprintf(stderr, " )\n"); +#endif +} + +/* Called by pplex.l from pp_set_replace_list() after a REPLACE statement: + + list is_pushpop + REPLACE . <> NULL false + REPLACE ALSO . <> NULL true + REPLACE LAST OFF. NULL true + REPLACE OFF. NULL false + */ +void +cb_set_replace_list (struct cb_replace_list *list, const int is_pushpop) +{ +#ifdef DEBUG_REPLACE_TRACE + fprintf(stderr, "set_replace_list(...)\n"); +#endif + if (!list) { + /* REPLACE [LAST] OFF */ + if (!is_pushpop) { + replace_repls->replace_list = NULL; + return; + } + if (!replace_repls->replace_list) { + return; + } + replace_repls->replace_list = replace_repls->replace_list->prev; + return; + } + /* REPLACE [ALSO] ... */ + if (replace_repls->replace_list && is_pushpop) { + list->last->next = replace_repls->replace_list; + list->prev = replace_repls->replace_list; + } else { + list->prev = NULL; + } + replace_repls->replace_list = list; + if (cb_src_list_file) { + cb_set_print_replace_list (list); + } +} diff --git a/cobc/tree.h b/cobc/tree.h index d3158294e..a022ece29 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -1702,8 +1702,8 @@ struct cb_replace_list { const struct cb_text_list *new_text; }; -extern void pp_set_replace_list (struct cb_replace_list *, - const cob_u32_t); +extern void cb_set_replace_list (struct cb_replace_list *, + const int); /* List of error messages */ struct list_error { @@ -2488,7 +2488,7 @@ extern void cb_emit_alter (cb_tree, cb_tree); extern void cb_emit_free (cb_tree); extern void cb_emit_call (cb_tree, cb_tree, cb_tree, cb_tree, - cb_tree, cb_tree, cb_tree, cb_tree, int); + cb_tree, cb_tree, cb_tree, cb_tree); extern void cb_emit_cancel (cb_tree); extern void cb_emit_close (cb_tree, cb_tree); @@ -2645,6 +2645,21 @@ extern cb_tree cobc_tree_cast_check (const cb_tree, const char *, const int, const enum cb_tag); #endif +/* pplex.l */ +extern void cb_ppecho_direct (const char *text, const char *token ); +extern struct cb_text_list *cb_pp_text_list_add (struct cb_text_list *, + const char *, const size_t); +/* replace.c */ +extern void cb_ppecho_copy_replace (const char *text, const char *token ); +extern void cb_free_replace (void); + +/* For COPY-REPLACING */ +extern void cb_set_copy_replacing_list (struct cb_replace_list *list); +extern struct cb_replace_list * cb_get_copy_replacing_list (void); + +extern void +cb_set_print_replace_list (struct cb_replace_list *); + /* codeoptim.c */ extern void cob_gen_optim (const enum cb_optim); diff --git a/cobc/typeck.c b/cobc/typeck.c index ba9ffd3d8..05e97d3f1 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -9096,8 +9096,7 @@ get_constant_call_name (cb_tree prog) void cb_emit_call (cb_tree prog, cb_tree par_using, cb_tree returning, cb_tree on_exception, cb_tree not_on_exception, - cb_tree convention, cb_tree newthread, cb_tree handle, - int call_line_number) + cb_tree convention, cb_tree newthread, cb_tree handle) { cb_tree l; cb_tree check_list; @@ -9360,12 +9359,12 @@ cb_emit_call (cb_tree prog, cb_tree par_using, cb_tree returning, } } if (cb_listing_xref) { - cobc_xref_call (entry, call_line_number, 0, is_sys_call); + cobc_xref_call (entry, CB_TREE (current_statement)->source_line, 0, is_sys_call); } } else if (cb_listing_xref && CB_REFERENCE_P(prog)) { entry = CB_FIELD(CB_REFERENCE(prog)->value)->name; - cobc_xref_call (entry, call_line_number, 1, 0); + cobc_xref_call (entry, CB_TREE (current_statement)->source_line, 1, 0); } if (error_ind) { @@ -11393,7 +11392,6 @@ validate_move_from_num_lit (cb_tree src, cb_tree dst, const unsigned int is_valu struct cb_literal *l = CB_LITERAL (src); int leftmost_significant, most_significant, least_significant; size_t i; - cob_s64_t val; cb_tree loc = src->source_line ? src : dst; /* Numeric literal */ @@ -11514,7 +11512,7 @@ validate_move_from_num_lit (cb_tree src, cb_tree dst, const unsigned int is_valu || fdst->usage == CB_USAGE_COMP_X || fdst->usage == CB_USAGE_COMP_N || fdst->usage == CB_USAGE_BINARY))) { - + cob_s64_t val; i = l->size - leftmost_significant; if (i <= 19) { val = cb_get_long_long (src); diff --git a/tests/testsuite.src/listings.at b/tests/testsuite.src/listings.at index 80f24ef4e..0faf9e6f3 100644 --- a/tests/testsuite.src/listings.at +++ b/tests/testsuite.src/listings.at @@ -94,9 +94,7 @@ AT_DATA([prog.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_LISTING0 -t prog.lst prog.cob], [0], [], []) - -AT_DATA([expected.lst], +AT_CHECK([$COMPILE_LISTING0 -t- prog.cob], [0], [GnuCOBOL V.R.P prog.cob LINE PG/LN A...B............................................................ @@ -115,8 +113,6 @@ LINE PG/LN A...B............................................................ 0 errors in compilation group ]) -AT_CHECK([diff expected.lst prog.lst], [0], [], []) - AT_DATA([prog2.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog2. @@ -2055,9 +2051,7 @@ AT_DATA([prog.cob], [ END FUNCTION WITHPAR. ]) -AT_CHECK([$COBC $LISTING_FLAGS -q -fsyntax-only -t prog.lst -fno-theader -ftcmd prog.cob], [0], [], []) - -AT_DATA([reference.lst], +AT_CHECK([$COBC $LISTING_FLAGS -q -fsyntax-only -t- -fno-theader -ftcmd prog.cob], [0], [ 000001 000002 IDENTIFICATION DIVISION. @@ -2070,16 +2064,14 @@ AT_DATA([reference.lst], 000009 ADD 1 TO PAR-IN GIVING PAR-OUT END-ADD. 000010 GOBACK. 000011 END FUNCTION WITHPAR. - + @&t@ command line: cobc -std=default -fdiagnostics-plain-output -fttitle=GnuCOBOL_V.R.P -+ -fno-ttimestamp -q -fsyntax-only -t prog.lst -fno-theader -ftcmd prog.cob ++ -fno-ttimestamp -q -fsyntax-only -t- -fno-theader -ftcmd prog.cob 0 warnings in compilation group 0 errors in compilation group ]) -# TODO: we don't perform any comparison here between prog.lst and reference.lst. Why ? - AT_CHECK([$COBC $LISTING_FLAGS -q -std=default -Wall -fno-tmessages -fsyntax-only -t- -fno-tsymbols -ftcmd prog.cob], [0], [GnuCOBOL V.R.P prog.cob Page 0001 diff --git a/tests/testsuite.src/syn_copy.at b/tests/testsuite.src/syn_copy.at index 9fbb52f4c..0ac0784b2 100644 --- a/tests/testsuite.src/syn_copy.at +++ b/tests/testsuite.src/syn_copy.at @@ -921,24 +921,16 @@ AT_CLEANUP AT_SETUP([COPY and REPLACE in same file]) -AT_KEYWORDS([copy]) +AT_KEYWORDS([replacing preprocess]) -# see Bug #868 +# See Bug #831 # the issue with this example is that the outer REPLACE # _could_ only see the result of the inner REPLACING: # "COLON", but needs to see "VAR-COLON". -# To even enable it to see the replaced data in the outer -# replacings pplex.l (ppecho_replace) must be changed to not -# output the results with a call to (ppecho_direct) but has to -# continue the loop with the - potential partially replaced - -# new content. - -AT_XFAIL_IF([true]) AT_DATA([copy.inc], [ 01 VAR-:TEST: PIC X(2) VALUE "OK". ]) - AT_DATA([prog.cob], [ IDENTIFICATION DIVISION. PROGRAM-ID. prog. @@ -954,6 +946,129 @@ AT_DATA([prog.cob], [ REPLACE OFF. ]) +AT_CHECK([$COMPILE_ONLY -P- prog.cob], [0], +[ 1 @&t@ + 2 IDENTIFICATION DIVISION. + 3 PROGRAM-ID. prog. + 4 DATA DIVISION. + 5 WORKING-STORAGE SECTION. + 6 @&t@ + 7 @&t@ + 8 @&t@ + 9 01 VAR-COMMA PIC X(2) VALUE "OK". + 10 @&t@ + 11 PROCEDURE DIVISION. + 12 DISPLAY VAR-COMMA NO ADVANCING + 13 END-DISPLAY. + 14 STOP RUN. + 15 @&t@ + +]) + +AT_CHECK([$COMPILE_LISTING -t- prog.cob], [0], +[GnuCOBOL V.R.P prog.cob Page 0001 + +LINE PG/LN A...B............................................................ + +000001 +000002 IDENTIFICATION DIVISION. +000003 PROGRAM-ID. prog. +000004 DATA DIVISION. +000005 WORKING-STORAGE SECTION. +000006 REPLACE ==VAR-COLON== BY ==VAR-COMMA==. +000007 COPY "copy.inc" +000001C +000002C 01 VAR-:TEST: PIC X(2) VALUE "OK". +000007 REPLACING ==:TEST:== BY ==COLON==. +000008 PROCEDURE DIVISION. +000009 DISPLAY VAR-COMMA NO ADVANCING +000010 END-DISPLAY. +000011 STOP RUN. +000012 REPLACE OFF. + + +0 warnings in compilation group +0 errors in compilation group +]) + +AT_CLEANUP + + +AT_SETUP([COPY and REPLACE errors]) +AT_KEYWORDS([copy]) + +AT_DATA([copy.inc], [ + 05 VAR PIC XX. +]) + +# see Bug #890 - the buffer for the copybook was switched +# already before parsing the DOT; additional the error did +# not stopped at the DOT, so there was max. one error printed + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + COPY "copy.inc" A. + COPY "copy.inc" ==A== BY B. + COPY "copy.inc" REPLACING. + COPY "copy.inc" REPLACING ABC. + COPY "copy.inc" REPLACING 'POST' IN. + COPY "copy.inc" REPLACING 'POST' BY BY. + COPY "copy.inc" + REPLACING ==some-name== BY ==other-name== + REPLACING "some lit" BY "other literal". + COPY "copy.inc". + PROCEDURE DIVISION. + STOP RUN. +]) + +AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], +[prog.cob:6: error: syntax error, unexpected Word or Literal, expecting . +prog.cob:7: error: syntax error, unexpected ==, expecting . +prog.cob:8: error: syntax error, unexpected ., expecting == or LEADING or TRAILING or Word or Literal +prog.cob:9: error: syntax error, unexpected ., expecting BY +prog.cob:10: error: syntax error, unexpected ., expecting Word or Literal +prog.cob:11: error: syntax error, unexpected BY, expecting == or IN or OF or Word or Literal +prog.cob:14: error: syntax error, unexpected REPLACING, expecting . +copy.inc:2: error: level number must begin with 01 or 77 +]) + +AT_CLEANUP + + +AT_SETUP([COPY and REPLACE with reserved words]) +AT_KEYWORDS([copy]) + +# see Bug #23 +AT_DATA([copy.inc], [ + 05 WS-'POST' PIC XX. + 05 'POST'-A PIC XX. + 05 'POST'-WS PIC XX. +]) +AT_DATA([proc.inc], [ + DISPLAY VAR VAR-2 +]) + +AT_DATA([prog.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INPUT-REC. + COPY "copy.inc" + REPLACING 'POST' BY IN. + PROCEDURE DIVISION. + DISPLAY WS-IN IN-A IN-WS NO ADVANCING. + IF WS-IN EQUALS IN-A + COPY "proc.inc" + REPLACING VAR BY IN-A IN INPUT-REC + ==VAR-2== BY ==IN-WS (1:1)==. + END-IF. + STOP RUN. +]) + AT_CHECK([$COMPILE_ONLY prog.cob], [0], [], []) -AT_CLEANUP \ No newline at end of file +AT_CLEANUP diff --git a/tests/testsuite.src/syn_definition.at b/tests/testsuite.src/syn_definition.at index 32db8e3b7..2cb6db9f0 100644 --- a/tests/testsuite.src/syn_definition.at +++ b/tests/testsuite.src/syn_definition.at @@ -313,12 +313,16 @@ AT_DATA([prog.cob], [ AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:11: error: syntax error, unexpected Identifier +prog.cob:11: error: WHEN without imperative statement prog.cob:16: error: syntax error, unexpected Identifier prog.cob:24: error: syntax error, unexpected Literal +prog.cob:24: error: WHEN without imperative statement prog.cob:30: error: syntax error, unexpected Identifier +prog.cob:30: error: WHEN without imperative statement prog.cob:36: error: 'NOT-DEFINED' is not defined prog.cob:42: error: syntax error, unexpected ELSE prog.cob:42: error: syntax error, unexpected Identifier +prog.cob:42: error: WHEN without imperative statement prog.cob:42: error: incomplete expression prog.cob:47: error: 'broken' is not defined ]) diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index d4653aa6f..89f269653 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -3371,6 +3371,7 @@ AT_CHECK([$COMPILE_ONLY -std=cobol85 prog.cob], [1], [], prog.cob: in paragraph 'MAIN': prog.cob:10: error: start of statement in Area A prog.cob:11: error: start of statement in Area A +prog.cob:13: error: END-IF should not start in Area A prog.cob:14: error: start of statement in Area A prog.cob:15: error: separator period in Area A prog.cob: in section 'SEC-1': @@ -4253,20 +4254,17 @@ AT_DATA([prog.cob], [ 'callee' WITH C LINKAGE . - GOBACK. + STOP RUN. ]) AT_CHECK([$COMPILE_ONLY prog.cob], [1], [], [prog.cob:10: error: CALL-CONVENTION and WITH LINKAGE are mutually exclusive ]) -# GOBACK does not belong to COBOL85 reserved words; the last line is -# therefore an empty paragraph that does not start in Area A AT_CHECK([$COMPILE_ONLY -std=cobol85 -freserved=EXTERN,C prog.cob], [1], [], [prog.cob:5: error: CALL-/ENTRY-CONVENTION does not conform to COBOL 85 prog.cob:6: error: WITH ... LINKAGE does not conform to COBOL 85 prog.cob:8: error: CALL-/ENTRY-CONVENTION does not conform to COBOL 85 prog.cob:10: error: WITH ... LINKAGE does not conform to COBOL 85 prog.cob:10: error: CALL-CONVENTION and WITH LINKAGE are mutually exclusive -prog.cob:12: error: 'GOBACK' should start in Area A ]) AT_CLEANUP @@ -5371,6 +5369,7 @@ AT_CHECK([$COMPILE_ONLY -fdiagnostics-show-option prog.cob], [1], [], [[prog.cob:11: warning: expression '115' LESS THAN '16' is always FALSE [-Wconstant-numlit-expression] prog.cob:13: warning: offset must be greater than zero [-Wignored-error] prog.cob:14: error: syntax error, unexpected IF +prog.cob:14: error: IF without imperative statement ]]) AT_CLEANUP @@ -5542,26 +5541,26 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE_ONLY -w -fmissing-statement=error prog.cob], [1], [], -[prog.cob:18: error: IF without imperative statement used -prog.cob:23: error: IF without imperative statement used -prog.cob:32: error: IF without imperative statement used -prog.cob:33: error: IF without imperative statement used -prog.cob:39: error: WHEN OTHER without imperative statement used +[prog.cob:15: error: IF without imperative statement used +prog.cob:20: error: IF without imperative statement used +prog.cob:27: error: IF without imperative statement used +prog.cob:25: error: IF without imperative statement used +prog.cob:38: error: WHEN OTHER without imperative statement used prog.cob:42: error: inline PERFORM without imperative statement used prog.cob:47: error: WHEN without imperative statement used -prog.cob:53: error: WHEN OTHER without imperative statement used +prog.cob:52: error: WHEN OTHER without imperative statement used prog.cob:58: error: WHEN without imperative statement used ]) AT_CHECK([$COMPILE_ONLY -fno-constant-folding -fmissing-statement=warning prog.cob], [0], [], -[prog.cob:18: warning: IF without imperative statement used -prog.cob:23: warning: IF without imperative statement used -prog.cob:32: warning: IF without imperative statement used -prog.cob:33: warning: IF without imperative statement used -prog.cob:39: warning: WHEN OTHER without imperative statement used +[prog.cob:15: warning: IF without imperative statement used +prog.cob:20: warning: IF without imperative statement used +prog.cob:27: warning: IF without imperative statement used +prog.cob:25: warning: IF without imperative statement used +prog.cob:38: warning: WHEN OTHER without imperative statement used prog.cob:42: warning: inline PERFORM without imperative statement used prog.cob:47: warning: WHEN without imperative statement used -prog.cob:53: warning: WHEN OTHER without imperative statement used +prog.cob:52: warning: WHEN OTHER without imperative statement used prog.cob:58: warning: WHEN without imperative statement used ]) @@ -7863,7 +7862,12 @@ AT_CLEANUP AT_SETUP([AREACHECK / NOAREACHECK directives]) -AT_KEYWORDS([misc directive]) +AT_KEYWORDS([misc directive CONTINUE]) + + # note: the following does an _extra_ check for the CONTINUE + # statement, as this internally is post-created (= on the next token) + # and therefore keeps its starting position "extra", + # see parser.y (begin_statement_at_tree_pos) AT_DATA([prog.cob], [ $SET NO-AREA-CHECK @@ -7876,19 +7880,23 @@ AT_DATA([prog.cob], [ DISPLAY "SOMETHING". $SET AREA-CHECK MAIN-2 SECTION. + CONTINUE. + CONTINUE. DISPLAY "SOMETHING ELSE" STOP RUN. ]) AT_CHECK([$COMPILE_ONLY -std=cobol85 prog.cob], [1], [], [prog.cob: in section 'MAIN-2': -prog.cob:12: error: start of statement in Area A prog.cob:13: error: start of statement in Area A +prog.cob:14: error: start of statement in Area A +prog.cob:15: error: start of statement in Area A ]) AT_CHECK([$COMPILE_ONLY -std=cobol85 -frelax-syntax-checks prog.cob], [0], [], [prog.cob: in section 'MAIN-2': -prog.cob:12: warning: start of statement in Area A prog.cob:13: warning: start of statement in Area A +prog.cob:14: warning: start of statement in Area A +prog.cob:15: warning: start of statement in Area A ]) AT_CLEANUP