[flang] Reactivate tree-driven constraint checking on expressions.

Original-commit: flang-compiler/f18@85c4a6aab6
Reviewed-on: https://github.com/flang-compiler/f18/pull/406
Tree-same-pre-rewrite: false

flang/lib/semantics/CMakeLists.txt

@@ -20,7 +20,6 @@ add_library(FortranSemantics
   check-computed-goto.cc
   check-deallocate.cc
   check-do-concurrent.cc
-  check-if-construct.cc
   check-if-stmt.cc
   check-nullify.cc
   expression.cc

flang/lib/semantics/check-if-construct.cc

@@ -1,42 +0,0 @@
-// 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-if-construct.h"
-#include "tools.h"
-#include "../parser/message.h"
-#include "../parser/parse-tree.h"
-
-namespace Fortran::semantics {
-
-void IfConstructChecker::Leave(const parser::IfConstruct &ifConstruct) {
-  auto &ifThenStmt{
-      std::get<parser::Statement<parser::IfThenStmt>>(ifConstruct.t).statement};
-  auto &ifThenExpr{
-      std::get<parser::ScalarLogicalExpr>(ifThenStmt.t).thing.thing.value()};
-  // R1135 - IF scalar logical expr
-  CheckScalarLogicalExpr(ifThenExpr, context_.messages());
-  for (const auto &elseIfBlock :
-      std::get<std::list<parser::IfConstruct::ElseIfBlock>>(ifConstruct.t)) {
-    auto &elseIfStmt{
-        std::get<parser::Statement<parser::ElseIfStmt>>(elseIfBlock.t)
-            .statement};
-    auto &elseIfExpr{
-        std::get<parser::ScalarLogicalExpr>(elseIfStmt.t).thing.thing.value()};
-    // R1136 - ELSE IF scalar logical expr
-    CheckScalarLogicalExpr(elseIfExpr, context_.messages());
-  }
-  // R1137 The (optional) ELSE does not have an expression to check; ignore it.
-}
-
-}  // namespace Fortran::semantics

flang/lib/semantics/check-if-construct.h

@@ -1,34 +0,0 @@
-// 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_IF_CONSTRUCT_H_
-#define FORTRAN_SEMANTICS_CHECK_IF_CONSTRUCT_H_
-
-#include "semantics.h"
-
-namespace Fortran::parser {
-struct IfConstruct;
-}
-
-namespace Fortran::semantics {
-class IfConstructChecker : public virtual BaseChecker {
-public:
-  IfConstructChecker(SemanticsContext &context) : context_{context} {}
-  void Leave(const parser::IfConstruct &);
-
-private:
-  SemanticsContext &context_;
-};
-}
-#endif  // FORTRAN_SEMANTICS_CHECK_IF_CONSTRUCT_H_

flang/lib/semantics/check-if-stmt.cc

@@ -20,9 +20,6 @@
 namespace Fortran::semantics {
 
 void IfStmtChecker::Leave(const parser::IfStmt &ifStmt) {
-  // R1139 Check for a scalar logical expression
-  auto &expr{std::get<parser::ScalarLogicalExpr>(ifStmt.t).thing.thing.value()};
-  CheckScalarLogicalExpr(expr, context_.messages());
   // C1143 Check that the action stmt is not an if stmt
   const auto &body{
       std::get<parser::UnlabeledStatement<parser::ActionStmt>>(ifStmt.t)};

flang/lib/semantics/expression.cc

@@ -28,13 +28,6 @@
 #include <optional>
 #include <set>
 
-// TODO pmk remove when scaffolding is obsolete
-#undef PMKDEBUG  // #define PMKDEBUG 1
-#if PMKDEBUG
-#include "../parser/dump-parse-tree.h"
-#include <iostream>
-#endif
-
 // Typedef for optional generic expressions (ubiquitous in this file)
 using MaybeExpr =
     std::optional<Fortran::evaluate::Expr<Fortran::evaluate::SomeType>>;
@@ -1828,14 +1821,19 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr &expr) {
     return std::make_optional<Expr<SomeType>>(expr.typedExpr->v);
   } else {
     FixMisparsedFunctionReference(context_, expr.u);
+    MaybeExpr result;
     if (!expr.source.empty()) {
       // Analyze the expression in a specified source position context for
       // better error reporting.
       auto save{GetFoldingContext().messages().SetLocation(expr.source)};
-      return Analyze(expr.u);
+      result = Analyze(expr.u);
     } else {
-      return Analyze(expr.u);
+      result = Analyze(expr.u);
     }
+    if (result.has_value()) {
+      expr.typedExpr.reset(new GenericExprWrapper{common::Clone(*result)});
+    }
+    return result;
   }
 }
 
@@ -1937,10 +1935,32 @@ std::optional<int> ExpressionAnalyzer::IsAcImpliedDo(
     return std::nullopt;
   }
 }
+
+void ExpressionAnalyzer::EnforceTypeConstraint(parser::CharBlock at,
+    const MaybeExpr &result, TypeCategory category, bool defaultKind) {
+  if (result.has_value()) {
+    if (auto type{result->GetType()}) {
+      if (type->category != category) {
+        Say(at, "Must have %s type, but is %s"_err_en_US,
+            parser::ToUpperCaseLetters(EnumToString(category)).data(),
+            parser::ToUpperCaseLetters(type->AsFortran()).data());
+      } else if (defaultKind) {
+        int kind{context().defaultKinds().GetDefaultKind(category)};
+        if (type->kind != kind) {
+          Say(at, "Must have default kind(%d) of %s type, but is %s"_err_en_US,
+              kind, parser::ToUpperCaseLetters(EnumToString(category)).data(),
+              parser::ToUpperCaseLetters(type->AsFortran()).data());
+        }
+      }
+    } else {
+      Say(at, "Must have %s type, but is typeless"_err_en_US,
+          parser::ToUpperCaseLetters(EnumToString(category)).data());
+    }
+  }
+}
 }
 
 namespace Fortran::semantics {
-
 evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
     SemanticsContext &context, common::TypeCategory category,
     const std::optional<parser::KindSelector> &selector) {
@@ -1948,36 +1968,8 @@ evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
   auto save{analyzer.GetContextualMessages().SetLocation(*context.location())};
   return analyzer.AnalyzeKindSelector(category, selector);
 }
-
-void ExprChecker::Enter(const parser::Expr &expr) {
-  if (!expr.typedExpr) {
-    if (MaybeExpr checked{AnalyzeExpr(context_, expr)}) {
-#if PMKDEBUG
-//        std::cout << "checked expression: " << *checked << '\n';
-#endif
-      expr.typedExpr.reset(
-          new evaluate::GenericExprWrapper{std::move(*checked)});
-    } else {
-#if PMKDEBUG
-      std::cout << "TODO: expression analysis failed for this expression: ";
-      parser::DumpTree(std::cout, expr);
-#endif
-    }
-  }
-}
-
-void ExprChecker::Enter(const parser::Variable &var) {
-#if PMKDEBUG
-  if (MaybeExpr checked{AnalyzeExpr(context_, var)}) {
-//    std::cout << "checked variable: " << *checked << '\n';
-#else
-  if (AnalyzeExpr(context_, var)) {
-#endif
-  } else {
-#if PMKDEBUG
-    std::cout << "TODO: expression analysis failed for this variable: ";
-    DumpTree(std::cout, var);
-#endif
-  }
+bool ExprChecker::Walk(const parser::Program &program) {
+  parser::Walk(program, *this);
+  return !context_.AnyFatalError();
 }
 }

flang/lib/semantics/expression.h

@@ -19,6 +19,7 @@
 #include "../common/Fortran.h"
 #include "../common/indirection.h"
 #include "../evaluate/expression.h"
+#include "../evaluate/fold.h"
 #include "../evaluate/tools.h"
 #include "../evaluate/type.h"
 #include "../parser/char-block.h"
@@ -118,7 +119,7 @@ public:
     }
   }
 
-  // Implement constraint-checking wrappers from the Fortran grammar
+  // Implement constraint-checking wrappers from the Fortran grammar.
   template<typename A> MaybeExpr Analyze(const parser::Scalar<A> &x) {
     auto result{Analyze(x.thing)};
     if (result.has_value()) {
@@ -141,35 +142,23 @@ public:
   }
   template<typename A> MaybeExpr Analyze(const parser::Integer<A> &x) {
     auto result{Analyze(x.thing)};
-    if (result.has_value()) {
-      if (!std::holds_alternative<Expr<SomeInteger>>(result->u)) {
-        SayAt(x, "Must have INTEGER type"_err_en_US);
-      }
-    }
+    EnforceTypeConstraint(
+        parser::FindSourceLocation(x), result, TypeCategory::Integer);
     return result;
   }
   template<typename A> MaybeExpr Analyze(const parser::Logical<A> &x) {
     auto result{Analyze(x.thing)};
-    if (result.has_value()) {
-      if (!std::holds_alternative<Expr<SomeLogical>>(result->u)) {
-        SayAt(x, "Must have LOGICAL type"_err_en_US);
-      }
-    }
+    EnforceTypeConstraint(
+        parser::FindSourceLocation(x), result, TypeCategory::Logical);
     return result;
   }
   template<typename A> MaybeExpr Analyze(const parser::DefaultChar<A> &x) {
     auto result{Analyze(x.thing)};
-    if (result.has_value()) {
-      if (auto *charExpr{std::get_if<Expr<SomeCharacter>>(&result->u)}) {
-        if (charExpr->GetKind() ==
-            context().defaultKinds().GetDefaultKind(TypeCategory::Character)) {
-          return result;
-        }
-      }
-      SayAt(x, "Must have default CHARACTER type"_err_en_US);
-    }
+    EnforceTypeConstraint(parser::FindSourceLocation(x), result,
+        TypeCategory::Character, true /* default kind */);
     return result;
   }
+
   MaybeExpr Analyze(const parser::Name &);
   MaybeExpr Analyze(const parser::DataRef &dr) {
     return Analyze<parser::DataRef>(dr);
@@ -255,6 +244,8 @@ private:
   };
   std::optional<CallAndArguments> Procedure(
       const parser::ProcedureDesignator &, ActualArguments &);
+  void EnforceTypeConstraint(parser::CharBlock, const MaybeExpr &, TypeCategory,
+      bool defaultKind = false);
 
   semantics::SemanticsContext &context_;
   std::map<parser::CharBlock, int> acImpliedDos_;  // values are INTEGER kinds
@@ -296,11 +287,42 @@ evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
 
 // Semantic analysis of all expressions in a parse tree, which becomes
 // decorated with typed representations for top-level expressions.
-class ExprChecker : public virtual BaseChecker {
+class ExprChecker {
 public:
   explicit ExprChecker(SemanticsContext &context) : context_{context} {}
-  void Enter(const parser::Expr &);
-  void Enter(const parser::Variable &);
+
+  template<typename A> bool Pre(const A &) { return true; }
+  template<typename A> void Post(const A &) {}
+  bool Walk(const parser::Program &);
+
+  bool Pre(const parser::Expr &x) {
+    AnalyzeExpr(context_, x);
+    return false;
+  }
+  bool Pre(const parser::Variable &x) {
+    AnalyzeExpr(context_, x);
+    return false;
+  }
+  template<typename A> bool Pre(const parser::Scalar<A> &x) {
+    AnalyzeExpr(context_, x);
+    return false;
+  }
+  template<typename A> bool Pre(const parser::Constant<A> &x) {
+    AnalyzeExpr(context_, x);
+    return false;
+  }
+  template<typename A> bool Pre(const parser::Integer<A> &x) {
+    AnalyzeExpr(context_, x);
+    return false;
+  }
+  template<typename A> bool Pre(const parser::Logical<A> &x) {
+    AnalyzeExpr(context_, x);
+    return false;
+  }
+  template<typename A> bool Pre(const parser::DefaultChar<A> &x) {
+    AnalyzeExpr(context_, x);
+    return false;
+  }
 
 private:
   SemanticsContext &context_;

flang/lib/semantics/semantics.cc

@@ -19,7 +19,6 @@
 #include "check-computed-goto.h"
 #include "check-deallocate.h"
 #include "check-do-concurrent.h"
-#include "check-if-construct.h"
 #include "check-if-stmt.h"
 #include "check-nullify.h"
 #include "expression.h"
@@ -77,10 +76,10 @@ private:
   SemanticsContext &context_;
 };
 
-using StatementSemanticsPass1 = SemanticsVisitor<ExprChecker>;
+using StatementSemanticsPass1 = ExprChecker;
 using StatementSemanticsPass2 = SemanticsVisitor<ArithmeticIfStmtChecker,
     AssignmentChecker, ComputedGotoStmtChecker, DeallocateChecker,
-    DoConcurrentChecker, IfConstructChecker, IfStmtChecker, NullifyChecker>;
+    DoConcurrentChecker, IfStmtChecker, NullifyChecker>;
 
 SemanticsContext::SemanticsContext(
     const common::IntrinsicTypeDefaultKinds &defaultKinds,

flang/lib/semantics/tools.h

@@ -105,6 +105,5 @@ parser::Name *GetSimpleName(parser::Expr &);
 const parser::Name *GetSimpleName(const parser::Expr &);
 parser::Name *GetSimpleName(parser::Variable &);
 const parser::Name *GetSimpleName(const parser::Variable &);
-
 }
 #endif  // FORTRAN_SEMANTICS_TOOLS_H_

flang/test/semantics/computed-goto02.f90

@@ -20,15 +20,15 @@ COMPLEX Z
 LOGICAL L
 INTEGER, DIMENSION (2) :: B
 
-!ERROR: Computed GOTO expression must be an integer expression
+!ERROR: Must have INTEGER type, but is REAL(4)
 GOTO (100) 1.5
-!ERROR: Computed GOTO expression must be an integer expression
+!ERROR: Must have INTEGER type, but is LOGICAL(4)
 GOTO (100) .TRUE.
-!ERROR: Computed GOTO expression must be an integer expression
+!ERROR: Must have INTEGER type, but is REAL(4)
 GOTO (100) R
-!ERROR: Computed GOTO expression must be an integer expression
+!ERROR: Must have INTEGER type, but is COMPLEX(4)
 GOTO (100) Z
-!ERROR: Computed GOTO expression must be a scalar expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 GOTO (100) B
 
 100 CONTINUE

flang/test/semantics/doconcurrent04.f90

@@ -1,4 +1,4 @@
-! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+! Copyright (c) 2018-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.
@@ -13,17 +13,11 @@
 ! limitations under the License.
 
 ! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
-! CHECK: image control statement not allowed in DO CONCURRENT
-! CHECK: SYNC ALL
-! CHECK: do-variable must have INTEGER type
+! CHECK: must have INTEGER type, but is REAL(4)
 
 subroutine do_concurrent_test1(i,n)
   implicit none
-  integer :: i, n
   real :: j
-  do 20 j = 1, 20
-     do 10 concurrent (i = 1:n)
-        SYNC ALL
-10   continue
+  do 20 concurrent (j = 1:n)
 20 enddo
 end subroutine do_concurrent_test1

flang/test/semantics/if_construct02.f90

@@ -18,107 +18,107 @@
 INTEGER :: I
 LOGICAL, DIMENSION (2) :: B
 
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 if ( B ) then
   a = 1
 end if
 
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 if ( B ) then
   a = 2
 else
   a = 3
 endif
 
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 if ( B ) then
   a = 4
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 else if( B ) then
   a = 5
 end if
 
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 if ( B ) then
   a = 6
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 else if( B ) then
   a = 7
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 elseif( B ) then
   a = 8
 end if
 
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 if ( B ) then
   a = 9
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 else if( B ) then
   a = 10
 else
   a = 11
 end if
 
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 if ( B ) then
   a = 12
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 else if( B ) then
   a = 13
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 else if( B ) then
   a = 14
 end if
 
 
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 if ( I ) then
   a = 1
 end if
 
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 if ( I ) then
   a = 2
 else
   a = 3
 endif
 
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 if ( I ) then
   a = 4
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 else if( I ) then
   a = 5
 end if
 
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 if ( I ) then
   a = 6
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 else if( I ) then
   a = 7
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 elseif( I ) then
   a = 8
 end if
 
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 if ( I ) then
   a = 9
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 else if( I ) then
   a = 10
 else
   a = 11
 end if
 
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 if ( I ) then
   a = 12
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 else if( I ) then
   a = 13
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is INTEGER(4)
 else if( I ) then
   a = 14
 end if

flang/test/semantics/if_stmt03.f90

@@ -18,9 +18,9 @@
 
 LOGICAL, DIMENSION (2) :: B
 
-!ERROR: Expected a LOGICAL expression
+!ERROR: Must have LOGICAL type, but is REAL(4)
 IF (A) A = LOG (A)
-!ERROR: Expected a scalar LOGICAL expression
+!ERROR: Must be a scalar value, but is a rank-1 array
 IF (B) A = LOG (A)
 
 END

flang/test/semantics/resolve37.f90

@@ -18,7 +18,7 @@ integer :: n = 2
 !ERROR: Must be a constant value
 parameter(m=n)
 integer(k) :: x
-!ERROR: Must have INTEGER type
+!ERROR: Must have INTEGER type, but is REAL(4)
 integer(l) :: y
 !ERROR: Must be a constant value
 integer(n) :: z
@@ -27,10 +27,10 @@ type t(k)
 end type
 !ERROR: Type parameter 'k' lacks a value and has no default
 type(t( &
-!ERROR: Must have INTEGER type
+!ERROR: Must have INTEGER type, but is LOGICAL(4)
   .true.)) :: w
-!ERROR: Must have INTEGER type
+!ERROR: Must have INTEGER type, but is REAL(4)
 real :: u(l*2)
-!ERROR: Must have INTEGER type
+!ERROR: Must have INTEGER type, but is REAL(4)
 character(len=l) :: v
 end

flang/test/semantics/resolve41.f90

@@ -15,7 +15,7 @@
 module m
   implicit none
   real, parameter :: a = 8.0
-  !ERROR: Must have INTEGER type
+  !ERROR: Must have INTEGER type, but is REAL(4)
   integer :: aa = 2_a
   integer :: b = 8
   !ERROR: Must be a constant value