diff --git a/flang/include/flang/Evaluate/traverse.h b/flang/include/flang/Evaluate/traverse.h index 7f4a67d97e64..90b93f6afd35 100644 --- a/flang/include/flang/Evaluate/traverse.h +++ b/flang/include/flang/Evaluate/traverse.h @@ -217,7 +217,7 @@ public: return CombineContents(x); } Result operator()(const semantics::DerivedTypeSpec &x) const { - return Combine(x.typeSymbol(), x.parameters()); + return Combine(x.originalTypeSymbol(), x.parameters()); } Result operator()(const StructureConstructorValues::value_type &x) const { return visitor_(x.second); diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h index e2d47d38f927..e2131e7e160c 100644 --- a/flang/include/flang/Semantics/type.h +++ b/flang/include/flang/Semantics/type.h @@ -259,6 +259,7 @@ public: DerivedTypeSpec(DerivedTypeSpec &&); const SourceName &name() const { return name_; } + const Symbol &originalTypeSymbol() const { return originalTypeSymbol_; } const Symbol &typeSymbol() const { return typeSymbol_; } const Scope *scope() const { return scope_; } // Return scope_ if it is set, or the typeSymbol_ scope otherwise. @@ -319,7 +320,8 @@ public: private: SourceName name_; - const Symbol &typeSymbol_; + const Symbol &originalTypeSymbol_; + const Symbol &typeSymbol_; // == originalTypeSymbol_.GetUltimate() const Scope *scope_{nullptr}; // same as typeSymbol_.scope() unless PDT bool cooked_{false}; bool evaluated_{false}; @@ -328,8 +330,9 @@ private: ParameterMapType parameters_; Category category_{Category::DerivedType}; bool RawEquals(const DerivedTypeSpec &that) const { - return &typeSymbol_ == &that.typeSymbol_ && cooked_ == that.cooked_ && - rawParameters_ == that.rawParameters_; + return &typeSymbol_ == &that.typeSymbol_ && + &originalTypeSymbol_ == &that.originalTypeSymbol_ && + cooked_ == that.cooked_ && rawParameters_ == that.rawParameters_; } friend llvm::raw_ostream &operator<<( llvm::raw_ostream &, const DerivedTypeSpec &); diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp index 70e24d6e82eb..2496e4427fe7 100644 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -66,8 +66,9 @@ bool ShapesAreCompatible(const std::optional &x, } bool TypeAndShape::operator==(const TypeAndShape &that) const { - return type_ == that.type_ && ShapesAreCompatible(shape_, that.shape_) && - attrs_ == that.attrs_ && corank_ == that.corank_; + return type_.IsEquivalentTo(that.type_) && + ShapesAreCompatible(shape_, that.shape_) && attrs_ == that.attrs_ && + corank_ == that.corank_; } TypeAndShape &TypeAndShape::Rewrite(FoldingContext &context) { diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index b852fbf12a6e..dfd49db74eea 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -2519,7 +2519,7 @@ void CheckHelper::CheckProcBinding( ? "A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US : "A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US); } else { - const auto *bindingChars{Characterize(binding.symbol())}; + const auto *bindingChars{Characterize(symbol)}; const auto *overriddenChars{Characterize(*overridden)}; if (bindingChars && overriddenChars) { if (isNopass) { diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 7c692440d247..0ff2795cc984 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3053,11 +3053,16 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, const Symbol &useUltimate{useSymbol.GetUltimate()}; const auto *useGeneric{useUltimate.detailsIf()}; if (localSymbol->has()) { - if (useGeneric && useGeneric->specific() && - IsProcedurePointer(*useGeneric->specific())) { - // We are use-associating a generic that shadows a procedure pointer. - // Local references that might be made to that procedure pointer should - // use a UseDetails symbol for proper data addressing. So create an + if (useGeneric && + ((useGeneric->specific() && + IsProcedurePointer(*useGeneric->specific())) || + (useGeneric->derivedType() && + useUltimate.name() != localSymbol->name()))) { + // We are use-associating a generic that either shadows a procedure + // pointer or shadows a derived type of the same name. + // Local references that might be made to the procedure pointer should + // use a UseDetails symbol for proper data addressing, and a derived + // type needs to be in scope with the renamed name. So create an // empty local generic now into which the use-associated generic may // be copied. localSymbol->set_details(GenericDetails{}); @@ -3153,9 +3158,15 @@ void ModuleVisitor::DoAddUse(SourceName location, SourceName localName, if (!useDerivedType) { combinedDerivedType = localDerivedType; } else if (!localDerivedType) { - combinedDerivedType = useDerivedType; + if (useDerivedType->name() == localName) { + combinedDerivedType = useDerivedType; + } else { + Symbol &combined{currScope().MakeSymbol(localName, + useDerivedType->attrs(), UseDetails{localName, *useDerivedType})}; + combinedDerivedType = &combined; + } } else { - const Scope *localScope{localDerivedType->scope()}; + const Scope *localScope{localDerivedType->GetUltimate().scope()}; const Scope *useScope{useDerivedType->GetUltimate().scope()}; if (localScope && useScope && localScope->derivedTypeSpec() && useScope->derivedTypeSpec() && @@ -6776,9 +6787,7 @@ std::optional DeclarationVisitor::ResolveDerivedType( } if (CheckUseError(name)) { return std::nullopt; - } - symbol = &symbol->GetUltimate(); - if (symbol->has()) { + } else if (symbol->GetUltimate().has()) { return DerivedTypeSpec{name.source, *symbol}; } else { Say(name, "'%s' is not a derived type"_err_en_US); @@ -7120,12 +7129,10 @@ bool ConstructVisitor::Pre(const parser::DataStmtValue &x) { auto &mutableData{const_cast(data)}; if (auto *elem{parser::Unwrap(mutableData)}) { if (const auto *name{std::get_if(&elem->base.u)}) { - if (const Symbol * symbol{FindSymbol(*name)}) { - const Symbol &ultimate{symbol->GetUltimate()}; - if (ultimate.has()) { - mutableData.u = elem->ConvertToStructureConstructor( - DerivedTypeSpec{name->source, ultimate}); - } + if (const Symbol * symbol{FindSymbol(*name)}; + symbol && symbol->GetUltimate().has()) { + mutableData.u = elem->ConvertToStructureConstructor( + DerivedTypeSpec{name->source, *symbol}); } } } diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index 810b9829b0b8..e867d7ad6e25 100644 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -22,8 +22,9 @@ namespace Fortran::semantics { DerivedTypeSpec::DerivedTypeSpec(SourceName name, const Symbol &typeSymbol) - : name_{name}, typeSymbol_{typeSymbol} { - CHECK(typeSymbol.has()); + : name_{name}, originalTypeSymbol_{typeSymbol}, + typeSymbol_{typeSymbol.GetUltimate()} { + CHECK(typeSymbol_.has()); } DerivedTypeSpec::DerivedTypeSpec(const DerivedTypeSpec &that) = default; DerivedTypeSpec::DerivedTypeSpec(DerivedTypeSpec &&that) = default; @@ -340,9 +341,7 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) { const Scope &typeScope{DEREF(typeSymbol_.scope())}; if (!MightBeParameterized()) { scope_ = &typeScope; - if (typeScope.derivedTypeSpec()) { - CHECK(*this == *typeScope.derivedTypeSpec()); - } else { + if (!typeScope.derivedTypeSpec() || *this != *typeScope.derivedTypeSpec()) { Scope &mutableTypeScope{const_cast(typeScope)}; mutableTypeScope.set_derivedTypeSpec(*this); InstantiateNonPDTScope(mutableTypeScope, containingScope); @@ -664,7 +663,7 @@ std::string DerivedTypeSpec::VectorTypeAsFortran() const { std::string DerivedTypeSpec::AsFortran() const { std::string buf; llvm::raw_string_ostream ss{buf}; - ss << name_; + ss << originalTypeSymbol_.name(); if (!rawParameters_.empty()) { CHECK(parameters_.empty()); ss << '('; diff --git a/flang/test/Semantics/get_team.f90 b/flang/test/Semantics/get_team.f90 index a28b0d72f23f..7e4886703d17 100644 --- a/flang/test/Semantics/get_team.f90 +++ b/flang/test/Semantics/get_team.f90 @@ -49,7 +49,7 @@ program get_team_test !ERROR: repeated keyword argument to intrinsic 'get_team' result_team = get_team(level=initial_team, level=parent_team) - !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types LOGICAL(4) and TYPE(__builtin_team_type) + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types LOGICAL(4) and TYPE(team_type) wrong_result_type = get_team() end program get_team_test diff --git a/flang/test/Semantics/modfile68.f90 b/flang/test/Semantics/modfile68.f90 new file mode 100644 index 000000000000..550560303f08 --- /dev/null +++ b/flang/test/Semantics/modfile68.f90 @@ -0,0 +1,42 @@ +! RUN: %python %S/test_modfile.py %s %flang_fc1 +module m1 + use iso_c_binding, only : c_ptr, c_null_ptr + private + public :: t1 + type :: t1 + type(c_ptr) :: c_ptr = c_null_ptr + end type +end + +!Expect: m1.mod +!module m1 +!use,intrinsic::__fortran_builtins,only:__builtin_c_ptr +!use,intrinsic::iso_c_binding,only:c_ptr +!use,intrinsic::iso_c_binding,only:c_null_ptr +!private::__builtin_c_ptr +!private::c_ptr +!private::c_null_ptr +!type::t1 +!type(c_ptr)::c_ptr=__builtin_c_ptr(__address=0_8) +!end type +!end + +module m2 + use m1, only : t1 + private + public :: t2 + type :: t2 + type(t1) :: x = t1() + end type +end + +!Expect: m2.mod +!module m2 +!use,intrinsic::__fortran_builtins,only:__builtin_c_ptr +!use m1,only:t1 +!private::__builtin_c_ptr +!private::t1 +!type::t2 +!type(t1)::x=t1(c_ptr=__builtin_c_ptr(__address=0_8)) +!end type +!end diff --git a/flang/test/Semantics/modproc01.f90 b/flang/test/Semantics/modproc01.f90 index 5652e15750c7..5f45362e9509 100644 --- a/flang/test/Semantics/modproc01.f90 +++ b/flang/test/Semantics/modproc01.f90 @@ -144,8 +144,12 @@ end program !CHECK: a1, ALLOCATABLE size=40 offset=0: ObjectEntity type: TYPE(pdt2(k2=1_4,l2=3_4)) !CHECK: k1: TypeParam type:INTEGER(4) Kind init:1_4 !CHECK: l1: TypeParam type:INTEGER(4) Len init:3_4 -!CHECK: DerivedType scope: size=1 alignment=1 instantiation of pdt2(k2=1_4,l2=3_4) -!CHECK: a2: ObjectEntity type: TYPE(pdt1(k1=1_4,l1=3_4)) shape: 1_8:1_8 +!CHECK: DerivedType scope: size=48 alignment=8 instantiation of pdt2(k2=1_4,l2=3_4) sourceRange=0 bytes +!CHECK: a2 size=40 offset=8: ObjectEntity type: TYPE(pdt1(k1=1_4,l1=3_4)) shape: 1_8:1_8 !CHECK: j2 size=1 offset=0: ObjectEntity type: INTEGER(1) !CHECK: k2: TypeParam type:INTEGER(4) Kind init:1_4 !CHECK: l2: TypeParam type:INTEGER(4) Len init:3_4 +!CHECK: DerivedType scope: size=40 alignment=8 instantiation of pdt1(k1=1_4,l1=3_4) sourceRange=0 bytes +!CHECK: a1, ALLOCATABLE size=40 offset=0: ObjectEntity type: TYPE(pdt2(k2=1_4,l2=3_4)) +!CHECK: k1: TypeParam type:INTEGER(4) Kind init:1_4 +!CHECK: l1: TypeParam type:INTEGER(4) Len init:3_4