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

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.

Differential Revision: https://reviews.llvm.org/D142769

diff --git a/flang/lib/Decimal/big-radix-floating-point.h b/flang/lib/Decimal/big-radix-floating-point.h
index 3256323..7fabc7b 100644 (file)
--- a/flang/lib/Decimal/big-radix-floating-point.h
+++ b/flang/lib/Decimal/big-radix-floating-point.h
@@ -9,8 +9,8 @@
 #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.

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 535f2f2..6831cfe 100644 (file)
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -1188,6 +1188,10 @@ private:
 // 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()) {
@@ -1203,6 +1207,10 @@ bool DistinguishUtils::DistinguishableOpOrAssign(
 
 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)};

diff --git a/flang/lib/Parser/provenance.cpp b/flang/lib/Parser/provenance.cpp
index 355d280..5c40ab7 100644 (file)
--- a/flang/lib/Parser/provenance.cpp
+++ b/flang/lib/Parser/provenance.cpp
@@ -293,7 +293,7 @@ void AllSources::EmitMessage(llvm::raw_ostream &o,
           [&](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  ";

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index f849bcd..7f85f83 100644 (file)
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1347,9 +1347,6 @@ void CheckHelper::CheckGeneric(
 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)}) {
@@ -2206,8 +2203,7 @@ void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec &derivedType,
       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;
     }
   }

diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp
index 45917bf..18b701f 100644 (file)
--- a/flang/lib/Semantics/runtime-type-info.cpp
+++ b/flang/lib/Semantics/runtime-type-info.cpp
@@ -67,14 +67,14 @@ private:
   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>
@@ -519,7 +519,7 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
               [&](const ProcBindingDetails &) { // handled in a later pass
               },
               [&](const GenericDetails &generic) {
-                DescribeGeneric(generic, specials);
+                DescribeGeneric(generic, specials, derivedTypeSpec);
               },
               [&](const auto &) {
                 common::die(
@@ -569,16 +569,18 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
       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.
@@ -985,13 +987,14 @@ RuntimeTableBuilder::DescribeBindings(const Scope &dtScope, Scope &scope) {
 }
 
 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);
                         }
                       }
                     },
@@ -1002,8 +1005,8 @@ void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
                       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;
                       }
@@ -1016,7 +1019,8 @@ void RuntimeTableBuilder::DescribeGeneric(const GenericDetails &generic,
 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(
@@ -1079,6 +1083,14 @@ void RuntimeTableBuilder::DescribeSpecialProc(
       }
     } 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;
       }
@@ -1119,7 +1131,8 @@ void RuntimeTableBuilder::DescribeSpecialProc(
 
 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()) {
@@ -1130,7 +1143,8 @@ void RuntimeTableBuilder::IncorporateDefinedIoGenericInterfaces(
       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);
       }
     }
   }

diff --git a/flang/test/Semantics/generic05.F90 b/flang/test/Semantics/generic05.F90
new file mode 100644 (file)
index 0000000..5d19137
--- /dev/null
+++ b/flang/test/Semantics/generic05.F90
@@ -0,0 +1,37 @@
+! 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

diff --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index 07e9377..3c9b8b7 100644 (file)
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -435,7 +435,7 @@ contains
     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
@@ -499,7 +499,7 @@ contains
     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
@@ -593,7 +593,7 @@ contains
     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

diff --git a/flang/test/Semantics/resolve65.f90 b/flang/test/Semantics/resolve65.f90
index f4a8d6b..00070b8 100644 (file)
--- a/flang/test/Semantics/resolve65.f90
+++ b/flang/test/Semantics/resolve65.f90
@@ -48,6 +48,7 @@ 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)