From 3c0110a6cacb49f5acb7ee6dc32abe03fdc59e4e Mon Sep 17 00:00:00 2001 From: David Declerck Date: Thu, 11 Jul 2024 17:23:55 +0200 Subject: [PATCH] Merge SVN 4712 --- cobc/ChangeLog | 13 +++ cobc/config.def | 8 +- cobc/error.c | 116 ++++++++++++++++++---- cobc/field.c | 12 +-- cobc/parser.y | 126 ++++++++++------------- cobc/pplex.l | 17 ---- cobc/scanner.l | 2 +- cobc/tree.h | 2 + cobc/typeck.c | 15 +-- doc/gnucobol.texi | 10 +- tests/testsuite.src/syn_misc.at | 160 +++++++++++++++++++----------- tests/testsuite.src/syn_occurs.at | 2 +- tests/testsuite.src/syn_screen.at | 30 ++++-- 13 files changed, 303 insertions(+), 210 deletions(-) diff --git a/cobc/ChangeLog b/cobc/ChangeLog index 458977bc3..75bfac62e 100644 --- a/cobc/ChangeLog +++ b/cobc/ChangeLog @@ -227,6 +227,19 @@ to clear_local_codegen_vars * cobc.c: ask user for reporting reallocation memory issues +2022-09-26 Nicolas Berthier + + * error.c (cb_syntax_check, cb_syntax_check_x): add variants of + cb_{error,warning}[_x] functions with explicit va_list, and new helper + functions to dispach to errors or warnings w.r.t + cb_relaxed_syntax_checks + * scanner.l, parser.l: make Area A enforcement raise errors instead of + warnings on strict dialects + * parser.y: add missing Area A check on SELECT and CD + * parser.y, typeck.c: simplify some uses of cb_relaxed_syntax_checks + * pplex.l: drop `>>(NO)AREACHECK` directives + * config.def: improve documentation for areacheck option + 2022-09-20 Simon Sobisch * parser.y (examine_format_variant): fix compiler warning diff --git a/cobc/config.def b/cobc/config.def index 187378668..4766b96c4 100644 --- a/cobc/config.def +++ b/cobc/config.def @@ -199,8 +199,12 @@ CB_CONFIG_BOOLEAN (cb_xml_parse_xmlss, "xml-parse-xmlss", "XML PARSE XMLSS") CB_CONFIG_BOOLEAN (cb_areacheck, "areacheck", - _("check contents of Area A in PROCEDURE DIVISION " - "(when reference format supports Area A enforcement)")) + _("check contents of Area A (when reference format supports Area A enforcement),\n" + " enabled checks include:\n" + " * division, section, paragraph names, level indicators (FD, SD, RD, and CD),\n" + " and toplevel numbers (01 and 77) must start in Area A;\n" + " * statements must not start in Area A; and\n" + " * separator periods must not be within Area A.")) /* Support flags */ diff --git a/cobc/error.c b/cobc/error.c index 15931aab7..a659f5cf7 100644 --- a/cobc/error.c +++ b/cobc/error.c @@ -189,7 +189,7 @@ cb_get_strerror (void) /* set the value for "ignore errors because instruction is in a constant FALSE path which gets no codegen at all" - if state is -1, don't set the value + if state is -1, don't set the value returns the value which was active on call */ @@ -203,7 +203,7 @@ cb_set_ignore_error (int state) return prev; } -void +void cb_add_error_to_listing (const char *file, int line, const char *prefix, char *errmsg) { @@ -342,23 +342,20 @@ static char *warning_option_text (const enum cb_warn_opt opt, const enum cb_warn return warning_option_buff; } -enum cb_warn_val -cb_warning (const enum cb_warn_opt opt, const char *fmt, ...) +static enum cb_warn_val +cb_warning_internal (const enum cb_warn_opt opt, const char *fmt, va_list ap) { const enum cb_warn_val pref = cb_warn_opt_val[opt]; - va_list ap; if (pref == COBC_WARN_DISABLED) { return pref; } - va_start (ap, fmt); if (pref != COBC_WARN_AS_ERROR) { print_error (NULL, 0, _("warning: "), fmt, ap, warning_option_text (opt, pref)); } else { print_error (NULL, 0, _("error: "), fmt, ap, warning_option_text (opt, pref)); } - va_end (ap); if (sav_lst_file) { return pref; @@ -373,6 +370,17 @@ cb_warning (const enum cb_warn_opt opt, const char *fmt, ...) return pref; } +enum cb_warn_val +cb_warning (const enum cb_warn_opt opt, const char *fmt, ...) +{ + enum cb_warn_val ret; + va_list ap; + va_start (ap, fmt); + ret = cb_warning_internal (opt, fmt, ap); + va_end (ap); + return ret; +} + void cb_error_always (const char *fmt, ...) { @@ -392,13 +400,12 @@ cb_error_always (const char *fmt, ...) } /* raise error (or warning if current branch is not generated) */ -enum cb_warn_val -cb_error (const char *fmt, ...) +static enum cb_warn_val +cb_error_internal (const char *fmt, va_list ap) { const enum cb_warn_opt opt = cb_warn_ignored_error; const enum cb_warn_val pref = cb_warn_opt_val[opt]; enum cb_warn_val ret = pref; - va_list ap; cobc_in_repository = 0; @@ -406,7 +413,6 @@ cb_error (const char *fmt, ...) return pref; } - va_start (ap, fmt); if (!ignore_error) { print_error (NULL, 0, _("error: "), fmt, ap, NULL); ret = COBC_WARN_AS_ERROR; @@ -415,7 +421,6 @@ cb_error (const char *fmt, ...) } else { print_error (NULL, 0, _("warning: "), fmt, ap, warning_option_text (opt, pref)); } - va_end (ap); if (sav_lst_file) { return ret; @@ -430,6 +435,17 @@ cb_error (const char *fmt, ...) return ret; } +enum cb_warn_val +cb_error (const char *fmt, ...) +{ + enum cb_warn_val ret; + va_list ap; + va_start (ap, fmt); + ret = cb_error_internal (fmt, ap); + va_end (ap); + return ret; +} + void cb_perror (const int config_error, const char *fmt, ...) { @@ -611,21 +627,18 @@ configuration_error (const char *fname, const int line, } /* Generic warning/error routines */ -enum cb_warn_val -cb_warning_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...) +static enum cb_warn_val +cb_warning_x_internal (const enum cb_warn_opt opt, cb_tree x, const char *fmt, va_list ap) { - va_list ap; const enum cb_warn_val pref = cb_warn_opt_val[opt]; if (pref == COBC_WARN_DISABLED) { return pref; } - va_start (ap, fmt); print_error (x->source_file, x->source_line, pref == COBC_WARN_AS_ERROR ? _("error: ") : _("warning: "), fmt, ap, warning_option_text (opt, pref)); - va_end (ap); if (sav_lst_file) { return pref; @@ -640,6 +653,17 @@ cb_warning_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...) return pref; } +enum cb_warn_val +cb_warning_x (const enum cb_warn_opt opt, cb_tree x, const char *fmt, ...) +{ + enum cb_warn_val ret; + va_list ap; + va_start (ap, fmt); + ret = cb_warning_x_internal (opt, x, fmt, ap); + va_end (ap); + return ret; +} + /* raise a warning (or error, or nothing) depending on a dialect option */ enum cb_warn_val cb_warning_dialect_x (const enum cb_support tag, cb_tree x, const char *fmt, ...) @@ -748,10 +772,9 @@ cb_note (const enum cb_warn_opt opt, const int suppress_listing, const char *fmt } } -enum cb_warn_val -cb_error_x (cb_tree x, const char *fmt, ...) +static enum cb_warn_val +cb_error_x_internal (cb_tree x, const char *fmt, va_list ap) { - va_list ap; const enum cb_warn_opt opt = cb_warn_ignored_error; const enum cb_warn_val pref = cb_warn_opt_val[opt]; enum cb_warn_val ret = COBC_WARN_AS_ERROR; @@ -760,7 +783,6 @@ cb_error_x (cb_tree x, const char *fmt, ...) return COBC_WARN_DISABLED; } - va_start (ap, fmt); if (!ignore_error) { print_error (x->source_file, x->source_line, _("error: "), fmt, ap, NULL); @@ -772,7 +794,6 @@ cb_error_x (cb_tree x, const char *fmt, ...) fmt, ap, warning_option_text (opt, pref)); ret = COBC_WARN_ENABLED; } - va_end (ap); if (sav_lst_file) { return ret; @@ -787,6 +808,57 @@ cb_error_x (cb_tree x, const char *fmt, ...) return ret; } +enum cb_warn_val +cb_error_x (cb_tree x, const char *fmt, ...) +{ + enum cb_warn_val ret; + va_list ap; + va_start (ap, fmt); + ret = cb_error_x_internal (x, fmt, ap); + va_end (ap); + return ret; +} + +/** + * dispatches the given message as a warning if cb_relaxed_syntax_checks holds, + * as an error otherwise + * + * \return 1 if the message is dispatched to a non-ignored warning, 0 otherwise + */ +unsigned int +cb_syntax_check (const char *fmt, ...) +{ + enum cb_warn_val ret; + va_list ap; + va_start (ap, fmt); + if (cb_relaxed_syntax_checks) + ret = cb_warning_internal (COBC_WARN_FILLER, fmt, ap); + else + ret = cb_error_internal (fmt, ap); + va_end (ap); + return cb_relaxed_syntax_checks ? ret != COBC_WARN_DISABLED : 0; +} + +/** + * dispatches the given tree and message to cb_warning_x if + * cb_relaxed_syntax_checks holds, to cb_error_x otherwise + * + * \return 1 if the message is dispatched to a non-ignored warning, 0 otherwise + */ +unsigned int +cb_syntax_check_x (cb_tree x, const char *fmt, ...) +{ + enum cb_warn_val ret; + va_list ap; + va_start (ap, fmt); + if (cb_relaxed_syntax_checks) + ret = cb_warning_x_internal (COBC_WARN_FILLER, x, fmt, ap); + else + ret = cb_error_x_internal (x, fmt, ap); + va_end (ap); + return cb_relaxed_syntax_checks ? ret != COBC_WARN_DISABLED : 0; +} + /** * verify if the given compiler option is supported by the current std/configuration * \param x tree whose position is used for raising warning/errors diff --git a/cobc/field.c b/cobc/field.c index 743b2fccd..959e4e7a0 100644 --- a/cobc/field.c +++ b/cobc/field.c @@ -830,18 +830,10 @@ copy_into_field_recursive (struct cb_field *source, struct cb_field *target, /* note: same message in parser.y */ -static int +static void duplicate_clause_message (cb_tree x, const char *clause) { - /* FIXME: replace by a new warning level that is set - to warn/error depending on cb_relaxed_syntax_checks */ - if (cb_relaxed_syntax_checks) { - cb_warning_x (COBC_WARN_FILLER, x, _("duplicate %s clause"), clause); - return 0; - } - - cb_error_x (x, _("duplicate %s clause"), clause); - return 1; + (void) cb_syntax_check_x (x, _("duplicate %s clause"), clause); } void diff --git a/cobc/parser.y b/cobc/parser.y index b8ba7cb6b..be73c3158 100644 --- a/cobc/parser.y +++ b/cobc/parser.y @@ -316,15 +316,17 @@ static int backup_source_line = 0; /* Area A enforcement */ static COB_INLINE void -check_area_a (cb_tree stmt) { +check_area_a (cb_tree word) { if (!cobc_in_area_a && cobc_areacheck) { - if (stmt) - cb_warning_x (COBC_WARN_FILLER, stmt, - _("'%s' should start in Area A"), - CB_NAME (stmt)); - else - cb_warning (COBC_WARN_FILLER, - _("statement should start in Area A")); + (void) cb_syntax_check_x (word, _("'%s' should start in Area A"), + CB_NAME (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); } } @@ -332,11 +334,9 @@ static COB_INLINE void check_non_area_a (cb_tree stmt) { if (cobc_in_area_a && cobc_areacheck) { if (stmt) - cb_warning_x (COBC_WARN_FILLER, stmt, - _("start of statement in Area A")); + (void) cb_syntax_check_x (stmt, _("start of statement in Area A")); else - cb_warning (COBC_WARN_FILLER, - _("start of statement in Area A")); + (void) cb_syntax_check (_("start of statement in Area A")); } } @@ -663,14 +663,7 @@ setup_use_file (struct cb_file *fileptr) static int emit_duplicate_clause_message (const char *clause) { - /* FIXME: replace by a new warning level that is set - to warn/error depending on cb_relaxed_syntax_checks */ - if (cb_relaxed_syntax_checks) { - cb_warning (COBC_WARN_FILLER, _("duplicate %s clause"), clause); - return 0; - } - cb_error (_("duplicate %s clause"), clause); - return 1; + return cb_syntax_check (_("duplicate %s clause"), clause); } static int @@ -687,14 +680,9 @@ check_repeated (const char *clause, const cob_flags_t bitval, static void emit_conflicting_clause_message (const char *clause, const char *conflicting) { - if (cb_relaxed_syntax_checks) { - cb_warning (COBC_WARN_FILLER, _("cannot specify both %s and %s; %s is ignored"), - clause, conflicting, clause); - } else { - cb_error (_("cannot specify both %s and %s"), - clause, conflicting); + if (cb_syntax_check (_("cannot specify both %s and %s"), clause, conflicting)) { + cb_note (COBC_WARN_FILLER, 0, _("%s is ignored"), clause); } - } @@ -741,12 +729,10 @@ setup_occurs_min_max (cb_tree occurs_min, cb_tree occurs_max) if (occurs_max != cb_int0) { current_field->occurs_max = cb_get_int (occurs_max); if (!current_field->depending) { - if (cb_relaxed_syntax_checks) { - cb_warning (COBC_WARN_FILLER, _("TO phrase without DEPENDING phrase")); - cb_warning (COBC_WARN_FILLER, _("maximum number of occurrences assumed to be exact number")); + if (cb_syntax_check (_("TO phrase without DEPENDING phrase"))) { + cb_note (COBC_WARN_FILLER, 0, + _("maximum number of occurrences assumed to be exact number")); current_field->occurs_min = 1; /* CHECKME: why using 1 ? */ - } else { - cb_error (_("TO phrase without DEPENDING phrase")); } } if (current_field->occurs_max <= current_field->occurs_min) { @@ -824,10 +810,8 @@ check_relaxed_syntax (const cob_flags_t lev) break; /* LCOV_EXCL_STOP */ } - if (cb_relaxed_syntax_checks) { - cb_warning (COBC_WARN_FILLER, _("%s header missing - assumed"), s); - } else { - cb_error (_("%s header missing"), s); + if (cb_syntax_check (_("%s header missing"), s)) { + cb_note (COBC_WARN_FILLER, 0, _("%s header assumed"), s); } } @@ -3476,7 +3460,7 @@ end_program_list: end_program: END_PROGRAM { - check_area_a ($1); + check_area_a_of ("END PROGRAM"); backup_current_pos (); } end_program_name _dot @@ -3593,7 +3577,7 @@ function_prototype: _prototype_procedure_division_header: /* empty */ -| PROCEDURE { check_area_a ($1); } +| PROCEDURE { check_area_a_of ("PROCEDURE DIVISION"); } DIVISION _procedure_using_chaining _procedure_returning _dot { cb_validate_parameters_and_returning (current_program, $4); @@ -3605,7 +3589,7 @@ _prototype_procedure_division_header: /* CONTROL DIVISION (GCOS extension) */ -control: CONTROL { check_area_a ($1); }; +control: CONTROL { check_area_a_of ("CONTROL DIVISION"); }; _control_division: /* empty */ | control DIVISION _dot @@ -3617,7 +3601,7 @@ _control_division: _default_section: /* empty */ -| DEFAULT { check_area_a ($1); } +| DEFAULT { check_area_a_of ("DEFAULT SECTION"); } SECTION TOK_DOT _default_clauses { @@ -3676,7 +3660,7 @@ _identification_header: ; identification_header: - identification_or_id { check_area_a ($1); } + identification_or_id { check_area_a_of ("IDENTIFICATION DIVISION"); } DIVISION _dot { setup_program_start (); @@ -3949,7 +3933,7 @@ _environment_header: | environment_header ; -environment: ENVIRONMENT { check_area_a ($1); }; +environment: ENVIRONMENT { check_area_a_of ("ENVIRONMENT DIVISION"); }; environment_header: environment DIVISION _dot { @@ -3968,7 +3952,7 @@ _configuration_header: | configuration_header ; -configuration: CONFIGURATION { check_area_a ($1); }; +configuration: CONFIGURATION { check_area_a_of ("CONFIGURATION SECTION"); }; configuration_header: configuration SECTION _dot { @@ -5102,7 +5086,7 @@ _input_output_section: _i_o_control ; -input_output: INPUT_OUTPUT { check_area_a ($1); }; +input_output: INPUT_OUTPUT { check_area_a_of ("INPUT-OUTPUT SECTION"); }; _input_output_header: | input_output SECTION _dot { @@ -5127,7 +5111,8 @@ _file_control_sequence: ; file_control_entry: - SELECT flag_optional undefined_word + SELECT { check_non_area_a ($1); } + flag_optional undefined_word { char buff[COB_MINI_BUFF]; @@ -5135,10 +5120,10 @@ file_control_entry: COBC_HD_INPUT_OUTPUT_SECTION, COBC_HD_FILE_CONTROL, 0); check_duplicate = 0; - if (CB_VALID_TREE ($3)) { + if (CB_VALID_TREE ($4)) { /* Build new file */ - current_file = build_file ($3); - current_file->optional = CB_INTEGER ($2)->val; + current_file = build_file ($4); + current_file->optional = CB_INTEGER ($3)->val; /* Add file to current program list */ CB_ADD_TO_CHAIN (CB_TREE (current_file), @@ -5157,7 +5142,7 @@ file_control_entry: _select_clauses_or_error { cobc_cs_check = 0; - if (CB_VALID_TREE ($3)) { + if (CB_VALID_TREE ($4)) { if (current_file->organization == COB_ORG_INDEXED && key_type == RELATIVE_KEY) { cb_error_x (current_file->key, @@ -5168,7 +5153,7 @@ file_control_entry: _("cannot use RECORD KEY clause on RELATIVE files")); } - validate_file (current_file, $3); + validate_file (current_file, $4); if (cb_keycompress_pend > 0) { cb_keycompress = cb_keycompress_ready; cb_keycompress_pend = 0; @@ -6220,7 +6205,7 @@ _data_division_header: | data_division_header ; -data: DATA { check_area_a ($1); }; +data: DATA { check_area_a_of ("DATA DIVISION"); }; data_division_header: data DIVISION _dot { @@ -6231,7 +6216,7 @@ data_division_header: /* FILE SECTION */ -tok_file: TOK_FILE { check_area_a ($1); }; +tok_file: TOK_FILE { check_area_a_of ("FILE SECTION"); }; _file_section_header: | tok_file SECTION _dot { @@ -6298,12 +6283,12 @@ file_description_entry: file_type: FD { - check_area_a ($1); + check_area_a_of ("FD"); $$ = cb_int0; } | SD { - check_area_a ($1); + check_area_a_of ("SD"); $$ = cb_int1; } ; @@ -6652,7 +6637,7 @@ rep_name_list: /* COMMUNICATION SECTION */ -communication: COMMUNICATION { check_area_a ($1); }; +communication: COMMUNICATION { check_area_a_of ("COMMUNICATION SECTION"); }; _communication_section: | communication SECTION _dot { @@ -6692,8 +6677,9 @@ communication_description: /* File description entry */ +cd: CD { check_area_a_of ("CD"); }; communication_description_entry: - CD undefined_word + cd undefined_word { /* CD internally defines a new file */ if (CB_VALID_TREE ($2)) { @@ -6800,7 +6786,7 @@ unnamed_i_o_cd_clauses: /* WORKING-STORAGE SECTION */ -working_storage: WORKING_STORAGE { check_area_a ($1); }; +working_storage: WORKING_STORAGE { check_area_a_of ("WORKING-STORAGE SECTION"); }; _working_storage_section: | working_storage SECTION _dot { @@ -6886,7 +6872,6 @@ level_number: switch (level) { case 1: case 77: - case 78: check_area_a ($2); break; default: @@ -8118,11 +8103,7 @@ _occurs_keys_and_indexed: | occurs_keys occurs_indexed | occurs_indexed { - if (!cb_relaxed_syntax_checks) { - cb_error (_("INDEXED should follow ASCENDING/DESCENDING")); - } else { - cb_warning (cb_warn_additional, _("INDEXED should follow ASCENDING/DESCENDING")); - } + (void) cb_syntax_check (_("INDEXED should follow ASCENDING/DESCENDING")); } occurs_keys | occurs_indexed @@ -8528,7 +8509,7 @@ identified_by_clause: /* LOCAL-STORAGE SECTION */ -local_storage: LOCAL_STORAGE { check_area_a ($1); }; +local_storage: LOCAL_STORAGE { check_area_a_of ("LOCAL-STORAGE SECTION"); }; _local_storage_section: | local_storage SECTION _dot { @@ -8552,7 +8533,7 @@ _local_storage_section: /* LINKAGE SECTION */ -linkage: LINKAGE { check_area_a ($1); }; +linkage: LINKAGE { check_area_a_of ("LINKAGE SECTION"); }; _linkage_section: | linkage SECTION _dot { @@ -8571,7 +8552,7 @@ _linkage_section: /* REPORT SECTION */ _report_section: -| REPORT { check_area_a ($1); } +| REPORT { check_area_a_of ("REPORT SECTION"); } SECTION _dot { header_check |= COBC_HD_REPORT_SECTION; @@ -8590,7 +8571,7 @@ _report_description_sequence: /* RD report description */ report_description: - RD { check_area_a ($1); } + RD { check_area_a_of ("RD"); } report_name { if (CB_INVALID_TREE ($3)) { @@ -9345,7 +9326,7 @@ group_indicate_clause: /* SCREEN SECTION */ _screen_section: -| SCREEN { check_area_a ($1); } +| SCREEN { check_area_a_of ("SCREEN SECTION"); } SECTION _dot { cobc_cs_check = CB_CS_SCREEN; @@ -10468,7 +10449,7 @@ _procedure_division: ; procedure_division: - PROCEDURE { check_area_a ($1); } + PROCEDURE { check_area_a_of ("PROCEDURE DIVISION"); } DIVISION { current_section = NULL; @@ -10800,16 +10781,13 @@ _procedure_returning: _procedure_declaratives: | DECLARATIVES { - check_area_a ($1); /* "DECLARATIVES" should be in Area A */ + check_area_a_of ("DECLARATIVES"); in_declaratives = 1; emit_statement (cb_build_comment ("DECLARATIVES")); } _dot_or_else_area_a _procedure_list - END - { - check_area_a ($5); /* "END" should be in Area A */ - } + END { check_area_a_of ("END DECLARATIVES"); } DECLARATIVES { if (needs_field_debug) { diff --git a/cobc/pplex.l b/cobc/pplex.l index 04fc6b607..ce5662f66 100644 --- a/cobc/pplex.l +++ b/cobc/pplex.l @@ -331,23 +331,6 @@ MAYBE_AREA_A [ ]?#? return CALL_DIRECTIVE; } -^{MAYBE_AREA_A}[ ]*">>"[ ]?"AREACHECK" | -^{MAYBE_AREA_A}[ ]*">>"[ ]?"AREA-CHECK" { - if (cobc_has_areacheck_directive ("AREACHECK")) { - fprintf (ppout, "#AREACHECK\n"); - } - skip_to_eol (); -} - -^{MAYBE_AREA_A}[ ]*">>"[ ]?"NOAREACHECK" | -^{MAYBE_AREA_A}[ ]*">>"[ ]?"NO-AREACHECK" | -^{MAYBE_AREA_A}[ ]*">>"[ ]?"NO-AREA-CHECK" { - if (cobc_has_areacheck_directive ("NOAREACHECK")) { - fprintf (ppout, "#NOAREACHECK\n"); - } - skip_to_eol (); -} - ^{MAYBE_AREA_A}[ ]*">>"[ ]*\n { /* empty 2002+ style directive */ cb_plex_warning (COBC_WARN_FILLER, newline_count, diff --git a/cobc/scanner.l b/cobc/scanner.l index c8627b756..9978afd33 100644 --- a/cobc/scanner.l +++ b/cobc/scanner.l @@ -351,7 +351,7 @@ AREA_A \n"#AREA_A"\n <*>^{AREA_A}[ ]*/"." { count_lines (yytext + 9); /* skip "\n#area_a\n" */ if (cobc_in_procedure && cobc_areacheck) { - cb_warning (COBC_WARN_FILLER, _("separator period in Area A")); + (void) cb_syntax_check (_("separator period in Area A")); } } diff --git a/cobc/tree.h b/cobc/tree.h index 1d231742e..240fbfa72 100644 --- a/cobc/tree.h +++ b/cobc/tree.h @@ -2208,6 +2208,8 @@ extern void cb_note (const enum cb_warn_opt, const int, const char *, ...) COB_ extern void cb_inclusion_note (const char *, int); extern char *cb_get_qualified_name (const struct cb_reference *); extern enum cb_warn_val cb_error_x (cb_tree, const char *, ...) COB_A_FORMAT23; +extern unsigned int cb_syntax_check (const char *, ...) COB_A_FORMAT12; +extern unsigned int cb_syntax_check_x (cb_tree, const char *, ...) COB_A_FORMAT23; extern unsigned int cb_verify (const enum cb_support, const char *); extern unsigned int cb_verify_x (const cb_tree, const enum cb_support, const char *); diff --git a/cobc/typeck.c b/cobc/typeck.c index c6464dbe0..e393eaf01 100644 --- a/cobc/typeck.c +++ b/cobc/typeck.c @@ -2324,12 +2324,9 @@ cb_check_word_length (unsigned int length, const char *word) /* Absolute limit */ cb_error (_("word length exceeds maximum of %d characters: '%s'"), COB_MAX_WORDLEN, word); - } else if (!cb_relaxed_syntax_checks) { - cb_error (_("word length exceeds %d characters: '%s'"), - cb_word_length, word); } else { - cb_warning (cb_warn_additional, _("word length exceeds %d characters: '%s'"), - cb_word_length, word); + (void) cb_syntax_check (_("word length exceeds %d characters: '%s'"), + cb_word_length, word); } } } @@ -2717,14 +2714,10 @@ cb_build_identifier (cb_tree x, const int subchk) if (CB_LITERAL_P (sub)) { n = cb_get_int (sub); if (n < 1 || (!p->flag_unbounded && n > p->occurs_max)) { - if (cb_relaxed_syntax_checks) { - cb_warning_x (COBC_WARN_FILLER, x, - _("subscript of '%s' out of bounds: %d"), - name, n); + if (cb_syntax_check_x (x, _("subscript of '%s' out of bounds: %d"), + name, n)) { continue; /* *skip runtime check, as MF does */ } - cb_error_x (x, _("subscript of '%s' out of bounds: %d"), - name, n); } } diff --git a/doc/gnucobol.texi b/doc/gnucobol.texi index b54ee6e5b..d70f3e7d4 100644 --- a/doc/gnucobol.texi +++ b/doc/gnucobol.texi @@ -486,11 +486,11 @@ developping COBOL programs that are portable to actual mainframe environments. In general, division, section, and paragraph names must start in Area A. -In the @code{DATA DIVISION}, level numbers @code{01}, @code{77}, and (as -an extension) @code{78}, must also start in Area A. In the -@code{PROCEDURE DIVISION}s, statements and separator periods must fit -within Area B. Every source format listed above may be subject to Area -A enforcement, except @code{FIXED} and @code{FREE}. +In the @code{DATA DIVISION}, level numbers @code{01} and @code{77}, must +also start in Area A. In the @code{PROCEDURE DIVISION}s, statements and +separator periods must fit within Area B. Every source format listed +above may be subject to Area A enforcement, except @code{FIXED} and +@code{FREE}. Note that Area A enforcement enables recovery from missing periods between paragraphs and sections. diff --git a/tests/testsuite.src/syn_misc.at b/tests/testsuite.src/syn_misc.at index 821d154b1..ec49131cb 100644 --- a/tests/testsuite.src/syn_misc.at +++ b/tests/testsuite.src/syn_misc.at @@ -736,13 +736,20 @@ prog.cob:17: error: PROCEDURE DIVISION header missing ]) AT_CHECK([$COMPILE_ONLY -frelax-syntax-checks prog.cob], [0], [], -[prog.cob:2: warning: PROGRAM-ID header missing - assumed -prog.cob:2: warning: ENVIRONMENT DIVISION header missing - assumed -prog.cob:2: warning: CONFIGURATION SECTION header missing - assumed -prog.cob:10: warning: INPUT-OUTPUT SECTION header missing - assumed -prog.cob:10: warning: FILE-CONTROL header missing - assumed -prog.cob:14: warning: FILE SECTION header missing - assumed -prog.cob:17: warning: PROCEDURE DIVISION header missing - assumed +[prog.cob:2: warning: PROGRAM-ID header missing +prog.cob:2: note: PROGRAM-ID header assumed +prog.cob:2: warning: ENVIRONMENT DIVISION header missing +prog.cob:2: note: ENVIRONMENT DIVISION header assumed +prog.cob:2: warning: CONFIGURATION SECTION header missing +prog.cob:2: note: CONFIGURATION SECTION header assumed +prog.cob:10: warning: INPUT-OUTPUT SECTION header missing +prog.cob:10: note: INPUT-OUTPUT SECTION header assumed +prog.cob:10: warning: FILE-CONTROL header missing +prog.cob:10: note: FILE-CONTROL header assumed +prog.cob:14: warning: FILE SECTION header missing +prog.cob:14: note: FILE SECTION header assumed +prog.cob:17: warning: PROCEDURE DIVISION header missing +prog.cob:17: note: PROCEDURE DIVISION header assumed ]) AT_CLEANUP @@ -760,8 +767,10 @@ prog.cob:1: error: PROCEDURE DIVISION header missing ]) AT_CHECK([$COMPILE_ONLY -frelax-syntax-checks prog.cob], [0], [], -[prog.cob:1: warning: PROGRAM-ID header missing - assumed -prog.cob:1: warning: PROCEDURE DIVISION header missing - assumed +[prog.cob:1: warning: PROGRAM-ID header missing +prog.cob:1: note: PROGRAM-ID header assumed +prog.cob:1: warning: PROCEDURE DIVISION header missing +prog.cob:1: note: PROCEDURE DIVISION header assumed ]) AT_CLEANUP @@ -804,10 +813,12 @@ AT_CHECK([$COMPILE_ONLY prog3.cob], [1], [], ]) AT_CHECK([$COMPILE -frelax-syntax-checks prog3.cob], [0], [], -[prog3.cob:1: warning: PROGRAM-ID header missing - assumed +[prog3.cob:1: warning: PROGRAM-ID header missing +prog3.cob:1: note: PROGRAM-ID header assumed ]) AT_CHECK([$COBC -frelax-syntax-checks prog3.cob], [0], [], -[prog3.cob:1: warning: PROGRAM-ID header missing - assumed [[-Wothers]] +[prog3.cob:1: warning: PROGRAM-ID header missing [[-Wothers]] +prog3.cob:1: note: PROGRAM-ID header assumed [[-Wothers]] ]) AT_CLEANUP @@ -4726,16 +4737,16 @@ AT_DATA([prog.cob], [ ]) AT_CHECK([$COMPILE_ONLY prog.cob], [0], []) -AT_CHECK([$COMPILE_ONLY -std=cobol85 prog.cob], [0], [], -[prog.cob:9: warning: separator period in Area A +AT_CHECK([$COMPILE_ONLY -std=cobol85 prog.cob], [1], [], +[prog.cob:9: error: separator period in Area A prog.cob: in paragraph 'MAIN': -prog.cob:10: warning: start of statement in Area A -prog.cob:11: warning: start of statement in Area A -prog.cob:14: warning: start of statement in Area A -prog.cob:15: warning: separator period in Area A +prog.cob:10: error: start of statement in Area A +prog.cob:11: error: start of statement 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': -prog.cob:17: warning: start of statement in Area A -prog.cob:18: warning: separator period in Area A +prog.cob:17: error: start of statement in Area A +prog.cob:18: error: separator period in Area A ]) AT_CHECK([$COMPILE_ONLY -std=cobol85 -fno-areacheck prog.cob], [0], []) @@ -5640,7 +5651,7 @@ 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: warning: 'GOBACK' should start in Area A +prog.cob:12: error: 'GOBACK' should start in Area A ]) AT_CLEANUP @@ -9348,28 +9359,14 @@ AT_CHECK([$COMPILE_ONLY -fpicture-l=warning prog.cob], [0], [], AT_CLEANUP + AT_SETUP([AREACHECK / NOAREACHECK directives]) -AT_KEYWORDS([directive]) +AT_KEYWORDS([misc directive]) AT_DATA([prog.cob], [ - IDENTIFICATION DIVISION. - PROGRAM-ID. prog. - DATA DIVISION. - WORKING-STORAGE SECTION. - PROCEDURE DIVISION. - >> NOAREACHECK - MAIN-1 SECTION. - DISPLAY "SOMETHING". - >> AREACHECK - MAIN-2 SECTION. - DISPLAY "SOMETHING ELSE" - STOP RUN. -]) - -AT_DATA([prog2.cob], [ $SET NO-AREA-CHECK IDENTIFICATION DIVISION. - PROGRAM-ID. prog2. + PROGRAM-ID. prog. DATA DIVISION. WORKING-STORAGE SECTION. PROCEDURE DIVISION. @@ -9381,65 +9378,73 @@ AT_DATA([prog2.cob], [ STOP RUN. ]) -AT_CHECK([$COMPILE_ONLY -std=cobol85 prog.cob], [0], [], +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 +]) +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 ]) -AT_CHECK([$COMPILE_ONLY -std=cobol85 prog2.cob], [0], [], -[prog2.cob: in section 'MAIN-2': -prog2.cob:12: warning: start of statement in Area A -prog2.cob:13: warning: start of statement in Area A -]) - AT_CLEANUP AT_SETUP([AREACHECK / NOAREACHECK directives (2)]) -AT_KEYWORDS([directive missing-periods]) +AT_KEYWORDS([misc directive missing-periods]) AT_DATA([prog.cob], [ - >> NOAREACHECK + $SET NOAREACHECK IDENTIFICATION DIVISION. PROGRAM-ID. prog. DATA DIVISION. - >> AREACHECK + $SET AREACHECK WORKING-STORAGE SECTION. 01 X. 02 Y PIC X. 01 Z PIC X 01 T PIC 9. - >> NOAREACHECK + $SET NOAREACHECK PROCEDURE DIVISION. MAIN-1 SECTION. DISPLAY "SOMETHING" - >> AREACHECK + $SET AREACHECK MAIN-2 SECTION. DISPLAY "SOMETHING ELSE" STOP RUN. ]) AT_CHECK([$COMPILE_ONLY -std=cobol85 prog.cob], [1], [], -[prog.cob:10: warning: '01' should start in Area A +[prog.cob:10: error: '01' should start in Area A prog.cob:11: error: optional period used prog.cob: in section 'MAIN-1': prog.cob:17: error: optional period used prog.cob: in section 'MAIN-2': -prog.cob:18: warning: start of statement in Area A -prog.cob:19: warning: start of statement in Area A +prog.cob:18: error: start of statement in Area A +prog.cob:19: error: start of statement in Area A ]) -AT_CHECK([$COMPILE_ONLY -std=cobol85 -fmissing-period=ok prog.cob], [0], [], -[prog.cob:10: warning: '01' should start in Area A +AT_CHECK([$COMPILE_ONLY -std=cobol85 -fmissing-period=ok prog.cob], [1], [], +[prog.cob:10: error: '01' should start in Area A prog.cob: in section 'MAIN-2': -prog.cob:18: warning: start of statement in Area A -prog.cob:19: warning: start of statement in Area A +prog.cob:18: error: start of statement in Area A +prog.cob:19: error: start of statement in Area A +]) +AT_CHECK([$COMPILE_ONLY -fformat=cobol85 prog.cob], [1], [], +[prog.cob:10: error: '01' should start in Area A +prog.cob:11: warning: optional period used +prog.cob: in section 'MAIN-1': +prog.cob:17: warning: optional period used +prog.cob: in section 'MAIN-2': +prog.cob:18: error: start of statement in Area A +prog.cob:19: error: start of statement in Area A ]) AT_CLEANUP AT_SETUP([Optional dots]) -AT_KEYWORDS([missing-periods]) +AT_KEYWORDS([misc missing-periods]) AT_DATA([prog.cob], [ IDENTIFICATION DIVISION @@ -9491,3 +9496,44 @@ cobol85.cob:14: warning: optional period used ]) AT_CLEANUP + + +AT_SETUP([AREACHECK]) +AT_KEYWORDS([misc]) + +AT_DATA([pgm1.cob], [ + IDENTIFICATION DIVISION. + PROGRAM-ID. PGM1. + ENVIRONMENT DIVISION. + INPUT-OUTPUT SECTION. + FILE-CONTROL. + SELECT FILE01 ASSIGN "file01.dat". + DATA DIVISION. + FILE SECTION. + FD FILE01. + 01 RECORD-FILE01 PIC X(50). + WORKING-STORAGE SECTION. + 01 W-DATA01. + * 02 items may still lie in Area A for now: + 02 W-CH01 PIC X(10). + PROCEDURE DIVISION. + MAIN-PROCEDURE. + DISPLAY "Hello" + STOP RUN + . + END PROGRAM PGM1. +]) + +AT_CHECK([$COMPILE_ONLY -std=mvs pgm1.cob], [0], [], +[pgm1.cob:7: warning: start of statement in Area A +pgm1.cob: in paragraph 'MAIN-PROCEDURE': +pgm1.cob:18: warning: start of statement in Area A +]) + +AT_CHECK([$COMPILE_ONLY -std=mvs-strict pgm1.cob], [1], [], +[pgm1.cob:7: error: start of statement in Area A +pgm1.cob: in paragraph 'MAIN-PROCEDURE': +pgm1.cob:18: error: start of statement in Area A +]) + +AT_CLEANUP diff --git a/tests/testsuite.src/syn_occurs.at b/tests/testsuite.src/syn_occurs.at index ceeb4e6b4..eda46bedd 100644 --- a/tests/testsuite.src/syn_occurs.at +++ b/tests/testsuite.src/syn_occurs.at @@ -396,7 +396,7 @@ prog.cob:12: error: 'MISSING' is not defined AT_CHECK([$COMPILE_ONLY -frelax-syntax prog.cob], [1], [], [prog.cob:8: warning: OCCURS DEPENDING ON without TO phrase used prog.cob:10: warning: TO phrase without DEPENDING phrase -prog.cob:10: warning: maximum number of occurrences assumed to be exact number +prog.cob:10: note: maximum number of occurrences assumed to be exact number prog.cob:12: error: 'MISSING' is not defined ]) diff --git a/tests/testsuite.src/syn_screen.at b/tests/testsuite.src/syn_screen.at index e6810ffa2..1bd7d3087 100644 --- a/tests/testsuite.src/syn_screen.at +++ b/tests/testsuite.src/syn_screen.at @@ -442,16 +442,26 @@ prog.cob:24: error: cannot specify both HIGHLIGHT and LOWLIGHT ]) AT_CHECK([$COMPILE_ONLY -frelax-syntax-checks prog.cob], [1], [], -[prog.cob:11: warning: cannot specify both LOWLIGHT and HIGHLIGHT; LOWLIGHT is ignored -prog.cob:12: warning: cannot specify both ERASE EOS and ERASE EOL; ERASE EOS is ignored -prog.cob:13: warning: cannot specify both BLANK SCREEN and BLANK LINE; BLANK SCREEN is ignored -prog.cob:16: warning: cannot specify both LOWLIGHT and HIGHLIGHT; LOWLIGHT is ignored -prog.cob:17: warning: cannot specify both ERASE EOS and ERASE EOL; ERASE EOS is ignored -prog.cob:18: warning: cannot specify both BLANK SCREEN and BLANK LINE; BLANK SCREEN is ignored -prog.cob:21: warning: cannot specify both SCROLL DOWN and SCROLL UP; SCROLL DOWN is ignored -prog.cob:21: warning: cannot specify both TAB and AUTO; TAB is ignored -prog.cob:22: warning: cannot specify both SCROLL DOWN and SCROLL UP; SCROLL DOWN is ignored -prog.cob:22: warning: cannot specify both NO UPDATE and UPDATE; NO UPDATE is ignored +[prog.cob:11: warning: cannot specify both LOWLIGHT and HIGHLIGHT +prog.cob:11: note: LOWLIGHT is ignored +prog.cob:12: warning: cannot specify both ERASE EOS and ERASE EOL +prog.cob:12: note: ERASE EOS is ignored +prog.cob:13: warning: cannot specify both BLANK SCREEN and BLANK LINE +prog.cob:13: note: BLANK SCREEN is ignored +prog.cob:16: warning: cannot specify both LOWLIGHT and HIGHLIGHT +prog.cob:16: note: LOWLIGHT is ignored +prog.cob:17: warning: cannot specify both ERASE EOS and ERASE EOL +prog.cob:17: note: ERASE EOS is ignored +prog.cob:18: warning: cannot specify both BLANK SCREEN and BLANK LINE +prog.cob:18: note: BLANK SCREEN is ignored +prog.cob:21: warning: cannot specify both SCROLL DOWN and SCROLL UP +prog.cob:21: note: SCROLL DOWN is ignored +prog.cob:21: warning: cannot specify both TAB and AUTO +prog.cob:21: note: TAB is ignored +prog.cob:22: warning: cannot specify both SCROLL DOWN and SCROLL UP +prog.cob:22: note: SCROLL DOWN is ignored +prog.cob:22: warning: cannot specify both NO UPDATE and UPDATE +prog.cob:22: note: NO UPDATE is ignored prog.cob:24: error: cannot specify both HIGHLIGHT and LOWLIGHT ])