[flang] Implement semantic checks for DEALLOCATE statements.

The parser checks for duplicate dealloc-opts and expr
analysis checks that dealloc-opts are the right type.

Original-commit: flang-compiler/f18@1ade7f66177c8d7698b1e9da12904352c520e9d1
Reviewed-on: https://github.com/flang-compiler/f18/pull/401
Tree-same-pre-rewrite: false

diff --git a/flang/lib/semantics/CMakeLists.txt b/flang/lib/semantics/CMakeLists.txt
index 5bd69e4..7a9797d 100644 (file)
--- a/flang/lib/semantics/CMakeLists.txt
+++ b/flang/lib/semantics/CMakeLists.txt
@@ -18,6 +18,7 @@ add_library(FortranSemantics
   canonicalize-do.cc
   check-arithmeticif.cc
   check-computed-goto.cc
+  check-deallocate.cc
   check-do-concurrent.cc
   check-if-construct.cc
   check-if-stmt.cc

diff --git a/flang/lib/semantics/check-deallocate.cc b/flang/lib/semantics/check-deallocate.cc
new file mode 100644 (file)
index 0000000..2a3599d
--- /dev/null
+++ b/flang/lib/semantics/check-deallocate.cc
@@ -0,0 +1,79 @@
+// 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.
+
+#include "check-deallocate.h"
+#include "expression.h"
+#include "tools.h"
+#include "../parser/message.h"
+#include "../parser/parse-tree.h"
+
+namespace Fortran::semantics {
+
+void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
+  for (const parser::AllocateObject &allocateObject :
+      std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
+    std::visit(
+        common::visitors{
+            [&](const parser::Name &name) {
+              auto const *symbol{name.symbol};
+              if (!IsVariableName(*symbol)) {
+                context_.messages().Say(name.source,
+                    "name in DEALLOCATE statement must be a variable name"_err_en_US);
+              } else if (!IsAllocatableOrPointer(*symbol)) {  // C951
+                context_.messages().Say(name.source,
+                    "name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+              }
+            },
+            [&](const parser::StructureComponent &structureComponent) {
+              evaluate::ExpressionAnalyzer analyzer{context_};
+              if (MaybeExpr checked{analyzer.Analyze(structureComponent)}) {
+                if (!IsAllocatableOrPointer(
+                        *structureComponent.component.symbol)) {  // C951
+                  context_.messages().Say(structureComponent.component.source,
+                      "component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+                }
+              }
+            },
+        },
+        allocateObject.u);
+  }
+  // The parser is catchng dups too
+  bool gotStat{false}, gotMsg{false};
+  for (const parser::StatOrErrmsg &deallocOpt :
+      std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
+    std::visit(
+        common::visitors{
+            [&](const parser::StatVariable &statVariable) {
+              // ExpressionAnalyzer emits error messages
+              evaluate::ExpressionAnalyzer analyzer{context_};
+              (void)analyzer.Analyze(statVariable.v);
+              if(gotStat) {
+                  context_.Say("STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
+              }
+              gotStat = true;
+            },
+            [&](const parser::MsgVariable &msgVariable) {
+              // ExpressionAnalyzer emits error messages
+              evaluate::ExpressionAnalyzer analyzer{context_};
+              (void)analyzer.Analyze(msgVariable.v);
+              if(gotMsg) {
+                  context_.Say("ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
+              }
+              gotMsg = true;
+            },
+        },
+        deallocOpt.u);
+  }
+}
+}  // namespace Fortran::semantics

diff --git a/flang/lib/semantics/check-deallocate.h b/flang/lib/semantics/check-deallocate.h
new file mode 100644 (file)
index 0000000..79ce3a0
--- /dev/null
+++ b/flang/lib/semantics/check-deallocate.h
@@ -0,0 +1,34 @@
+// 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.
+
+#ifndef FORTRAN_SEMANTICS_CHECK_DEALLOCATE_H_
+#define FORTRAN_SEMANTICS_CHECK_DEALLOCATE_H_
+
+#include "semantics.h"
+
+namespace Fortran::parser {
+struct DeallocateStmt;
+}
+
+namespace Fortran::semantics {
+class DeallocateChecker : public virtual BaseChecker {
+public:
+  inline DeallocateChecker(SemanticsContext &context) : context_{context} {}
+  void Leave(const parser::DeallocateStmt &);
+
+private:
+  SemanticsContext &context_;
+};
+}
+#endif  // FORTRAN_SEMANTICS_CHECK_DEALLOCATE_H_

diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc
index 2c70f83..53da7a6 100644 (file)
--- a/flang/lib/semantics/semantics.cc
+++ b/flang/lib/semantics/semantics.cc
@@ -17,6 +17,7 @@
 #include "canonicalize-do.h"
 #include "check-arithmeticif.h"
 #include "check-computed-goto.h"
+#include "check-deallocate.h"
 #include "check-do-concurrent.h"
 #include "check-if-construct.h"
 #include "check-if-stmt.h"
@@ -78,8 +79,8 @@ private:
 
 using StatementSemanticsPass1 = SemanticsVisitor<ExprChecker>;
 using StatementSemanticsPass2 = SemanticsVisitor<ArithmeticIfStmtChecker,
-    AssignmentChecker, ComputedGotoStmtChecker, DoConcurrentChecker,
-    IfConstructChecker, IfStmtChecker, NullifyChecker>;
+    AssignmentChecker, ComputedGotoStmtChecker, DeallocateChecker,
+    DoConcurrentChecker, IfConstructChecker, IfStmtChecker, NullifyChecker>;
 
 SemanticsContext::SemanticsContext(
     const common::IntrinsicTypeDefaultKinds &defaultKinds,

diff --git a/flang/lib/semantics/tools.cc b/flang/lib/semantics/tools.cc
index 85fbf3f..54081b8 100644 (file)
--- a/flang/lib/semantics/tools.cc
+++ b/flang/lib/semantics/tools.cc
@@ -123,10 +123,18 @@ bool IsPointer(const Symbol &symbol) {
   return symbol.attrs().test(Attr::POINTER);
 }
 
+bool IsAllocatable(const Symbol &symbol) {
+  return symbol.attrs().test(Attr::ALLOCATABLE);
+}
+
 bool IsPointerDummy(const Symbol &symbol) {
   return IsPointer(symbol) && IsDummy(symbol);
 }
 
+bool IsAllocatableOrPointer(const Symbol &symbol) {
+  return IsPointer(symbol) || IsAllocatable(symbol);
+}
+
 bool IsParameter(const Symbol &symbol) {
   return symbol.attrs().test(Attr::PARAMETER);
 }

diff --git a/flang/lib/semantics/tools.h b/flang/lib/semantics/tools.h
index 04f0959..b08b997 100644 (file)
--- a/flang/lib/semantics/tools.h
+++ b/flang/lib/semantics/tools.h
@@ -49,6 +49,8 @@ bool IsPureFunction(const Symbol &);
 bool IsPureFunction(const Scope &);
 bool IsProcName(const Symbol &symbol);  // proc-name
 bool IsVariableName(const Symbol &symbol);  // variable-name
+bool IsAllocatable(const Symbol &);
+bool IsAllocatableOrPointer(const Symbol &);
 
 // Determines whether an object might be visible outside a
 // PURE function (C1594); returns a non-null Symbol pointer for

diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt
index 850ae55..ea6e7d1 100644 (file)
--- a/flang/test/semantics/CMakeLists.txt
+++ b/flang/test/semantics/CMakeLists.txt
@@ -91,6 +91,8 @@ set(ERROR_TESTS
   computed-goto02.f90
   nullify01.f90
   nullify02.f90
+  deallocate01.f90
+  deallocate04.f90
 )
 
 # These test files have expected symbols in the source

diff --git a/flang/test/semantics/deallocate01.f90 b/flang/test/semantics/deallocate01.f90
new file mode 100644 (file)
index 0000000..a8ecdbd
--- /dev/null
+++ b/flang/test/semantics/deallocate01.f90
@@ -0,0 +1,61 @@
+! 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.
+
+! Test that DEALLOCATE works
+
+INTEGER, PARAMETER :: maxvalue=1024
+
+Type dt
+  Integer :: l = 3
+End Type
+Type t
+  Type(dt),Pointer :: p
+End Type
+
+Type(t),Allocatable :: x(:)
+Type(t),Pointer :: y(:)
+Type(t),Pointer :: z
+Integer :: s
+CHARACTER(256) :: e
+
+Integer, Pointer :: pi
+
+Allocate(p)
+Allocate(x(3))
+
+Deallocate(x(2)%p)
+
+Deallocate(y(2)%p)
+
+Deallocate(pi)
+
+Deallocate(z%p)
+
+Deallocate(x%p, stat=s, errmsg=e)
+Deallocate(x%p, errmsg=e)
+Deallocate(x%p, stat=s)
+
+Deallocate(y%p, stat=s, errmsg=e)
+Deallocate(y%p, errmsg=e)
+Deallocate(y%p, stat=s)
+
+Deallocate(z, stat=s, errmsg=e)
+Deallocate(z, errmsg=e)
+Deallocate(z, stat=s)
+
+Deallocate(z, y%p, stat=s, errmsg=e)
+Deallocate(z, y%p, errmsg=e)
+Deallocate(z, y%p, stat=s)
+
+End Program

diff --git a/flang/test/semantics/deallocate04.f90 b/flang/test/semantics/deallocate04.f90
new file mode 100644 (file)
index 0000000..52c6f93
--- /dev/null
+++ b/flang/test/semantics/deallocate04.f90
@@ -0,0 +1,69 @@
+! 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.
+
+! Check for semantic errors in DEALLOCATE statements
+
+INTEGER, PARAMETER :: maxvalue=1024
+
+Type dt
+  Integer :: l = 3
+End Type
+Type t
+  Type(dt) :: p
+End Type
+
+Type(t),Allocatable :: x(:)
+
+Real :: r
+Integer :: s
+Integer :: e
+Integer :: pi
+Character(256) :: ee
+Procedure(Real) :: prp
+
+Allocate(x(3))
+
+!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+Deallocate(x(2)%p)
+
+!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+Deallocate(pi)
+
+!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+Deallocate(x(2)%p, pi)
+
+!ERROR: name in DEALLOCATE statement must be a variable name
+Deallocate(prp)
+
+!ERROR: name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: name in DEALLOCATE statement must be a variable name
+Deallocate(pi, prp)
+
+!ERROR: name in DEALLOCATE statement must be a variable name
+Deallocate(maxvalue)
+
+!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+Deallocate(x%p)
+
+!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Must have default CHARACTER type
+Deallocate(x%p, stat=s, errmsg=e)
+
+!ERROR: component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute
+!ERROR: Must have INTEGER type
+!ERROR: Must have default CHARACTER type
+Deallocate(x%p, stat=r, errmsg=e)
+
+End Program