[flang] Semantics checker for STOP and ERROR STOP statements.

This commit introduces a new checker (StopChecker) for STOP
and ERROR STOP Fortran statements along with a test code.

Signed-off-by: Paul Osmialowski <pawel.osmialowski@arm.com>

Original-commit: flang-compiler/f18@c554174
Reviewed-on: flang-compiler/f18#367
Tree-same-pre-rewrite: false

flang/lib/semantics/CMakeLists.txt

@@ -24,6 +24,7 @@ add_library(FortranSemantics
   check-if-stmt.cc
   check-nullify.cc
   check-return.cc
+  check-stop.cc
   expression.cc
   mod-file.cc
   resolve-labels.cc

flang/lib/semantics/check-stop.cc

@@ -0,0 +1,82 @@
+// Copyright (c) 2019, Arm Ltd.  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-stop.h"
+#include "semantics.h"
+#include "tools.h"
+#include "../common/Fortran.h"
+#include "../evaluate/expression.h"
+#include "../parser/parse-tree.h"
+#include <optional>
+
+Fortran::semantics::StopChecker::StopChecker(
+    Fortran::semantics::SemanticsContext &context)
+  : context_{context} {}
+
+Fortran::semantics::StopChecker::~StopChecker() = default;
+
+void Fortran::semantics::StopChecker::Enter(
+    const Fortran::parser::StopStmt &stmt) {
+  const auto &sc{std::get<std::optional<Fortran::parser::StopCode>>(stmt.t)};
+  const auto &sle{
+      std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(stmt.t)};
+
+  if (sc.has_value()) {
+    const Fortran::parser::CharBlock &source{sc.value().v.thing.source};
+    const auto &expr = *(sc.value().v.thing.typedExpr);
+
+    if (!(Fortran::semantics::ExprIsScalar(expr))) {
+      context_.Say(source, "Stop code must be a scalar"_err_en_US);
+    } else {
+      if (Fortran::semantics::ExprHasTypeCategory(
+              expr, Fortran::common::TypeCategory::Integer)) {
+        // C1171 default kind
+        if (!(Fortran::semantics::ExprHasTypeKind(expr,
+                context_.defaultKinds().GetDefaultKind(
+                    Fortran::common::TypeCategory::Integer)))) {
+          context_.Say(
+              source, "Integer stop code must be of default kind"_err_en_US);
+        }
+      } else if (Fortran::semantics::ExprHasTypeCategory(
+                     expr, Fortran::common::TypeCategory::Character)) {
+        // R1162 spells scalar-DEFAULT-char-expr
+        if (!(Fortran::semantics::ExprHasTypeKind(expr,
+                context_.defaultKinds().GetDefaultKind(
+                    Fortran::common::TypeCategory::Character)))) {
+          context_.Say(
+              source, "Character stop code must be of default kind"_err_en_US);
+        }
+      } else {
+        context_.Say(
+            source, "Stop code must be of INTEGER or CHARACTER type"_err_en_US);
+      }
+    }
+  }
+  if (sle.has_value()) {
+    const Fortran::parser::CharBlock &source{
+        sle.value().thing.thing.value().source};
+    const auto &expr = *(sle.value().thing.thing.value().typedExpr);
+
+    if (!(Fortran::semantics::ExprIsScalar(expr))) {
+      context_.Say(source,
+          "The optional QUIET parameter value must be a scalar"_err_en_US);
+    } else {
+      if (!(Fortran::semantics::ExprHasTypeCategory(
+              expr, Fortran::common::TypeCategory::Logical))) {
+        context_.Say(source,
+            "The optional QUIET parameter value must be of LOGICAL type"_err_en_US);
+      }
+    }
+  }
+}

flang/lib/semantics/check-stop.h

@@ -0,0 +1,40 @@
+// Copyright (c) 2019, Arm Ltd.  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_STOP_H_
+#define FORTRAN_SEMANTICS_CHECK_STOP_H_
+
+#include "semantics.h"
+
+namespace Fortran::parser {
+struct StopStmt;
+}
+
+namespace Fortran::semantics {
+
+// Semantic analysis of STOP and ERROR STOP statements.
+class StopChecker : public virtual BaseChecker {
+public:
+  explicit StopChecker(SemanticsContext &);
+  ~StopChecker();
+
+  void Enter(const parser::StopStmt &);
+
+private:
+  SemanticsContext &context_;
+};
+
+}  // namespace Fortran::semantics
+
+#endif  // FORTRAN_SEMANTICS_CHECK_STOP_H_

flang/lib/semantics/semantics.cc

@@ -23,6 +23,7 @@
 #include "check-if-stmt.h"
 #include "check-nullify.h"
 #include "check-return.h"
+#include "check-stop.h"
 #include "expression.h"
 #include "mod-file.h"
 #include "resolve-labels.h"
@@ -82,7 +83,7 @@ using StatementSemanticsPass1 = ExprChecker;
 using StatementSemanticsPass2 =
     SemanticsVisitor<ArithmeticIfStmtChecker, AssignmentChecker, CoarrayChecker,
         ComputedGotoStmtChecker, DeallocateChecker, DoConcurrentChecker,
-        IfStmtChecker, NullifyChecker, ReturnStmtChecker>;
+        IfStmtChecker, NullifyChecker, ReturnStmtChecker, StopChecker>;
 
 SemanticsContext::SemanticsContext(
     const common::IntrinsicTypeDefaultKinds &defaultKinds,

flang/lib/semantics/tools.cc

@@ -280,4 +280,12 @@ bool ExprHasTypeCategory(const evaluate::GenericExprWrapper &expr,
   auto dynamicType{expr.v.GetType()};
   return dynamicType.has_value() && dynamicType->category == type;
 }
+bool ExprHasTypeKind(const evaluate::GenericExprWrapper &expr, int kind) {
+  auto dynamicType{expr.v.GetType()};
+  return dynamicType.has_value() && dynamicType->kind == kind;
+}
+
+bool ExprIsScalar(const evaluate::GenericExprWrapper &expr) {
+  return !(expr.v.Rank() > 0);
+}
 }

flang/lib/semantics/tools.h

@@ -98,5 +98,7 @@ const Symbol *FindExternallyVisibleObject(
 
 bool ExprHasTypeCategory(
     const evaluate::GenericExprWrapper &expr, const common::TypeCategory &type);
+bool ExprHasTypeKind(const evaluate::GenericExprWrapper &expr, int kind);
+bool ExprIsScalar(const evaluate::GenericExprWrapper &expr);
 }
 #endif  // FORTRAN_SEMANTICS_TOOLS_H_

flang/test/semantics/CMakeLists.txt

@@ -78,6 +78,7 @@ set(ERROR_TESTS
   resolve49.f90
   resolve50.f90
   resolve51.f90
+  stop01.f90
   structconst01.f90
   structconst02.f90
   structconst03.f90

flang/test/semantics/stop.f90

@@ -0,0 +1,119 @@
+! Copyright (c) 2019, Arm Ltd.  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.
+
+program main
+  implicit none
+  integer :: i = -1
+  integer, pointer :: p_i
+  integer(kind = 1) :: invalid = 0
+  integer, dimension(1:100) :: iarray
+  integer, dimension(1:100), pointer :: p_iarray
+  integer, allocatable, dimension(1:100) :: aiarray
+  logical :: l = .false.
+  logical, dimension(1:100) :: larray
+  logical, allocatable, dimension(1:100) :: alarray
+  character(len = 128) :: chr1
+  character(kind = 4, len = 128) :: chr2
+
+  if (i .eq. 0) stop "Stop."
+!ERROR: Stop code must be of INTEGER or CHARACTER type
+  if (i .eq. 0) stop "Stop."(1:4)
+  if (i .eq. 0) stop chr1
+!ERROR: Character stop code must be of default kind
+  if (i .eq. 0) stop chr2
+  if (i .eq. 0) stop 1
+  if (i .eq. 0) stop 1 + 2
+  if (i .eq. 0) stop i
+  if (i .eq. 0) stop p_i
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) stop p_iarray
+  if (i .eq. 0) stop p_iarray(1)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) stop p_iarray(1:4)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) stop iarray
+  if (i .eq. 0) stop iarray(1)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) stop iarray(1:4)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) stop aiarray
+  if (i .eq. 0) stop aiarray(1)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) stop aiarray(1:4)
+  if (i .eq. 0) stop 1 + i
+!ERROR: Integer stop code must be of default kind
+  if (i .eq. 0) stop invalid
+!ERROR: Stop code must be of INTEGER or CHARACTER type
+  if (i .eq. 0) stop 12.34
+  if (i .eq. 0) stop 1, quiet = .true.
+  if (i .eq. 0) stop 2, quiet = .false.
+  if (i .eq. 0) stop 3, quiet = l
+  if (i .eq. 0) stop 3, quiet = .not. l
+!ERROR: The optional QUIET parameter value must be a scalar
+  if (i .eq. 0) stop 3, quiet = larray
+  if (i .eq. 0) stop 3, quiet = larray(1)
+!ERROR: The optional QUIET parameter value must be a scalar
+  if (i .eq. 0) stop 3, quiet = larray(1:4)
+!ERROR: The optional QUIET parameter value must be a scalar
+  if (i .eq. 0) stop 3, quiet = alarray
+!ERROR: The optional QUIET parameter value must be of LOGICAL type
+  if (i .eq. 0) stop 1, quiet = "Quiet."
+!ERROR: The optional QUIET parameter value must be of LOGICAL type
+  if (i .eq. 0) stop 1, quiet = "Quiet."(1:4)
+  if (i .eq. 0) stop , quiet = .false.
+  if (i .eq. 0) error stop "Error."
+  if (i .eq. 0) error stop chr1
+!ERROR: Character stop code must be of default kind
+  if (i .eq. 0) error stop chr2
+  if (i .eq. 0) error stop 1
+  if (i .eq. 0) error stop i
+  if (i .eq. 0) error stop p_i
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) error stop p_iarray
+  if (i .eq. 0) error stop p_iarray(1)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) error stop p_iarray(1:4)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) error stop iarray
+  if (i .eq. 0) error stop iarray(1)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) error stop iarray(1:4)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) error stop aiarray
+  if (i .eq. 0) error stop aiarray(1)
+!ERROR: Stop code must be a scalar
+  if (i .eq. 0) error stop aiarray(1:4)
+  if (i .eq. 0) error stop 1 + i
+!ERROR: Integer stop code must be of default kind
+  if (i .eq. 0) error stop invalid
+!ERROR: Stop code must be of INTEGER or CHARACTER type
+  if (i .eq. 0) error stop 12.34
+  if (i .eq. 0) error stop 1, quiet = .true.
+  if (i .eq. 0) error stop 2, quiet = .false.
+  if (i .eq. 0) error stop 3, quiet = l
+  if (i .eq. 0) error stop 3, quiet = .not. l
+!ERROR: The optional QUIET parameter value must be a scalar
+  if (i .eq. 0) error stop 3, quiet = larray
+  if (i .eq. 0) error stop 3, quiet = larray(1)
+!ERROR: The optional QUIET parameter value must be a scalar
+  if (i .eq. 0) error stop 3, quiet = larray(1:4)
+!ERROR: The optional QUIET parameter value must be a scalar
+  if (i .eq. 0) error stop 3, quiet = alarray
+!ERROR: The optional QUIET parameter value must be of LOGICAL type
+  if (i .eq. 0) error stop 1, quiet = "Quiet."
+!ERROR: The optional QUIET parameter value must be of LOGICAL type
+  if (i .eq. 0) error stop 1, quiet = "Quiet."(1:4)
+  if (i .eq. 0) error stop , quiet = .false.
+  stop
+end program