[gcc r17-2344] cobol: Accept FD name as CALL parameter.

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 ) {