template<typename A> bool IsConstantExpr(const A &);
extern template bool IsConstantExpr(const Expr<SomeType> &);
extern template bool IsConstantExpr(const Expr<SomeInteger> &);
+extern template bool IsConstantExpr(const Expr<SubscriptInteger> &);
// Checks whether an expression is an object designator with
// constant addressing and no vector-valued subscript.
const A &, parser::ContextualMessages &, const semantics::Scope &);
extern template void CheckSpecificationExpr(const Expr<SomeType> &x,
parser::ContextualMessages &, const semantics::Scope &);
+extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x,
+ parser::ContextualMessages &, const semantics::Scope &);
+extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x,
+ parser::ContextualMessages &, const semantics::Scope &);
+extern template void CheckSpecificationExpr(
+ const std::optional<Expr<SomeType>> &x, parser::ContextualMessages &,
+ const semantics::Scope &);
extern template void CheckSpecificationExpr(
const std::optional<Expr<SomeInteger>> &x, parser::ContextualMessages &,
const semantics::Scope &);
parser::CharBlock, const ProcedureDesignator &, ActualArguments &);
using AdjustActuals =
std::optional<std::function<bool(const Symbol &, ActualArguments &)>>;
+ bool ResolveForward(const Symbol &);
const Symbol *ResolveGeneric(const Symbol &, const ActualArguments &,
const AdjustActuals &, bool mightBeStructureConstructor = false);
void EmitGenericResolutionError(const Symbol &);
class Scope;
class Symbol;
+class ProgramTree;
using SymbolRef = common::Reference<const Symbol>;
using SymbolVector = std::vector<SymbolRef>;
// type information.
class SubprogramNameDetails {
public:
- SubprogramNameDetails(SubprogramKind kind) : kind_{kind} {}
+ SubprogramNameDetails(SubprogramKind kind, ProgramTree &node)
+ : kind_{kind}, node_{node} {}
SubprogramNameDetails() = delete;
SubprogramKind kind() const { return kind_; }
+ ProgramTree &node() const { return *node_; }
private:
SubprogramKind kind_;
+ common::Reference<ProgramTree> node_;
};
// A name from an entity-decl -- could be object or function.
}
template bool IsConstantExpr(const Expr<SomeType> &);
template bool IsConstantExpr(const Expr<SomeInteger> &);
+template bool IsConstantExpr(const Expr<SubscriptInteger> &);
// Object pointer initialization checking predicate IsInitialDataTarget().
// This code determines whether an expression is allowable as the static
template void CheckSpecificationExpr(const Expr<SomeType> &,
parser::ContextualMessages &, const semantics::Scope &);
+template void CheckSpecificationExpr(const Expr<SomeInteger> &,
+ parser::ContextualMessages &, const semantics::Scope &);
+template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
+ parser::ContextualMessages &, const semantics::Scope &);
+template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
+ parser::ContextualMessages &, const semantics::Scope &);
template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
parser::ContextualMessages &, const semantics::Scope &);
template void CheckSpecificationExpr(
// optionality and defaults. The kind and rank patterns are represented
// here with code values that are significant to the matching/validation engine.
+// An actual argument to an intrinsic procedure may be a procedure itself
+// only if the dummy argument is Rank::reduceOperation,
+// KindCode::addressable, or the special case of NULL(MOLD=procedurePointer).
+
// These are small bit-sets of type category enumerators.
// Note that typeless (BOZ literal) values don't have a distinct type category.
// These typeless arguments are represented in the tables as if they were
std::optional<DynamicType> type{arg->GetType()};
if (!type) {
CHECK(arg->Rank() == 0);
- const Expr<SomeType> *expr{arg->UnwrapExpr()};
- CHECK(expr);
- if (std::holds_alternative<BOZLiteralConstant>(expr->u)) {
+ const Expr<SomeType> &expr{DEREF(arg->UnwrapExpr())};
+ if (std::holds_alternative<BOZLiteralConstant>(expr.u)) {
if (d.typePattern.kindCode == KindCode::typeless ||
d.rank == Rank::elementalOrBOZ) {
continue;
d.keyword);
}
} else {
- // NULL(), pointer to subroutine, &c.
- if (d.typePattern.kindCode == KindCode::addressable) {
+ // NULL(), procedure, or procedure pointer
+ CHECK(IsProcedurePointer(expr));
+ if (d.typePattern.kindCode == KindCode::addressable ||
+ d.rank == Rank::reduceOperation) {
continue;
} else {
- messages.Say("Typeless item not allowed for '%s=' argument"_err_en_US,
+ messages.Say(
+ "Actual argument for '%s=' may not be a procedure"_err_en_US,
d.keyword);
}
}
argOk = rank == 0 || rank + 1 == arrayArg->Rank();
break;
case Rank::reduceOperation:
- // TODO: Confirm that the argument is a pure function
- // of two arguments with several constraints
+ // TODO: validate the reduction operation -- it must be a pure
+ // function of two arguments with special constraints.
CHECK(arrayArg);
argOk = rank == 0;
break;
void Check(const Scope &);
private:
+ template<typename A> void CheckSpecExpr(const A &x) {
+ if (symbolBeingChecked_ && IsSaved(*symbolBeingChecked_)) {
+ if (!evaluate::IsConstantExpr(x)) {
+ messages_.Say(
+ "Specification expression must be constant in declaration of '%s' with the SAVE attribute"_err_en_US,
+ symbolBeingChecked_->name());
+ }
+ } else {
+ evaluate::CheckSpecificationExpr(x, messages_, DEREF(scope_));
+ }
+ }
+ template<typename A> void CheckSpecExpr(const std::optional<A> &x) {
+ if (x) {
+ CheckSpecExpr(*x);
+ }
+ }
template<typename A> void CheckSpecExpr(A &x) {
x = Fold(foldingContext_, std::move(x));
- evaluate::CheckSpecificationExpr(x, messages_, DEREF(scope_));
- }
- template<typename A> void CheckSpecExpr(const A &x) {
- evaluate::CheckSpecificationExpr(x, messages_, DEREF(scope_));
+ const A &constx{x};
+ CheckSpecExpr(constx);
}
void CheckValue(const Symbol &, const DerivedTypeSpec *);
void CheckVolatile(
// This symbol is the one attached to the innermost enclosing scope
// that has a symbol.
const Symbol *innermostSymbol_{nullptr};
+ const Symbol *symbolBeingChecked_{nullptr};
};
void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
void CheckHelper::CheckObjectEntity(
const Symbol &symbol, const ObjectEntityDetails &details) {
+ CHECK(!symbolBeingChecked_);
+ symbolBeingChecked_ = &symbol; // for specification expr checks
CheckArraySpec(symbol, details.shape());
Check(details.shape());
Check(details.coshape());
CheckAssumedTypeEntity(symbol, details);
+ symbolBeingChecked_ = nullptr;
if (!details.coshape().empty()) {
if (IsAllocatable(symbol)) {
if (!details.coshape().IsDeferredShape()) { // C827
#include "flang/Semantics/expression.h"
#include "check-call.h"
#include "pointer-assignment.h"
+#include "resolve-names.h"
#include "flang/Common/idioms.h"
#include "flang/Evaluate/common.h"
#include "flang/Evaluate/fold.h"
return true;
}
+// Handles a forward reference to a module function from what must
+// be a specification expression. Return false if the symbol is
+// an invalid forward reference.
+bool ExpressionAnalyzer::ResolveForward(const Symbol &symbol) {
+ if (context_.HasError(symbol)) {
+ return false;
+ }
+ if (const auto *details{
+ symbol.detailsIf<semantics::SubprogramNameDetails>()}) {
+ if (details->kind() == semantics::SubprogramKind::Module) {
+ // If this symbol is still a SubprogramNameDetails, we must be
+ // checking a specification expression in a sibling module
+ // procedure. Resolve its names now so that its interface
+ // is known.
+ semantics::ResolveSpecificationParts(context_, symbol);
+ if (symbol.has<semantics::SubprogramNameDetails>()) {
+ // When the symbol hasn't had its details updated, we must have
+ // already been in the process of resolving the function's
+ // specification part; but recursive function calls are not
+ // allowed in specification parts (10.1.11 para 5).
+ Say("The module function '%s' may not be referenced recursively in a specification expression"_err_en_US,
+ symbol.name());
+ context_.SetError(const_cast<Symbol &>(symbol));
+ return false;
+ }
+ } else { // 10.1.11 para 4
+ Say("The internal function '%s' may not be referenced in a specification expression"_err_en_US,
+ symbol.name());
+ context_.SetError(const_cast<Symbol &>(symbol));
+ return false;
+ }
+ }
+ return true;
+}
+
// Resolve a call to a generic procedure with given actual arguments.
// adjustActuals is called on procedure bindings to handle pass arg.
const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
const Symbol *elemental{nullptr}; // matching elemental specific proc
const auto &details{symbol.GetUltimate().get<semantics::GenericDetails>()};
for (const Symbol &specific : details.specificProcs()) {
+ if (!ResolveForward(specific)) {
+ continue;
+ }
if (std::optional<characteristics::Procedure> procedure{
characteristics::Procedure::Characterize(
ProcedureDesignator{specific}, context_.intrinsics())}) {
return Expr<SomeType>{NullPointer{}};
}
}
+ if (const Symbol * symbol{proc.GetSymbol()}) {
+ if (!ResolveForward(*symbol)) {
+ return std::nullopt;
+ }
+ }
if (auto chars{CheckCall(callSite, proc, arguments)}) {
if (chars->functionResult) {
const auto &result{*chars->functionResult};
}
}
}
- if (const Symbol * symbol{proc.GetSymbol()}) {
- if (const auto *details{
- symbol->detailsIf<semantics::SubprogramNameDetails>()}) {
- // If this symbol is still a SubprogramNameDetails, we must be
- // checking a specification expression in a sibling module or internal
- // procedure. Since recursion is disallowed in specification
- // expressions, we should handle such references by processing the
- // sibling procedure's specification part right now (recursively),
- // but until we can do so, just complain about the forward reference.
- // TODO: recursively process sibling's specification part.
- if (details->kind() == semantics::SubprogramKind::Module) {
- Say("The module function '%s' must have been previously defined "
- "when referenced in a specification expression"_err_en_US,
- symbol->name());
- } else {
- Say("The internal function '%s' cannot be referenced in "
- "a specification expression"_err_en_US,
- symbol->name());
- }
- return std::nullopt;
- }
- }
return std::nullopt;
}
#include "flang/Parser/parse-tree.h"
#include "flang/Semantics/symbol.h"
+#include <list>
#include <variant>
// A ProgramTree represents a tree of program units and their contained
const parser::Name &name() const { return name_; }
Kind GetKind() const;
const Stmt &stmt() const { return stmt_; }
+ bool isSpecificationPartResolved() const {
+ return isSpecificationPartResolved_;
+ }
+ void set_isSpecificationPartResolved(bool yes = true) {
+ isSpecificationPartResolved_ = yes;
+ }
const parser::ParentIdentifier &GetParentId() const; // only for Submodule
const parser::SpecificationPart &spec() const { return spec_; }
const parser::ExecutionPart *exec() const { return exec_; }
- std::
vector<ProgramTree> &children() { return children_; }
- const std::
vector<ProgramTree> &children() const { return children_; }
+ std::
list<ProgramTree> &children() { return children_; }
+ const std::
list<ProgramTree> &children() const { return children_; }
Symbol::Flag GetSubpFlag() const;
bool IsModule() const; // Module or Submodule
bool HasModulePrefix() const; // in function or subroutine stmt
static_cast<const parser::Statement<parser::ProgramStmt> *>(nullptr)};
const parser::SpecificationPart &spec_;
const parser::ExecutionPart *exec_{nullptr};
- std::
vector<ProgramTree> children_;
+ std::
list<ProgramTree> children_;
Scope *scope_{nullptr};
const parser::CharBlock *endStmt_{nullptr};
+ bool isSpecificationPartResolved_{false};
};
}
friend void ShowImplicitRule(std::ostream &, const ImplicitRules &, char);
};
+// scope -> implicit rules for that scope
+using ImplicitRulesMap = std::map<const Scope *, ImplicitRules>;
+
// Track statement source locations and save messages.
class MessageHandler {
public:
class BaseVisitor {
public:
BaseVisitor() { DIE("BaseVisitor: default-constructed"); }
- BaseVisitor(SemanticsContext &c, ResolveNamesVisitor &v)
- : this_{&v}, context_{&c}, messageHandler_{c} {}
+ BaseVisitor(
+ SemanticsContext &c, ResolveNamesVisitor &v, ImplicitRulesMap &rules)
+ : implicitRulesMap_{&rules}, this_{&v}, context_{&c}, messageHandler_{c} {}
template<typename T> void Walk(const T &);
MessageHandler &messageHandler() { return messageHandler_; }
return messageHandler_.Say(name.source, std::move(text), args...);
}
+protected:
+ ImplicitRulesMap *implicitRulesMap_{nullptr};
+
private:
ResolveNamesVisitor *this_;
SemanticsContext *context_;
void SetScope(const Scope &);
private:
- // scope -> implicit rules for that scope
- std::map<const Scope *, ImplicitRules> implicitRulesMap_;
// implicit rules in effect for current scope
ImplicitRules *implicitRules_{nullptr};
std::optional<SourceName> prevImplicit_;
using SubprogramVisitor::Post;
using SubprogramVisitor::Pre;
- ResolveNamesVisitor(SemanticsContext &context) : BaseVisitor{context, *this} {
+ ResolveNamesVisitor(SemanticsContext &context, ImplicitRulesMap &rules)
+ : BaseVisitor{context, *this, rules} {
PushScope(context.globalScope());
}
void NoteExecutablePartCall(Symbol::Flag, const parser::Call &);
+ friend void ResolveSpecificationParts(SemanticsContext &, const Symbol &);
+
private:
// Kind of procedure we are expecting to see in a ProcedureDesignator
std::optional<Symbol::Flag> expectedProcFlag_;
void HandleProcedureName(Symbol::Flag, const parser::Name &);
bool SetProcFlag(const parser::Name &, Symbol &, Symbol::Flag);
void ResolveSpecificationParts(ProgramTree &);
- void AddSubpNames(const ProgramTree &);
- bool BeginScope(const ProgramTree &);
+ void AddSubpNames(ProgramTree &);
+ bool BeginScopeForNode(const ProgramTree &);
void FinishSpecificationParts(const ProgramTree &);
void FinishDerivedTypeInstantiation(Scope &);
void ResolveExecutionParts(const ProgramTree &);
}
void ImplicitRulesVisitor::SetScope(const Scope &scope) {
- implicitRules_ = &implicitRulesMap_.at(&scope);
+ implicitRules_ = &DEREF(implicitRulesMap_).at(&scope);
prevImplicit_ = std::nullopt;
prevImplicitNone_ = std::nullopt;
prevImplicitNoneType_ = std::nullopt;
}
void ImplicitRulesVisitor::BeginScope(const Scope &scope) {
// find or create implicit rules for this scope
- implicitRulesMap_.try_emplace(&scope, context(), implicitRules_);
+ DEREF(implicitRulesMap_).try_emplace(&scope, context(), implicitRules_);
SetScope(scope);
}
currScope_ = &scope;
auto kind{currScope_->kind()};
if (kind != Scope::Kind::Block) {
- ImplicitRulesVisitor::BeginScope(scope);
+ BeginScope(scope);
}
// The name of a module or submodule cannot be "used" in its scope,
// as we read 19.3.1(2), so we allow the name to be used as a local
// Build the scope tree and resolve names in the specification parts of this
// node and its children
void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) {
- if (!BeginScope(node)) {
+ if (node.isSpecificationPartResolved()) {
+ return; // been here already
+ }
+ node.set_isSpecificationPartResolved();
+ if (!BeginScopeForNode(node)) {
return; // an error prevented scope from being created
}
Scope &scope{currScope()};
}
}
-// Add SubprogramNameDetails symbols for contained subprograms
-void ResolveNamesVisitor::AddSubpNames(const ProgramTree &node) {
+// Add SubprogramNameDetails symbols for module and internal subprograms
+void ResolveNamesVisitor::AddSubpNames(ProgramTree &node) {
auto kind{
node.IsModule() ? SubprogramKind::Module : SubprogramKind::Internal};
- for (const auto &child : node.children()) {
- auto &symbol{MakeSymbol(child.name(), SubprogramNameDetails{kind})};
+ for (auto &child : node.children()) {
+ auto &symbol{MakeSymbol(child.name(), SubprogramNameDetails{kind, child})};
symbol.set(child.GetSubpFlag());
}
}
// Push a new scope for this node or return false on error.
-bool ResolveNamesVisitor::BeginScope(const ProgramTree &node) {
+bool ResolveNamesVisitor::BeginScopeForNode(const ProgramTree &node) {
switch (node.GetKind()) {
SWITCH_COVERS_ALL_CASES
case ProgramTree::Kind::Program:
CHECK(!GetDeclTypeSpec());
}
+// A singleton instance of the scope -> IMPLICIT rules mapping is
+// shared by all instances of ResolveNamesVisitor and accessed by this
+// pointer when the visitors (other than the top-level original) are
+// constructed.
+static ImplicitRulesMap *sharedImplicitRulesMap{nullptr};
+
bool ResolveNames(SemanticsContext &context, const parser::Program &program) {
- ResolveNamesVisitor{context}.Walk(program);
+ ImplicitRulesMap implicitRulesMap;
+ auto restorer{common::ScopedSet(sharedImplicitRulesMap, &implicitRulesMap)};
+ ResolveNamesVisitor{context, implicitRulesMap}.Walk(program);
return !context.AnyFatalError();
}
+
+// Processes a module (but not internal) function when it is referenced
+// in a specification expression in a sibling procedure.
+void ResolveSpecificationParts(
+ SemanticsContext &context, const Symbol &subprogram) {
+ auto originalLocation{context.location()};
+ ResolveNamesVisitor visitor{context, DEREF(sharedImplicitRulesMap)};
+ ProgramTree &node{subprogram.get<SubprogramNameDetails>().node()};
+ const Scope &moduleScope{subprogram.owner()};
+ visitor.SetScope(const_cast<Scope &>(moduleScope));
+ visitor.ResolveSpecificationParts(node);
+ context.set_location(std::move(originalLocation));
+}
}
namespace Fortran::semantics {
class SemanticsContext;
+class Symbol;
bool ResolveNames(SemanticsContext &, const parser::Program &);
+void ResolveSpecificationParts(SemanticsContext &, const Symbol &);
void DumpSymbols(std::ostream &);
}
bool IsSaved(const Symbol &symbol) {
auto scopeKind{symbol.owner().kind()};
- if (scopeKind == Scope::Kind::MainProgram ||
- scopeKind == Scope::Kind::Module) {
+ if (scopeKind == Scope::Kind::Module || scopeKind == Scope::Kind::BlockData) {
return true;
} else if (scopeKind == Scope::Kind::DerivedType) {
return false; // this is a component
integer :: local
!ERROR: Invalid specification expression: reference to local entity 'local'
type(t(local)) :: x2
- !ERROR: The internal function 'internal' cannot be referenced in a specification expression
+ !ERROR: The internal function 'internal' may not be referenced in a specification expression
type(t(internal(0))) :: x3
integer, intent(out) :: out
!ERROR: Invalid specification expression: reference to INTENT(OUT) dummy argument 'out'
type(t(coarray[1])) :: x7
type(t(kind(foo()))) :: x101 ! ok
type(t(modulefunc1(0))) :: x102 ! ok
- !ERROR: The module function 'modulefunc2' must have been previously defined when referenced in a specification expression
type(t(modulefunc2(0))) :: x103 ! ok
contains
pure integer function internal(n)
f4 => rf
! OK call to f4 pointer (rf)
x = acos(f4())
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
x = acos(f4)
end function
function f5(x)
f5 => rfunc
! OK call to f5 pointer
x = acos(f5(x+1))
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
x = acos(f5)
end function
! Sanity test: f18 handles C1560 violation by ignoring RESULT
function f1() result(r)
real :: r
r = acos(f1()) !OK, recursive call
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
x = acos(f1)
end function
function f2(i) result(r)
integer i
real :: r
r = acos(f2(i+1)) ! OK, recursive call
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
r = acos(f2)
end function
function f3(i) result(r)
integer i
real :: r(1)
r = acos(f3(i+1)) !OK recursive call
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
r = sum(acos(f3))
end function
real :: x
procedure(rf), pointer :: r
r => rf
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
x = acos(f4()) ! recursive call
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
x = acos(f4)
x = acos(r()) ! OK
end function
real :: x
procedure(acos), pointer :: r
r => acos
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
x = acos(f5(x+1)) ! recursive call
- !ERROR: Typeless item not allowed for 'x=' argument
+ !ERROR: Actual argument for 'x=' may not be a procedure
x = acos(f5)
x = acos(r(x+1)) ! OK
end function
--- /dev/null
+! RUN: %S/test_errors.sh %s %flang %t
+! Tests valid and invalid usage of forward references to procedures
+! in specification expressions.
+module m
+ interface ifn2
+ module procedure if2
+ end interface
+ interface ifn3
+ module procedure if3
+ end interface
+ !ERROR: Specification expression must be constant in declaration of 'a' with the SAVE attribute
+ real :: a(if1(1))
+ !ERROR: No specific procedure of generic 'ifn2' matches the actual arguments
+ real :: b(ifn2(1))
+ contains
+ subroutine t1(n)
+ integer :: iarr(if1(n))
+ end subroutine
+ pure integer function if1(n)
+ integer, intent(in) :: n
+ if1 = n
+ end function
+ subroutine t2(n)
+ integer :: iarr(ifn3(n)) ! should resolve to if3
+ end subroutine
+ pure integer function if2(n)
+ integer, intent(in) :: n
+ if2 = n
+ end function
+ pure integer function if3(n)
+ integer, intent(in) :: n
+ if3 = n
+ end function
+end module
+
+subroutine nester
+ !ERROR: The internal function 'if1' may not be referenced in a specification expression
+ real :: a(if1(1))
+ contains
+ subroutine t1(n)
+ !ERROR: The internal function 'if2' may not be referenced in a specification expression
+ integer :: iarr(if2(n))
+ end subroutine
+ pure integer function if1(n)
+ integer, intent(in) :: n
+ if1 = n
+ end function
+ pure integer function if2(n)
+ integer, intent(in) :: n
+ if2 = n
+ end function
+end subroutine
projects / platform / upstream / llvm.git / commitdiff