[flang-commits] [flang] 3809554 - [flang] Constraint checks C751 to C760

Pete Steinfeld via flang-commits flang-commits at lists.llvm.org
Fri May 15 19:05:25 PDT 2020


Author: Pete Steinfeld
Date: 2020-05-15T18:50:14-07:00
New Revision: 38095549c6a12a75794595464fa9b95f5c6dcf35

URL: https://github.com/llvm/llvm-project/commit/38095549c6a12a75794595464fa9b95f5c6dcf35
DIFF: https://github.com/llvm/llvm-project/commit/38095549c6a12a75794595464fa9b95f5c6dcf35.diff

LOG: [flang] Constraint checks C751 to C760

Summary:
Many of these were already implemented, and I just annotated the tests and/or
the code.

C752 was a simple check to verify that CONTIGUOUS components are arrays with

C754 proved to be virtually identical to C750 that I implemented previously.
This caused me to remove the distinction between specification expressions for
type parameters and bounds expressions that I'd previously created.
the POINTER attribute.

I also changed the error messages to specify that errors in specification
expressions could arise from either bad derived type components or type
parameters.

In cases where we detect a type param that was not declared, I created a symbol
marked as erroneous.  That avoids subsequent semantic process for expressions
containing the symbol.  This change caused me to adjust tests resolve33.f90 and
resolve34.f90.  Also, I avoided putting out error messages for erroneous type
param symbols in `OkToAddComponent()` in resolve-names.cpp and in
`EvaluateParameters()`, type.cpp.

C756 checks that procedure components have the POINTER attribute.

Reviewers: tskeith, klausler, DavidTruby

Subscribers: llvm-commits

Tags: #llvm, #flang

Differential Revision: https://reviews.llvm.org/D79798

Added: 
    flang/test/Semantics/resolve90.f90

Modified: 
    flang/include/flang/Evaluate/check-expression.h
    flang/lib/Evaluate/check-expression.cpp
    flang/lib/Semantics/check-declarations.cpp
    flang/lib/Semantics/resolve-names.cpp
    flang/lib/Semantics/type.cpp
    flang/test/Semantics/assign02.f90
    flang/test/Semantics/resolve31.f90
    flang/test/Semantics/resolve33.f90
    flang/test/Semantics/resolve34.f90
    flang/test/Semantics/resolve52.f90
    flang/test/Semantics/resolve79.f90
    flang/test/Semantics/resolve89.f90

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h
index b14a47838e3a..16fe0bf11ae3 100644
--- a/flang/include/flang/Evaluate/check-expression.h
+++ b/flang/include/flang/Evaluate/check-expression.h
@@ -43,37 +43,28 @@ bool IsInitialDataTarget(
 // (10.1.11(2), C1010).  Constant expressions are always valid
 // specification expressions.
 
-// There are two contexts where specification expressions appear -- array
-// bounds and type param expressions.  We need to 
diff erentiate them because
-// additional checks are required for array bounds expressions in declarations
-// of derived type components (see C750).
-ENUM_CLASS(SpecificationExprContext, TYPE_PARAM, BOUND)
-
 template <typename A>
 void CheckSpecificationExpr(const A &, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &,
-    SpecificationExprContext);
+    const semantics::Scope &, const IntrinsicProcTable &);
 extern template void CheckSpecificationExpr(const Expr<SomeType> &x,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SomeType>> &x, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &,
-    SpecificationExprContext);
+    const semantics::Scope &, const IntrinsicProcTable &);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SomeInteger>> &x, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &,
-    SpecificationExprContext);
+    const semantics::Scope &, const IntrinsicProcTable &);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SubscriptInteger>> &x,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 
 // Simple contiguity (9.5.4)
 template <typename A>

diff  --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 923e814fc59b..6c8db0fe2419 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -191,10 +191,9 @@ class CheckSpecificationExprHelper
 public:
   using Result = std::optional<std::string>;
   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
-  explicit CheckSpecificationExprHelper(const semantics::Scope &s,
-      const IntrinsicProcTable &table, SpecificationExprContext specExprContext)
-      : Base{*this}, scope_{s}, table_{table}, specExprContext_{
-                                                   specExprContext} {}
+  explicit CheckSpecificationExprHelper(
+      const semantics::Scope &s, const IntrinsicProcTable &table)
+      : Base{*this}, scope_{s}, table_{table} {}
   using Base::operator();
 
   Result operator()(const ProcedureDesignator &) const {
@@ -205,9 +204,9 @@ class CheckSpecificationExprHelper
   Result operator()(const semantics::Symbol &symbol) const {
     if (semantics::IsNamedConstant(symbol)) {
       return std::nullopt;
-    } else if (scope_.IsDerivedType() && IsVariableName(symbol) &&
-        specExprContext_ == SpecificationExprContext::BOUND) { // C750
-      return "derived type component not allowed to reference variable '"s +
+    } else if (scope_.IsDerivedType() && IsVariableName(symbol)) { // C750, C754
+      return "derived type component or type parameter value not allowed to "
+             "reference variable '"s +
           symbol.name().ToString() + "'";
     } else if (symbol.IsDummy()) {
       if (symbol.attrs().test(semantics::Attr::OPTIONAL)) {
@@ -256,10 +255,9 @@ class CheckSpecificationExprHelper
   template <int KIND>
   Result operator()(const TypeParamInquiry<KIND> &inq) const {
     if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
-        inq.parameter().owner() != scope_ &&
-        specExprContext_ == SpecificationExprContext::BOUND) { // C750
-      return "non-constant reference to a type parameter inquiry "
-             "not allowed for derived type components";
+        inq.parameter().owner() != scope_) { // C750, C754
+      return "non-constant reference to a type parameter inquiry not "
+             "allowed for derived type components or type parameter values";
     }
     return std::nullopt;
   }
@@ -274,28 +272,30 @@ class CheckSpecificationExprHelper
         return "reference to statement function '"s +
             symbol->name().ToString() + "'";
       }
-      if (scope_.IsDerivedType() &&
-          specExprContext_ == SpecificationExprContext::BOUND) { // C750
+      if (scope_.IsDerivedType()) { // C750, C754
         return "reference to function '"s + symbol->name().ToString() +
-            "' not allowed for derived type components";
+            "' not allowed for derived type components or type parameter"
+            " values";
       }
       // TODO: other checks for standard module procedures
     } else {
       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
-      if (scope_.IsDerivedType() &&
-          specExprContext_ == SpecificationExprContext::BOUND) { // C750
+      if (scope_.IsDerivedType()) { // C750, C754
         if ((table_.IsIntrinsic(intrin.name) &&
                 badIntrinsicsForComponents_.find(intrin.name) !=
                     badIntrinsicsForComponents_.end()) ||
             IsProhibitedFunction(intrin.name)) {
           return "reference to intrinsic '"s + intrin.name +
-              "' not allowed for derived type components";
+              "' not allowed for derived type components or type parameter"
+              " values";
         }
         if (table_.GetIntrinsicClass(intrin.name) ==
                 IntrinsicClass::inquiryFunction &&
             !IsConstantExpr(x)) {
           return "non-constant reference to inquiry intrinsic '"s +
-              intrin.name + "' not allowed for derived type components";
+              intrin.name +
+              "' not allowed for derived type components or type"
+              " parameter values";
         }
       } else if (intrin.name == "present") {
         return std::nullopt; // no need to check argument(s)
@@ -311,7 +311,6 @@ class CheckSpecificationExprHelper
 private:
   const semantics::Scope &scope_;
   const IntrinsicProcTable &table_;
-  const SpecificationExprContext specExprContext_;
   const std::set<std::string> badIntrinsicsForComponents_{
       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
   static bool IsProhibitedFunction(std::string name) { return false; }
@@ -319,33 +318,30 @@ class CheckSpecificationExprHelper
 
 template <typename A>
 void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages,
-    const semantics::Scope &scope, const IntrinsicProcTable &table,
-    SpecificationExprContext specExprContext) {
-  if (auto why{
-          CheckSpecificationExprHelper{scope, table, specExprContext}(x)}) {
+    const semantics::Scope &scope, const IntrinsicProcTable &table) {
+  if (auto why{CheckSpecificationExprHelper{scope, table}(x)}) {
     messages.Say("Invalid specification expression: %s"_err_en_US, *why);
   }
 }
 
 template void CheckSpecificationExpr(const Expr<SomeType> &,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 template void CheckSpecificationExpr(const Expr<SomeInteger> &,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
     parser::ContextualMessages &, const semantics::Scope &,
-    const IntrinsicProcTable &, SpecificationExprContext);
+    const IntrinsicProcTable &);
 template void CheckSpecificationExpr(
     const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &,
-    const semantics::Scope &, const IntrinsicProcTable &,
-    SpecificationExprContext);
+    const semantics::Scope &, const IntrinsicProcTable &);
 
 // IsSimplyContiguous() -- 9.5.4
 class IsSimplyContiguousHelper

diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index edbd01d4eca0..e29cdcae0447 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -33,10 +33,7 @@ class CheckHelper {
 
   void Check() { Check(context_.globalScope()); }
   void Check(const ParamValue &, bool canBeAssumed);
-  void Check(const Bound &bound) {
-    CheckSpecExpr(
-        bound.GetExplicit(), evaluate::SpecificationExprContext::BOUND);
-  }
+  void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); }
   void Check(const ShapeSpec &spec) {
     Check(spec.lbound());
     Check(spec.ubound());
@@ -47,9 +44,7 @@ class CheckHelper {
   void Check(const Scope &);
 
 private:
-  template <typename A>
-  void CheckSpecExpr(
-      const A &x, const evaluate::SpecificationExprContext specExprContext) {
+  template <typename A> void CheckSpecExpr(const A &x) {
     if (symbolBeingChecked_ && IsSaved(*symbolBeingChecked_)) {
       if (!evaluate::IsConstantExpr(x)) {
         messages_.Say(
@@ -58,22 +53,18 @@ class CheckHelper {
       }
     } else {
       evaluate::CheckSpecificationExpr(
-          x, messages_, DEREF(scope_), context_.intrinsics(), specExprContext);
+          x, messages_, DEREF(scope_), context_.intrinsics());
     }
   }
-  template <typename A>
-  void CheckSpecExpr(const std::optional<A> &x,
-      const evaluate::SpecificationExprContext specExprContext) {
+  template <typename A> void CheckSpecExpr(const std::optional<A> &x) {
     if (x) {
-      CheckSpecExpr(*x, specExprContext);
+      CheckSpecExpr(*x);
     }
   }
-  template <typename A>
-  void CheckSpecExpr(
-      A &x, const evaluate::SpecificationExprContext specExprContext) {
+  template <typename A> void CheckSpecExpr(A &x) {
     x = Fold(foldingContext_, std::move(x));
     const A &constx{x};
-    CheckSpecExpr(constx, specExprContext);
+    CheckSpecExpr(constx);
   }
   void CheckValue(const Symbol &, const DerivedTypeSpec *);
   void CheckVolatile(
@@ -141,8 +132,7 @@ void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
           " external function result"_err_en_US);
     }
   } else {
-    CheckSpecExpr(
-        value.GetExplicit(), evaluate::SpecificationExprContext::TYPE_PARAM);
+    CheckSpecExpr(value.GetExplicit());
   }
 }
 
@@ -294,6 +284,12 @@ void CheckHelper::Check(const Symbol &symbol) {
           "A dummy argument may not have the SAVE attribute"_err_en_US);
     }
   }
+  if (symbol.owner().IsDerivedType() &&
+      (symbol.attrs().test(Attr::CONTIGUOUS) &&
+          !(IsPointer(symbol) && symbol.Rank() > 0))) { // C752
+    messages_.Say(
+        "A CONTIGUOUS component must be an array with the POINTER attribute"_err_en_US);
+  }
 }
 
 void CheckHelper::CheckValue(
@@ -584,6 +580,12 @@ void CheckHelper::CheckProcEntity(
       messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
     }
   } else if (symbol.owner().IsDerivedType()) {
+    if (!symbol.attrs().test(Attr::POINTER)) { // C756
+      const auto &name{symbol.name()};
+      messages_.Say(name,
+          "Procedure component '%s' must have POINTER attribute"_err_en_US,
+          name);
+    }
     CheckPassArg(symbol, details.interface().symbol(), details);
   }
   if (symbol.attrs().test(Attr::POINTER)) {
@@ -1066,7 +1068,7 @@ void CheckHelper::CheckVolatile(const Symbol &symbol, bool isAssociated,
 
 void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
   CheckConflicting(symbol, Attr::POINTER, Attr::TARGET);
-  CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE);
+  CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751
   CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
   if (symbol.Corank() > 0) {
     messages_.Say(
@@ -1076,6 +1078,7 @@ void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
 }
 
 // C760 constraints on the passed-object dummy argument
+// C757 constraints on procedure pointer components
 void CheckHelper::CheckPassArg(
     const Symbol &proc, const Symbol *interface, const WithPassArg &details) {
   if (proc.attrs().test(Attr::NOPASS)) {
@@ -1117,7 +1120,7 @@ void CheckHelper::CheckPassArg(
       break;
     }
   }
-  if (!passArgIndex) {
+  if (!passArgIndex) { // C758
     messages_.Say(*passName,
         "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
         *passName, interface->name());

diff  --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index f4768bc426c2..175d02597dfa 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -3671,6 +3671,13 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
     if (!symbol) {
       Say(paramName,
           "No definition found for type parameter '%s'"_err_en_US); // C742
+      // No symbol for a type param.  Create one and mark it as containing an
+      // error to improve subsequent semantic processing
+      BeginAttrs();
+      Symbol *typeParam{MakeTypeSymbol(
+          paramName, TypeParamDetails{common::TypeParamAttr::Len})};
+      typeParam->set(Symbol::Flag::Error);
+      EndAttrs();
     } else if (!symbol->has<TypeParamDetails>()) {
       Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US,
           *symbol, "Definition of '%s'"_en_US); // C741
@@ -3906,7 +3913,7 @@ bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) {
   CHECK(!interfaceName_);
   return true;
 }
-void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) {
+void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &stmt) {
   interfaceName_ = nullptr;
 }
 bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) {
@@ -4682,7 +4689,7 @@ void DeclarationVisitor::SetType(
       SetType(name,
           currScope().MakeCharacterType(std::move(length), std::move(kind)));
       return;
-    } else {
+    } else { // C753
       Say(name,
           "A length specifier cannot be used to declare the non-character entity '%s'"_err_en_US);
     }
@@ -4810,21 +4817,23 @@ bool DeclarationVisitor::OkToAddComponent(
   for (const Scope *scope{&currScope()}; scope;) {
     CHECK(scope->IsDerivedType());
     if (auto *prev{FindInScope(*scope, name)}) {
-      auto msg{""_en_US};
-      if (extends) {
-        msg = "Type cannot be extended as it has a component named"
-              " '%s'"_err_en_US;
-      } else if (prev->test(Symbol::Flag::ParentComp)) {
-        msg = "'%s' is a parent type of this type and so cannot be"
-              " a component"_err_en_US;
-      } else if (scope != &currScope()) {
-        msg = "Component '%s' is already declared in a parent of this"
-              " derived type"_err_en_US;
-      } else {
-        msg = "Component '%s' is already declared in this"
-              " derived type"_err_en_US;
+      if (!prev->test(Symbol::Flag::Error)) {
+        auto msg{""_en_US};
+        if (extends) {
+          msg = "Type cannot be extended as it has a component named"
+                " '%s'"_err_en_US;
+        } else if (prev->test(Symbol::Flag::ParentComp)) {
+          msg = "'%s' is a parent type of this type and so cannot be"
+                " a component"_err_en_US;
+        } else if (scope != &currScope()) {
+          msg = "Component '%s' is already declared in a parent of this"
+                " derived type"_err_en_US;
+        } else {
+          msg = "Component '%s' is already declared in this"
+                " derived type"_err_en_US;
+        }
+        Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US);
       }
-      Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US);
       return false;
     }
     if (scope == &currScope() && extends) {

diff  --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index c02ab6b6afd3..d8c817bd92cc 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -123,9 +123,12 @@ void DerivedTypeSpec::EvaluateParameters(
             continue;
           }
         }
-        evaluate::SayWithDeclaration(messages, symbol,
-            "Value of type parameter '%s' (%s) is not convertible to its type"_err_en_US,
-            name, expr->AsFortran());
+        if (!symbol.test(Symbol::Flag::Error)) {
+          evaluate::SayWithDeclaration(messages, symbol,
+              "Value of type parameter '%s' (%s) is not convertible to its"
+              " type"_err_en_US,
+              name, expr->AsFortran());
+        }
       }
     }
   }
@@ -147,7 +150,7 @@ void DerivedTypeSpec::EvaluateParameters(
         auto expr{
             evaluate::Fold(foldingContext, common::Clone(details.init()))};
         AddParamValue(name, ParamValue{std::move(*expr), details.attr()});
-      } else {
+      } else if (!symbol.test(Symbol::Flag::Error)) {
         messages.Say(name_,
             "Type parameter '%s' lacks a value and has no default"_err_en_US,
             name);

diff  --git a/flang/test/Semantics/assign02.f90 b/flang/test/Semantics/assign02.f90
index caf5b6ed9f1f..292a6d42ff98 100644
--- a/flang/test/Semantics/assign02.f90
+++ b/flang/test/Semantics/assign02.f90
@@ -11,7 +11,7 @@ module m1
   end type
 contains
 
-  ! C853
+  ! C852
   subroutine s0
     !ERROR: 'p1' may not have both the POINTER and TARGET attributes
     real, pointer :: p1, p3

diff  --git a/flang/test/Semantics/resolve31.f90 b/flang/test/Semantics/resolve31.f90
index a668e6877a08..f22f7e5af29e 100644
--- a/flang/test/Semantics/resolve31.f90
+++ b/flang/test/Semantics/resolve31.f90
@@ -84,7 +84,7 @@ module m4
     !ERROR: A sequence type data component must either be of an intrinsic type or a derived sequence type
     type(plainType) :: testField1
     type(sequenceType) :: testField2
-    procedure(real), nopass :: procField
+    procedure(real), pointer, nopass :: procField
   end type testType
   !ERROR: A sequence type may not have type parameters
   type :: paramType(param)

diff  --git a/flang/test/Semantics/resolve33.f90 b/flang/test/Semantics/resolve33.f90
index 6f4f7b066c3a..380a1ab2b8a7 100644
--- a/flang/test/Semantics/resolve33.f90
+++ b/flang/test/Semantics/resolve33.f90
@@ -39,7 +39,6 @@ module m
   !ERROR: No definition found for type parameter 'k'
   !ERROR: No definition found for type parameter 'l'
   type :: t6(k, l)
-    !ERROR: Must be a constant value
     character(kind=k, len=l) :: d3
   end type
   type(t6(2, 10)) :: x3

diff  --git a/flang/test/Semantics/resolve34.f90 b/flang/test/Semantics/resolve34.f90
index 783336614069..93dcd2a43420 100644
--- a/flang/test/Semantics/resolve34.f90
+++ b/flang/test/Semantics/resolve34.f90
@@ -27,9 +27,13 @@ module m3
     !ERROR: 't1' is a parent type of this type and so cannot be a component
     real :: t1
   end type
-  type, extends(t2) :: t3
-    !ERROR: 't1' is a parent type of this type and so cannot be a component
-    real :: t1
+  type :: t3
+  end type
+  type, extends(t3) :: t4
+  end type
+  type, extends(t4) :: t5
+    !ERROR: 't3' is a parent type of this type and so cannot be a component
+    real :: t3
   end type
 end
 

diff  --git a/flang/test/Semantics/resolve52.f90 b/flang/test/Semantics/resolve52.f90
index 6f684e845918..0b3ebd0dc104 100644
--- a/flang/test/Semantics/resolve52.f90
+++ b/flang/test/Semantics/resolve52.f90
@@ -5,6 +5,13 @@
 ! all of its length type parameters shall be assumed; it shall be polymorphic
 ! (7.3.2.3) if and only if the type being defined is extensible (7.5.7).
 ! It shall not have the VALUE attribute.
+!
+! C757 If the procedure pointer component has an implicit interface or has no
+! arguments, NOPASS shall be specified.
+!
+! C758 If PASS (arg-name) appears, the interface of the procedure pointer
+! component shall have a dummy argument named arg-name.
+
 
 module m1
   type :: t

diff  --git a/flang/test/Semantics/resolve79.f90 b/flang/test/Semantics/resolve79.f90
index a010324dc23d..1545aad97dbb 100644
--- a/flang/test/Semantics/resolve79.f90
+++ b/flang/test/Semantics/resolve79.f90
@@ -24,6 +24,8 @@ module m
     procedure(passNopassProc), pass, pointer, nopass :: passNopassField
     !WARNING: Attribute 'POINTER' cannot be used more than once
     procedure(pointerProc), pointer, public, pointer :: pointerField
+    !ERROR: Procedure component 'nonpointerfield' must have POINTER attribute
+    procedure(publicProc), public :: nonpointerField
   contains
     procedure :: noPassProc
     procedure :: passProc

diff  --git a/flang/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90
index fd9488ff0b01..f3bf218fdce7 100644
--- a/flang/test/Semantics/resolve89.f90
+++ b/flang/test/Semantics/resolve89.f90
@@ -1,9 +1,15 @@
 ! RUN: %S/test_errors.sh %s %t %f18
 ! C750 Each bound in the explicit-shape-spec shall be a specification
 ! expression in which there are no references to specification functions or
-! the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_- TYPE_OF, PRESENT,
+! the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, PRESENT,
 ! or SAME_TYPE_AS, every specification inquiry reference is a constant
 ! expression, and the value does not depend on the value of a variable.
+!
+! C754 Each type-param-value within a component-def-stmt shall be a colon or 
+! a specification expression in which there are no references to specification 
+! functions or the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF,
+! PRESENT, or SAME_TYPE_AS, every specification inquiry reference is a 
+! constant expression, and the value does not depend on the value of a variable.
 impure function impureFunc()
   integer :: impureFunc
 
@@ -21,6 +27,7 @@ module m
 end module m
 
 subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
+! C750
   use m
   implicit logical(l)
   integer, intent(in) :: iArg
@@ -58,7 +65,7 @@ subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
   real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic
 
   type arrayType
-    !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'var'
+    !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'var'
     real, dimension(var) :: varField
     !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc'
     real, dimension(iVolatileStmtFunc()) :: arrayFieldWithVolatile
@@ -66,17 +73,17 @@ subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
     real, dimension(iImpureStmtFunc()) :: arrayFieldWithImpureFunction
     !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc'
     real, dimension(iPureStmtFunc()) :: arrayFieldWithPureFunction
-    !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'iarg'
+    !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'iarg'
     real, dimension(iabs(iArg)) :: arrayFieldWithIntrinsic
-    !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components
+    !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values
     real, dimension(merge(1, 2, allocated(allocArg))) :: realField1
-    !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components
+    !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values
     real, dimension(merge(1, 2, associated(pointerArg))) :: realField2
-    !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components
+    !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components or type parameter values
     real, dimension(merge(1, 2, is_contiguous(arrayArg))) :: realField3
-    !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'ioarg'
+    !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'ioarg'
     real, dimension(ioArg) :: realField4
-    !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components
+    !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values
     real, dimension(merge(1, 2, present(optionalArg))) :: realField5
   end type arrayType
 
@@ -100,7 +107,7 @@ subroutine inner (derivedArg)
       type localDerivedType
         ! OK because the specification inquiry is a constant
         integer, dimension(localDerived%kindParam) :: goodField
-        !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components
+        !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components or type parameter values
         integer, dimension(derivedArg%lenParam) :: badField
       end type localDerivedType
 
@@ -108,3 +115,42 @@ subroutine inner (derivedArg)
       integer, dimension(derivedArg%kindParam) :: localVar
     end subroutine inner
 end subroutine s1
+
+subroutine s2(iArg, allocArg, pointerArg, arrayArg, optionalArg)
+  ! C754
+  integer, intent(in) :: iArg
+  real, allocatable, intent(in) :: allocArg
+  real, pointer, intent(in) :: pointerArg
+  integer, dimension(:), intent(in) :: arrayArg
+  real, optional, intent(in) :: optionalArg
+
+  type paramType(lenParam)
+    integer, len :: lenParam = 4
+  end type paramType
+
+  type charType
+    !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'iarg'
+    character(iabs(iArg)) :: fieldWithIntrinsic
+    !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values
+    character(merge(1, 2, allocated(allocArg))) :: allocField
+    !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values
+    character(merge(1, 2, associated(pointerArg))) :: assocField
+    !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components or type parameter values
+    character(merge(1, 2, is_contiguous(arrayArg))) :: contigField
+    !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values
+    character(merge(1, 2, present(optionalArg))) :: presentField
+  end type charType
+
+  type derivedType
+    !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'iarg'
+    type(paramType(iabs(iArg))) :: fieldWithIntrinsic
+    !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values
+    type(paramType(merge(1, 2, allocated(allocArg)))) :: allocField
+    !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values
+    type(paramType(merge(1, 2, associated(pointerArg)))) :: assocField
+    !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components or type parameter values
+    type(paramType(merge(1, 2, is_contiguous(arrayArg)))) :: contigField
+    !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values
+    type(paramType(merge(1, 2, present(optionalArg)))) :: presentField
+  end type derivedType
+end subroutine s2

diff  --git a/flang/test/Semantics/resolve90.f90 b/flang/test/Semantics/resolve90.f90
new file mode 100644
index 000000000000..3260ee983fb9
--- /dev/null
+++ b/flang/test/Semantics/resolve90.f90
@@ -0,0 +1,18 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! C751 A component shall not have both the ALLOCATABLE and POINTER attributes.
+! C752 If the CONTIGUOUS attribute is specified, the component shall be an 
+!   array with the POINTER attribute.
+! C753 The * char-length option is permitted only if the component is of type 
+!   character.
+subroutine s()
+  type derivedType
+    !ERROR: 'pointerallocatablefield' may not have both the POINTER and ALLOCATABLE attributes
+    real, pointer, allocatable :: pointerAllocatableField
+    real, dimension(:), contiguous, pointer :: goodContigField
+    !ERROR: A CONTIGUOUS component must be an array with the POINTER attribute
+    real, dimension(:), contiguous, allocatable :: badContigField
+    character :: charField * 3
+    !ERROR: A length specifier cannot be used to declare the non-character entity 'realfield'
+    real :: realField * 3
+  end type derivedType
+end subroutine s


        


More information about the flang-commits mailing list