diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -111,12 +111,18 @@ llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; std::optional keyword() const { return keyword_; } - void set_keyword(parser::CharBlock x) { keyword_ = x; } + ActualArgument &set_keyword(parser::CharBlock x) { + keyword_ = x; + return *this; + } bool isAlternateReturn() const { return std::holds_alternative(u_); } bool isPassedObject() const { return isPassedObject_; } - void set_isPassedObject(bool yes = true) { isPassedObject_ = yes; } + ActualArgument &set_isPassedObject(bool yes = true) { + isPassedObject_ = yes; + return *this; + } bool Matches(const characteristics::DummyArgument &) const; common::Intent dummyIntent() const { return dummyIntent_; } diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -235,11 +235,14 @@ // Predicate: is an expression is an array element reference? template -bool IsArrayElement(const Expr &expr, bool intoSubstring = false) { +bool IsArrayElement(const Expr &expr, bool intoSubstring = true, + bool skipComponents = false) { if (auto dataRef{ExtractDataRef(expr, intoSubstring)}) { const DataRef *ref{&*dataRef}; - while (const Component * component{std::get_if(&ref->u)}) { - ref = &component->base(); + if (skipComponents) { + while (const Component * component{std::get_if(&ref->u)}) { + ref = &component->base(); + } } if (const auto *coarrayRef{std::get_if(&ref->u)}) { return !coarrayRef->subscript().empty(); @@ -789,6 +792,7 @@ bool IsFunction(const Expr &); bool IsProcedurePointer(const Expr &); bool IsNullPointer(const Expr &); +bool IsObjectPointer(const Expr &, FoldingContext &); // Extracts the chain of symbols from a designator, which has perhaps been // wrapped in an Expr<>, removing all of the (co)subscripts. The @@ -913,12 +917,13 @@ // These functions are used in Evaluate so they are defined here rather than in // Semantics to avoid a link-time dependency on Semantics. // All of these apply GetUltimate() or ResolveAssociations() to their arguments. - bool IsVariableName(const Symbol &); bool IsPureProcedure(const Symbol &); bool IsPureProcedure(const Scope &); bool IsFunction(const Symbol &); +bool IsFunction(const Scope &); bool IsProcedure(const Symbol &); +bool IsProcedure(const Scope &); bool IsProcedurePointer(const Symbol &); bool IsSaved(const Symbol &); // saved implicitly or explicitly bool IsDummy(const Symbol &); diff --git a/flang/include/flang/Evaluate/traverse.h b/flang/include/flang/Evaluate/traverse.h --- a/flang/include/flang/Evaluate/traverse.h +++ b/flang/include/flang/Evaluate/traverse.h @@ -50,7 +50,7 @@ Result operator()(const common::Indirection &x) const { return visitor_(x.value()); } - template Result operator()(SymbolRef x) const { + template Result operator()(const SymbolRef x) const { return visitor_(*x); } template Result operator()(const std::unique_ptr &x) const { diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -100,6 +100,9 @@ [&](const semantics::AssocEntityDetails &assoc) { return Characterize(assoc, context); }, + [&](const semantics::ProcBindingDetails &binding) { + return Characterize(binding.symbol(), context); + }, [](const auto &) { return std::optional{}; }, }, // GetUltimate() used here, not ResolveAssociations(), because @@ -178,6 +181,12 @@ if (auto elements{GetSize(Shape{shape_})}) { // Sizes of arrays (even with single elements) are multiples of // their alignments. + if (LEN_) { + CHECK(type_.category() == TypeCategory::Character); + return Fold(foldingContext, + std::move(*elements) * Expr{type_.kind()} * + Expr{*LEN_}); + } if (auto elementBytes{ type_.MeasureSizeInBytes(foldingContext, GetRank(shape_) > 0)}) { return Fold( diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -66,7 +66,7 @@ auto IsVariableHelper::operator()(const ProcedureDesignator &x) const -> Result { const Symbol *symbol{x.GetSymbol()}; - return symbol && symbol->attrs().test(semantics::Attr::POINTER); + return symbol && IsPointer(*symbol); } // Conversions of COMPLEX component expressions to REAL. @@ -696,6 +696,40 @@ expr.u); } +template inline const ProcedureRef *UnwrapProcedureRef(const A &) { + return nullptr; +} + +template +inline const ProcedureRef *UnwrapProcedureRef(const FunctionRef &func) { + return &func; +} + +template +inline const ProcedureRef *UnwrapProcedureRef(const Expr &expr) { + return std::visit( + [](const auto &x) { return UnwrapProcedureRef(x); }, expr.u); +} + +// IsObjectPointer() +bool IsObjectPointer(const Expr &expr, FoldingContext &context) { + if (IsNullPointer(expr)) { + return true; + } else if (IsProcedurePointer(expr)) { + return false; + } else if (const auto *procRef{UnwrapProcedureRef(expr)}) { + auto proc{ + characteristics::Procedure::Characterize(procRef->proc(), context)}; + return proc && proc->functionResult && + proc->functionResult->attrs.test( + characteristics::FunctionResult::Attr::Pointer); + } else if (const Symbol * symbol{GetLastSymbol(expr)}) { + return IsPointer(symbol->GetUltimate()); + } else { + return false; + } +} + // IsNullPointer() struct IsNullPointerHelper : public AllTraverse { using Base = AllTraverse; @@ -1026,6 +1060,11 @@ symbol.GetUltimate().details()); } +bool IsFunction(const Scope &scope) { + const Symbol *symbol{scope.GetSymbol()}; + return symbol && IsFunction(*symbol); +} + bool IsProcedure(const Symbol &symbol) { return std::visit(common::visitors{ [](const SubprogramDetails &) { return true; }, @@ -1038,8 +1077,14 @@ symbol.GetUltimate().details()); } -const Symbol *FindCommonBlockContaining(const Symbol &object) { - const auto *details{object.detailsIf()}; +bool IsProcedure(const Scope &scope) { + const Symbol *symbol{scope.GetSymbol()}; + return symbol && IsProcedure(*symbol); +} + +const Symbol *FindCommonBlockContaining(const Symbol &original) { + const Symbol &root{GetAssociationRoot(original)}; + const auto *details{root.detailsIf()}; return details ? details->commonBlock() : nullptr; } diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -330,15 +330,22 @@ const Symbol &object, const Scope &scope) { // TODO: Storage association with any object for which this predicate holds, // once EQUIVALENCE is supported. - if (IsUseAssociated(object, scope) || IsHostAssociated(object, scope) || - (IsPureProcedure(scope) && IsPointerDummy(object)) || - (IsIntentIn(object) && IsDummy(object))) { + const Symbol &ultimate{GetAssociationRoot(object)}; + if (IsDummy(ultimate)) { + if (IsIntentIn(ultimate)) { + return &ultimate; + } + if (IsPointer(ultimate) && IsPureProcedure(ultimate.owner()) && + IsFunction(ultimate.owner())) { + return &ultimate; + } + } else if (&GetProgramUnitContaining(ultimate) != + &GetProgramUnitContaining(scope)) { return &object; - } else if (const Symbol * block{FindCommonBlockContaining(object)}) { + } else if (const Symbol * block{FindCommonBlockContaining(ultimate)}) { return block; - } else { - return nullptr; } + return nullptr; } bool ExprHasTypeCategory( diff --git a/flang/test/Semantics/structconst03.f90 b/flang/test/Semantics/structconst03.f90 --- a/flang/test/Semantics/structconst03.f90 +++ b/flang/test/Semantics/structconst03.f90 @@ -71,7 +71,6 @@ !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure x1 = t1(0)(dummy1) x1 = t1(0)(dummy2) - !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure x1 = t1(0)(dummy3) ! TODO when semantics handles coindexing: ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure @@ -106,9 +105,7 @@ !ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(0)(dummy1a) x1a = t1(0)(dummy2a) - !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(0)(dummy3) - !ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(0)(dummy3a) ! TODO when semantics handles coindexing: ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure @@ -123,6 +120,22 @@ end subroutine subr end subroutine + pure integer function pf1(dummy3) + real, pointer :: dummy3 + type(t1(0)) :: x1 + pf1 = 0 + !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure + x1 = t1(0)(dummy3) + contains + pure subroutine subr(dummy3a) + real, pointer :: dummy3a + type(t1(0)) :: x1a + !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure + x1a = t1(0)(dummy3) + x1a = t1(0)(dummy3a) + end subroutine + end function + impure real function ipf1(dummy1, dummy2, dummy3, dummy4) real, target :: local1 type(t1(0)) :: x1 diff --git a/flang/test/Semantics/structconst04.f90 b/flang/test/Semantics/structconst04.f90 --- a/flang/test/Semantics/structconst04.f90 +++ b/flang/test/Semantics/structconst04.f90 @@ -66,7 +66,6 @@ !ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure x1 = t1(dummy1) x1 = t1(dummy2) - !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure x1 = t1(dummy3) ! TODO when semantics handles coindexing: ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure @@ -101,9 +100,7 @@ !ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(dummy1a) x1a = t1(dummy2a) - !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(dummy3) - !ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(dummy3a) ! TODO when semantics handles coindexing: ! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure @@ -118,6 +115,21 @@ end subroutine subr end subroutine + pure integer function pf1(dummy3) + real, pointer :: dummy3 + type(t1) :: x1 + !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure + x1 = t1(dummy3) + contains + pure subroutine subr(dummy3a) + real, pointer :: dummy3a + type(t1) :: x1a + !ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure + x1a = t1(dummy3) + x1a = t1(dummy3a) + end subroutine + end function + impure real function ipf1(dummy1, dummy2, dummy3, dummy4) real, target :: local1 type(t1) :: x1