From: James K. Lowden Date: Wed, 29 Jul 2026 19:30:42 +0000 (-0400) Subject: cobol: Support SET of NUMERIC type for GnuCOBOL emulation. X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=2d665597ec6cb4e9f2740d3d4dbccc786687f911;p=thirdparty%2Fgcc.git 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 7a6d25e52a4..75c946df96c 100644 --- 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 fd226b520f6..f57d310f63b 100644 --- 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 5eac3beef59..aff6c1c7431 100644 --- 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 .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 is used. .It Fl Wno-usage-typename diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h index d64353523e0..bc97e411ee3 100644 --- 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 f50224fac05..e2350ef142e 100644 --- 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 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 e2518e11240..9dfd9ce403c 100644 --- a/gcc/cobol/messages.cc +++ b/gcc/cobol/messages.cc @@ -141,8 +141,8 @@ std::set 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_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 477ed347848..39f33fdf3b5 100644 --- 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 ) ) {