[flang] Avoid segfault in association semantics by cleaning up code a bit

Original-commit: flang-compiler/f18@04d40c3d75b0cf05e454e3b981e4a119bb8dcebb
Reviewed-on: https://github.com/flang-compiler/f18/pull/488
Tree-same-pre-rewrite: false

diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc
index 2586db0..25c98f4 100644 (file)
--- a/flang/lib/evaluate/intrinsics.cc
+++ b/flang/lib/evaluate/intrinsics.cc
@@ -1422,7 +1422,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
         bool ok{false};
         if (const auto &arg{specificCall->arguments[0]}) {
           if (const auto *expr{arg->UnwrapExpr()}) {
-            if (const Symbol * symbol{IsWholeSymbolDataRef(*expr)}) {
+            if (const Symbol * symbol{UnwrapWholeSymbolDataRef(*expr)}) {
               ok = symbol->attrs().test(semantics::Attr::OPTIONAL);
             }
           }

diff --git a/flang/lib/evaluate/tools.h b/flang/lib/evaluate/tools.h
index 9fcace3..ff4d420 100644 (file)
--- a/flang/lib/evaluate/tools.h
+++ b/flang/lib/evaluate/tools.h
@@ -72,9 +72,16 @@ template<typename A> bool IsVariable(const FunctionRef<A> &funcRef) {
     return false;
   }
 }
-template<typename A> bool IsVariable(const Expr<A> &expr) {
+template<typename T> bool IsVariable(const Expr<T> &expr) {
   return std::visit([](const auto &x) { return IsVariable(x); }, expr.u);
 }
+template<typename A> bool IsVariable(const std::optional<A> &x) {
+  if (x.has_value()) {
+    return IsVariable(*x);
+  } else {
+    return false;
+  }
+}
 
 // Predicate: true when an expression is assumed-rank
 bool IsAssumedRank(const semantics::Symbol &);
@@ -88,9 +95,16 @@ template<typename A> bool IsAssumedRank(const Designator<A> &designator) {
     return false;
   }
 }
-template<typename A> bool IsAssumedRank(const Expr<A> &expr) {
+template<typename T> bool IsAssumedRank(const Expr<T> &expr) {
   return std::visit([](const auto &x) { return IsAssumedRank(x); }, expr.u);
 }
+template<typename A> bool IsAssumedRank(const std::optional<A> &x) {
+  if (x.has_value()) {
+    return IsAssumedRank(*x);
+  } else {
+    return false;
+  }
+}
 
 // Generalizing packagers: these take operations and expressions of more
 // specific types and wrap them in Expr<> containers of more abstract types.
@@ -145,7 +159,7 @@ template<typename A> constexpr bool IsNumericCategoryExpr() {
 
 // Specializing extractor.  If an Expr wraps some type of object, perhaps
 // in several layers, return a pointer to it; otherwise null.  Also works
-// with ActualArgument.
+// with expressions contained in ActualArgument.
 template<typename A, typename B>
 auto UnwrapExpr(B &x) -> common::Constify<A, B> * {
   using Ty = std::decay_t<B>;
@@ -188,7 +202,6 @@ template<typename A>
 common::IfNoLvalue<std::optional<DataRef>, A> ExtractDataRef(const A &) {
   return std::nullopt;  // default base casec
 }
-
 template<typename T>
 std::optional<DataRef> ExtractDataRef(const Designator<T> &d) {
   return std::visit(
@@ -200,12 +213,10 @@ std::optional<DataRef> ExtractDataRef(const Designator<T> &d) {
       },
       d.u);
 }
-
 template<typename T>
 std::optional<DataRef> ExtractDataRef(const Expr<T> &expr) {
   return std::visit([](const auto &x) { return ExtractDataRef(x); }, expr.u);
 }
-
 template<typename A>
 std::optional<DataRef> ExtractDataRef(const std::optional<A> &x) {
   if (x.has_value()) {
@@ -217,7 +228,7 @@ std::optional<DataRef> ExtractDataRef(const std::optional<A> &x) {
 
 // If an expression is simply a whole symbol data designator,
 // extract and return that symbol, else null.
-template<typename A> const Symbol *IsWholeSymbolDataRef(const A &x) {
+template<typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {
   if (auto dataRef{ExtractDataRef(x)}) {
     if (const Symbol **p{std::get_if<const Symbol *>(&dataRef->u)}) {
       return *p;
@@ -603,27 +614,36 @@ struct TypeKindVisitor {
   VALUE value;
 };
 
+// GetLastSymbol() returns the rightmost symbol in an object or procedure
+// designator (possibly wrapped in an Expr<>), or a null pointer if
+// none is found.
 template<typename A> const semantics::Symbol *GetLastSymbol(const A &) {
   return nullptr;
 }
-
 template<typename T>
 const semantics::Symbol *GetLastSymbol(const Designator<T> &x) {
   return x.GetLastSymbol();
 }
-
 inline const semantics::Symbol *GetLastSymbol(const ProcedureDesignator &x) {
   return x.GetSymbol();
 }
-
 inline const semantics::Symbol *GetLastSymbol(const ProcedureRef &x) {
   return GetLastSymbol(x.proc());
 }
-
 template<typename T> const semantics::Symbol *GetLastSymbol(const Expr<T> &x) {
   return std::visit([](const auto &y) { return GetLastSymbol(y); }, x.u);
 }
+template<typename A>
+const semantics::Symbol *GetLastSymbol(const std::optional<A> &x) {
+  if (x.has_value()) {
+    return GetLastSymbol(*x);
+  } else {
+    return nullptr;
+  }
+}
 
+// Convenience: If GetLastSymbol() succeeds on the argument, return its
+// set of attributes, otherwise the empty set.
 template<typename A> semantics::Attrs GetAttrs(const A &x) {
   if (const semantics::Symbol * symbol{GetLastSymbol(x)}) {
     return symbol->attrs();
@@ -632,11 +652,13 @@ template<typename A> semantics::Attrs GetAttrs(const A &x) {
   }
 }
 
+// Predicate: IsAllocatableOrPointer()
 template<typename A> bool IsAllocatableOrPointer(const A &x) {
   return GetAttrs(x).HasAny(
       semantics::Attrs{semantics::Attr::POINTER, semantics::Attr::ALLOCATABLE});
 }
 
+// Predicate: IsProcedurePointer()
 template<typename A> bool IsProcedurePointer(const A &) { return false; }
 inline bool IsProcedurePointer(const ProcedureDesignator &) { return true; }
 inline bool IsProcedurePointer(const ProcedureRef &) { return true; }
@@ -644,5 +666,12 @@ inline bool IsProcedurePointer(const Expr<SomeType> &expr) {
   return std::visit(
       [](const auto &x) { return IsProcedurePointer(x); }, expr.u);
 }
+template<typename A> bool IsProcedurePointer(const std::optional<A> &x) {
+  if (x.has_value()) {
+    return IsProcedurePointer(*x);
+  } else {
+    return false;
+  }
+}
 }
 #endif  // FORTRAN_EVALUATE_TOOLS_H_

diff --git a/flang/lib/parser/parse-tree.cc b/flang/lib/parser/parse-tree.cc
index 0187492..edd23c2 100644 (file)
--- a/flang/lib/parser/parse-tree.cc
+++ b/flang/lib/parser/parse-tree.cc
@@ -207,6 +207,19 @@ Statement<ActionStmt> StmtFunctionStmt::ConvertToAssignment() {
           AssignmentStmt{std::move(variable), std::move(funcExpr)}}}};
 }
 
+CharBlock Variable::GetSource() const {
+  return std::visit(
+      common::visitors{
+          [&](const common::Indirection<Designator> &des) {
+            return des.value().source;
+          },
+          [&](const common::Indirection<parser::FunctionReference> &call) {
+            return call.value().v.source;
+          },
+      },
+      u);
+}
+
 std::ostream &operator<<(std::ostream &os, const Name &x) {
   return os << x.ToString();
 }

diff --git a/flang/lib/parser/parse-tree.h b/flang/lib/parser/parse-tree.h
index 8818b4a..5e6cb07 100644 (file)
--- a/flang/lib/parser/parse-tree.h
+++ b/flang/lib/parser/parse-tree.h
@@ -1773,6 +1773,7 @@ struct Designator {
 struct Variable {
   UNION_CLASS_BOILERPLATE(Variable);
   mutable Expr::TypedExpr typedExpr;
+  parser::CharBlock GetSource() const;
   std::variant<common::Indirection<Designator>,
       common::Indirection<FunctionReference>>
       u;

diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc
index 58453e5..066d01c 100644 (file)
--- a/flang/lib/semantics/resolve-names.cc
+++ b/flang/lib/semantics/resolve-names.cc
@@ -928,13 +928,11 @@ private:
   // expr is set in either case unless there were errors
   struct Selector {
     Selector() {}
-    Selector(const parser::CharBlock &source, MaybeExpr &&expr,
-        const parser::Name *variable = nullptr)
-      : source{source}, expr{std::move(expr)}, variable{variable} {}
+    Selector(const parser::CharBlock &source, MaybeExpr &&expr)
+      : source{source}, expr{std::move(expr)} {}
     operator bool() const { return expr.has_value(); }
     parser::CharBlock source;
     MaybeExpr expr;
-    const parser::Name *variable{nullptr};
   };
   // association -> [associate-name =>] selector
   struct {
@@ -4017,7 +4015,8 @@ void ConstructVisitor::Post(const parser::CoarrayAssociation &x) {
   if (auto *symbol{FindInScope(currScope(), name)}) {
     const auto &selector{std::get<parser::Selector>(x.t)};
     if (auto sel{ResolveSelector(selector)}) {
-      if (!sel.variable || sel.variable->symbol->Corank() == 0) {
+      const Symbol *whole{UnwrapWholeSymbolDataRef(sel.expr)};
+      if (!whole || whole->Corank() == 0) {
         Say(sel.source,  // C1116
             "Selector in coarray association must name a coarray"_err_en_US);
       } else if (auto dynType{sel.expr->GetType()}) {
@@ -4040,8 +4039,8 @@ void ConstructVisitor::Post(const parser::SelectTypeStmt &x) {
     MakePlaceholder(*name, MiscDetails::Kind::SelectTypeAssociateName);
     association_.name = &*name;
   } else {
-    const auto *varName{association_.selector.variable};
-    if (!varName || !varName->symbol->has<ObjectEntityDetails>()) {
+    const Symbol *whole{UnwrapWholeSymbolDataRef(association_.selector.expr)};
+    if (!whole || !whole->has<ObjectEntityDetails>()) {
       Say(association_.selector.source,  // C1157
           "Selector is not a named variable: 'associate-name =>' is required"_err_en_US);
       association_ = {};
@@ -4094,55 +4093,55 @@ Symbol *ConstructVisitor::MakeAssocEntity() {
     return nullptr;
   }
   if (auto &expr{association_.selector.expr}) {
-    symbol.set_details(AssocEntityDetails{std::move(*expr)});
-    association_.selector.expr.reset();
+    symbol.set_details(AssocEntityDetails{common::Clone(*expr)});
   } else {
     symbol.set_details(AssocEntityDetails{});
   }
   return &symbol;
 }
 
-// Set the type of symbol based on the current association variable or expr.
+// Set the type of symbol based on the current association selector.
 void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) {
-  if (association_.selector.variable) {
-    const Symbol *varSymbol{association_.selector.variable->symbol};
-    CHECK(varSymbol);
-    if (const DeclTypeSpec * type{varSymbol->GetType()}) {
-      symbol.SetType(*type);
-    }
-  } else {
-    auto &details{symbol.get<AssocEntityDetails>()};
-    if (const MaybeExpr & expr{details.expr()}) {
-      if (std::optional<evaluate::DynamicType> type{expr->GetType()}) {
-        if (const auto *charExpr{
-                evaluate::UnwrapExpr<evaluate::Expr<evaluate::SomeCharacter>>(
-                    *expr)}) {
-          symbol.SetType(ToDeclTypeSpec(std::move(*type),
-              FoldExpr(std::visit(
-                  [](const auto &kindChar) { return kindChar.LEN(); },
-                  charExpr->u))));
-        } else {
-          symbol.SetType(ToDeclTypeSpec(std::move(*type)));
+  auto &details{symbol.get<AssocEntityDetails>()};
+  const MaybeExpr *pexpr{&details.expr()};
+  if (!pexpr->has_value()) {
+    pexpr = &association_.selector.expr;
+  }
+  if (pexpr->has_value()) {
+    const SomeExpr &expr{**pexpr};
+    if (evaluate::IsVariable(expr)) {
+      if (const Symbol * varSymbol{evaluate::GetLastSymbol(expr)}) {
+        if (const DeclTypeSpec * type{varSymbol->GetType()}) {
+          symbol.SetType(*type);
+          return;
         }
+      }
+    }
+    if (std::optional<evaluate::DynamicType> type{expr.GetType()}) {
+      if (const auto *charExpr{
+              evaluate::UnwrapExpr<evaluate::Expr<evaluate::SomeCharacter>>(
+                  expr)}) {
+        symbol.SetType(ToDeclTypeSpec(std::move(*type),
+            FoldExpr(
+                std::visit([](const auto &kindChar) { return kindChar.LEN(); },
+                    charExpr->u))));
       } else {
-        // BOZ literal not acceptable
-        Say(symbol.name(), "Associate name '%s' must have a type"_err_en_US);
+        symbol.SetType(ToDeclTypeSpec(std::move(*type)));
       }
+    } else {
+      // BOZ literals, procedure designators, &c. are not acceptable
+      Say(symbol.name(), "Associate name '%s' must have a type"_err_en_US);
     }
   }
 }
 
 // If current selector is a variable, set some of its attributes on symbol.
 void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) {
-  if (association_.selector.variable) {
-    if (const auto *varSymbol{association_.selector.variable->symbol}) {
-      symbol.attrs() |= varSymbol->attrs() &
-          Attrs{Attr::TARGET, Attr::ASYNCHRONOUS, Attr::VOLATILE,
-              Attr::CONTIGUOUS};
-      if (varSymbol->attrs().test(Attr::POINTER)) {
-        symbol.attrs().set(Attr::TARGET);
-      }
-    }
+  Attrs attrs{evaluate::GetAttrs(association_.selector.expr)};
+  symbol.attrs() |= attrs &
+      Attrs{Attr::TARGET, Attr::ASYNCHRONOUS, Attr::VOLATILE, Attr::CONTIGUOUS};
+  if (attrs.test(Attr::POINTER)) {
+    symbol.attrs().set(Attr::TARGET);
   }
 }
 
@@ -4150,15 +4149,11 @@ ConstructVisitor::Selector ConstructVisitor::ResolveSelector(
     const parser::Selector &x) {
   return std::visit(
       common::visitors{
-          [&](const parser::Expr &y) {
-            return Selector{y.source, EvaluateExpr(y)};
+          [&](const parser::Expr &expr) {
+            return Selector{expr.source, EvaluateExpr(expr)};
           },
-          [&](const parser::Variable &y) {
-            if (const auto *variable{ResolveVariable(y)}) {
-              return Selector{variable->source, EvaluateExpr(y), variable};
-            } else {
-              return Selector{};
-            }
+          [&](const parser::Variable &var) {
+            return Selector{var.GetSource(), EvaluateExpr(var)};
           },
       },
       x.u);
@@ -4174,8 +4169,10 @@ const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec(
   case common::TypeCategory::Logical:
     return context().MakeLogicalType(type.kind());
   case common::TypeCategory::Derived:
-    return currScope().MakeDerivedType(
-        DeclTypeSpec::TypeDerived, DerivedTypeSpec{type.GetDerivedTypeSpec()});
+    return currScope().MakeDerivedType(type.isPolymorphic()
+            ? DeclTypeSpec::ClassDerived
+            : DeclTypeSpec::TypeDerived,
+        DerivedTypeSpec{type.GetDerivedTypeSpec()});
   case common::TypeCategory::Character:
   default: CRASH_NO_CASE;
   }