diff --git a/flang/lib/Decimal/big-radix-floating-point.h b/flang/lib/Decimal/big-radix-floating-point.h index 32563235a76cb..7fabc7bb0fce2 100644 --- 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 535f2f2158c1c..6831cfead727a 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -1188,6 +1188,10 @@ class DistinguishUtils { // 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 355d280504a7c..5c40ab7bb433a 100644 --- 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 f849bcd5ed6d2..7f85f83c79f4e 100644 --- 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 45917bf35c4fc..18b701f0b66a9 100644 --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -67,14 +67,14 @@ class RuntimeTableBuilder { SomeExpr PackageIntValueExpr(const SomeExpr &genre, std::int64_t = 0) const; std::vector DescribeBindings( const Scope &dtScope, Scope &); - void DescribeGeneric( - const GenericDetails &, std::map &); + void DescribeGeneric(const GenericDetails &, + std::map &, const DerivedTypeSpec *); void DescribeSpecialProc(std::map &, const Symbol &specificOrBinding, bool isAssignment, bool isFinal, - std::optional); + std::optional, const DerivedTypeSpec *); void IncorporateDefinedIoGenericInterfaces( std::map &, GenericKind::DefinedIo, - const Scope *); + const Scope *, const DerivedTypeSpec *); // Instantiated for ParamValue and Bound template @@ -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()}; 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 &specials) { + std::map &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 &specials, const Symbol &specificOrBinding, bool isAssignment, bool isFinal, - std::optional io) { + std::optional io, + const DerivedTypeSpec *derivedTypeSpec) { const auto *binding{specificOrBinding.detailsIf()}; 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( + 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 &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(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 index 0000000000000..5d19137f301be --- /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 07e93773ea3a8..3c9b8b7f35849 100644 --- a/flang/test/Semantics/io11.f90 +++ b/flang/test/Semantics/io11.f90 @@ -435,7 +435,7 @@ subroutine unformattedReadProc1(dtv,unit,iostat,iomsg) 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 @@ subroutine unformattedReadProc(dtv,unit,iostat,iomsg) 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 @@ subroutine unformattedReadProc(dtv,unit,iostat,iomsg) 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 f4a8d6b9e41f3..00070b8ca8fb7 100644 --- a/flang/test/Semantics/resolve65.f90 +++ b/flang/test/Semantics/resolve65.f90 @@ -48,6 +48,7 @@ subroutine assign_t4(x, y) 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)