[flang] C1594 constraint checking on pointer components in struct constructors

Original-commit: flang-compiler/f18@386cd8a9b43f4e65c3e42febbae991fa87d277a9
Reviewed-on: https://github.com/flang-compiler/f18/pull/311
Tree-same-pre-rewrite: false

diff --git a/flang/lib/evaluate/variable.h b/flang/lib/evaluate/variable.h
index e2432a5..c51fafc 100644 (file)
--- a/flang/lib/evaluate/variable.h
+++ b/flang/lib/evaluate/variable.h
@@ -55,6 +55,13 @@ struct BaseObject {
   Expr<SubscriptInteger> LEN() const;
   bool operator==(const BaseObject &) const;
   std::ostream &AsFortran(std::ostream &) const;
+  const Symbol *symbol() const {
+    if (const auto *result{std::get_if<const Symbol *>(&u)}) {
+      return *result;
+    } else {
+      return nullptr;
+    }
+  }
   std::variant<const Symbol *, StaticDataObject::Pointer> u;
 };
 

diff --git a/flang/lib/semantics/CMakeLists.txt b/flang/lib/semantics/CMakeLists.txt
index 0f55e85..afa1f09 100644 (file)
--- a/flang/lib/semantics/CMakeLists.txt
+++ b/flang/lib/semantics/CMakeLists.txt
@@ -25,6 +25,7 @@ add_library(FortranSemantics
   scope.cc
   semantics.cc
   symbol.cc
+  tools.cc
   type.cc
   unparse-with-symbols.cc
 )

diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc
index c970416..735d08e 100644 (file)
--- a/flang/lib/semantics/expression.cc
+++ b/flang/lib/semantics/expression.cc
@@ -16,6 +16,7 @@
 #include "scope.h"
 #include "semantics.h"
 #include "symbol.h"
+#include "tools.h"
 #include "../common/idioms.h"
 #include "../evaluate/common.h"
 #include "../evaluate/fold.h"
@@ -1484,12 +1485,23 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context,
           }
         } else {
           CHECK(symbol->has<semantics::ObjectEntityDetails>());
+          // C1594(4)
+          if (!isNULL) {
+            const auto &innermost{context.context().FindScope(expr.source)};
+            if (const auto *pureFunc{
+                    semantics::FindPureFunctionContaining(&innermost)}) {
+              if (semantics::IsOrHasPointerComponent(*symbol) &&
+                  semantics::IsExternallyVisibleObject(*value, *pureFunc)) {
+                context.Say(expr.source,
+                    "Externally visible object must not be associated with a pointer in a PURE function"_err_en_US);
+              }
+            }
+          }
           if (symbol->attrs().test(semantics::Attr::POINTER)) {
             if (!isNULL) {
               // TODO C7104: check that object pointer components are
               // being initialized with compatible object designators
-              context.Say(expr.source,
-                  "TODO: non-null object pointer component value not implemented yet"_err_en_US);
+              // TODO pmk WIP this is next
             }
           } else if (MaybeExpr converted{
                          ConvertToType(*symbol, std::move(*value))}) {
@@ -1527,7 +1539,6 @@ static MaybeExpr AnalyzeExpr(ExpressionAnalysisContext &context,
     }
   }
 
-  // TODO pmk check type compatibility on component expressions
   return AsMaybeExpr(Expr<SomeDerived>{std::move(result)});
 }
 

diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc
index 516b370..f47de1c 100644 (file)
--- a/flang/lib/semantics/semantics.cc
+++ b/flang/lib/semantics/semantics.cc
@@ -57,6 +57,15 @@ bool SemanticsContext::AnyFatalError() const {
       (warningsAreErrors_ || messages_.AnyFatalError());
 }
 
+const Scope &SemanticsContext::FindScope(
+    const parser::CharBlock &source) const {
+  if (const auto *scope{globalScope_.FindScope(source)}) {
+    return *scope;
+  } else {
+    common::die("invalid source location");
+  }
+}
+
 bool Semantics::Perform() {
   ValidateLabels(context_.messages(), program_);
   if (AnyFatalError()) {
@@ -82,14 +91,6 @@ bool Semantics::Perform() {
   return !AnyFatalError();
 }
 
-const Scope &Semantics::FindScope(const parser::CharBlock &source) const {
-  if (const auto *scope{context_.globalScope().FindScope(source)}) {
-    return *scope;
-  } else {
-    common::die("invalid source location");
-  }
-}
-
 void Semantics::EmitMessages(std::ostream &os) const {
   context_.messages().Emit(os, cooked_);
 }

diff --git a/flang/lib/semantics/semantics.h b/flang/lib/semantics/semantics.h
index b37ac69..f949070 100644 (file)
--- a/flang/lib/semantics/semantics.h
+++ b/flang/lib/semantics/semantics.h
@@ -77,6 +77,8 @@ public:
     return messages_.Say(std::forward<A>(args)...);
   }
 
+  const Scope &FindScope(const parser::CharBlock &) const;
+
 private:
   const common::IntrinsicTypeDefaultKinds &defaultKinds_;
   std::vector<std::string> searchDirectories_;
@@ -99,7 +101,9 @@ public:
 
   SemanticsContext &context() const { return context_; }
   bool Perform();
-  const Scope &FindScope(const parser::CharBlock &) const;
+  const Scope &FindScope(const parser::CharBlock &where) const {
+    return context_.FindScope(where);
+  }
   bool AnyFatalError() const { return context_.AnyFatalError(); }
   void EmitMessages(std::ostream &) const;
   void DumpSymbols(std::ostream &);

diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt
index 74eda1e..00e6797 100644 (file)
--- a/flang/test/semantics/CMakeLists.txt
+++ b/flang/test/semantics/CMakeLists.txt
@@ -74,6 +74,7 @@ set(ERROR_TESTS
   resolve46.f90
   structconst01.f90
   structconst02.f90
+  structconst03.f90
 )
 
 # These test files have expected symbols in the source

diff --git a/flang/test/semantics/structconst03.f90 b/flang/test/semantics/structconst03.f90
new file mode 100644 (file)
index 0000000..c518382
--- /dev/null
+++ b/flang/test/semantics/structconst03.f90
@@ -0,0 +1,178 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Error tests for structure constructors: C1594 violations
+! from assigning globally-visible data to POINTER components.
+
+module usefrom
+  real :: usedfrom1
+end module usefrom
+
+module module1
+  use usefrom
+  implicit none
+  type :: has_pointer1
+    real, pointer :: p
+    type(has_pointer1), allocatable :: link1
+  end type has_pointer1
+  type :: has_pointer2
+    type(has_pointer1) :: p
+    type(has_pointer2), allocatable :: link2
+  end type has_pointer2
+  type, extends(has_pointer2) :: has_pointer3
+    type(has_pointer3), allocatable :: link3
+  end type has_pointer3
+  type :: t1(k)
+    integer, kind :: k
+    real, pointer :: p
+    type(t1(k)), allocatable :: link
+  end type t1
+  type :: t2(k)
+    integer, kind :: k
+    type(has_pointer1) :: hp1
+    type(t2(k)), allocatable :: link
+  end type t2
+  type :: t3(k)
+    integer, kind :: k
+    type(has_pointer2) :: hp2
+    type(t3(k)), allocatable :: link
+  end type t3
+  type :: t4(k)
+    integer, kind :: k
+    type(has_pointer3) :: hp3
+    type(t4(k)), allocatable :: link
+  end type t4
+  real :: modulevar1
+  real :: commonvar1
+  type(has_pointer1) :: modulevar2, commonvar2
+  type(has_pointer2) :: modulevar3, commonvar3
+  type(has_pointer3) :: modulevar4, commonvar4
+  common /cblock/ commonvar1
+
+ contains
+
+  pure real function pf1(dummy1, dummy2, dummy3, dummy4)
+    real :: local1
+    type(t1(0)) :: x1
+    type(t2(0)) :: x2
+    type(t3(0)) :: x3
+    type(t4(0)) :: x4
+    real, intent(in) :: dummy1
+    real, intent(inout) :: dummy2
+    real, pointer :: dummy3
+    real, intent(inout) :: dummy4[*]
+    pf1 = 0.
+    x1 = t1(0)(local1)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x1 = t1(0)(usedfrom1)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x1 = t1(0)(modulevar1)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x1 = t1(0)(commonvar1)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x1 = t1(0)(dummy1)
+    x1 = t1(0)(dummy2)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x1 = t1(0)(dummy3)
+! TODO when semantics handles coindexing:
+! TODO !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+! TODO x1 = t1(0)(dummy4[0])
+    x1 = t1(0)(dummy4)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x2 = t2(0)(modulevar2)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x2 = t2(0)(commonvar2)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x3 = t3(0)(modulevar3)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x3 = t3(0)(commonvar3)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x4 = t4(0)(modulevar4)
+    !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+    x4 = t4(0)(commonvar4)
+   contains
+    subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
+      real :: local1a
+      type(t1(0)) :: x1a
+      type(t2(0)) :: x2a
+      type(t3(0)) :: x3a
+      type(t4(0)) :: x4a
+      real, intent(in) :: dummy1a
+      real, intent(inout) :: dummy2a
+      real, pointer :: dummy3a
+      real, intent(inout) :: dummy4a[*]
+      x1a = t1(0)(local1a)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x1a = t1(0)(usedfrom1)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x1a = t1(0)(modulevar1)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x1a = t1(0)(commonvar1)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x1a = t1(0)(dummy1)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x1a = t1(0)(dummy1a)
+      x1a = t1(0)(dummy2a)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x1a = t1(0)(dummy3)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x1a = t1(0)(dummy3a)
+! TODO when semantics handles coindexing:
+! TODO !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+! TODO x1a = t1(0)(dummy4a[0])
+      x1a = t1(0)(dummy4a)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x2a = t2(0)(modulevar2)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x2a = t2(0)(commonvar2)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x3a = t3(0)(modulevar3)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x3a = t3(0)(commonvar3)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x4a = t4(0)(modulevar4)
+      !ERROR: Externally visible object must not be associated with a pointer in a PURE function
+      x4a = t4(0)(commonvar4)
+    end subroutine subr
+  end function pf1
+
+  impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
+    real :: local1
+    type(t1(0)) :: x1
+    type(t2(0)) :: x2
+    type(t3(0)) :: x3
+    type(t4(0)) :: x4
+    real, intent(in) :: dummy1
+    real, intent(inout) :: dummy2
+    real, pointer :: dummy3
+    real, intent(inout) :: dummy4[*]
+    ipf1 = 0.
+    x1 = t1(0)(local1)
+    x1 = t1(0)(usedfrom1)
+    x1 = t1(0)(modulevar1)
+    x1 = t1(0)(commonvar1)
+    x1 = t1(0)(dummy1)
+    x1 = t1(0)(dummy2)
+    x1 = t1(0)(dummy3)
+! TODO when semantics handles coindexing:
+! TODO x1 = t1(0)(dummy4[0])
+    x1 = t1(0)(dummy4)
+    x2 = t2(0)(modulevar2)
+    x2 = t2(0)(commonvar2)
+    x3 = t3(0)(modulevar3)
+    x3 = t3(0)(commonvar3)
+    x4 = t4(0)(modulevar4)
+    x4 = t4(0)(commonvar4)
+  end function ipf1
+end module module1