diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -145,9 +145,6 @@ 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); } diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -115,6 +115,7 @@ } 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 @@ -257,6 +258,10 @@ 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 @@ -399,21 +404,11 @@ 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() && @@ -453,6 +448,38 @@ } } +// 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()) { + 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; @@ -954,10 +981,6 @@ 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); } diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp --- a/flang/lib/Semantics/check-omp-structure.cpp +++ b/flang/lib/Semantics/check-omp-structure.cpp @@ -284,7 +284,7 @@ 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 " @@ -1026,7 +1026,7 @@ "%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, diff --git a/flang/lib/Semantics/resolve-names-utils.cpp b/flang/lib/Semantics/resolve-names-utils.cpp --- a/flang/lib/Semantics/resolve-names-utils.cpp +++ b/flang/lib/Semantics/resolve-names-utils.cpp @@ -357,8 +357,14 @@ 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) { - obj.symbol.attrs().set(Attr::SAVE); + if (!obj.symbol.attrs().test(Attr::SAVE)) { + obj.symbol.attrs().set(Attr::SAVE); + if (isImplicit) { + obj.symbol.implicitAttrs().set(Attr::SAVE); + } + } } } } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1097,10 +1097,8 @@ ParamValue GetParamValue( const parser::TypeParamValue &, common::TypeParamAttr attr); void CheckCommonBlockDerivedType(const SourceName &, const Symbol &); - std::optional CheckSaveAttr(const Symbol &); Attrs HandleSaveName(const SourceName &, Attrs); void AddSaveName(std::set &, 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 &, @@ -2877,7 +2875,7 @@ if (localSymbol.has()) { 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(); @@ -5595,11 +5593,8 @@ 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) { @@ -5617,40 +5612,16 @@ } } else { for (auto &object : symbol->get().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 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() && - !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)) { @@ -5669,13 +5640,6 @@ } } -// 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 diff --git a/flang/test/Lower/host-associated-globals.f90 b/flang/test/Lower/host-associated-globals.f90 --- a/flang/test/Lower/host-associated-globals.f90 +++ b/flang/test/Lower/host-associated-globals.f90 @@ -26,9 +26,9 @@ ! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QMtest_mod_used_in_hostEnot_in_equiv) : !fir.ref 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() diff --git a/flang/test/Semantics/resolve45.f90 b/flang/test/Semantics/resolve45.f90 --- a/flang/test/Semantics/resolve45.f90 +++ b/flang/test/Semantics/resolve45.f90 @@ -1,22 +1,24 @@ ! 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 @@ -27,9 +29,9 @@ 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 @@ -65,6 +67,6 @@ 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