@@ -1665,4 +1665,121 @@ std::optional<bool> ActualArgNeedsCopy(const ActualArgument *actual,
16651665 return std::nullopt ;
16661666}
16671667
1668+ // CollectUsedSymbolValues()
1669+
1670+ class CollectUsedSymbolValuesHelper
1671+ : public SetTraverse<CollectUsedSymbolValuesHelper,
1672+ semantics::UnorderedSymbolSet> {
1673+ public:
1674+ using Result = semantics::UnorderedSymbolSet;
1675+ using Base = SetTraverse<CollectUsedSymbolValuesHelper, Result>;
1676+ explicit CollectUsedSymbolValuesHelper (
1677+ semantics::SemanticsContext &c, bool isDefinition = false )
1678+ : Base{*this }, context_{c}, isDefinition_{isDefinition} {}
1679+ using Base::operator ();
1680+
1681+ Result operator ()(const semantics::Symbol &symbol) const {
1682+ Result result;
1683+ if (!isDefinition_) {
1684+ const Symbol &root{semantics::GetAssociationRoot (symbol)};
1685+ switch (root.owner ().kind ()) {
1686+ case semantics::Scope::Kind::Subprogram:
1687+ case semantics::Scope::Kind::MainProgram:
1688+ case semantics::Scope::Kind::BlockConstruct:
1689+ if ((root.has <semantics::ObjectEntityDetails>() ||
1690+ IsProcedurePointer (root))) {
1691+ result.insert (root);
1692+ if (root.test (semantics::Symbol::Flag::CrayPointee)) {
1693+ result.insert (semantics::GetCrayPointer (root));
1694+ }
1695+ }
1696+ break ;
1697+ default :
1698+ break ;
1699+ }
1700+ }
1701+ return result;
1702+ }
1703+
1704+ Result operator ()(const Subscript &subscript) {
1705+ auto restorer{common::ScopedSet (isDefinition_, false )};
1706+ return (*this )(subscript.u );
1707+ }
1708+
1709+ template <typename T> Result operator ()(const FunctionRef<T> &fRef ) {
1710+ return (*this )(static_cast <ProcedureRef>(fRef ));
1711+ }
1712+ Result operator ()(const ProcedureRef &call) {
1713+ auto restorer{common::ScopedSet (isDefinition_, false )};
1714+ Result result{(*this )(call.proc ())};
1715+ int skipLeading{0 };
1716+ if (const auto *intrinsic{call.proc ().GetSpecificIntrinsic ()}) {
1717+ if (context_.intrinsics ().GetIntrinsicClass (intrinsic->name ) ==
1718+ IntrinsicClass::inquiryFunction) {
1719+ skipLeading = 1 ; // first argument to inquiry doesn't count as a use
1720+ }
1721+ }
1722+ for (const auto &maybeArg : call.arguments ()) {
1723+ if (skipLeading) {
1724+ --skipLeading;
1725+ } else if (maybeArg) {
1726+ if (const auto *expr{maybeArg->UnwrapExpr ()}) {
1727+ if (IsBindingUsedAsProcedure (*expr)) {
1728+ // Ignore procedure bindings being used as actual procedures
1729+ // (a local extension).
1730+ } else {
1731+ result = Combine (std::move (result), (*this )(*expr));
1732+ }
1733+ }
1734+ }
1735+ }
1736+ return result;
1737+ }
1738+
1739+ Result operator ()(const Assignment &assignment) {
1740+ auto restorer{common::ScopedSet (isDefinition_, true )};
1741+ Result result{(*this )(assignment.lhs )};
1742+ if (IsBindingUsedAsProcedure (assignment.rhs )) {
1743+ // Don't look at the RHS, we're just using its binding (extension).
1744+ } else {
1745+ auto restorer{common::ScopedSet (isDefinition_, false )};
1746+ result = Combine (std::move (result), (*this )(assignment.rhs ));
1747+ }
1748+ return result;
1749+ }
1750+
1751+ Result operator ()(const TypeParamInquiry &) const {
1752+ return {}; // doesn't count as a use
1753+ }
1754+ Result operator ()(const DescriptorInquiry &) const {
1755+ return {}; // doesn't count as a use
1756+ }
1757+
1758+ private:
1759+ static bool IsBindingUsedAsProcedure (const Expr<SomeType> &expr) {
1760+ if (const auto *pd{std::get_if<ProcedureDesignator>(&expr.u )}) {
1761+ if (const Symbol *symbol{pd->GetSymbol ()}) {
1762+ return symbol->has <semantics::ProcBindingDetails>();
1763+ }
1764+ }
1765+ return false ;
1766+ }
1767+
1768+ semantics::SemanticsContext &context_;
1769+ bool isDefinition_{false };
1770+ };
1771+
1772+ semantics::UnorderedSymbolSet CollectUsedSymbolValues (
1773+ semantics::SemanticsContext &context, const Expr<SomeType> &expr,
1774+ bool isDefinition) {
1775+ return CollectUsedSymbolValuesHelper{context, isDefinition}(expr);
1776+ }
1777+ semantics::UnorderedSymbolSet CollectUsedSymbolValues (
1778+ semantics::SemanticsContext &context, const ProcedureRef &call) {
1779+ return CollectUsedSymbolValuesHelper{context}(call);
1780+ }
1781+ semantics::UnorderedSymbolSet CollectUsedSymbolValues (
1782+ semantics::SemanticsContext &context, const Assignment &assignment) {
1783+ return CollectUsedSymbolValuesHelper{context}(assignment);
1784+ }
16681785} // namespace Fortran::evaluate
0 commit comments