[flang] Catch more semantic errors with coarrays (#125536)

Detect and report a bunch of uncaught semantic errors with coarray
declarations. Add more tests, and clean up bad usage in existing tests.

Author: klausler

flang/include/flang/Semantics/tools.h

@@ -631,6 +631,8 @@ using PotentialAndPointerComponentIterator =
 // dereferenced.
 PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
     const DerivedTypeSpec &, bool ignoreCoarrays = false);
+PotentialComponentIterator::const_iterator FindCoarrayPotentialComponent(
+    const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
     const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator FindPointerUltimateComponent(

flang/lib/Evaluate/tools.cpp

@@ -1812,7 +1812,11 @@ bool IsSaved(const Symbol &original) {
   } else if (scopeKind == Scope::Kind::DerivedType) {
     return false; // this is a component
   } else if (symbol.attrs().test(Attr::SAVE)) {
-    return true; // explicit SAVE attribute
+    // explicit or implied SAVE attribute
+    // N.B.: semantics sets implied SAVE for main program
+    // local variables whose derived types have coarray
+    // potential subobject components.
+    return true;
   } else if (IsDummy(symbol) || IsFunctionResult(symbol) ||
       IsAutomatic(symbol) || IsNamedConstant(symbol)) {
     return false;

flang/lib/Semantics/check-declarations.cpp

@@ -683,20 +683,10 @@ void CheckHelper::CheckObjectEntity(
   const DeclTypeSpec *type{details.type()};
   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
   bool isComponent{symbol.owner().IsDerivedType()};
-  if (details.coshape().empty()) { // not a coarray
-    if (!isComponent && !IsPointer(symbol) && derived) {
-      if (IsEventTypeOrLockType(derived)) {
-        messages_.Say(
-            "Variable '%s' with EVENT_TYPE or LOCK_TYPE must be a coarray"_err_en_US,
-            symbol.name());
-      } else if (auto component{FindEventOrLockPotentialComponent(
-                     *derived, /*ignoreCoarrays=*/true)}) {
-        messages_.Say(
-            "Variable '%s' with EVENT_TYPE or LOCK_TYPE potential component '%s' must be a coarray"_err_en_US,
-            symbol.name(), component.BuildResultDesignatorName());
-      }
-    }
-  } else { // it's a coarray
+  const Symbol *commonBlock{FindCommonBlockContaining(symbol)};
+  bool isLocalVariable{!commonBlock && !isComponent && !details.isDummy() &&
+      symbol.owner().kind() != Scope::Kind::OtherConstruct};
+  if (int corank{evaluate::GetCorank(symbol)}; corank > 0) { // it's a coarray
     bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
     if (IsAllocatable(symbol)) {
       if (!isDeferredCoshape) { // C827
@@ -726,6 +716,46 @@ void CheckHelper::CheckObjectEntity(
       messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,
           symbol.name());
     }
+    if (IsNamedConstant(symbol)) {
+      messages_.Say(
+          "Coarray '%s' may not be a named constant"_err_en_US, symbol.name());
+    }
+    if (IsFunctionResult(symbol)) {
+      messages_.Say("Function result may not be a coarray"_err_en_US);
+    } else if (commonBlock) {
+      messages_.Say("Coarray '%s' may not be in COMMON block '/%s/'"_err_en_US,
+          symbol.name(), commonBlock->name());
+    } else if (isLocalVariable && !IsAllocatableOrPointer(symbol) &&
+        !IsSaved(symbol)) {
+      messages_.Say("Local coarray must have the SAVE attribute"_err_en_US);
+    }
+    for (int j{0}; j < corank; ++j) {
+      if (auto lcbv{evaluate::ToInt64(evaluate::Fold(
+              context().foldingContext(), evaluate::GetLCOBOUND(symbol, j)))}) {
+        if (auto ucbv{
+                evaluate::ToInt64(evaluate::Fold(context().foldingContext(),
+                    evaluate::GetUCOBOUND(symbol, j)))}) {
+          if (ucbv < lcbv) {
+            messages_.Say(
+                "Cobounds %jd:%jd of codimension %d produce an empty coarray"_err_en_US,
+                std::intmax_t{*lcbv}, std::intmax_t{*ucbv}, j + 1);
+          }
+        }
+      }
+    }
+  } else { // not a coarray
+    if (!isComponent && !IsPointer(symbol) && derived) {
+      if (IsEventTypeOrLockType(derived)) {
+        messages_.Say(
+            "Variable '%s' with EVENT_TYPE or LOCK_TYPE must be a coarray"_err_en_US,
+            symbol.name());
+      } else if (auto component{FindEventOrLockPotentialComponent(
+                     *derived, /*ignoreCoarrays=*/true)}) {
+        messages_.Say(
+            "Variable '%s' with EVENT_TYPE or LOCK_TYPE potential component '%s' must be a coarray"_err_en_US,
+            symbol.name(), component.BuildResultDesignatorName());
+      }
+    }
   }
   if (details.isDummy()) {
     if (IsIntentOut(symbol)) {
@@ -926,6 +956,42 @@ void CheckHelper::CheckObjectEntity(
         symbol.name());
   }
 
+  if (derived) {
+    bool isUnsavedLocal{
+        isLocalVariable && !IsAllocatable(symbol) && !IsSaved(symbol)};
+    if (IsFunctionResult(symbol) || IsPointer(symbol) ||
+        evaluate::IsCoarray(symbol) || isUnsavedLocal) {
+      if (auto badPotential{FindCoarrayPotentialComponent(*derived)}) {
+        if (IsFunctionResult(symbol)) { // F'2023 C825
+          SayWithDeclaration(*badPotential,
+              "Function result '%s' may not have a coarray potential component '%s'"_err_en_US,
+              symbol.name(), badPotential.BuildResultDesignatorName());
+        } else if (IsPointer(symbol)) { // F'2023 C825
+          SayWithDeclaration(*badPotential,
+              "Pointer '%s' may not have a coarray potential component '%s'"_err_en_US,
+              symbol.name(), badPotential.BuildResultDesignatorName());
+        } else if (evaluate::IsCoarray(symbol)) { // F'2023 C825
+          SayWithDeclaration(*badPotential,
+              "Coarray '%s' may not have a coarray potential component '%s'"_err_en_US,
+              symbol.name(), badPotential.BuildResultDesignatorName());
+        } else if (isUnsavedLocal) { // F'2023 C826
+          SayWithDeclaration(*badPotential,
+              "Local variable '%s' without the SAVE attribute may not have a coarray potential subobject component '%s'"_err_en_US,
+              symbol.name(), badPotential.BuildResultDesignatorName());
+        } else {
+          DIE("caught unexpected bad coarray potential component");
+        }
+      }
+    } else if (isComponent && (IsAllocatable(symbol) || symbol.Rank() > 0)) {
+      if (auto badUltimate{FindCoarrayUltimateComponent(*derived)}) {
+        // TODO: still an error in F'2023?
+        SayWithDeclaration(*badUltimate,
+            "Allocatable or array component '%s' may not have a coarray ultimate component '%s'"_err_en_US,
+            symbol.name(), badUltimate.BuildResultDesignatorName());
+      }
+    }
+  }
+
   // Check CUDA attributes and special circumstances of being in device
   // subprograms
   const Scope &progUnit{GetProgramUnitContaining(symbol)};
@@ -3161,10 +3227,6 @@ parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(
     msgs.Say(symbol.name(),
         "Interoperable function result must be scalar"_err_en_US);
   }
-  if (symbol.Corank()) {
-    msgs.Say(symbol.name(),
-        "Interoperable function result may not be a coarray"_err_en_US);
-  }
   return msgs;
 }
 

flang/lib/Semantics/resolve-names.cpp

@@ -6127,32 +6127,6 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
               "POINTER or ALLOCATABLE"_err_en_US);
         }
       }
-      // TODO: This would be more appropriate in CheckDerivedType()
-      if (auto it{FindCoarrayUltimateComponent(*derived)}) { // C748
-        std::string ultimateName{it.BuildResultDesignatorName()};
-        // Strip off the leading "%"
-        if (ultimateName.length() > 1) {
-          ultimateName.erase(0, 1);
-          if (attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) {
-            evaluate::AttachDeclaration(
-                Say(name.source,
-                    "A component with a POINTER or ALLOCATABLE attribute may "
-                    "not "
-                    "be of a type with a coarray ultimate component (named "
-                    "'%s')"_err_en_US,
-                    ultimateName),
-                derived->typeSymbol());
-          }
-          if (!arraySpec().empty() || !coarraySpec().empty()) {
-            evaluate::AttachDeclaration(
-                Say(name.source,
-                    "An array or coarray component may not be of a type with a "
-                    "coarray ultimate component (named '%s')"_err_en_US,
-                    ultimateName),
-                derived->typeSymbol());
-          }
-        }
-      }
     }
   }
   if (OkToAddComponent(name)) {
@@ -9889,6 +9863,21 @@ void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) {
         object->set_cudaDataAttr(common::CUDADataAttr::Device);
       }
     }
+    // Main program local objects usually don't have an implied SAVE attribute,
+    // as one might think, but in the exceptional case of a derived type
+    // local object that contains a coarray, we have to mark it as an
+    // implied SAVE so that evaluate::IsSaved() will return true.
+    if (node.scope()->kind() == Scope::Kind::MainProgram) {
+      if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+        if (const DeclTypeSpec * type{object->type()}) {
+          if (const DerivedTypeSpec * derived{type->AsDerived()}) {
+            if (!IsSaved(symbol) && FindCoarrayPotentialComponent(*derived)) {
+              SetImplicitAttr(symbol, Attr::SAVE);
+            }
+          }
+        }
+      }
+    }
   }
 }
 

flang/lib/Semantics/tools.cpp

@@ -1386,6 +1386,13 @@ template class ComponentIterator<ComponentKind::Potential>;
 template class ComponentIterator<ComponentKind::Scope>;
 template class ComponentIterator<ComponentKind::PotentialAndPointer>;
 
+PotentialComponentIterator::const_iterator FindCoarrayPotentialComponent(
+    const DerivedTypeSpec &derived) {
+  PotentialComponentIterator potentials{derived};
+  return std::find_if(potentials.begin(), potentials.end(),
+      [](const Symbol &symbol) { return evaluate::IsCoarray(symbol); });
+}
+
 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
     const DerivedTypeSpec &derived) {
   UltimateComponentIterator ultimates{derived};

flang/test/Lower/pre-fir-tree04.f90

@@ -5,6 +5,7 @@
 ! CHECK: Subroutine test_coarray
 Subroutine test_coarray
   use iso_fortran_env, only: team_type, event_type, lock_type
+  save
   type(team_type) :: t
   type(event_type) :: done[*]
   type(lock_type) :: alock[*]

flang/test/Semantics/allocate11.f90

@@ -38,7 +38,14 @@ subroutine C937(var)
 
   type B
     type(A) y
-    !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named 'y%x')
+    !ERROR: Allocatable or array component 'forward' may not have a coarray ultimate component '%y%x'
+    type(B), allocatable :: forward
+    real :: u
+  end type
+
+  type B2
+    type(A) y
+    !ERROR: Pointer 'forward' may not have a coarray potential component '%y%x'
     type(B), pointer :: forward
     real :: u
   end type
@@ -48,11 +55,14 @@ subroutine C937(var)
   end type
 
   type D
-    !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named 'x')
-    type(A), pointer :: potential
+    !ERROR: Allocatable or array component 'potential' may not have a coarray ultimate component '%x'
+    type(A), allocatable :: potential
   end type
 
-
+  type D2
+    !ERROR: Pointer 'potential' may not have a coarray potential component '%x'
+    type(A), pointer :: potential
+  end type
 
   class(*), allocatable :: var
   ! unlimited polymorphic is the ONLY way to get an allocatable/pointer 'var' that can be

flang/test/Semantics/assign02.f90

@@ -74,8 +74,8 @@ subroutine s4(x)
 
   ! C1020
   subroutine s5
-    real, target :: x[*]
-    real, target, volatile :: y[*]
+    real, target, save :: x[*]
+    real, target, volatile, save :: y[*]
     real, pointer :: p
     real, pointer, volatile :: q
     p => x
@@ -148,7 +148,7 @@ function f2()
 
   ! C1026 (R1037) A data-target shall not be a coindexed object.
   subroutine s10
-    real, target :: a[*]
+    real, target, save :: a[*]
     real, pointer :: b
     !ERROR: A coindexed object may not be a pointer target
     b => a[1]

flang/test/Semantics/associated.f90

@@ -90,7 +90,7 @@ subroutine test(assumedRank)
     type(t2) :: t2x
     type(t2), target :: t2xtarget
     integer, target :: targetIntArr(2)
-    integer, target :: targetIntCoarray[*]
+    integer, target, save :: targetIntCoarray[*]
     integer, pointer :: intPointerArr(:)
     procedure(objPtrFunc), pointer :: objPtrFuncPointer
 

flang/test/Semantics/bind-c09.f90

@@ -44,6 +44,6 @@ function func8() result(res) bind(c)
 end
 
 function func9() result(res) bind(c)
-  ! ERROR: Interoperable function result may not be a coarray
+  ! ERROR: Function result may not be a coarray
   integer :: res[10, *]
 end

flang/test/Semantics/call10.f90

@@ -200,8 +200,9 @@ pure subroutine s13
     !ERROR: An image control statement may not appear in a pure subprogram
     sync all ! C1599
   end subroutine
-  pure subroutine s14
-    integer :: img, nimgs, i[*], tmp
+  pure subroutine s14(i)
+    integer :: img, nimgs, tmp
+    integer, intent(in out) :: i[*]
                                    ! implicit sync all
     img = this_image()
     nimgs = num_images()

flang/test/Semantics/call12.f90

@@ -40,7 +40,9 @@ pure function test(ptr, in, hpd, hhpd)
     type(hasHiddenPtr), intent(in) :: hhpd
     type(hasPtr), allocatable :: alloc
     type(hasHiddenPtr), allocatable :: hpAlloc
+    !ERROR: Pointer 'hcp' may not have a coarray potential component '%co'
     type(hasCoarray), pointer :: hcp
+    type(hasCoarray), allocatable :: hca
     integer :: n
     common /block/ y
     external :: extfunc
@@ -60,8 +62,8 @@ pure function test(ptr, in, hpd, hhpd)
     !BECAUSE: 'in' is an INTENT(IN) dummy argument
     in%a = 0. ! C1594(1)
     !ERROR: Left-hand side of assignment is not definable
-    !BECAUSE: A pure subprogram may not define the coindexed object 'hcp%co[1_8]'
-    hcp%co[1] = 0. ! C1594(1)
+    !BECAUSE: A pure subprogram may not define the coindexed object 'hca%co[1_8]'
+    hca%co[1] = 0. ! C1594(1)
     !ERROR: The left-hand side of a pointer assignment is not definable
     !BECAUSE: 'ptr' may not be defined in pure subprogram 'test' because it is a POINTER dummy argument of a pure function
     ptr => z ! C1594(2)

flang/test/Semantics/change_team01.f90

@@ -4,6 +4,7 @@
 
 subroutine test
   use, intrinsic :: iso_fortran_env, only: team_type
+  save
   type(team_type) :: team
   integer, codimension[*] :: selector
   integer, codimension[2,*] :: selector2d

flang/test/Semantics/coarrays01.f90

@@ -2,7 +2,7 @@
 ! Test selector and team-value in CHANGE TEAM statement
 
 ! OK
-subroutine s1
+subroutine s1(y)
   use iso_fortran_env, only: team_type
   type(team_type) :: t
   real :: y[10,*]
@@ -11,7 +11,7 @@ subroutine s1
   form team(1, t)
 end
 
-subroutine s2
+subroutine s2(y,y2,x)
   use iso_fortran_env
   type(team_type) :: t
   real :: y[10,*], y2[*], x[*]
@@ -27,7 +27,7 @@ subroutine s2
   end team
 end
 
-subroutine s3
+subroutine s3(y)
   type :: team_type
   end type
   type :: foo