https://gcc.gnu.org/g:d556f558b9db9a136ac9ec4cc804dd899d2e63cd
commit r17-2344-gd556f558b9db9a136ac9ec4cc804dd899d2e63cd Author: James K. Lowden <[email protected]> Date: Sat Jul 11 17:56:58 2026 -0400 cobol: Accept FD name as CALL parameter. A nonstandard extension CALL may pass an FD. On the mainframe the called cannot be a COBOL program and the passed parameter is the file's DCB. With this patch the parser is accepts an FD name as a CALL parameter and interprets it, for now, as a buffer name, with a warning. Without -dialect ibm it is an error [Wcall-fd]. Further development is needed to emulate mainframe semantics. Begins to address RT 3619. Also introduce __funcsig__ as a debugging convenience to print the full name of __PRETTY_FUNCTION__ without type and parameters. gcc/cobol/ChangeLog: * cbldiag.h (enum cbl_diag_id_t): Add IbmCallFd. * cobol1.cc (cobol_langhook_handle_option): Handle Wcall-fd. * gcobol.1: Document Wcall-fd. * lang-specs.h: Add Wcall-fd. * lang.opt: Same * messages.cc: Add Wcall-fd as IBM dialect option. * parse.y: Use was_fd_name() to prevent misuse. * parse_ante.h (field_find): Add incompatible semantics warning. (parser_move_carefully): Same. * symbols.cc (symbols_update): Add FD name to symbol map. * symbols.h (update_symbol_map2): Declare overload for file. (was_fd_name): Declare function. * symfind.cc (struct funcname): Define to minimize __PRETTY_FUNCTION__. (__funcsig__): Define function-name macro. (class sym_name_t): Redefine public members as const. (class symbol_file_names_t) Define maps for FD names. (update_symbol_map2): Define overload for file. (was_fd_name): Define. (symbol_find): Use new symbol_file_names class. Diff: --- gcc/cobol/cbldiag.h | 1 + gcc/cobol/cobol1.cc | 4 ++ gcc/cobol/gcobol.1 | 4 ++ gcc/cobol/lang-specs.h | 1 + gcc/cobol/lang.opt | 5 +++ gcc/cobol/messages.cc | 1 + gcc/cobol/parse.y | 8 +++- gcc/cobol/parse_ante.h | 12 +++++ gcc/cobol/symbols.cc | 5 ++- gcc/cobol/symbols.h | 3 ++ gcc/cobol/symfind.cc | 118 +++++++++++++++++++++++++++++++++++++++++++++++-- 11 files changed, 156 insertions(+), 6 deletions(-) diff --git a/gcc/cobol/cbldiag.h b/gcc/cobol/cbldiag.h index 6bb998d02d7c..8916a191200b 100644 --- a/gcc/cobol/cbldiag.h +++ b/gcc/cobol/cbldiag.h @@ -172,6 +172,7 @@ enum cbl_diag_id_t : uint64_t { LexReplaceE, LexSeparatorE, + IbmCallFd, IbmCdf, IbmEjectE, IbmEqualAssignE, diff --git a/gcc/cobol/cobol1.cc b/gcc/cobol/cobol1.cc index f7d832d5d2e7..3e2f3d43994e 100644 --- a/gcc/cobol/cobol1.cc +++ b/gcc/cobol/cobol1.cc @@ -581,6 +581,10 @@ cobol_langhook_handle_option (size_t scode, cobol_warning(MfBinaryLongLong, binary_long_long, warning_as_error); return true; + case OPT_Wcall_fd: + cobol_warning(IbmCallFd, cobol_call_fd, warning_as_error); + return true; + case OPT_Wcall_giving: cobol_warning(MfCallGiving, call_giving, warning_as_error); return true; diff --git a/gcc/cobol/gcobol.1 b/gcc/cobol/gcobol.1 index 8d39a1b3612c..bd11694ffd55 100644 --- a/gcc/cobol/gcobol.1 +++ b/gcc/cobol/gcobol.1 @@ -44,6 +44,7 @@ .Op Fl Wno-bad-line-directive .Op Fl Wno-bad-numeric .Op Fl Wno-binary-long-long +.Op Fl Wno-call-fd .Op Fl Wno-call-giving .Op Fl Wno-call-literal .Op Fl Wno-cdf-dollar @@ -603,6 +604,9 @@ Warn if malformed directive is encountered. .It Fl Wno-binary-long-long Warn if BINARY-LONG-LONG is used. +.It Fl Wno-call_fd +Warn if CALL with FD parameter is used. +This feature is currently unimplemented. .It Fl Wno-call_giving Warn if CALL ... GIVING is used. .It Fl Wno-call_literal diff --git a/gcc/cobol/lang-specs.h b/gcc/cobol/lang-specs.h index 65f49b662883..a7a3092f0494 100644 --- a/gcc/cobol/lang-specs.h +++ b/gcc/cobol/lang-specs.h @@ -54,6 +54,7 @@ "%{Wno-bad-line-directive} " "%{Wno-bad-numeric} " "%{Wno-binary-long-long} " + "%{Wno-call-fd} " "%{Wno-call-giving} " "%{Wno-call-literal} " "%{Wno-cdf-dollar} " diff --git a/gcc/cobol/lang.opt b/gcc/cobol/lang.opt index bd4cb22b0b28..61b1f583c83a 100644 --- a/gcc/cobol/lang.opt +++ b/gcc/cobol/lang.opt @@ -228,6 +228,11 @@ Wnllanginfo-error Cobol Warning Var(nllanginfo_error, 1) Init(1) Warn if nlanglanginfo(3) fails. +; IbmCallFd +Wcall-fd +Cobol Warning Var(cobol_call_fd, 1) Init(1) +Warn if fd name is used as a CALL parameter. + ; IbmCdf Wibm-cdf Cobol Warning Var(cobol_ibmcdf, 1) Init(1) diff --git a/gcc/cobol/messages.cc b/gcc/cobol/messages.cc index aac9ff0a622e..6b33e91fc342 100644 --- a/gcc/cobol/messages.cc +++ b/gcc/cobol/messages.cc @@ -124,6 +124,7 @@ std::set<cbl_diag_t> cbl_diagnostics { { EcUnknownW, "-Wec-unknown", diagnostics::kind::warning }, + { IbmCallFd, "-Wcall-fd", diagnostics::kind::error, dialect_ibm_e }, { IbmCdf, "-Wibm-cdf", diagnostics::kind::error, dialect_ibm_e }, { IbmEjectE, "-Wcobol-eject", diagnostics::kind::error, dialect_ibm_e }, { IbmLengthOf, "-Wlength-of", diagnostics::kind::error, dialect_ibm_mf_gnu }, diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index dec2f4e7dc2b..8213520980a0 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -1642,7 +1642,7 @@ cobol_words1: COBOL_WORDS EQUATE NAME[keyword] WITH NAME[name] { if( ! cdf_tokens.reserve(@name, $name) ) { YYERROR; } } | PROCESS { - cbl_message(@1, IbmCdf, "%qs", $1); + cbl_message(@1, IbmCdf, "CDF directive ignored: %qs", $1); } ; @@ -13678,6 +13678,12 @@ ast_op( const cbl_loc_t& loc, cbl_refer_t *lhs, char op, cbl_refer_t *rhs ) { static void ast_relop( const cbl_loc_t& loc, cbl_field_t *tgt, cbl_refer_t lhs, relop_t op, cbl_refer_t rhs ) { + if( was_fd_name(lhs.field) || was_fd_name(rhs.field) ) { + const char *name = was_fd_name(lhs.field) ? lhs.field->name : rhs.field->name; + error_msg(loc, "cannot compare anything to FD %qs", name); + return; + } + if( ! (valid_move(lhs.field, rhs.field) && valid_move(rhs.field, lhs.field)) ) { if( is_numeric(lhs.field) != is_numeric(rhs.field) ) { if( (lhs.field->type == FldFloat) || (rhs.field->type == FldFloat) ) { diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index bfc15a9918f1..dbab65f42a4d 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -2896,6 +2896,13 @@ field_find( cbl_loc_t loc, const std::list<const char *>& names ) { } } symbol_elem_t *e = symbol_find(names); + if( e && SymField == e->type && was_fd_name(cbl_field_of(e)) ) { + if( dialect_ok(loc, IbmCallFd, "CALL USING FD unimplemented") ) { + // No other COBOL compiler interprets the FD as a buffer. This feature + // requires further development. + warn_msg(loc, "CALL USING FD passes file buffer, not handle"); + } + } return e? cbl_field_of(e) : NULL; } @@ -3426,6 +3433,11 @@ parser_move_carefully( const char */*F*/, int /*L*/, for( const auto& num_result : tgt_list->targets ) { const cbl_refer_t& tgt = num_result.refer; + if( was_fd_name(tgt.field) ) { + error_msg(src.loc, "cannot compare anything to FD %qs", tgt.field->name); + return false; + } + 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", diff --git a/gcc/cobol/symbols.cc b/gcc/cobol/symbols.cc index 45437d334185..56dbf066145c 100644 --- a/gcc/cobol/symbols.cc +++ b/gcc/cobol/symbols.cc @@ -2059,7 +2059,10 @@ symbols_update( size_t first, bool parsed_ok ) { ninvalid++; continue; } - if( parsed_ok ) parser_file_add(&file); + if( parsed_ok ) { + parser_file_add(&file); + update_symbol_map2(file); // Add FD name as a name for the default record. + } } else { if( p->type == SymField ) { auto f = cbl_field_of(p); diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index 3744b3a7f616..408a8a5f1043 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -2369,9 +2369,12 @@ void build_symbol_map(); bool update_symbol_map( symbol_elem_t *e ); void update_symbol_map2( const symbol_elem_t *elem ); +void update_symbol_map2( const cbl_file_t& file ); void finalize_symbol_map2(); void dump_symbol_map2(); +bool was_fd_name( const cbl_field_t * field ); // uses symbol_map2, sort of + symbol_elem_t * symbol_register( const char name[] ); std::pair<symbol_elem_t *, bool> diff --git a/gcc/cobol/symfind.cc b/gcc/cobol/symfind.cc index a3abd4049d8a..6c3d06cc1a6e 100644 --- a/gcc/cobol/symfind.cc +++ b/gcc/cobol/symfind.cc @@ -45,6 +45,34 @@ extern int yydebug; +/* + * This silly function accepts __PRETTY_FUNCTION__ and trims the return type + * and parameter list from the name. It's used only for debug messages. It + * will not DTRT for conversion operators e.g. operator bool() or others with + * spaces in their names. + */ +struct funcname { + std::string output; + funcname( const char name[] ) { + auto ename = name + strlen(name); + auto p = std::find(name, ename, ' '); + p = p == ename? name : p + 1; + auto pend = std::find(p, ename, '('); + std::reverse_iterator<const char *> rbeg(pend), rend(p); + // Find the last character that could not by part of the function name. + const std::string stop(" *&"); + auto rp = std::find_if( rbeg, rend, + [stop]( char ch ) { + return stop.find(ch) != std::string::npos; + } ); + if( rp != rend ) p = rp.base(); + + assert(p < pend && pend < ename); + output.assign(p, pend); + } +}; +#define __funcsig__ funcname(__PRETTY_FUNCTION__).output.c_str() + static bool is_data_field( symbol_elem_t& e ) { if( e.type != SymField ) return false; @@ -56,10 +84,10 @@ is_data_field( symbol_elem_t& e ) { } class sym_name_t { -public: // TEMPORARY - const char *name; - size_t program, parent; public: + const char *name; + const size_t program, parent; + explicit sym_name_t( const char name[] ) : name(name), program(0), parent(0) { assert(name[0] == '\0'); } sym_name_t( size_t program, const char name[], size_t parent ) @@ -86,12 +114,60 @@ public: typedef std::map< sym_name_t, std::vector<size_t> > symbol_map_t; - static symbol_map_t symbol_map; typedef std::map <field_key_t, std::list<size_t> > field_keymap_t; static field_keymap_t symbol_map2; +/* + * symbol_file_names_t is a small "lookaside" map of FD name to the file's + * default buffer. It's a little bit too generous. It works correctly for + * CALL, but because it's used by the parser's name: nonterminal, everything + * that wants a cbl_field_t gets it. So MOVE would also work. + * + * To make it convenient for the parser to verify it's not relying on an FD + * name, the was_fd_name() function calls symbol_file_names_t::exists. + */ +static class symbol_file_names_t : protected symbol_map_t { + std::set<size_t> named_defaults; + public: + void add( const cbl_file_t& file ) { + auto program = symbol_elem_of(&file)->program; + std::vector<size_t> ids( 1, file.default_record ); + sym_name_t key(program, file.name, 0); + (*this)[key] = ids; + // Keep track of symbols we added, so the parser can ask. + auto f = cbl_field_of(symbol_at(ids.front())); + assert('_' == f->name[0]); // not a COBOL name + named_defaults.insert(ids.front()); + } + symbol_map_t find( size_t program, const char name[] ) const { + symbol_map_t output; + std::copy_if( cbegin(), cend(), + std::inserter(output, output.begin()), + [program, name]( const auto& elem ) { + return match(program, name, elem); + } ); + + dbgmsg("%s:%d: found %lu #%lu for %s", __funcsig__, __LINE__, + (unsigned long)output.size(), + output.empty()? 0ul : (unsigned long)output.begin()->second.front(), + name); + + return output; + } + bool exists( const cbl_field_t * field ) const { + auto isym = symbol_index(symbol_elem_of(field)); + return 1 == named_defaults.count(isym); + } + protected: + static bool match( size_t program, const char *name, const_reference elem ) { + const sym_name_t& key = elem.first; + return key.program == program + && 0 == strcasecmp(key.name, name); + } +} symbol_file_names; + /* * As each field is added to the symbol table, add its name and index to the * name map. Initially the type is FldInvalid. Those are removed by @@ -118,6 +194,36 @@ update_symbol_map2( const symbol_elem_t *e ) { symbol_map2[fk].push_back(symbol_index(e)); } +void +update_symbol_map2( const cbl_file_t& file ) { + assert(file.default_record); + auto e = symbol_elem_of(&file); + + symbol_file_names.add(file); + + sym_name_t key( e->program, file.name, 0 ); + auto m = symbol_file_names.find(e->program, file.name); + dbgmsg("%s:%d: %s => %lu (last of %lu)", __func__, __LINE__, + key.name, m[key].back(), m[key].size() ); +} + +/* + * The field may have been accepted as an FD NAME, representing the file's + * buffer. That is valid for a CALL parameter, for example, but not otherwise, + * as in MOVE. + * + * When parsing a name nonterminal, we smuggle in the file's default buffer if + * an FD name is referenced (and unique). The function below exists to check + * against that possibility in cases where it's not allowed. + */ +bool +was_fd_name( const cbl_field_t * field ) { + if( current_program_index() < field->our_index ) { + return symbol_file_names.exists(field); + } + return false; +} + /* * Purge any field whose type is FldInvalid. Remove any names that do * not map to any field. @@ -529,6 +635,10 @@ symbol_find( size_t program, std::list<const char *> names ) { items = qualified; } + if( items.empty() && names.size() == 1 ) { + items = symbol_file_names.find(program, names.front()); + } + auto unique = items.size() == 1; if( ! unique ) {
