[gcc r17-2836] cobol: New warning to allow REDEFINES anywhere in data item definition.

https://gcc.gnu.org/g:b36454ad89d2b3c455e4f2033c860aa62549a289

commit r17-2836-gb36454ad89d2b3c455e4f2033c860aa62549a289
Author: James K. Lowden <[email protected]>
Date:   Thu Jul 30 18:41:05 2026 -0400

    cobol: New warning to allow REDEFINES anywhere in data item definition.
    
    The new warning -Wredefines-first (an error by default) allows the
    user to reduce the error to a warning, or suppress it.  Suppression is
    automatic with -dialect mf.
    
    gcc/cobol/ChangeLog:
    
            PR cobol/120804
            * cbldiag.h (enum cbl_diag_id_t): Add MfRedefinesFirst.
            * cobol1.cc (cobol_langhook_handle_option): Handle option.
            * gcobol.1: Document option.
            * lang-specs.h: Add -Wredefines-first to spec string.
            * lang.opt: Add option.
            * messages.cc: Add option to dialect map.
            * parse.y: Error message depends on option value.

Diff:
---
 gcc/cobol/cbldiag.h    |  1 +
 gcc/cobol/cobol1.cc    |  4 ++++
 gcc/cobol/gcobol.1     |  6 +++++-
 gcc/cobol/lang-specs.h |  1 +
 gcc/cobol/lang.opt     |  5 +++++
 gcc/cobol/messages.cc  | 11 +++++++++--
 gcc/cobol/parse.y      | 14 +++++---------
 7 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h
index 75c946df96c0..5f88e15563a6 100644
--- a/gcc/cobol/cbldiag.h
+++ b/gcc/cobol/cbldiag.h
@@ -203,6 +203,7 @@ enum cbl_diag_id_t : uint64_t {
   MfAnyLength, 
   MfMoveIndex, 
   MfMovePointer, 
+  MfRedefinesFirst,
   MfReturningNum,
   MfSetNumeric,
   MfTrailing,
diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index f57d310f63b0..eedaf600440a 100644
--- a/gcc/cobol/cobol1.cc
+++ b/gcc/cobol/cobol1.cc
@@ -641,6 +641,10 @@ cobol_langhook_handle_option (size_t scode,
           cobol_warning(MfAnyLength, cobol_any_length, warning_as_error);
           return true;
 
+        case OPT_Wredefines_first:
+          cobol_warning(MfRedefinesFirst, redefines_first, warning_as_error);
+          return true;
+
         case OPT_Wreturning_number:
           cobol_warning(MfReturningNum, returning_number, warning_as_error);
           return true;
diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1
index 36addddeb89f..de968bd02bc1 100644
--- a/gcc/cobol/gcobol.1
+++ b/gcc/cobol/gcobol.1
@@ -80,6 +80,7 @@
 .Op Fl Wno-procedure-not-found
 .Op Fl Wno-procedure-pointer
 .Op Fl Wno-replace-error
+.Op Fl Wno-redefines-first
 .Op Fl Wno-returning-number
 .Op Fl Wno-segment-error
 .Op Fl Wno-segment-negative
@@ -640,9 +641,12 @@ Warn if CDF defines Level 78 constant.
 .It Fl Wno-move-index
 Warn if MOVE INDEX is used.
 .It Fl Wno-move-pointer
-Warn if MOVE POINTER is used.
+Warn if
+MOVE POINTER is used.
 .It Fl Wno-set-numeric
 Warn if SET is used with NUMERIC target.
+.It Fl Wno-redefines-first
+Warn if REDEFINES does not appear immediately after NAME.
 .It Fl Wno-returning-number
 Warn if RETURNING <number> is used.
 .It Fl Wno-usage-typename
diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h
index bc97e411ee30..272ef480b6ae 100644
--- a/gcc/cobol/lang-specs.h
+++ b/gcc/cobol/lang-specs.h
@@ -90,6 +90,7 @@
 	"%{Wprocedure-not-found} %{Wno-procedure-not-found} "
 	"%{Wprocedure-pointer} %{Wno-procedure-pointer} "
 	"%{Wreplace-error} %{Wno-replace-error} "
+	"%{Wredefines-first} %{Wno-redefines-first} "
 	"%{Wreturning-number} %{Wno-returning-number} "
 	"%{Wsegment-error} %{Wno-segment-error} "
 	"%{Wsegment-negative} %{Wno-segment-negative} "
diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt
index e2350ef142ee..9e2f989b2626 100644
--- a/gcc/cobol/lang.opt
+++ b/gcc/cobol/lang.opt
@@ -174,6 +174,11 @@ Wmove-pointer
 Cobol Warning Var(move_pointer, 1) Init(1)
 Warn if MOVE POINTER is used.
 
+; MfRedefinesFirst
+Wredefines-first
+Cobol Warning Var(redefines_first, 1) Init(1)
+Warn if REDEFINES does not appear immediately after NAME.
+
 ; MfReturningNum
 Wreturning-number
 Cobol Warning Var(returning_number, 1) Init(1)
diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc
index 9dfd9ce403cb..e55ab194dd79 100644
--- a/gcc/cobol/messages.cc
+++ b/gcc/cobol/messages.cc
@@ -154,6 +154,7 @@ std::set<cbl_diag_t> cbl_diagnostics {
   { MfLevel_1_Occurs, "-Wlevel-1-occurs", diagnostics::kind::error, dialect_mf_gnu },
   { MfMoveIndex, "-Wmove-index", diagnostics::kind::error, dialect_gnu_e },
   { MfMovePointer, "-Wmove-pointer", diagnostics::kind::error, dialect_mf_gnu },
+  { MfRedefinesFirst, "-Wredefines-first", diagnostics::kind::error, dialect_mf_gnu },
   { MfReturningNum, "-Wreturning-number", diagnostics::kind::error, dialect_mf_gnu },
   { MfSetNumeric, "-Wset-numeric", diagnostics::kind::error, dialect_mf_gnu },
   { MfTrailing, "-Winspect-trailing", diagnostics::kind::error, dialect_mf_gnu },
@@ -404,8 +405,14 @@ dialect_ok( const cbl_loc_t& loc, cbl_diag_id_t id, const char term[], bool ok )
     if( !ok ) return true; // current dialect correctly does not match the feature
   }
 
-  cbl_message(loc, id, "%qs %s %<-dialect %s%>",
-              term, verb, cbl_dialect_str(diag->dialect));
+  if( term[0] == '-' ) {
+    term++; // do not quote
+    cbl_message(loc, id, "%s %s %<-dialect %s%>",
+                term, verb, cbl_dialect_str(diag->dialect));
+  } else {
+    cbl_message(loc, id, "%qs %s %<-dialect %s%>",
+                term, verb, cbl_dialect_str(diag->dialect));
+  }
   return false;
 }
 
diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y
index 13a94ffc59ef..eef000a7ee60 100644
--- a/gcc/cobol/parse.y
+++ b/gcc/cobol/parse.y
@@ -4550,7 +4550,7 @@ data_clauses:   data_clause
                 data_clause_t clause = data_clause_t($1);
                 proto_field.add_clause(clause);
                 }
-        |       data_clauses data_clause {
+        |       data_clauses[clauses] data_clause {
                   const char *clause = "data";
                   switch($2) {
                   case occurs_clause_e:     clause = "OCCURS";    break;
@@ -4575,16 +4575,12 @@ data_clauses:   data_clause
                     YYERROR;
                   }
 
-		  // We could be more judicious. We could clear the map when
-		  // the first clause is encountered, and e.g. set the location
-		  // to just the VALUE string, not the whole clause.  As of now
-		  // the map isn't used, though.
                   data_clause_locations[data_clause_t($2)] = @data_clause;
 
-                  if( $data_clause == redefines_clause_e ) {
-                    error_msg(@2, "REDEFINES must appear "
-                             "immediately after LEVEL and NAME");
-                    YYERROR;
+                  if( $clauses && $data_clause == redefines_clause_e ) {
+                      dialect_ok(@2, MfRedefinesFirst,
+                                 "-REDEFINES must appear "
+                                 "immediately after LEVEL and NAME");
                   }
                   cbl_field_t *field = current_field();
                   const int globex = (global_e | external_e);