[flang] Improve checking of structure constructor arguments

When a misparsed FunctionReference was converted to a StructureConstructor,
the components accessed were not checked for accessibility.

The conversion happens in expression analysis so that where the accessibity
must be checked. So move `CheckAccessibleComponent` to `tools.h` so that it
can be shared by `resolve-names.cpp` and `expression.cpp`.

Add FindModuleContaining to help implement this and use it other places.

Check that an access-spec can only appear in a module.

Remove some unnecessary "semantics::" qualifiers.

Original-commit: flang-compiler/f18@99ce156e49ec0847ce42a6d10f0a62664714092b
Reviewed-on: https://github.com/flang-compiler/f18/pull/1046

diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index f739584..2c20195 100644 (file)
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -30,6 +30,7 @@ class DerivedTypeSpec;
 class Scope;
 class Symbol;
 
+const Scope *FindModuleContaining(const Scope &);
 const Symbol *FindCommonBlockContaining(const Symbol &object);
 const Scope *FindProgramUnitContaining(const Scope &);
 const Scope *FindProgramUnitContaining(const Symbol &);
@@ -167,6 +168,9 @@ std::unique_ptr<parser::Message> WhyNotModifiable(SourceName, const SomeExpr &,
 const Symbol *IsExternalInPureContext(const Symbol &, const Scope &);
 bool HasCoarray(const parser::Expr &);
 bool IsPolymorphicAllocatable(const Symbol &);
+// Return an error if component symbol is not accessible from scope (7.5.4.8(2))
+std::optional<parser::MessageFormattedText> CheckAccessibleComponent(
+    const semantics::Scope &, const Symbol &);
 
 // Analysis of image control statements
 bool IsImageControlStmt(const parser::ExecutableConstruct &);

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 8132a6b..ef7c764 100644 (file)
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1428,6 +1428,11 @@ MaybeExpr ExpressionAnalyzer::Analyze(
       }
     }
     if (symbol) {
+      if (const auto *currScope{context_.globalScope().FindScope(source)}) {
+        if (auto msg{CheckAccessibleComponent(*currScope, *symbol)}) {
+          Say(source, *msg);
+        }
+      }
       if (checkConflicts) {
         auto componentIter{
             std::find(components.begin(), components.end(), *symbol)};
@@ -1459,13 +1464,10 @@ MaybeExpr ExpressionAnalyzer::Analyze(
         } else if (symbol->has<semantics::ObjectEntityDetails>()) {
           // C1594(4)
           const auto &innermost{context_.FindScope(expr.source)};
-          if (const auto *pureProc{
-                  semantics::FindPureProcedureContaining(innermost)}) {
-            if (const Symbol *
-                pointer{semantics::FindPointerComponent(*symbol)}) {
+          if (const auto *pureProc{FindPureProcedureContaining(innermost)}) {
+            if (const Symbol * pointer{FindPointerComponent(*symbol)}) {
               if (const Symbol *
-                  object{semantics::FindExternallyVisibleObject(
-                      *value, *pureProc)}) {
+                  object{FindExternallyVisibleObject(*value, *pureProc)}) {
                 if (auto *msg{Say(expr.source,
                         "Externally visible object '%s' may not be "
                         "associated with pointer component '%s' in a "

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3cb31c9..38a9ba9 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -230,7 +230,6 @@ public:
   bool SetPassNameOn(Symbol &);
   bool SetBindNameOn(Symbol &);
   void Post(const parser::LanguageBindingSpec &);
-  bool Pre(const parser::AccessSpec &);
   bool Pre(const parser::IntentSpec &);
   bool Pre(const parser::Pass &);
 
@@ -435,8 +434,6 @@ public:
   Scope &currScope() { return DEREF(currScope_); }
   // The enclosing scope, skipping blocks and derived types.
   Scope &InclusiveScope();
-  // The global scope, containing program units.
-  Scope &GlobalScope();
 
   // Create a new scope and push it on the scope stack.
   void PushScope(Scope::Kind kind, Symbol *symbol);
@@ -699,6 +696,7 @@ public:
   bool Pre(const parser::NamedConstant &);
   void Post(const parser::EnumDef &);
   bool Pre(const parser::Enumerator &);
+  bool Pre(const parser::AccessSpec &);
   bool Pre(const parser::AsynchronousStmt &);
   bool Pre(const parser::ContiguousStmt &);
   bool Pre(const parser::ExternalStmt &);
@@ -804,7 +802,6 @@ protected:
       const parser::Name &, const std::optional<parser::IntegerTypeSpec> &);
   bool CheckUseError(const parser::Name &);
   void CheckAccessibility(const SourceName &, bool, Symbol &);
-  bool CheckAccessibleComponent(const SourceName &, const Symbol &);
   void CheckCommonBlocks();
   void CheckSaveStmts();
   void CheckEquivalenceSets();
@@ -1545,10 +1542,6 @@ void AttrsVisitor::Post(const parser::LanguageBindingSpec &x) {
     bindName_ = EvaluateExpr(*x.v);
   }
 }
-bool AttrsVisitor::Pre(const parser::AccessSpec &x) {
-  attrs_->set(AccessSpecToAttr(x));
-  return false;
-}
 bool AttrsVisitor::Pre(const parser::IntentSpec &x) {
   CHECK(attrs_);
   attrs_->set(IntentSpecToAttr(x));
@@ -1907,16 +1900,9 @@ Scope &ScopeHandler::InclusiveScope() {
       return *scope;
     }
   }
-  common::die("inclusive scope not found");
-}
-Scope &ScopeHandler::GlobalScope() {
-  for (auto *scope = currScope_; scope; scope = &scope->parent()) {
-    if (scope->IsGlobal()) {
-      return *scope;
-    }
-  }
-  common::die("global scope not found");
+  DIE("inclusive scope not found");
 }
+
 void ScopeHandler::PushScope(Scope::Kind kind, Symbol *symbol) {
   PushScope(currScope().MakeScope(kind, symbol));
 }
@@ -2879,37 +2865,6 @@ void DeclarationVisitor::CheckAccessibility(
   }
 }
 
-// Check that component is accessible from current scope.
-bool DeclarationVisitor::CheckAccessibleComponent(
-    const SourceName &name, const Symbol &symbol) {
-  if (!symbol.attrs().test(Attr::PRIVATE)) {
-    return true;
-  }
-  // component must be in a module/submodule because of PRIVATE:
-  const Scope *moduleScope{&symbol.owner()};
-  CHECK(moduleScope->IsDerivedType());
-  while (
-      moduleScope->kind() != Scope::Kind::Module && !moduleScope->IsGlobal()) {
-    moduleScope = &moduleScope->parent();
-  }
-  if (moduleScope->kind() == Scope::Kind::Module) {
-    for (auto *scope{&currScope()}; !scope->IsGlobal();
-         scope = &scope->parent()) {
-      if (scope == moduleScope) {
-        return true;
-      }
-    }
-    Say(name,
-        "PRIVATE component '%s' is only accessible within module '%s'"_err_en_US,
-        name.ToString(), moduleScope->GetName().value());
-  } else {
-    Say(name,
-        "PRIVATE component '%s' is only accessible within its module"_err_en_US,
-        name.ToString());
-  }
-  return false;
-}
-
 void DeclarationVisitor::Post(const parser::TypeDeclarationStmt &) {
   if (!GetAttrs().HasAny({Attr::POINTER, Attr::ALLOCATABLE})) {  // C702
     if (const auto *typeSpec{GetDeclTypeSpec()}) {
@@ -3067,6 +3022,19 @@ void DeclarationVisitor::Post(const parser::EnumDef &) {
   enumerationState_ = EnumeratorState{};
 }
 
+bool DeclarationVisitor::Pre(const parser::AccessSpec &x) {
+  Attr attr{AccessSpecToAttr(x)};
+  const Scope &scope{
+      currScope().IsDerivedType() ? currScope().parent() : currScope()};
+  if (!scope.IsModule()) {  // C817
+    Say(currStmtSource().value(),
+        "%s attribute may only appear in the specification part of a module"_err_en_US,
+        EnumToString(attr));
+  }
+  attrs_->set(attr);
+  return false;
+}
+
 bool DeclarationVisitor::Pre(const parser::AsynchronousStmt &x) {
   return HandleAttributeStmt(Attr::ASYNCHRONOUS, x.v);
 }
@@ -3833,12 +3801,7 @@ bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) {
     // we need to resolve its symbol in the scope of the derived type.
     Walk(std::get<parser::ComponentDataSource>(component.t));
     if (const auto &kw{std::get<std::optional<parser::Keyword>>(component.t)}) {
-      if (Symbol * symbol{FindInTypeOrParents(*typeScope, kw->v)}) {
-        if (!kw->v.symbol) {
-          kw->v.symbol = symbol;
-        }
-        CheckAccessibleComponent(kw->v.source, *symbol);
-      }
+      FindInTypeOrParents(*typeScope, kw->v);
     }
   }
   return false;
@@ -5214,9 +5177,11 @@ const parser::Name *DeclarationVisitor::FindComponent(
   } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
     if (const Scope * scope{derived->scope()}) {
       if (Resolve(component, scope->FindComponent(component.source))) {
-        if (CheckAccessibleComponent(component.source, *component.symbol)) {
-          return &component;
+        if (auto msg{
+                CheckAccessibleComponent(currScope(), *component.symbol)}) {
+          context().Say(component.source, *msg);
         }
+        return &component;
       } else {
         SayDerivedType(component.source,
             "Component '%s' not found in derived type '%s'"_err_en_US, *scope);
@@ -5517,7 +5482,7 @@ bool ResolveNamesVisitor::SetProcFlag(
 
 bool ModuleVisitor::Pre(const parser::AccessStmt &x) {
   Attr accessAttr{AccessSpecToAttr(std::get<parser::AccessSpec>(x.t))};
-  if (currScope().kind() != Scope::Kind::Module) {
+  if (!currScope().IsModule()) {  // C869
     Say(currStmtSource().value(),
         "%s statement may only appear in the specification part of a module"_err_en_US,
         EnumToString(accessAttr));
@@ -5525,7 +5490,7 @@ bool ModuleVisitor::Pre(const parser::AccessStmt &x) {
   }
   const auto &accessIds{std::get<std::list<parser::AccessId>>(x.t)};
   if (accessIds.empty()) {
-    if (prevAccessStmt_) {
+    if (prevAccessStmt_) {  // C869
       Say("The default accessibility of this module has already been declared"_err_en_US)
           .Attach(*prevAccessStmt_, "Previous declaration"_en_US);
     }

diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp
index f69748a..92e2f5f 100644 (file)
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -72,16 +72,7 @@ const Scope *ModuleDetails::parent() const {
   return isSubmodule_ && scope_ ? &scope_->parent() : nullptr;
 }
 const Scope *ModuleDetails::ancestor() const {
-  if (!isSubmodule_ || !scope_) {
-    return nullptr;
-  }
-  for (auto *scope{scope_};;) {
-    auto *parent{&scope->parent()};
-    if (parent->kind() != Scope::Kind::Module) {
-      return scope;
-    }
-    scope = parent;
-  }
+  return isSubmodule_ && scope_ ? FindModuleContaining(*scope_) : nullptr;
 }
 void ModuleDetails::set_scope(const Scope *scope) {
   CHECK(!scope_);

diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 57980dd..922f38f 100644 (file)
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -24,6 +24,24 @@
 
 namespace Fortran::semantics {
 
+// Find this or containing scope that matches predicate
+static const Scope *FindScopeContaining(
+    const Scope &start, std::function<bool(const Scope &)> predicate) {
+  for (const Scope *scope{&start};; scope = &scope->parent()) {
+    if (predicate(*scope)) {
+      return scope;
+    }
+    if (scope->IsGlobal()) {
+      return nullptr;
+    }
+  }
+}
+
+const Scope *FindModuleContaining(const Scope &start) {
+  return FindScopeContaining(
+      start, [](const Scope &scope) { return scope.IsModule(); });
+}
+
 const Symbol *FindCommonBlockContaining(const Symbol &object) {
   if (const auto *details{object.detailsIf<ObjectEntityDetails>()}) {
     return details->commonBlock();
@@ -33,21 +51,15 @@ const Symbol *FindCommonBlockContaining(const Symbol &object) {
 }
 
 const Scope *FindProgramUnitContaining(const Scope &start) {
-  const Scope *scope{&start};
-  while (scope) {
-    switch (scope->kind()) {
+  return FindScopeContaining(start, [](const Scope &scope) {
+    switch (scope.kind()) {
     case Scope::Kind::Module:
     case Scope::Kind::MainProgram:
     case Scope::Kind::Subprogram:
-    case Scope::Kind::BlockData: return scope;
-    case Scope::Kind::Global: return nullptr;
-    case Scope::Kind::DerivedType:
-    case Scope::Kind::Block:
-    case Scope::Kind::Forall:
-    case Scope::Kind::ImpliedDos: scope = &scope->parent();
+    case Scope::Kind::BlockData: return true;
+    default: return false;
     }
-  }
-  return nullptr;
+  });
 }
 
 const Scope *FindProgramUnitContaining(const Symbol &symbol) {
@@ -164,16 +176,9 @@ bool IsUseAssociated(const Symbol &symbol, const Scope &scope) {
 
 bool DoesScopeContain(
     const Scope *maybeAncestor, const Scope &maybeDescendent) {
-  if (maybeAncestor) {
-    const Scope *scope{&maybeDescendent};
-    while (!scope->IsGlobal()) {
-      scope = &scope->parent();
-      if (scope == maybeAncestor) {
-        return true;
-      }
-    }
-  }
-  return false;
+  return maybeAncestor && !maybeDescendent.IsGlobal() &&
+      FindScopeContaining(maybeDescendent.parent(),
+          [&](const Scope &scope) { return &scope == maybeAncestor; });
 }
 
 bool DoesScopeContain(const Scope *maybeAncestor, const Symbol &symbol) {
@@ -717,7 +722,7 @@ bool IsAssumedLengthExternalCharacterFunction(const Symbol &symbol) {
 
 const Symbol *IsExternalInPureContext(
     const Symbol &symbol, const Scope &scope) {
-  if (const auto *pureProc{semantics::FindPureProcedureContaining(scope)}) {
+  if (const auto *pureProc{FindPureProcedureContaining(scope)}) {
     if (const Symbol * root{GetAssociationRoot(symbol)}) {
       if (const Symbol *
           visible{FindExternallyVisibleObject(*root, *pureProc)}) {
@@ -956,6 +961,21 @@ bool IsPolymorphicAllocatable(const Symbol &symbol) {
   return IsAllocatable(symbol) && IsPolymorphic(symbol);
 }
 
+std::optional<parser::MessageFormattedText> CheckAccessibleComponent(
+    const Scope &scope, const Symbol &symbol) {
+  CHECK(symbol.owner().IsDerivedType());  // symbol must be a component
+  if (symbol.attrs().test(Attr::PRIVATE)) {
+    if (const Scope * moduleScope{FindModuleContaining(symbol.owner())}) {
+      if (!moduleScope->sourceRange().Contains(scope.sourceRange())) {
+        return parser::MessageFormattedText{
+            "PRIVATE component '%s' is only accessible within module '%s'"_err_en_US,
+            symbol.name(), moduleScope->GetName().value()};
+      }
+    }
+  }
+  return std::nullopt;
+}
+
 std::list<SourceName> OrderParameterNames(const Symbol &typeSymbol) {
   std::list<SourceName> result;
   if (const DerivedTypeSpec * spec{typeSymbol.GetParentTypeSpec()}) {
@@ -1227,10 +1247,10 @@ const Symbol *FindImmediateComponent(const DerivedTypeSpec &type,
 }
 
 bool IsFunctionResult(const Symbol &symbol) {
-  return (symbol.has<semantics::ObjectEntityDetails>() &&
-             symbol.get<semantics::ObjectEntityDetails>().isFuncResult()) ||
-      (symbol.has<semantics::ProcEntityDetails>() &&
-          symbol.get<semantics::ProcEntityDetails>().isFuncResult());
+  return (symbol.has<ObjectEntityDetails>() &&
+             symbol.get<ObjectEntityDetails>().isFuncResult()) ||
+      (symbol.has<ProcEntityDetails>() &&
+          symbol.get<ProcEntityDetails>().isFuncResult());
 }
 
 bool IsFunctionResultWithSameNameAsFunction(const Symbol &symbol) {

diff --git a/flang/test/Semantics/resolve10.f90 b/flang/test/Semantics/resolve10.f90
index 5866faa..75a44a4 100644 (file)
--- a/flang/test/Semantics/resolve10.f90
+++ b/flang/test/Semantics/resolve10.f90
@@ -1,10 +1,42 @@
 module m
   public
+  type t
+    integer, private :: i
+  end type
   !ERROR: The default accessibility of this module has already been declared
-  private
+  private  !C869
 end
 
-subroutine s
+subroutine s1
   !ERROR: PUBLIC statement may only appear in the specification part of a module
-  public
+  public  !C869
+end
+
+subroutine s2
+  !ERROR: PRIVATE attribute may only appear in the specification part of a module
+  integer, private :: i  !C817
+end
+
+subroutine s3
+  type t
+    !ERROR: PUBLIC attribute may only appear in the specification part of a module
+    integer, public :: i  !C817
+  end type
+end
+
+module m4
+  interface
+    module subroutine s()
+    end subroutine
+  end interface
+end
+submodule(m4) sm4
+  !ERROR: PUBLIC statement may only appear in the specification part of a module
+  public  !C869
+  !ERROR: PUBLIC attribute may only appear in the specification part of a module
+  real, public :: x  !C817
+  type :: t
+    !ERROR: PRIVATE attribute may only appear in the specification part of a module
+    real, private :: y  !C817
+  end type
 end

diff --git a/flang/test/Semantics/resolve34.f90 b/flang/test/Semantics/resolve34.f90
index 0f0c8d1..c3b28bb 100644 (file)
--- a/flang/test/Semantics/resolve34.f90
+++ b/flang/test/Semantics/resolve34.f90
@@ -91,3 +91,43 @@ subroutine s7
   !ERROR: PRIVATE component 't1' is only accessible within module 'm7'
   j = x%t1%i1
 end
+
+! 7.5.4.8(2)
+module m8
+  type  :: t
+    integer :: i1
+    integer, private :: i2
+  end type
+contains
+  subroutine s0
+    type(t) :: x
+    x = t(i1=2, i2=5)  !OK
+  end
+end
+subroutine s8
+  use m8
+  type(t) :: x
+  !ERROR: PRIVATE component 'i2' is only accessible within module 'm8'
+  x = t(2, 5)
+  !ERROR: PRIVATE component 'i2' is only accessible within module 'm8'
+  x = t(i1=2, i2=5)
+end
+
+! 7.5.4.8(2)
+module m9
+  interface
+    module subroutine s()
+    end subroutine
+  end interface
+  type  :: t
+    integer :: i1
+    integer, private :: i2
+  end type
+end
+submodule(m9) sm8
+contains
+  module subroutine s
+    type(t) :: x
+    x = t(i1=2, i2=5)  !OK
+  end
+end