[flang] Fix defined I/O semantics crash & missing errors that exposed it

[klausler]

Summary

Semantics crashes when emitting runtime derived type information tables
for a type that has user-defined I/O procedures declared outside the
type with explicit INTERFACE blocks (as opposed to a GENERIC binding
within the type). This is due to the runtime table constructor
adding a table entry for each specific procedure of any explicit interface
of the right kind (e.g., READ(UNFORMATTED)) that it found, rather than
just the ones that pertain to the derived type in question. But
semantics also wasn't checking such interfaces for distinguishable
specific procedures, either.

Clean these up, improve the spelling of defined I/O procedure kinds
in error messages ("read(formatted)" rather than "READFORMATTED"),
and make error messages stemming from macro expansions only have
one "error:" prefix on the original message so that a new test
would work.

flang/lib/Decimal/big-radix-floating-point.h

 //===-- lib/Decimal/big-radix-floating-point.h ------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_DECIMAL_BIG_RADIX_FLOATING_POINT_H_
 #define FORTRAN_DECIMAL_BIG_RADIX_FLOATING_POINT_H_
 
-// This is a helper class for use in floating-point conversions
-// between binary decimal representations.  It holds a multiple-precision
+// This is a helper class for use in floating-point conversions between
+// binary and decimal representations.  It holds a multiple-precision
 // integer value using digits of a radix that is a large even power of ten
 // (10,000,000,000,000,000 by default, 10**16).  These digits are accompanied
 // by a signed exponent that denotes multiplication by a power of ten.
 // The effective radix point is to the right of the digits (i.e., they do
 // not represent a fraction).
 //
 // The operations supported by this class are limited to those required
 // for conversions between binary and decimal representations; it is not

flang/lib/Evaluate/characteristics.cpp

private:
   const DummyArgument *GetPassArg(const Procedure &) const;
 
   const common::LanguageFeatureControl &features_;
 };
 
 // Simpler distinguishability rules for operators and assignment
 bool DistinguishUtils::DistinguishableOpOrAssign(
     const Procedure &proc1, const Procedure &proc2) const {
+  if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
+      (proc1.IsSubroutine() && proc2.IsFunction())) {
+    return true;
+  }
   auto &args1{proc1.dummyArguments};
   auto &args2{proc2.dummyArguments};
   if (args1.size() != args2.size()) {
     return true; // C1511: distinguishable based on number of arguments
   }
   for (std::size_t i{0}; i < args1.size(); ++i) {
     if (Distinguishable(args1[i], args2[i])) {
       return true; // C1511, C1512: distinguishable based on this arg
     }
   }
   return false;
 }
 
 bool DistinguishUtils::Distinguishable(
     const Procedure &proc1, const Procedure &proc2) const {
+  if ((proc1.IsFunction() && proc2.IsSubroutine()) ||
+      (proc1.IsSubroutine() && proc2.IsFunction())) {
+    return true;
+  }
   auto &args1{proc1.dummyArguments};
   auto &args2{proc2.dummyArguments};
   auto count1{CountDummyProcedures(args1)};
   auto count2{CountDummyProcedures(args2)};
   if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
     return true; // distinguishable based on C1514 rule 2
   }
   if (Rule3Distinguishable(proc1, proc2)) {

flang/lib/Parser/provenance.cpp

common::visit(
               EmitMessage(o, origin.replaces,
                   inc.isModule ? "used here"s : "included here"s, prefix, color,
                   echoSourceLine);
             }
           },
           [&](const Macro &mac) {
             EmitMessage(
                 o, origin.replaces, message, prefix, color, echoSourceLine);
-            EmitMessage(o, mac.definition, "in a macro defined here", prefix,
+            EmitMessage(o, mac.definition, "in a macro defined here", ""s,
                 color, echoSourceLine);
             if (echoSourceLine) {
               o << "that expanded to:\n  " << mac.expansion << "\n  ";
               for (std::size_t j{0};
                    origin.covers.OffsetMember(j) < range->start(); ++j) {
                 o << (mac.expansion[j] == '\t' ? '\t' : ' ');
               }
               o << "^\n";

flang/lib/Semantics/check-declarations.cpp

if (details.derivedType()) {
     Check(*details.derivedType());
   }
 }
 
 // Check that the specifics of this generic are distinguishable from each other
 void CheckHelper::CheckSpecificsAreDistinguishable(
     const Symbol &generic, const GenericDetails &details) {
   GenericKind kind{details.kind()};
-  if (!kind.IsName()) {
-    return;
-  }
   DistinguishabilityHelper helper{context_};
   for (const Symbol &specific : details.specificProcs()) {
     if (const Procedure *procedure{Characterize(specific)}) {
       if (procedure->HasExplicitInterface()) {
         helper.Add(generic, kind, specific, *procedure);
       } else {
         if (auto *msg{messages_.Say(specific.name(),
                 "Specific procedure '%s' of generic interface '%s' must have an explicit interface"_err_en_US,
for (TypeWithDefinedIo definedIoType : seenDefinedIoTypes_) {
     // a single generic if both were visible in the same scope.)
     if (derivedType == definedIoType.type && ioKind == definedIoType.ioKind &&
         proc != definedIoType.proc &&
         (generic.owner().IsDerivedType() ||
             definedIoType.generic.owner().IsDerivedType())) {
       SayWithDeclaration(proc, definedIoType.proc.name(),
           "Derived type '%s' already has defined input/output procedure"
           " '%s'"_err_en_US,
-          derivedType.name(),
-          parser::ToUpperCaseLetters(GenericKind::EnumToString(ioKind)));
+          derivedType.name(), GenericKind::AsFortran(ioKind));
       return;
     }
   }
   seenDefinedIoTypes_.emplace_back(
       TypeWithDefinedIo{derivedType, ioKind, proc, generic});
 }
 
 void CheckHelper::CheckDioDummyIsDerived(const Symbol &subp, const Symbol &arg,

flang/lib/Semantics/runtime-type-info.cpp

private:
   bool InitializeDataPointer(evaluate::StructureConstructorValues &,
       const Symbol &symbol, const ObjectEntityDetails &object, Scope &scope,
       Scope &dtScope, const std::string &distinctName);
   evaluate::StructureConstructor PackageIntValue(
       const SomeExpr &genre, std::int64_t = 0) const;
   SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const;
   std::vector<evaluate::StructureConstructor> DescribeBindings(
       const Scope &dtScope, Scope &);
-  void DescribeGeneric(
-      const GenericDetails &, std::map<int, evaluate::StructureConstructor> &);
+  void DescribeGeneric(const GenericDetails &,
+      std::map<int, evaluate::StructureConstructor> &, const DerivedTypeSpec *);
   void DescribeSpecialProc(std::map<int, evaluate::StructureConstructor> &,
       const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
-      std::optional<GenericKind::DefinedIo>);
+      std::optional<GenericKind::DefinedIo>, const DerivedTypeSpec *);
   void IncorporateDefinedIoGenericInterfaces(
       std::map<int, evaluate::StructureConstructor> &, GenericKind::DefinedIo,
-      const Scope *);
+      const Scope *, const DerivedTypeSpec *);
 
   // Instantiated for ParamValue and Bound
   template <typename A>
   evaluate::StructureConstructor GetValue(
       const A &x, const SymbolVector *parameters) {
     if (x.isExplicit()) {
       return GetValue(x.GetExplicit(), parameters);
     } else {
for (const auto &pair : dtScope) {
                 if (IsProcedurePointer(symbol)) {
                   procPtrComponents.emplace_back(
                       DescribeComponent(symbol, proc, scope));
                 }
               },
               [&](const ProcBindingDetails &) { // handled in a later pass
               },
               [&](const GenericDetails &generic) {
-                DescribeGeneric(generic, specials);
+                DescribeGeneric(generic, specials, derivedTypeSpec);
               },
               [&](const auto &) {
                 common::die(
                     "unexpected details on symbol '%s' in derived type scope",
                     symbol.name().ToString().c_str());
               },
           },
           symbol.details());
if (!isAbstractType) {
               std::move(bindings),
               evaluate::ConstantSubscripts{
                   static_cast<evaluate::ConstantSubscript>(bindings.size())}));
       // Describe "special" bindings to defined assignments, FINAL subroutines,
       // and user-defined derived type I/O subroutines.
       const DerivedTypeDetails &dtDetails{dtSymbol->get<DerivedTypeDetails>()};
       for (const auto &pair : dtDetails.finals()) {
         DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/,
-            true, std::nullopt);
+            true, std::nullopt, derivedTypeSpec);
+      }
+      if (derivedTypeSpec) {
+        IncorporateDefinedIoGenericInterfaces(specials,
+            GenericKind::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
+        IncorporateDefinedIoGenericInterfaces(specials,
+            GenericKind::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);
+        IncorporateDefinedIoGenericInterfaces(specials,
+            GenericKind::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);
+        IncorporateDefinedIoGenericInterfaces(specials,
+            GenericKind::DefinedIo::WriteUnformatted, &scope, derivedTypeSpec);
       }
-      IncorporateDefinedIoGenericInterfaces(
-          specials, GenericKind::DefinedIo::ReadFormatted, &scope);
-      IncorporateDefinedIoGenericInterfaces(
-          specials, GenericKind::DefinedIo::ReadUnformatted, &scope);
-      IncorporateDefinedIoGenericInterfaces(
-          specials, GenericKind::DefinedIo::WriteFormatted, &scope);
-      IncorporateDefinedIoGenericInterfaces(
-          specials, GenericKind::DefinedIo::WriteUnformatted, &scope);
       // Pack the special procedure bindings in ascending order of their "which"
       // code values, and compile a little-endian bit-set of those codes for
       // use in O(1) look-up at run time.
       std::vector<evaluate::StructureConstructor> sortedSpecials;
       for (auto &pair : specials) {
         auto bit{std::uint32_t{1} << pair.first};
         CHECK(!(specialBitSet & bit));
         specialBitSet |= bit;
for (const SymbolRef &ref : CollectBindings(dtScope)) {
     AddValue(values, bindingSchema_, "name"s,
         SaveNameAsPointerTarget(scope, ref.get().name().ToString()));
     result.emplace_back(DEREF(bindingSchema_.AsDerived()), std::move(values));
   }
   return result;
 }
 
 void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
-    std::map<int, evaluate::StructureConstructor> &specials) {
+    std::map<int, evaluate::StructureConstructor> &specials,
+    const DerivedTypeSpec *derivedTypeSpec) {
   common::visit(common::visitors{
                     [&](const GenericKind::OtherKind &k) {
                       if (k == GenericKind::OtherKind::Assignment) {
                         for (auto ref : generic.specificProcs()) {
                           DescribeSpecialProc(specials, *ref, true,
-                              false /*!final*/, std::nullopt);
+                              false /*!final*/, std::nullopt, derivedTypeSpec);
                         }
                       }
                     },
                     [&](const GenericKind::DefinedIo &io) {
                       switch (io) {
                       case GenericKind::DefinedIo::ReadFormatted:
                       case GenericKind::DefinedIo::ReadUnformatted:
                       case GenericKind::DefinedIo::WriteFormatted:
                       case GenericKind::DefinedIo::WriteUnformatted:
                         for (auto ref : generic.specificProcs()) {
-                          DescribeSpecialProc(
-                              specials, *ref, false, false /*!final*/, io);
+                          DescribeSpecialProc(specials, *ref, false,
+                              false /*!final*/, io, derivedTypeSpec);
                         }
                         break;
                       }
                     },
                     [](const auto &) {},
                 },
       generic.kind().u);
 }
 
 void RuntimeTableBuilder::DescribeSpecialProc(
     std::map<int, evaluate::StructureConstructor> &specials,
     const Symbol &specificOrBinding, bool isAssignment, bool isFinal,
-    std::optional<GenericKind::DefinedIo> io) {
+    std::optional<GenericKind::DefinedIo> io,
+    const DerivedTypeSpec *derivedTypeSpec) {
   const auto *binding{specificOrBinding.detailsIf<ProcBindingDetails>()};
   const Symbol &specific{*(binding ? &binding->symbol() : &specificOrBinding)};
   if (auto proc{evaluate::characteristics::Procedure::Characterize(
           specific, context_.foldingContext())}) {
     std::uint8_t isArgDescriptorSet{0};
     int argThatMightBeDescriptor{0};
     MaybeExpr which;
     if (isAssignment) {
if (isAssignment) {
           if (int rank{evaluate::GetRank(typeAndShape.shape())}; rank > 0) {
             argThatMightBeDescriptor = 1;
             which = IntExpr<1>(ToInt64(which).value() + rank);
           }
         }
       }
     } else { // user defined derived type I/O
       CHECK(proc->dummyArguments.size() >= 4);
+      if (derivedTypeSpec &&
+          !std::get<evaluate::characteristics::DummyDataObject>(
+              proc->dummyArguments[0].u)
+               .type.type()
+               .IsTkCompatibleWith(evaluate::DynamicType{*derivedTypeSpec})) {
+        // Defined I/O specific procedure is not for this derived type.
+        return;
+      }
       if (binding) {
         isArgDescriptorSet |= 1;
       }
       switch (io.value()) {
       case GenericKind::DefinedIo::ReadFormatted:
         which = readFormattedEnum_;
         break;
       case GenericKind::DefinedIo::ReadUnformatted:
if (auto proc{evaluate::characteristics::Procedure::Characterize(
     auto pair{specials.try_emplace(
         *index, DEREF(specialSchema_.AsDerived()), std::move(values))};
     CHECK(pair.second); // ensure not already present
   }
 }
 
 void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
     std::map<int, evaluate::StructureConstructor> &specials,
-    GenericKind::DefinedIo definedIo, const Scope *scope) {
+    GenericKind::DefinedIo definedIo, const Scope *scope,
+    const DerivedTypeSpec *derivedTypeSpec) {
   SourceName name{GenericKind::AsFortran(definedIo)};
   for (; !scope->IsGlobal(); scope = &scope->parent()) {
     if (auto asst{scope->find(name)}; asst != scope->end()) {
       const Symbol &generic{asst->second->GetUltimate()};
       const auto &genericDetails{generic.get<GenericDetails>()};
       CHECK(std::holds_alternative<GenericKind::DefinedIo>(
           genericDetails.kind().u));
       CHECK(std::get<GenericKind::DefinedIo>(genericDetails.kind().u) ==
           definedIo);
       for (auto ref : genericDetails.specificProcs()) {
-        DescribeSpecialProc(specials, *ref, false, false, definedIo);
+        DescribeSpecialProc(
+            specials, *ref, false, false, definedIo, derivedTypeSpec);
       }
     }
   }
 }
 
 RuntimeDerivedTypeTables BuildRuntimeDerivedTypeTables(
     SemanticsContext &context) {
   RuntimeDerivedTypeTables result;

flang/test/Semantics/generic05.F90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Check for distinguishability of defined I/O procedures defined within
+! and outside their types.
+module m1
+  type t1
+    integer n
+   contains
+    procedure :: readt1a, readt1b
+    !ERROR: Generic 'read(unformatted)' may not have specific procedures 'readt1a' and 'readt1b' as their interfaces are not distinguishable
+    generic :: read(unformatted) => readt1a, readt1b
+  end type
+  type t2
+    integer n
+  end type
+  type t3
+    integer n
+  end type
+  !ERROR: Generic 'read(unformatted)' may not have specific procedures 'readt2a' and 'readt2b' as their interfaces are not distinguishable
+  interface read(unformatted)
+    module procedure :: readt1a, readt2a, readt2b, readt3
+  end interface
+ contains
+#define DEFINE_READU(name, type) \
+  subroutine name(dtv, unit, iostat, iomsg); \
+    class(type), intent(in out) :: dtv; \
+    integer, intent(in) :: unit; \
+    integer, intent(out) :: iostat; \
+    character(*), intent(in out) :: iomsg; \
+    read(unit, iostat=iostat, iomsg=iomsg) dtv%n; \
+  end subroutine name
+  !ERROR: Derived type 't1' already has defined input/output procedure 'read(unformatted)'
+  DEFINE_READU(readt1a, t1)
+  DEFINE_READU(readt1b, t1)
+  DEFINE_READU(readt2a, t2)
+  DEFINE_READU(readt2b, t2)
+  DEFINE_READU(readt3, t3)
+end module

flang/test/Semantics/io11.f90

 contains
   subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
     class(t),intent(inout) :: dtv
     integer,intent(in) :: unit
     integer,intent(out) :: iostat
     character(*),intent(inout) :: iomsg
     read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
   end subroutine
-  !ERROR: Derived type 't' already has defined input/output procedure 'READUNFORMATTED'
+  !ERROR: Derived type 't' already has defined input/output procedure 'read(unformatted)'
   subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
     class(t),intent(inout) :: dtv
     integer,intent(in) :: unit
     integer,intent(out) :: iostat
     character(*),intent(inout) :: iomsg
     read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
   end subroutine
 end module

 contains
   subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
     class(t),intent(inout) :: dtv
     integer,intent(in) :: unit
     integer,intent(out) :: iostat
     character(*),intent(inout) :: iomsg
     read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
   end subroutine
-  !ERROR: Derived type 't' already has defined input/output procedure 'READUNFORMATTED'
+  !ERROR: Derived type 't' already has defined input/output procedure 'read(unformatted)'
   subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
     class(t(4)),intent(inout) :: dtv
     integer,intent(in) :: unit
     integer,intent(out) :: iostat
     character(*),intent(inout) :: iomsg
     read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
   end subroutine
 end module

 contains
   subroutine unformattedReadProc(dtv,unit,iostat,iomsg)
     class(t(*)),intent(inout) :: dtv
     integer,intent(in) :: unit
     integer,intent(out) :: iostat
     character(*),intent(inout) :: iomsg
     read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
   end subroutine
-  !ERROR: Derived type 't' already has defined input/output procedure 'READUNFORMATTED'
+  !ERROR: Derived type 't' already has defined input/output procedure 'read(unformatted)'
   subroutine unformattedReadProc1(dtv,unit,iostat,iomsg)
     class(t(*)),intent(inout) :: dtv
     integer,intent(in) :: unit
     integer,intent(out) :: iostat
     character(*),intent(inout) :: iomsg
     read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
   end subroutine
 end module

flang/test/Semantics/resolve65.f90

subroutine assign_t4(x, y)
     class(t) :: x
       integer, intent(in) :: y
   end
 end
 
 module m2
   type :: t
   end type
+  !ERROR: Generic 'assignment(=)' may not have specific procedures 's3' and 's4' as their interfaces are not distinguishable
   interface assignment(=)
     !ERROR: In defined assignment subroutine 's1', dummy argument 'y' may not be OPTIONAL
     subroutine s1(x, y)
       import t
       type(t), intent(out) :: x
       real, optional, intent(in) :: y
     end
     !ERROR: In defined assignment subroutine 's2', dummy argument 'y' must be a data object