cobol: Support SET of NUMERIC type for GnuCOBOL emulation.

gcc/cobol/ChangeLog:

	* cbldiag.h (enum cbl_diag_id_t): Add MfSetNumeric and sort alphabetically.
	* cobol1.cc (cobol_langhook_handle_option): Handle OPT_Wset_numeric.
	* gcobol.1: Document Wset-numeric option.
	* lang-specs.h: Add Wset-numeric to specs string.
	* lang.opt: Add Wset-numeric option.
	* messages.cc: Add MfSetNumeric to mf and gnu dialects, and sort alphabetically.
	* parse_ante.h (parser_move_carefully): Report diagnotic per dialect.

diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h
index 7a6d25e52a4fb432c1dd4fb01a387cb4f0a8d1bb..75c946df96c0c3aa99550b8654d5365749ba5232 100644 (file)
--- a/gcc/cobol/cbldiag.h
+++ b/gcc/cobol/cbldiag.h
@@ -204,8 +204,9 @@ enum cbl_diag_id_t : uint64_t {
   MfMoveIndex, 
   MfMovePointer, 
   MfReturningNum,
-  MfUsageTypename,
+  MfSetNumeric,
   MfTrailing,
+  MfUsageTypename,
   
   Par78CdfDefinedW,
   ParIconvE, 

diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc
index fd226b520f633372dd8aaf6722a4d60321597b17..f57d310f63b09400d65441bf44dd4528d3ebf062 100644 (file)
--- a/gcc/cobol/cobol1.cc
+++ b/gcc/cobol/cobol1.cc
@@ -629,6 +629,10 @@ cobol_langhook_handle_option (size_t scode,
           cobol_warning(MfMovePointer, move_pointer, warning_as_error);
           return true;
 
+        case OPT_Wset_numeric:
+          cobol_warning(MfSetNumeric, set_numeric, warning_as_error);
+          return true;
+
         case OPT_Wlevel_78:
           cobol_warning(MfLevel78, level_78, warning_as_error);
           return true;

diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1
index 5eac3beef595afd5cab9d319edda9041a0945af7..aff6c1c7431e34e13750a3818fcb07a549af9c87 100644 (file)
--- a/gcc/cobol/gcobol.1
+++ b/gcc/cobol/gcobol.1
@@ -83,6 +83,7 @@
 .Op Fl Wno-returning-number
 .Op Fl Wno-segment-error
 .Op Fl Wno-segment-negative
+.Op Fl Wno-set-numeric
 .Op Fl Wno-stop-number
 .Op Fl Wno-stray-indicator
 .Op Fl Wno-usage-typename
@@ -504,18 +505,20 @@ used with
 .It
 .Sy INSPECT ... TRAILING
 .It
+.Sy LEVEL 78
+constants
+.It
 .Sy OCCURS
 at
 .Sy "LEVEL 01"
 .It
-.Sy LEVEL 78
-constants
-.It
 .Sy MOVE POINTER
 .It
 .Sy RETURNING
 <number>
 .It
+.Sy SET NUMERIC
+.It
 .Sy USAGE IS TYPENAME
 .El
 .El
@@ -635,6 +638,8 @@ Warn if CDF defines Level 78 constant.
 Warn if MOVE INDEX is used.
 .It Fl Wno-move-pointer
 Warn if MOVE POINTER is used.
+.It Fl Wno-set-numeric
+Warn if SET is used with NUMERIC target.
 .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 d64353523e046d057589d485952dacc911f509fb..bc97e411ee30013940c5e82d64534ce6e5292118 100644 (file)
--- a/gcc/cobol/lang-specs.h
+++ b/gcc/cobol/lang-specs.h
@@ -93,6 +93,7 @@
        "%{Wreturning-number} %{Wno-returning-number} "
        "%{Wsegment-error} %{Wno-segment-error} "
        "%{Wsegment-negative} %{Wno-segment-negative} "
+       "%{Wset-numeric} %{Wno-set-numeric} "
        "%{Wstop-number} %{Wno-stop-number} "
        "%{Wstray-indicator} %{Wno-stray-indicator} "
        "%{Wusage-typename} %{Wno-usage-typename} "

diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt
index f50224fac05a18919102f2f24b556719b5d7f848..e2350ef142eebb6e203175e0b04dfb1dc4ab7f41 100644 (file)
--- a/gcc/cobol/lang.opt
+++ b/gcc/cobol/lang.opt
@@ -179,6 +179,11 @@ Wreturning-number
 Cobol Warning Var(returning_number, 1) Init(1)
 Warn if RETURNING <number> is used.
 
+; MfSetNumeric, 
+Wset-numeric
+Cobol Warning Var(set_numeric, 1) Init(1)
+Warn if SET is used with NUMERIC target.
+
 ; MfUsageTypename
 Wusage-typename
 Cobol Warning Var(usage_typename, 1) Init(1)

diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc
index e2518e112403cd930aa1151b137b08e86756acdc..9dfd9ce403cbe4a3b8e85b292d41bf3b3b545c36 100644 (file)
--- a/gcc/cobol/messages.cc
+++ b/gcc/cobol/messages.cc
@@ -141,8 +141,8 @@ std::set<cbl_diag_t> cbl_diagnostics {
   { IsoResume, "-Wcobol-resume", diagnostics::kind::error, dialect_ibm_e },
   // IBM, MF, and GNU all support ASSIGN TO filename, so we keep mum. 
   { IsoAssignFile, "-Wassign-file", diagnostics::kind::ignored, dialect_ibm_mf_gnu },
-  
 
+  { MfAnyLength, "-Wany-length", diagnostics::kind::error, dialect_mf_gnu },
   { MfAssignExternal, "-Wassign-external", diagnostics::kind::error, dialect_mf_gnu },
   { MfBinaryLongLong, "-Wbinary-long-long", diagnostics::kind::error, dialect_mf_gnu },
   { MfCallGiving, "-Wcall-giving", diagnostics::kind::error, dialect_mf_gnu },
@@ -150,14 +150,14 @@ std::set<cbl_diag_t> cbl_diagnostics {
   { MfCdfDollar, "-Wcdf-dollar", diagnostics::kind::error, dialect_mf_gnu },
   { MfComp6, "-Wcomp-6", diagnostics::kind::error, dialect_mf_gnu },
   { MfCompX, "-Wcomp-x", diagnostics::kind::error, dialect_mf_gnu },
-  { MfLevel_1_Occurs, "-Wlevel-1-occurs", diagnostics::kind::error, dialect_mf_gnu },
   { MfLevel78, "-Wlevel-78", diagnostics::kind::error, dialect_mf_gnu },
-  { MfAnyLength, "-Wany-length", diagnostics::kind::error, dialect_mf_gnu },
+  { 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 },
   { MfReturningNum, "-Wreturning-number", diagnostics::kind::error, dialect_mf_gnu },
-  { MfUsageTypename, "-Wusage-typename", diagnostics::kind::error, dialect_mf_gnu },
+  { MfSetNumeric, "-Wset-numeric", diagnostics::kind::error, dialect_mf_gnu },
   { MfTrailing, "-Winspect-trailing", diagnostics::kind::error, dialect_mf_gnu },
+  { MfUsageTypename, "-Wusage-typename", diagnostics::kind::error, dialect_mf_gnu },
 
   { LexIncludeE, "-Winclude-file-not-found", diagnostics::kind::error }, 
   { LexIncludeOkN, "-Winclude-file-found", diagnostics::kind::note }, 

diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h
index 477ed34784800e3b6047a6d9b277509a508be677..39f33fdf3b54ce3a2d55af6aafe62a7c55231e91 100644 (file)
--- a/gcc/cobol/parse_ante.h
+++ b/gcc/cobol/parse_ante.h
@@ -3436,11 +3436,11 @@ parser_move_carefully( const char */*F*/, int /*L*/,
 
     if( is_index ) {
       if( tgt.field->type != FldIndex && src.field->type != FldIndex) {
-        error_msg(src.loc, "invalid SET %qs (%s) TO %qs (%s): not a field index",
-                  name_of(tgt.field), 3 + cbl_field_type_str(tgt.field->type),
-                  name_of(src.field), 3 + cbl_field_type_str(src.field->type));
-        delete tgt_list;
-        return false;
+        auto msg = xasprintf("invalid SET %qs (%s) TO %qs (%s): not a field index",
+                             name_of(tgt.field), cbl_field_type_name(tgt.field->type),
+                             name_of(src.field), cbl_field_type_name(src.field->type));
+        dialect_ok(src.loc, MfSetNumeric, msg);
+        free(msg);
       }
     } else {
       if( ! valid_move( tgt.field, src.field ) ) {