[flang] Add evaluate::GetDerivedTypeSpec(DynamicType)

It gets the semantics::DerivedTypeSpec of a DynamicType if it has one.
Make use of it where it simplifies the code.

Original-commit: flang-compiler/f18@9ad12e7c131459a8beab2b9ffa204966a85f405a
Reviewed-on: https://github.com/flang-compiler/f18/pull/872

diff --git a/flang/lib/evaluate/characteristics.cc b/flang/lib/evaluate/characteristics.cc
index 85b8caa..e2c4076 100644 (file)
--- a/flang/lib/evaluate/characteristics.cc
+++ b/flang/lib/evaluate/characteristics.cc
@@ -293,12 +293,11 @@ bool DummyDataObject::CanBePassedViaImplicitInterface() const {
     return false;  // 15.4.2.2(3)(b-d)
   } else if (type.type().IsPolymorphic()) {
     return false;  // 15.4.2.2(3)(f)
-  } else if (type.type().category() == TypeCategory::Derived) {
-    if (!type.type().GetDerivedTypeSpec().parameters().empty()) {
-      return false;  // 15.4.2.2(3)(e)
-    }
+  } else if (const auto *derived{GetDerivedTypeSpec(type.type())}) {
+    return derived->parameters().empty();  // 15.4.2.2(3)(e)
+  } else {
+    return true;
   }
-  return true;
 }
 
 std::ostream &DummyDataObject::Dump(std::ostream &o) const {

diff --git a/flang/lib/evaluate/type.cc b/flang/lib/evaluate/type.cc
index 86acfa5..621d8c1 100644 (file)
--- a/flang/lib/evaluate/type.cc
+++ b/flang/lib/evaluate/type.cc
@@ -100,6 +100,20 @@ bool DynamicType::IsTypelessIntrinsicArgument() const {
   return category_ == TypeCategory::Integer && kind_ == TypelessKind;
 }
 
+const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
+    const std::optional<DynamicType> &type) {
+  return type ? GetDerivedTypeSpec(*type) : nullptr;
+}
+
+const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &type) {
+  if (type.category() == TypeCategory::Derived &&
+      !type.IsUnlimitedPolymorphic()) {
+    return &type.GetDerivedTypeSpec();
+  } else {
+    return nullptr;
+  }
+}
+
 static const semantics::Symbol *FindParentComponent(
     const semantics::DerivedTypeSpec &derived) {
   const semantics::Symbol &typeSymbol{derived.typeSymbol()};

diff --git a/flang/lib/evaluate/type.h b/flang/lib/evaluate/type.h
index 0bc5e09..021d4ab 100644 (file)
--- a/flang/lib/evaluate/type.h
+++ b/flang/lib/evaluate/type.h
@@ -212,6 +212,11 @@ private:
   const semantics::DerivedTypeSpec *derived_{nullptr};  // TYPE(T), CLASS(T)
 };
 
+// Return the DerivedTypeSpec of a DynamicType if it has one.
+const semantics::DerivedTypeSpec *GetDerivedTypeSpec(const DynamicType &);
+const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
+    const std::optional<DynamicType> &);
+
 std::string DerivedTypeSpecAsFortran(const semantics::DerivedTypeSpec &);
 
 template<TypeCategory CATEGORY, int KIND = 0> struct TypeBase {

diff --git a/flang/lib/semantics/assignment.cc b/flang/lib/semantics/assignment.cc
index 577b007..57e55a6 100644 (file)
--- a/flang/lib/semantics/assignment.cc
+++ b/flang/lib/semantics/assignment.cc
@@ -593,14 +593,12 @@ void CheckDefinabilityInPureScope(parser::ContextualMessages &messages,
 
 static std::optional<std::string> GetPointerComponentDesignatorName(
     const SomeExpr &expr) {
-  if (auto type{evaluate::DynamicType::From(expr)}) {
-    if (type->category() == TypeCategory::Derived &&
-        !type->IsUnlimitedPolymorphic()) {
-      UltimateComponentIterator ultimates{type->GetDerivedTypeSpec()};
-      if (auto pointer{
-              std::find_if(ultimates.begin(), ultimates.end(), IsPointer)}) {
-        return pointer.BuildResultDesignatorName();
-      }
+  if (const auto *derived{
+          evaluate::GetDerivedTypeSpec(evaluate::DynamicType::From(expr))}) {
+    UltimateComponentIterator ultimates{*derived};
+    if (auto pointer{
+            std::find_if(ultimates.begin(), ultimates.end(), IsPointer)}) {
+      return pointer.BuildResultDesignatorName();
     }
   }
   return std::nullopt;
@@ -648,11 +646,9 @@ void AssignmentContext::CheckForPureContext(const SomeExpr &lhs,
           Say(at_,
               "Deallocation of polymorphic object is not permitted in a PURE subprogram"_err_en_US);
         }
-        if (type->category() == TypeCategory::Derived &&
-            !type->IsUnlimitedPolymorphic()) {
-          const DerivedTypeSpec &derived{type->GetDerivedTypeSpec()};
+        if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
           if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
-                  derived)}) {
+                  *derived)}) {
             evaluate::SayWithDeclaration(messages, *bad,
                 "Deallocation of polymorphic non-coarray component '%s' is not permitted in a PURE subprogram"_err_en_US,
                 bad.BuildResultDesignatorName());

diff --git a/flang/lib/semantics/check-allocate.cc b/flang/lib/semantics/check-allocate.cc
index eed83d1..5f9d638 100644 (file)
--- a/flang/lib/semantics/check-allocate.cc
+++ b/flang/lib/semantics/check-allocate.cc
@@ -203,12 +203,10 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
       }
       info.sourceExprRank = expr->Rank();
       info.sourceExprLoc = parserSourceExpr->source;
-      if (info.sourceExprType.value().category() == TypeCategory::Derived &&
-          !info.sourceExprType.value().IsUnlimitedPolymorphic()) {
-        const DerivedTypeSpec &derived{
-            info.sourceExprType.value().GetDerivedTypeSpec()};
+      if (const DerivedTypeSpec *
+          derived{evaluate::GetDerivedTypeSpec(info.sourceExprType)}) {
         // C949
-        if (auto it{FindCoarrayUltimateComponent(derived)}) {
+        if (auto it{FindCoarrayUltimateComponent(*derived)}) {
           context
               .Say(at,
                   "SOURCE or MOLD expression must not have a type with a coarray ultimate component"_err_en_US)
@@ -219,10 +217,10 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
         }
         if (info.gotSource) {
           // C948
-          if (IsEventTypeOrLockType(&derived)) {
+          if (IsEventTypeOrLockType(derived)) {
             context.Say(at,
                 "SOURCE expression type must not be EVENT_TYPE or LOCK_TYPE from ISO_FORTRAN_ENV"_err_en_US);
-          } else if (auto it{FindEventOrLockPotentialComponent(derived)}) {
+          } else if (auto it{FindEventOrLockPotentialComponent(*derived)}) {
             context
                 .Say(at,
                     "SOURCE expression type must not have potential subobject "
@@ -571,16 +569,14 @@ bool AllocationCheckerHelper::RunCoarrayRelatedChecks(
       // C948
       const evaluate::DynamicType &sourceType{
           allocateInfo_.sourceExprType.value()};
-      if (sourceType.category() == TypeCategory::Derived &&
-          !sourceType.IsUnlimitedPolymorphic()) {
-        const DerivedTypeSpec derived{sourceType.GetDerivedTypeSpec()};
-        if (IsTeamType(&derived)) {
+      if (const auto *derived{evaluate::GetDerivedTypeSpec(sourceType)}) {
+        if (IsTeamType(derived)) {
           context
               .Say(allocateInfo_.sourceExprLoc.value(),
                   "SOURCE or MOLD expression type must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray"_err_en_US)
               .Attach(name_.source, "'%s' is a coarray"_en_US, name_.source);
           return false;
-        } else if (IsIsoCType(&derived)) {
+        } else if (IsIsoCType(derived)) {
           context
               .Say(allocateInfo_.sourceExprLoc.value(),
                   "SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray"_err_en_US)

diff --git a/flang/lib/semantics/check-call.cc b/flang/lib/semantics/check-call.cc
index 788b815..5b323f2 100644 (file)
--- a/flang/lib/semantics/check-call.cc
+++ b/flang/lib/semantics/check-call.cc
@@ -44,9 +44,8 @@ static void CheckImplicitInterfaceArg(
     } else if (type->IsPolymorphic()) {
       messages.Say(
           "Polymorphic argument requires an explicit interface"_err_en_US);
-    } else if (type->category() == TypeCategory::Derived) {
-      auto &derived{type->GetDerivedTypeSpec()};
-      if (!derived.parameters().empty()) {
+    } else if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
+      if (!derived->parameters().empty()) {
         messages.Say(
             "Parameterized derived type argument requires an explicit interface"_err_en_US);
       }
@@ -157,17 +156,15 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};
   bool actualIsVolatile{
       actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
-  if (!actualType.type().IsUnlimitedPolymorphic() &&
-      actualType.type().category() == TypeCategory::Derived) {
-    const auto &derived{actualType.type().GetDerivedTypeSpec()};
+  if (const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())}) {
     if (dummy.type.type().IsAssumedType()) {
-      if (!derived.parameters().empty()) {  // 15.5.2.4(2)
+      if (!derived->parameters().empty()) {  // 15.5.2.4(2)
         messages.Say(
             "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
             dummyName);
       }
       if (const Symbol *
-          tbp{FindImmediateComponent(derived, [](const Symbol &symbol) {
+          tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) {
             return symbol.has<ProcBindingDetails>();
           })}) {  // 15.5.2.4(2)
         evaluate::SayWithDeclaration(messages, *tbp,
@@ -175,7 +172,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             dummyName, tbp->name());
       }
       if (const Symbol *
-          finalizer{FindImmediateComponent(derived, [](const Symbol &symbol) {
+          finalizer{FindImmediateComponent(*derived, [](const Symbol &symbol) {
             return symbol.has<FinalProcDetails>();
           })}) {  // 15.5.2.4(2)
         evaluate::SayWithDeclaration(messages, *finalizer,
@@ -186,7 +183,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     if (actualIsCoindexed) {
       if (dummy.intent != common::Intent::In && !dummyIsValue) {
         if (auto bad{
-                FindAllocatableUltimateComponent(derived)}) {  // 15.5.2.4(6)
+                FindAllocatableUltimateComponent(*derived)}) {  // 15.5.2.4(6)
           evaluate::SayWithDeclaration(messages, *bad,
               "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
               bad.BuildResultDesignatorName(), dummyName);
@@ -206,7 +203,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       }
     }
     if (actualIsVolatile != dummyIsVolatile) {  // 15.5.2.4(22)
-      if (auto bad{semantics::FindCoarrayUltimateComponent(derived)}) {
+      if (auto bad{semantics::FindCoarrayUltimateComponent(*derived)}) {
         evaluate::SayWithDeclaration(messages, *bad,
             "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
             dummyName, bad.BuildResultDesignatorName());
@@ -400,11 +397,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
               "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type"_err_en_US);
         }
       }
-      if (actualType.type().category() == TypeCategory::Derived &&
-          !DefersSameTypeParameters(actualType.type().GetDerivedTypeSpec(),
-              dummy.type.type().GetDerivedTypeSpec())) {
-        messages.Say(
-            "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
+      if (const auto *derived{
+              evaluate::GetDerivedTypeSpec(actualType.type())}) {
+        if (!DefersSameTypeParameters(
+                *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) {
+          messages.Say(
+              "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);
+        }
       }
     }
   }

diff --git a/flang/lib/semantics/check-coarray.cc b/flang/lib/semantics/check-coarray.cc
index 088afaa..2b8ac22 100644 (file)
--- a/flang/lib/semantics/check-coarray.cc
+++ b/flang/lib/semantics/check-coarray.cc
@@ -26,13 +26,9 @@ namespace Fortran::semantics {
 template<typename T>
 static void CheckTeamType(SemanticsContext &context, const T &x) {
   if (const auto *expr{GetExpr(x)}) {
-    if (auto type{expr->GetType()}) {
-      if (type->category() != TypeCategory::Derived ||
-          type->IsUnlimitedPolymorphic() ||
-          !IsTeamType(&type->GetDerivedTypeSpec())) {
-        context.Say(parser::FindSourceLocation(x),  // C1114
-            "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
-      }
+    if (!IsTeamType(evaluate::GetDerivedTypeSpec(expr->GetType()))) {
+      context.Say(parser::FindSourceLocation(x),  // C1114
+          "Team value must be of type TEAM_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
     }
   }
 }

diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc
index 0bebe4b..9b54b42 100644 (file)
--- a/flang/lib/semantics/expression.cc
+++ b/flang/lib/semantics/expression.cc
@@ -913,16 +913,6 @@ static std::optional<Component> CreateComponent(
   return std::nullopt;
 }
 
-static const semantics::DerivedTypeSpec *GetDerivedTypeSpec(
-    const std::optional<DynamicType> &type) {
-  if (type && type->category() == TypeCategory::Derived) {
-    if (!type->IsUnlimitedPolymorphic()) {
-      return &type->GetDerivedTypeSpec();
-    }
-  }
-  return nullptr;
-}
-
 // Derived type component references and type parameter inquiries
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
   MaybeExpr base{Analyze(sc.base)};

diff --git a/flang/lib/semantics/tools.cc b/flang/lib/semantics/tools.cc
index 25c7e11..90878d6 100644 (file)
--- a/flang/lib/semantics/tools.cc
+++ b/flang/lib/semantics/tools.cc
@@ -95,11 +95,14 @@ Tristate IsDefinedAssignment(
   } else if (lhsCat != TypeCategory::Derived) {
     return ToTristate(lhsCat != rhsCat &&
         (!IsNumericTypeCategory(lhsCat) || !IsNumericTypeCategory(rhsCat)));
-  } else if (rhsCat == TypeCategory::Derived &&
-      lhsType->GetDerivedTypeSpec() == rhsType->GetDerivedTypeSpec()) {
-    return Tristate::Maybe;  // TYPE(t) = TYPE(t) can be defined or intrinsic
   } else {
-    return Tristate::Yes;
+    const auto *lhsDerived{evaluate::GetDerivedTypeSpec(lhsType)};
+    const auto *rhsDerived{evaluate::GetDerivedTypeSpec(rhsType)};
+    if (lhsDerived && rhsDerived && *lhsDerived == *rhsDerived) {
+      return Tristate::Maybe;  // TYPE(t) = TYPE(t) can be defined or intrinsic
+    } else {
+      return Tristate::Yes;
+    }
   }
 }