[flang] Move SAVE attribute checks to declaration checking

[klausler]

Summary

Constraint checking for explicit SAVE attributes is more
accurate when done along with other declaration checking, rather
than on the fly during name resolution. This allows us to
catch attempts to attach explicit SAVE attributes to anything
that can't have one (constraints C859, C860).

Also delete IsSave(), whose few remaining uses were changed to the
more general IsSaved() predicate that seems more correct for
those uses, returning true for both explicit and implied SAVE
attributes.

flang/include/flang/Semantics/tools.h

inline bool IsPointer(const Symbol &symbol) {
   return symbol.attrs().test(Attr::POINTER);
 }
 inline bool IsAllocatable(const Symbol &symbol) {
   return symbol.attrs().test(Attr::ALLOCATABLE);
 }
 inline bool IsAllocatableOrPointer(const Symbol &symbol) {
   return IsPointer(symbol) || IsAllocatable(symbol);
 }
-inline bool IsSave(const Symbol &symbol) {
-  return symbol.attrs().test(Attr::SAVE);
-}
 inline bool IsNamedConstant(const Symbol &symbol) {
   return symbol.attrs().test(Attr::PARAMETER);
 }
 inline bool IsOptional(const Symbol &symbol) {
   return symbol.attrs().test(Attr::OPTIONAL);
 }
 inline bool IsIntentIn(const Symbol &symbol) {
   return symbol.attrs().test(Attr::INTENT_IN);

flang/lib/Semantics/check-declarations.cpp

parser::Message *SayWithDeclaration(const Symbol &symbol, A &&...x) {
     parser::Message *msg{messages_.Say(std::forward<A>(x)...)};
     if (msg && messages_.at().begin() != symbol.name().begin()) {
       evaluate::AttachDeclaration(*msg, symbol);
     }
     return msg;
   }
   bool IsResultOkToDiffer(const FunctionResult &);
   void CheckGlobalName(const Symbol &);
+  void CheckExplicitSave(const Symbol &);
   void CheckBindC(const Symbol &);
   void CheckBindCFunctionResult(const Symbol &);
   // Check functions for defined I/O procedures
   void CheckDefinedIoProc(
       const Symbol &, const GenericDetails &, GenericKind::DefinedIo);
   bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
   void CheckDioDummyIsDerived(const Symbol &, const Symbol &,
       GenericKind::DefinedIo ioKind, const Symbol &);
common::visit(
       },
       symbol.details());
   if (symbol.attrs().test(Attr::VOLATILE)) {
     CheckVolatile(symbol, derived);
   }
   if (symbol.attrs().test(Attr::BIND_C)) {
     CheckBindC(symbol);
   }
+  if (symbol.attrs().test(Attr::SAVE) &&
+      !symbol.implicitAttrs().test(Attr::SAVE)) {
+    CheckExplicitSave(symbol);
+  }
   CheckGlobalName(symbol);
   if (isDone) {
     return; // following checks do not apply
   }
   if (symbol.attrs().test(Attr::PROTECTED)) {
     if (symbol.owner().kind() != Scope::Kind::Module) { // C854
       messages_.Say(
           "A PROTECTED entity must be in the specification part of a module"_err_en_US);
if (symbol.attrs().test(Attr::CONTIGUOUS) && IsPointer(symbol) &&
       symbol.Rank() == 0) { // C830
     messages_.Say("CONTIGUOUS POINTER must be an array"_err_en_US);
   }
   if (IsDummy(symbol)) {
     if (IsNamedConstant(symbol)) {
       messages_.Say(
           "A dummy argument may not also be a named constant"_err_en_US);
     }
-    if (!symbol.test(Symbol::Flag::InDataStmt) /*caught elsewhere*/ &&
-        IsSaved(symbol)) {
-      messages_.Say(
-          "A dummy argument may not have the SAVE attribute"_err_en_US);
-    }
   } else if (IsFunctionResult(symbol)) {
     if (IsNamedConstant(symbol)) {
       messages_.Say(
           "A function result may not also be a named constant"_err_en_US);
     }
-    if (!symbol.test(Symbol::Flag::InDataStmt) /*caught elsewhere*/ &&
-        IsSaved(symbol)) {
-      messages_.Say(
-          "A function result may not have the SAVE attribute"_err_en_US);
-    }
     CheckBindCFunctionResult(symbol);
   }
   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::CheckCommonBlock(const Symbol &symbol) {
   CheckGlobalName(symbol);
   if (symbol.attrs().test(Attr::BIND_C)) {
     CheckBindC(symbol);
   }
 }
 
+// C859, C860
+void CheckHelper::CheckExplicitSave(const Symbol &symbol) {
+  const Symbol &ultimate{symbol.GetUltimate()};
+  if (ultimate.test(Symbol::Flag::InDataStmt)) {
+    // checked elsewhere
+  } else if (symbol.has<UseDetails>()) {
+    messages_.Say(
+        "The USE-associated name '%s' may not have an explicit SAVE attribute"_err_en_US,
+        symbol.name());
+  } else if (IsDummy(ultimate)) {
+    messages_.Say(
+        "The dummy argument '%s' may not have an explicit SAVE attribute"_err_en_US,
+        symbol.name());
+  } else if (IsFunctionResult(ultimate)) {
+    messages_.Say(
+        "The function result variable '%s' may not have an explicit SAVE attribute"_err_en_US,
+        symbol.name());
+  } else if (const Symbol * common{FindCommonBlockContaining(ultimate)}) {
+    messages_.Say(
+        "The entity '%s' in COMMON block /%s/ may not have an explicit SAVE attribute"_err_en_US,
+        symbol.name(), common->name());
+  } else if (IsAutomatic(ultimate)) {
+    messages_.Say(
+        "The automatic object '%s' may not have an explicit SAVE attribute"_err_en_US,
+        symbol.name());
+  } else if (!evaluate::IsVariable(ultimate) && !IsProcedurePointer(ultimate)) {
+    messages_.Say(
+        "The entity '%s' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block"_err_en_US,
+        symbol.name());
+  }
+}
+
 void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553
   if (!innermostSymbol_ || !IsBindCProcedure(*innermostSymbol_)) {
     return;
   }
   if (IsPointer(symbol) || IsAllocatable(symbol)) {
     messages_.Say(
         "BIND(C) function result cannot have ALLOCATABLE or POINTER attribute"_err_en_US);
   }
if (const Symbol * interface{details.procInterface()}) {
               "to procedure pointer '%s'"_err_en_US,
               ultimate.name(), symbol.name());
         }
       } else if (IsElementalProcedure(*interface)) {
         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
             symbol.name()); // C1517
       }
     }
-  } else if (IsSave(symbol)) {
-    messages_.Say(
-        "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US,
-        symbol.name());
   }
   CheckExternal(symbol);
 }
 
 // When a module subprogram has the MODULE prefix the following must match
 // with the corresponding separate module procedure interface body:
 // - C1549: characteristics and dummy argument names
 // - C1550: binding label

flang/lib/Semantics/check-omp-structure.cpp

 
 void OmpStructureChecker::CheckPredefinedAllocatorRestriction(
     const parser::CharBlock &source, const parser::Name &name) {
   if (const auto *symbol{name.symbol}) {
     const auto *commonBlock{FindCommonBlockContaining(*symbol)};
     const auto &scope{context_.FindScope(symbol->name())};
     const Scope &containingScope{GetProgramUnitContaining(scope)};
     if (!isPredefinedAllocator &&
-        (IsSave(*symbol) || commonBlock ||
+        (IsSaved(*symbol) || commonBlock ||
             containingScope.kind() == Scope::Kind::Module)) {
       context_.Say(source,
           "If list items within the ALLOCATE directive have the "
           "SAVE attribute, are a common block name, or are "
           "declared in the scope of a module, then only "
           "predefined memory allocator parameters can be used "
           "in the allocator clause"_err_en_US);
     }
common::visit(
                     if (sym &&
                         (sym->has<MainProgramDetails>() ||
                             sym->has<ModuleDetails>())) {
                       context_.Say(name->source,
                           "The module name or main program name cannot be in a "
                           "%s "
                           "directive"_err_en_US,
                           ContextDirectiveAsFortran());
-                    } else if (!IsSave(*name->symbol) &&
+                    } else if (!IsSaved(*name->symbol) &&
                         declScope.kind() != Scope::Kind::MainProgram &&
                         declScope.kind() != Scope::Kind::Module) {
                       context_.Say(name->source,
                           "A variable that appears in a %s directive must be "
                           "declared in the scope of a module or have the SAVE "
                           "attribute, either explicitly or "
                           "implicitly"_err_en_US,
                           ContextDirectiveAsFortran());

flang/lib/Semantics/resolve-names-utils.cpp

Bound ArraySpecAnalyzer::GetBound(const parser::SpecificationExpr &x) {
   }
   return Bound{std::move(expr)};
 }
 
 // If SAVE is set on src, set it on all members of dst
 static void PropagateSaveAttr(
     const EquivalenceObject &src, EquivalenceSet &dst) {
   if (src.symbol.attrs().test(Attr::SAVE)) {
+    bool isImplicit{src.symbol.implicitAttrs().test(Attr::SAVE)};
     for (auto &obj : dst) {
+      if (!obj.symbol.attrs().test(Attr::SAVE)) {
         obj.symbol.attrs().set(Attr::SAVE);
+        if (isImplicit) {
+          obj.symbol.implicitAttrs().set(Attr::SAVE);
+        }
+      }
     }
   }
 }
 static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) {
   if (!src.empty()) {
     PropagateSaveAttr(src.front(), dst);
   }
 }

flang/lib/Semantics/resolve-names.cpp

private:
   std::optional<DerivedTypeSpec> ResolveExtendsType(
       const parser::Name &, const parser::Name *);
   Symbol *MakeTypeSymbol(const SourceName &, Details &&);
   Symbol *MakeTypeSymbol(const parser::Name &, Details &&);
   bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
   ParamValue GetParamValue(
       const parser::TypeParamValue &, common::TypeParamAttr attr);
   void CheckCommonBlockDerivedType(const SourceName &, const Symbol &);
-  std::optional<MessageFixedText> CheckSaveAttr(const Symbol &);
   Attrs HandleSaveName(const SourceName &, Attrs);
   void AddSaveName(std::set<SourceName> &, const SourceName &);
-  void SetSaveAttr(Symbol &);
   bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
   const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
   void Initialization(const parser::Name &, const parser::Initialization &,
       bool inComponentDecl);
   bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol);
   bool CheckForHostAssociatedImplicit(const parser::Name &);
 
   // Declare an object or procedure entity.
void ModuleVisitor::DoAddUse(SourceName location, SourceName localName,
   if (auto *details{localSymbol.detailsIf<UseErrorDetails>()}) {
     details->add_occurrence(location, *useModuleScope_);
     return;
   }
 
   if (localSymbol.has<UnknownDetails>()) {
     localSymbol.set_details(UseDetails{localName, useSymbol});
     localSymbol.attrs() =
-        useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE};
+        useSymbol.attrs() & ~Attrs{Attr::PUBLIC, Attr::PRIVATE, Attr::SAVE};
     localSymbol.implicitAttrs() =
         localSymbol.attrs() & Attrs{Attr::ASYNCHRONOUS, Attr::VOLATILE};
     localSymbol.flags() = useSymbol.flags();
     return;
   }
 
   Symbol &localUltimate{localSymbol.GetUltimate()};
   const Symbol &useUltimate{useSymbol.GetUltimate()};
for (const SourceName &name : specPartState_.saveInfo.entities) {
     auto *symbol{FindInScope(name)};
     if (!symbol) {
       // error was reported
     } else if (specPartState_.saveInfo.saveAll) {
       // C889 - note that pgi, ifort, xlf do not enforce this constraint
       Say2(name,
           "Explicit SAVE of '%s' is redundant due to global SAVE statement"_warn_en_US,
           *specPartState_.saveInfo.saveAll, "Global SAVE statement"_en_US);
-    } else if (auto msg{CheckSaveAttr(*symbol)}) {
-      Say(name, std::move(*msg));
-      context().SetError(*symbol);
-    } else {
-      SetSaveAttr(*symbol);
+    } else if (!IsSaved(*symbol)) {
+      SetExplicitAttr(*symbol, Attr::SAVE);
     }
   }
   for (const SourceName &name : specPartState_.saveInfo.commons) {
     if (auto *symbol{currScope().FindCommonBlock(name)}) {
       auto &objects{symbol->get<CommonBlockDetails>().objects()};
       if (objects.empty()) {
         if (currScope().kind() != Scope::Kind::BlockConstruct) {
           Say(name,
               "'%s' appears as a COMMON block in a SAVE statement but not in"
               " a COMMON statement"_err_en_US);
         } else { // C1108
           Say(name,
               "SAVE statement in BLOCK construct may not contain a"
               " common block name '%s'"_err_en_US);
         }
       } else {
         for (auto &object : symbol->get<CommonBlockDetails>().objects()) {
-          SetSaveAttr(*object);
+          if (!IsSaved(*object)) {
+            SetImplicitAttr(*object, Attr::SAVE);
           }
         }
       }
     }
-  if (specPartState_.saveInfo.saveAll) {
-    // Apply SAVE attribute to applicable symbols
-    for (auto pair : currScope()) {
-      auto &symbol{*pair.second};
-      if (!CheckSaveAttr(symbol)) {
-        SetSaveAttr(symbol);
-      }
-    }
   }
   specPartState_.saveInfo = {};
 }
 
-// If SAVE attribute can't be set on symbol, return error message.
-std::optional<MessageFixedText> DeclarationVisitor::CheckSaveAttr(
-    const Symbol &symbol) {
-  if (IsDummy(symbol)) {
-    return "SAVE attribute may not be applied to dummy argument '%s'"_err_en_US;
-  } else if (symbol.IsFuncResult()) {
-    return "SAVE attribute may not be applied to function result '%s'"_err_en_US;
-  } else if (symbol.has<ProcEntityDetails>() &&
-      !symbol.attrs().test(Attr::POINTER)) {
-    return "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US;
-  } else if (IsAutomatic(symbol)) {
-    return "SAVE attribute may not be applied to automatic data object '%s'"_err_en_US;
-  } else {
-    return std::nullopt;
-  }
-}
-
 // Record SAVEd names in specPartState_.saveInfo.entities.
 Attrs DeclarationVisitor::HandleSaveName(const SourceName &name, Attrs attrs) {
   if (attrs.test(Attr::SAVE)) {
     AddSaveName(specPartState_.saveInfo.entities, name);
   }
   return attrs;
 }
 
 // Record a name in a set of those to be saved.
 void DeclarationVisitor::AddSaveName(
     std::set<SourceName> &set, const SourceName &name) {
   auto pair{set.insert(name)};
   if (!pair.second) {
     Say2(name, "SAVE attribute was already specified on '%s'"_warn_en_US,
         *pair.first, "Previous specification of SAVE attribute"_en_US);
   }
 }
 
-// Set the SAVE attribute on symbol unless it is implicitly saved anyway.
-void DeclarationVisitor::SetSaveAttr(Symbol &symbol) {
-  if (!IsSaved(symbol)) {
-    SetImplicitAttr(symbol, Attr::SAVE);
-  }
-}
-
 // Check types of common block objects, now that they are known.
 void DeclarationVisitor::CheckCommonBlocks() {
   // check for empty common blocks
   for (const auto &pair : currScope().commonBlocks()) {
     const auto &symbol{*pair.second};
     if (symbol.get<CommonBlockDetails>().objects().empty() &&
         symbol.attrs().test(Attr::BIND_C)) {
       Say(symbol.name(),

flang/test/Lower/host-associated-globals.f90

 ! CHECK-LABEL: func.func @_QFmodule_varPbar()
 ! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QMtest_mod_used_in_hostEi) : !fir.ref<!fir.array<4xi8>>
 ! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : index
 ! CHECK:  %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<!fir.array<4xi8>>, index) -> !fir.ref<i8>
 ! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<i8>) -> !fir.ptr<i32>
 ! CHECK:  %[[VAL_4:.*]] = fir.address_of(@_QMtest_mod_used_in_hostEnot_in_equiv) : !fir.ref<i32>
 
 subroutine test_common()
-  integer, save :: i(2)
-  integer, save :: j_in_equiv
-  integer, save :: not_in_equiv
+  integer :: i(2)
+  integer :: j_in_equiv
+  integer :: not_in_equiv
   equivalence (i(2),j_in_equiv)
   common /x/ i, not_in_equiv
   call bar()
 contains
  subroutine bar()
     print *, j_in_equiv, not_in_equiv
  end subroutine
 end subroutine

flang/test/Semantics/resolve45.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
+!ERROR: The function result variable 'f1' may not have an explicit SAVE attribute
 function f1(x, y)
+  !ERROR: The dummy argument 'x' may not have an explicit SAVE attribute
   integer x
-  !ERROR: SAVE attribute may not be applied to dummy argument 'x'
-  !ERROR: SAVE attribute may not be applied to dummy argument 'y'
   save x,y
+  !ERROR: The dummy argument 'y' may not have an explicit SAVE attribute
   integer y
-  !ERROR: SAVE attribute may not be applied to function result 'f1'
   save f1
 end
 
-function f2(x, y)
-  !ERROR: SAVE attribute may not be applied to function result 'f2'
-  real, save :: f2
-  !ERROR: SAVE attribute may not be applied to dummy argument 'x'
+!ERROR: The entity 'f2' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block
+function f2(x, y) result(r)
+  save f2
+  !ERROR: The function result variable 'r' may not have an explicit SAVE attribute
+  real, save :: r
+  !ERROR: The dummy argument 'x' may not have an explicit SAVE attribute
   complex, save :: x
   allocatable :: y
+  !ERROR: The dummy argument 'y' may not have an explicit SAVE attribute
   integer :: y
-  !ERROR: SAVE attribute may not be applied to dummy argument 'y'
   save :: y
 end
 
 ! SAVE statement should not trigger the above errors
 function f2b(x, y)
   real :: x, y
   save
 end
 
 subroutine s3(x)
-  !ERROR: SAVE attribute may not be applied to dummy argument 'x'
+  !ERROR: The dummy argument 'x' may not have an explicit SAVE attribute
   procedure(integer), pointer, save :: x
-  !ERROR: Procedure 'y' with SAVE attribute must also have POINTER attribute
+  !ERROR: The entity 'y' with an explicit SAVE attribute must be a variable, procedure pointer, or COMMON block
   procedure(integer), save :: y
 end
 
 subroutine s4
   !WARNING: Explicit SAVE of 'z' is redundant due to global SAVE statement
   save z
   save
   procedure(integer), pointer :: x

 
 subroutine s8a(n)
   integer :: n
   real :: x(n)  ! OK: save statement doesn't affect x
   save
 end
 subroutine s8b(n)
   integer :: n
-  !ERROR: SAVE attribute may not be applied to automatic data object 'x'
+  !ERROR: The automatic object 'x' may not have an explicit SAVE attribute
   real, save :: x(n)
 end