template SetOfSymbols CollectSymbols(const Expr<SomeInteger> &);
template SetOfSymbols CollectSymbols(const Expr<SubscriptInteger> &);
+// HasVectorSubscript()
+struct HasVectorSubscriptHelper : public AnyTraverse<HasVectorSubscriptHelper> {
+ using Base = AnyTraverse<HasVectorSubscriptHelper>;
+ HasVectorSubscriptHelper() : Base{*this} {}
+ using Base::operator();
+ bool operator()(const Subscript &ss) const {
+ return !std::holds_alternative<Triplet>(ss.u) && ss.Rank() > 0;
+ }
+ bool operator()(const ProcedureRef &) const {
+ return false; // don't descend into function call arguments
+ }
+};
+
+bool HasVectorSubscript(const Expr<SomeType> &expr) {
+ return HasVectorSubscriptHelper{}(expr);
+}
}
return nullptr;
}
+template<typename A> const Symbol *GetFirstSymbol(const A &x) {
+ if (auto dataRef{ExtractDataRef(x)}) {
+ return &dataRef->GetFirstSymbol();
+ } else {
+ return nullptr;
+ }
+}
+
// Creation of conversion expressions can be done to either a known
// specific intrinsic type with ConvertToType<T>(x) or by converting
// one arbitrary expression to the type of another with ConvertTo(to, from).
extern template SetOfSymbols CollectSymbols(const Expr<SomeType> &);
extern template SetOfSymbols CollectSymbols(const Expr<SomeInteger> &);
extern template SetOfSymbols CollectSymbols(const Expr<SubscriptInteger> &);
+
+// Predicate: does a variable contain a vector-valued subscript (not a triplet)?
+bool HasVectorSubscript(const Expr<SomeType> &);
}
#endif // FORTRAN_EVALUATE_TOOLS_H_
return *this;
}
+Message &Message::Attach(std::unique_ptr<Message> &&m) {
+ return Attach(m.release());
+}
+
bool Message::AtSameLocation(const Message &that) const {
return std::visit(
common::visitors{
std::string MoveString() { return std::move(string_); }
private:
- void Format(const MessageFixedText *text, ...);
+ void Format(const MessageFixedText *, ...);
template<typename A> A Convert(const A &x) {
static_assert(!std::is_class_v<std::decay_t<A>>);
attachmentIsContext_ = true;
}
Message &Attach(Message *);
+ Message &Attach(std::unique_ptr<Message> &&);
template<typename... A> Message &Attach(A &&... args) {
return Attach(new Message{std::forward<A>(args)...}); // reference-counted
}
static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
const evaluate::Expr<evaluate::SomeType> &actual,
const characteristics::TypeAndShape &actualType,
- parser::ContextualMessages &messages) {
+ parser::ContextualMessages &messages, const Scope &scope) {
dummy.type.IsCompatibleWith(messages, actualType);
bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
"Element of assumed-shape array may not be associated with a dummy argument array"_err_en_US);
}
}
+ const char *reason{nullptr};
+ if (dummy.intent == common::Intent::Out) {
+ reason = "INTENT(OUT)";
+ } else if (dummy.intent == common::Intent::InOut) {
+ reason = "INTENT(IN OUT)";
+ } else if (dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::Asynchronous)) {
+ reason = "ASYNCHRONOUS";
+ } else if (dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::Volatile)) {
+ reason = "VOLATILE";
+ }
+ if (reason != nullptr) {
+ std::unique_ptr<parser::Message> why{
+ WhyNotModifiable(messages.at(), actual, scope)};
+ if (why.get() != nullptr) {
+ if (auto *msg{messages.Say(
+ "Actual argument associated with %s dummy must be definable"_err_en_US,
+ reason)}) {
+ msg->Attach(std::move(why));
+ }
+ }
+ }
// TODO pmk more here
}
static void CheckExplicitInterfaceArg(const evaluate::ActualArgument &arg,
const characteristics::DummyArgument &dummy,
- evaluate::FoldingContext &context) {
+ evaluate::FoldingContext &context, const Scope &scope) {
auto &messages{context.messages()};
std::visit(
common::visitors{
if (const auto *expr{arg.UnwrapExpr()}) {
if (auto type{characteristics::TypeAndShape::Characterize(
*expr, context)}) {
- CheckExplicitDataArg(object, *expr, *type, context.messages());
+ CheckExplicitDataArg(
+ object, *expr, *type, context.messages(), scope);
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
std::holds_alternative<evaluate::BOZLiteralConstant>(
expr->u)) {
}
bool CheckExplicitInterface(const characteristics::Procedure &proc,
- ActualArguments &actuals, FoldingContext &context) {
+ ActualArguments &actuals, FoldingContext &context, const Scope &scope) {
if (!RearrangeArguments(proc, actuals, context.messages())) {
return false;
}
for (auto &actual : actuals) {
const auto &dummy{proc.dummyArguments[index++]};
if (actual.has_value()) {
- if (!CheckExplicitInterfaceArg(*actual, dummy, context)) {
+ if (!CheckExplicitInterfaceArg(*actual, dummy, context, scope)) {
return false;
}
} else if (!dummy.IsOptional()) {
if (dummy.name.empty()) {
context.messages().Say(
"Dummy argument #%d is not OPTIONAL and is not associated with an "
- "effective argument in this procedure reference"_err_en_US,
+ "actual argument in this procedure reference"_err_en_US,
index);
} else {
context.messages().Say(
"Dummy argument '%s' (#%d) is not OPTIONAL and is not associated "
- "with an effective argument in this procedure reference"_err_en_US,
+ "with an actual argument in this procedure reference"_err_en_US,
dummy.name, index);
}
return false;
void CheckArguments(const characteristics::Procedure &proc,
evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
- bool treatingExternalAsImplicit) {
- parser::Messages buffer;
- parser::ContextualMessages messages{context.messages().at(), &buffer};
- if (proc.HasExplicitInterface() && !treatingExternalAsImplicit) {
- evaluate::FoldingContext localContext{context, messages};
- CheckExplicitInterface(proc, actuals, localContext);
- } else {
+ const Scope &scope, bool treatingExternalAsImplicit) {
+ bool explicitInterface{proc.HasExplicitInterface()};
+ if (explicitInterface()) {
+ CheckExplicitInterface(proc, actuals, context, scope);
+ }
+ if (!explicitInterface || treatingExternalAsImplicit) {
+ parser::Messages buffer;
+ parser::ContextualMessages messages{context.messages().at(), &buffer};
for (auto &actual : actuals) {
if (actual.has_value()) {
CheckImplicitInterfaceArg(*actual, messages);
}
}
- }
- if (!buffer.empty()) {
- if (treatingExternalAsImplicit) {
- if (auto *msg{context.messages().Say(
- "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
- buffer.AttachTo(*msg);
+ if (!buffer.empty()) {
+ if (treatingExternalAsImplicit) {
+ if (auto *msg{context.messages().Say(
+ "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
+ buffer.AttachTo(*msg);
+ }
+ } else if (auto *msgs{context.messages().messages()}) {
+ msgs->Merge(std::move(buffer));
}
- } else if (auto *msgs{context.messages().messages()}) {
- msgs->Merge(std::move(buffer));
}
}
}
}
namespace Fortran::semantics {
+class Scope;
+
// The Boolean flag argument should be true when the called procedure
// does not actually have an explicit interface at the call site, but
// its characteristics are known because it is a subroutine or function
// defined at the top level in the same source file.
void CheckArguments(const evaluate::characteristics::Procedure &,
- evaluate::ActualArguments &, evaluate::FoldingContext &,
+ evaluate::ActualArguments &, evaluate::FoldingContext &, const Scope &,
bool treatingExternalAsImplicit = false);
// Check actual arguments against a procedure with an explicit interface.
"References to the procedure '%s' require an explicit interface"_en_US,
DEREF(proc.GetSymbol()).name());
}
- semantics::CheckArguments(
- *chars, arguments, GetFoldingContext(), treatExternalAsImplicit);
+ semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
+ context_.FindScope(callSite), treatExternalAsImplicit);
}
return chars;
}
return nullptr;
}
+// When an construct association maps to a variable, and that variable
+// is not an array with a vector-valued subscript, return the base
+// Symbol of that variable, else nullptr. Descends into other construct
+// associations when one associations maps to another.
static const Symbol *GetAssociatedVariable(const AssocEntityDetails &details) {
if (const MaybeExpr & expr{details.expr()}) {
- if (evaluate::IsVariable(*expr)) {
- if (const Symbol * varSymbol{evaluate::GetLastSymbol(*expr)}) {
+ if (evaluate::IsVariable(*expr) && !evaluate::HasVectorSubscript(*expr)) {
+ if (const Symbol * varSymbol{evaluate::GetFirstSymbol(*expr)}) {
return GetAssociationRoot(*varSymbol);
}
}
}
// C1101 and C1158
-// TODO Need to check for the case of a variable that has a vector subscript
-// that is construct associated, also need to check for a coindexed object
+// TODO Need to check for a coindexed object (why? C1103?)
std::optional<parser::MessageFixedText> WhyNotModifiable(
const Symbol &symbol, const Scope &scope) {
const Symbol *root{GetAssociationRoot(symbol)};
}
}
+std::unique_ptr<parser::Message> WhyNotModifiable(
+ parser::CharBlock at, const SomeExpr &expr, const Scope &scope) {
+ if (evaluate::IsVariable(expr)) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr)}) {
+ if (evaluate::HasVectorSubscript(expr)) {
+ return std::make_unique<parser::Message>(
+ at, "variable has a vector subscript"_en_US);
+ } else {
+ const Symbol &symbol{dataRef->GetFirstSymbol()};
+ if (auto maybeWhy{WhyNotModifiable(symbol, scope)}) {
+ return std::make_unique<parser::Message>(symbol.name(),
+ parser::MessageFormattedText{
+ std::move(*maybeWhy), symbol.name()});
+ }
+ }
+ } else {
+ // reference to function returning POINTER
+ }
+ } else {
+ return std::make_unique<parser::Message>(
+ at, "expression is not a variable"_en_US);
+ }
+ return {};
+}
+
static const DeclTypeSpec &InstantiateIntrinsicType(Scope &scope,
const DeclTypeSpec &spec, SemanticsContext &semanticsContext) {
const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};
bool IsAssumedLengthCharacter(const Symbol &);
bool IsAssumedLengthCharacterFunction(const Symbol &);
std::optional<parser::MessageFixedText> WhyNotModifiable(
- const Symbol &symbol, const Scope &scope);
+ const Symbol &, const Scope &);
+std::unique_ptr<parser::Message> WhyNotModifiable(
+ SourceName, const SomeExpr &, const Scope &);
// Is the symbol modifiable in this scope
bool IsExternalInPureContext(const Symbol &symbol, const Scope &scope);
call intentout(3.14159)
!ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
call intentout(in + 1.)
- !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
call intentout(x) ! ok
!ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
call intentout((x))
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
call intentinout(in)
!ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
call intentinout(3.14159)
real :: a(1)
integer :: j(1)
j(1) = 1
- !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+ !ERROR: Actual argument associated with INTENT(OUT) dummy must be definable
call intentout(a(j))
- !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy must be definable
call intentinout(a(j))
- !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+ !ERROR: Actual argument associated with ASYNCHRONOUS dummy must be definable
call asynchronous(a(j))
- !ERROR: array section with vector subscript cannot be associated with a dummy argument that must be definable
+ !ERROR: Actual argument associated with VOLATILE dummy must be definable
call volatile(a(j))
end subroutine
projects / platform / upstream / llvm.git / commitdiff