https://gcc.gnu.org/g:723601605a76b955f0a82fcc492dcb11524779d2
commit r17-4167-g723601605a76b955f0a82fcc492dcb11524779d2 Author: James K. Lowden <[email protected]> Date: Wed Sep 9 22:05:41 2026 -0400 cobol: Various GnuCOBOL compatibility features. Allow h'41' to mean 65 under -dialect gnu Introduce table to associate keyword variations with dialects. Recognize COBOL-WORDS for intrinsic functions. gcc/cobol/ChangeLog: * cbldiag.h (enum cbl_diag_id_t): Introduce MfHexNumeric. * cobol1.cc (cobol_langhook_handle_option): Handle Whex-numeric. * gcobol.1: Document Whex-numeric. * lang-specs.h: Add Whex-numeric to spec string. * lang.opt: Define Whex-numeric. * messages.cc: Add Whex-numeric to mf and gnu dialects. Make Wcontent-expr available in all dialects outside ISO. Finer distinctions remain to be drawn. * parse.y: (dialect_words_set): New function for per-dialect keywords. * scan.l: New rule for hexadecimal numeric notation. * symbols.cc (dimensions): Rewrite for REDEFINES table. * symbols.h (hex2numstr): Declare new function. (class current_tokens_t): Refine to recognize COBOL-WORDS. * util.cc (literal_subscript_oob): Rewrite to avoid UB. (hex2numstr): New function. Diff: --- gcc/cobol/cbldiag.h | 1 + gcc/cobol/cobol1.cc | 4 +++ gcc/cobol/gcobol.1 | 3 +++ gcc/cobol/lang-specs.h | 3 ++- gcc/cobol/lang.opt | 5 ++++ gcc/cobol/messages.cc | 3 ++- gcc/cobol/parse.y | 38 +++++++++++++++++++++++++--- gcc/cobol/scan.l | 68 +++++++++++++++++++++++++++++++++++--------------- gcc/cobol/symbols.cc | 7 ++++-- gcc/cobol/symbols.h | 10 +++++--- gcc/cobol/util.cc | 53 ++++++++++++++++++++++++++------------- 11 files changed, 145 insertions(+), 50 deletions(-) diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index d5da51182181..ab5f417e2a03 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -201,6 +201,7 @@ enum cbl_diag_id_t : uint64_t { MfCdfDollar, MfComp6, MfCompX, + MfHexNumeric, MfLevel_1_Occurs, MfLevel78, MfAnyLength, diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc index 89cdefe1ef39..77671c94416c 100644 --- a/gcc/cobol/cobol1.cc +++ b/gcc/cobol/cobol1.cc @@ -641,6 +641,10 @@ cobol_langhook_handle_option (size_t scode, cobol_warning(MfCompX, comp_x, warning_as_error); return true; + case OPT_Whex_numeric: + cobol_warning(MfHexNumeric, hex_numeric, warning_as_error); + return true; + case OPT_Winspect_trailing: cobol_warning(MfTrailing, inspect_trailing, warning_as_error); return true; diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index 14888d1ece7a..21438c0568b0 100644 --- a/gcc/cobol/gcobol.1 +++ b/gcc/cobol/gcobol.1 @@ -63,6 +63,7 @@ .Op Fl Wno-dynamic-call .Op Fl Wno-ec-unknown .Op Fl Wno-entry-convention +.Op Fl Wno-hex-numeric .Op Fl Wno-ibm-cdf .Op Fl Wno-iconv-error .Op Fl Wno-include-file-found @@ -654,6 +655,8 @@ Warn if DISPLAY WITH screen options is used. Note if CALL with dynamic target is used. .It Fl Wno-file-code-set Warn if FILE CODE SET is used. +.It Fl Wno-hex-numeric +Warn if hexadecimal notation is used for integers. .It Fl Wno-inspect-trailing Warn if INSPECT ... TRAILING is used. .It Fl Wno-level-1-occurs diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h index 9d0919324ac7..ace1dfa06801 100644 --- a/gcc/cobol/lang-specs.h +++ b/gcc/cobol/lang-specs.h @@ -67,13 +67,14 @@ "%{Wcobol-volatile} %{Wno-cobol-volatile} " "%{Wcomp-6} %{Wno-comp-6} " "%{Wcomp-x} %{Wno-comp-x} " + "%{Wcontent-expr} %{Wno-content-expr} " "%{Wcopybook-found} %{Wno-copybook-found} " "%{Wdisplay-screen} %{Wno-display-screen} " "%{Wdynamic-call} %{Wno-dynamic-call} " "%{Wec-unknown} %{Wno-ec-unknown} " "%{Wentry-convention} %{Wno-entry-convention} " + "%{Whex-numeric} %{Wno-hex-numeric} " "%{Wibm-cdf} %{Wno-ibm-cdf} " - "%{Wcontent-expr} %{Wno-content-expr} " "%{Wiconv-error} %{Wno-iconv-error} " "%{Winclude-file-found} %{Wno-include-file-found} " "%{Winclude-file-not-found} %{Wno-include-file-not-found} " diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt index be9f51363357..0d381a3394e3 100644 --- a/gcc/cobol/lang.opt +++ b/gcc/cobol/lang.opt @@ -144,6 +144,11 @@ Wcomp-x Cobol Warning Var(comp_x, 1) Init(1) Warn if COMPUTATIONAL is used with PICTURE X. +; MfHexNumeric +Whex-numeric +Cobol Warning Var(hex_numeric, 1) Init(1) +Warn if hexadecimal notation is used for integers. + ; MfDisplayScreen Wdisplay-screen Cobol Warning Var(display_screen, 1) Init(1) diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc index 9d1a1374a36f..468e6754293f 100644 --- a/gcc/cobol/messages.cc +++ b/gcc/cobol/messages.cc @@ -126,7 +126,7 @@ std::set<cbl_diag_t> cbl_diagnostics { { IbmCallFd, "-Wcall-fd", diagnostics::kind::error, dialect_ibm_e }, { IbmCdf, "-Wibm-cdf", diagnostics::kind::error, dialect_ibm_e }, - { IbmContentExpr, "-Wcontent-expr", diagnostics::kind::error, dialect_ibm_e }, + { IbmContentExpr, "-Wcontent-expr", diagnostics::kind::error, dialect_ibm_mf_gnu }, { IbmEjectE, "-Wcobol-eject", diagnostics::kind::error, dialect_ibm_e }, { IbmLengthOf, "-Wlength-of", diagnostics::kind::error, dialect_ibm_mf_gnu }, { IbmEqualAssignE, "-Wequal-assign", diagnostics::kind::error, dialect_ibm_e }, @@ -154,6 +154,7 @@ std::set<cbl_diag_t> cbl_diagnostics { { MfComp6, "-Wcomp-6", diagnostics::kind::error, dialect_mf_gnu }, { MfCompX, "-Wcomp-x", diagnostics::kind::error, dialect_mf_gnu }, { MfDisplayScreen, "-Wdisplay-screen", diagnostics::kind::error, dialect_mf_gnu }, + { MfHexNumeric, "-Whex-numeric", diagnostics::kind::error, dialect_mf_gnu }, { MfLevel78, "-Wlevel-78", 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 }, diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index 91c6cd0c2342..1cc16f575c29 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -15072,6 +15072,39 @@ cbl_field_t::value_str() const { return data.etc_type_str(); } +/* + * Default keyword adjustments for -dialect {mf,gnu} + */ +static void +dialect_words_set( cbl_dialect_t dialect ) { + const static auto dialect_mf_gnu = cbl_dialect_t(dialect_mf_e | dialect_gnu_e); + static unsigned int done; + + typedef bool (current_tokens_t::*wordop_func_t)(const cbl_loc_t& loc, + const cbl_name_t keyword, + const cbl_name_t alias); + struct wordop_t { + cbl_dialect_t dialect; + wordop_func_t op; + cbl_name_t keyword, alias; + bool match(cbl_dialect_t dialect) const { return this->dialect & dialect; } + + }; + const static std::vector<wordop_t> wordops { + { dialect_mf_gnu, ¤t_tokens_t::equate, "BINARY-DOUBLE", "BINARY-C-LONG" }, + { dialect_gnu_e, ¤t_tokens_t::substitute, "CONCAT", "CONCATENATE" }, + }; + + if( dialect != (done & dialect) ) { // if any part of dialect not done + for( const auto& w : wordops ) { + if( w.match(dialect) ) { + (cdf_tokens.*w.op)(cbl_loc_t(), w.keyword, w.alias); + } + } + } + done |= dialect; +} + void cobol_dialect_set( cbl_dialect_t dialect ) { switch(dialect) { @@ -15082,11 +15115,8 @@ cobol_dialect_set( cbl_dialect_t dialect ) { cobol_gcobol_feature_set(feature_embiggen_e); break; case dialect_mf_e: - break; case dialect_gnu_e: - if( 0 == (cbl_dialects & dialect) ) { // first time - cdf_tokens.equate(cbl_loc_t(), "BINARY-DOUBLE", "BINARY-C-LONG"); - } + dialect_words_set(dialect); break; } cbl_dialects |= dialect; diff --git a/gcc/cobol/scan.l b/gcc/cobol/scan.l index 9f44703c4792..9e715a25dfb6 100644 --- a/gcc/cobol/scan.l +++ b/gcc/cobol/scan.l @@ -1155,6 +1155,12 @@ USE({SPC}FOR)? { return USE; } WITH { return WITH; } {INTEGERZ} { return numstr_of(yytext); } + H{hexseq} { + dialect_ok(yylloc, MfHexNumeric, yytext); + yylval.numstr.radix = decimal_e; + yylval.numstr.string = hex2numstr(yytext); + return NUMSTR; + } {NAME} { yylval.string = xstrdup(yytext); @@ -1200,6 +1206,12 @@ USE({SPC}FOR)? { return USE; } {DOTSEP} { yy_pop_state(); return '.'; } [+-]?{INTEGERZ} { return numstr_of(yytext); } + H{hexseq} { + dialect_ok(yylloc, MfHexNumeric, yytext); + yylval.numstr.radix = decimal_e; + yylval.numstr.string = hex2numstr(yytext); + return NUMSTR; + } [+-]?{dfc} { char *s = xstrdup(yytext); // "The decimal point can appear anywhere within // the literal except as the rightmost character." @@ -1292,11 +1304,11 @@ USE({SPC}FOR)? { return USE; } VALUES({SPC}ARE)?/[[:space:]] { return VALUE; } VALUES?({SPC}(IS|ARE))?{SPC}NULLS? { return NULLPTR; } - VALUES?({SPC}(IS|ARE))?/{SPC}[+-]?{dfc} { + VALUES?({SPC}(IS|ARE))?/{SPC}(H{hexseq}|[+-]?{dfc}) { yy_push_state(numeric_state); return VALUE; } THRU|THROUGH { return THRU; } - (THRU|THROUGH)/{SPC}[[:digit:].,+-] { + (THRU|THROUGH)/{SPC}(H{hexseq}|[[:digit:].,+-]) { yy_push_state(numeric_state); return THRU; } @@ -2074,13 +2086,19 @@ USE({SPC}FOR)? { return USE; } BX/{hexseq} { yylval.numstr.radix = hexadecimal_e; yy_push_state(numstr_state); } + H{hexseq} { + dialect_ok(yylloc, MfHexNumeric, yytext); + yylval.numstr.radix = decimal_e; + yylval.numstr.string = hex2numstr(yytext); + return NUMSTR; + } - {PREFIX}?[''] { yylval.literal.set_prefix(yytext, yyleng-1); - yy_push_state(quoted1); } - {PREFIX}?[""] { yylval.literal.set_prefix(yytext, yyleng-1); - yy_push_state(quoted2); } - {PREFIX}?[""]/{STRING2}[""] { yylval.literal.set_prefix(yytext, yyleng-1); - yy_push_state(quoted2); } + {PREFIX}?[''] { yylval.literal.set_prefix(yytext, yyleng-1); + yy_push_state(quoted1); } + {PREFIX}?[""] { yylval.literal.set_prefix(yytext, yyleng-1); + yy_push_state(quoted2); } + {PREFIX}?[""]/{STRING2}[""] { yylval.literal.set_prefix(yytext, yyleng-1); + yy_push_state(quoted2); } {INTEGERZ}/[[:punct:]][[:space:]]{BLANK_EOL}? { return numstr_of(yytext); } {dfc}/[[:blank:][:punct:]] { return numstr_of(yytext); } @@ -2105,18 +2123,24 @@ USE({SPC}FOR)? { return USE; } [[:blank:]]+ {BLANK_EOL} - [+-]?{INTEGERZ} { pop_return numstr_of(yytext); } - [+-]?{dfc}([.][[:digit:]])* { - char *s = xstrdup(yytext); - char *p = strchr(s, '.'); - if( p && strlen(p) == 1 ) { - *p = '\0'; - myless(p - s); - } - int token = numstr_of(s); - free(s); - pop_return token; - } + [+-]?{INTEGERZ} { pop_return numstr_of(yytext); } + H{hexseq} { + dialect_ok(yylloc, MfHexNumeric, yytext); + yylval.numstr.radix = decimal_e; + yylval.numstr.string = hex2numstr(yytext); + pop_return NUMSTR; + } + [+-]?{dfc}([.][[:digit:]])* { + char *s = xstrdup(yytext); + char *p = strchr(s, '.'); + if( p && strlen(p) == 1 ) { + *p = '\0'; + myless(p - s); + } + int token = numstr_of(s); + free(s); + pop_return token; + } } <procedure_div>{ @@ -2544,6 +2568,8 @@ USE({SPC}FOR)? { return USE; } if( 0 != (yylval.number = symbol_function_token(name)) ) { pop_return FUNCTION_UDF; } + int token = NAME; + if( (token = redefined_token(name)) ) { return token; } yylval.string = name; pop_return NAME; } @@ -2555,6 +2581,8 @@ USE({SPC}FOR)? { return USE; } if( 0 != (yylval.number = symbol_function_token(name)) ) { pop_return FUNCTION_UDF_0; } + int token = NAME; + if( (token = redefined_token(name)) ) { return token; } yylval.string = name; pop_return NAME; } diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index dac99cad3ec9..bef6f116c3b8 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -1524,8 +1524,11 @@ dimensions( const cbl_field_t *f ) { if( f->type == FldIndex ) return 0; - while( (f = parent_of(f)) != NULL ) { - if( is_table(f) ) n++; + cbl_field_t *parent; + for( ; (parent = parent_of(f)) != nullptr; f = parent ) { + if( parent != symbol_redefines(f) ) { + if( is_table(parent) ) n++; + } } return n; diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index 8134c9fbb952..94af43938256 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -1861,6 +1861,7 @@ struct cbl_special_name_t { }; char * hex_decode( const char text[] ); +char * hex2numstr( const char text[] ); /* * An alphabet may just name an encoding, which implies binary collation. @@ -3073,8 +3074,9 @@ class current_tokens_t { } bool equate( const cbl_loc_t& loc, const cbl_name_t keyword, const cbl_name_t alias ) { int token; - if( 0 == (token = binary_integer_usage_of(keyword)) ) { - if( 0 == (token = keyword_tok(keyword)) ) { + + if( 0 == (token = keyword_tok(keyword, true)) ) { + if( 0 == (token = binary_integer_usage_of(keyword)) ) { error_msg(loc, "EQUATE: not a reserved word: %qs", keyword); return false; } @@ -3093,8 +3095,8 @@ class current_tokens_t { } bool substitute( const cbl_loc_t& loc, const cbl_name_t keyword, const cbl_name_t alias ) { int token; - if( 0 == (token = binary_integer_usage_of(keyword)) ) { - if( 0 == (token = keyword_tok(keyword)) ) { + if( 0 == (token = keyword_tok(keyword, true)) ) { + if( 0 == (token = binary_integer_usage_of(keyword)) ) { error_msg(loc, "SUBSTITUTE: not a reserved word: %qs", keyword); return false; } diff --git a/gcc/cobol/util.cc b/gcc/cobol/util.cc index 027f409f7b70..6abd9091f75d 100644 --- a/gcc/cobol/util.cc +++ b/gcc/cobol/util.cc @@ -2146,32 +2146,37 @@ const cbl_field_t * literal_subscript_oob( const cbl_refer_t& r, size_t& isub /* output */) { // Verify literal subscripts if dimensions are correct. size_t ndim(dimensions(r.field)); - if( ndim == 0 || ndim != r.nsubscript() ) return NULL; - std::vector<cbl_field_t *> dims( ndim, NULL ); - auto pdim = dims.end(); - - for( auto f = r.field; f; f = parent_of(f) ) { - if( f->occurs.ntimes() ) { - --pdim; - *pdim = f; + if( ndim == 0 || ndim != r.nsubscript() ) return nullptr; + std::deque<cbl_field_t *> dims(1, r.field); + if( ! is_table(dims[0]) ) dims.clear(); + + // dims is a vector of fields representing the dimensions, starting topmost. + cbl_field_t *parent; + for( auto f = r.field; (parent = parent_of(f)) != nullptr; f = parent ) { + if( parent != symbol_redefines(f) ) { + if( is_table(parent) ) { + dims.push_front(parent); + } } } - assert(dims[0] != NULL); - assert(pdim == dims.begin()); + + assert(dims.size() == ndim); /* * For each subscript, if it is a literal, verify it is in bounds * for the corresponding dimension. Return the first subscript not * meeting those criteria, if any. */ - auto psub = std::find_if( r.subscripts.begin(), r.subscripts.end(), - [pdim]( const cbl_refer_t& r ) mutable { - const auto& occurs((*pdim)->occurs); - pdim++; - return ! occurs.subscript_ok(r.field); - } ); - isub = psub - r.subscripts.begin(); - return psub == r.subscripts.end()? NULL : dims[isub]; + for( isub=0; isub < ndim; isub++ ) { + const auto& subscript = r.subscripts[isub]; + const auto& occurs = dims[isub]->occurs; + + if( ! occurs.subscript_ok(subscript.field) ) { + break; // found one + } + } + + return isub == ndim? nullptr : dims[isub]; } size_t @@ -2525,6 +2530,18 @@ hex_decode( const char input[] ) { return output; } +// input: H'[[:xdigit:]]+', for GnuCOBOL +char * +hex2numstr( const char input[] ) { + char q; + long unsigned int value; + + int n = sscanf(++input, "%c%" GCC_PRISZ "x%c", &q, &value, &q); + assert(n == 3 && (q == '\'' || q == '"')); + + return xasprintf("%lu", value); +} + /* * Verify unique procedure reference. *
