have been. But there may be names without symbols or expressions without
analyzed form if errors occurred earlier.
+### Initialization processing
+
+Fortran supports many means of specifying static initializers for variables,
+object pointers, and procedure pointers, as well as default initializers for
+derived type object components, pointers, and type parameters.
+
+Non-pointer static initializers of variables and named constants are
+scanned, analyzed, folded, scalar-expanded, and validated as they are
+traversed during declaration processing in name resolution.
+So are the default initializers of non-pointer object components in
+non-parameterized derived types.
+Name constant arrays with implied shapes take their actual shape from
+the initialization expression.
+
+Default initializers of non-pointer components and type parameters
+in distinct parameterized
+derived type instantiations are similarly processed as those instances
+are created, as their expressions may depend on the values of type
+parameters.
+Error messages produced during parameterized derived type instantiation
+are decorated with contextual attachments that point to the declarations
+or other type specifications that caused the instantiation.
+
+Static initializations in `DATA` statements are collected, validated,
+and converted into static initialization in the symbol table, as if
+the initialized objects had used the newer style of static initialization
+in their entity declarations.
+
+All statically initialized pointers, and default component initializers for
+pointers, are processed late in name resolution after all specification parts
+have been traversed.
+This allows for forward references even in the presence of `IMPLICIT NONE`.
+Object pointer initializers in parameterized derived type instantiations are
+also cloned and folded at this late stage.
+Validation of pointer initializers takes place later in declaration
+checking (below).
+
+### Declaration checking
+
+Whenever possible, the enforcement of constraints and "shalls" pertaining to
+properties of symbols is deferred to a single read-only pass over the symbol table
+that takes place after all name resolution and typing is complete.
+
### Write module files
Separate compilation information is written out on successful compilation
template <typename A> class ReferenceCounted {
public:
ReferenceCounted() {}
+ int references() const { return references_; }
void TakeReference() { ++references_; }
void DropReference() {
if (--references_ == 0) {
class raw_ostream;
}
-namespace Fortran::evaluate {
-class IntrinsicProcTable;
-}
namespace Fortran::evaluate::characteristics {
struct Procedure;
}
static std::optional<TypeAndShape> Characterize(
const semantics::Symbol &, FoldingContext &);
static std::optional<TypeAndShape> Characterize(
- const semantics::ObjectEntityDetails &);
+ const semantics::ObjectEntityDetails &, FoldingContext &);
static std::optional<TypeAndShape> Characterize(
const semantics::ProcInterface &);
static std::optional<TypeAndShape> Characterize(
const semantics::AssocEntityDetails &, FoldingContext &);
static std::optional<TypeAndShape> Characterize(
const semantics::ProcEntityDetails &);
- void AcquireShape(const semantics::ObjectEntityDetails &);
+ void AcquireShape(const semantics::ObjectEntityDetails &, FoldingContext &);
void AcquireLEN();
protected:
bool operator!=(const DummyDataObject &that) const {
return !(*this == that);
}
- static std::optional<DummyDataObject> Characterize(const semantics::Symbol &);
+ static std::optional<DummyDataObject> Characterize(
+ const semantics::Symbol &, FoldingContext &);
bool CanBePassedViaImplicitInterface() const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
TypeAndShape type;
bool operator==(const DummyProcedure &) const;
bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
static std::optional<DummyProcedure> Characterize(
- const semantics::Symbol &, const IntrinsicProcTable &);
+ const semantics::Symbol &, FoldingContext &context);
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
CopyableIndirection<Procedure> procedure;
common::Intent intent{common::Intent::Default};
bool operator==(const DummyArgument &) const;
bool operator!=(const DummyArgument &that) const { return !(*this == that); }
static std::optional<DummyArgument> Characterize(
- const semantics::Symbol &, const IntrinsicProcTable &);
+ const semantics::Symbol &, FoldingContext &);
static std::optional<DummyArgument> FromActual(
std::string &&, const Expr<SomeType> &, FoldingContext &);
bool IsOptional() const;
bool operator==(const FunctionResult &) const;
bool operator!=(const FunctionResult &that) const { return !(*this == that); }
static std::optional<FunctionResult> Characterize(
- const Symbol &, const IntrinsicProcTable &);
+ const Symbol &, FoldingContext &);
bool IsAssumedLengthCharacter() const;
// Characterizes the procedure represented by a symbol, which may be an
// "unrestricted specific intrinsic function".
static std::optional<Procedure> Characterize(
- const semantics::Symbol &, const IntrinsicProcTable &);
+ const semantics::Symbol &, FoldingContext &);
static std::optional<Procedure> Characterize(
- const ProcedureDesignator &, const IntrinsicProcTable &);
+ const ProcedureDesignator &, FoldingContext &);
static std::optional<Procedure> Characterize(
- const ProcedureRef &, const IntrinsicProcTable &);
+ const ProcedureRef &, FoldingContext &);
// At most one of these will return true.
// For "EXTERNAL P" with no type for or calls to P, both will be false.
}
namespace Fortran::evaluate {
-class IntrinsicProcTable;
// Predicate: true when an expression is a constant expression (in the
// strict sense of the Fortran standard); it may not (yet) be a hard
extern template bool IsConstantExpr(const Expr<SubscriptInteger> &);
extern template bool IsConstantExpr(const StructureConstructor &);
+// Predicate: true when an expression actually is a typed Constant<T>,
+// perhaps with parentheses and wrapping around it. False for all typeless
+// expressions, including BOZ literals.
+template <typename A> bool IsActuallyConstant(const A &);
+extern template bool IsActuallyConstant(const Expr<SomeType> &);
+
// Checks whether an expression is an object designator with
// constant addressing and no vector-valued subscript.
// If a non-null ContextualMessages pointer is passed, an error message
bool IsInitialProcedureTarget(const ProcedureDesignator &);
bool IsInitialProcedureTarget(const Expr<SomeType> &);
+// Validate the value of a named constant, the static initial
+// value of a non-pointer non-allocatable non-dummy variable, or the
+// default initializer of a component of a derived type (or instantiation
+// of a derived type). Converts type and expands scalars as necessary.
+std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &,
+ Expr<SomeType> &&, FoldingContext &,
+ const semantics::Scope *instantiation = nullptr);
+
// Check whether an expression is a specification expression
// (10.1.11(2), C1010). Constant expressions are always valid
// specification expressions.
template <typename A>
-void CheckSpecificationExpr(const A &, parser::ContextualMessages &,
- const semantics::Scope &, const IntrinsicProcTable &);
-extern template void CheckSpecificationExpr(const Expr<SomeType> &x,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
-extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
+void CheckSpecificationExpr(
+ const A &, const semantics::Scope &, FoldingContext &);
+extern template void CheckSpecificationExpr(
+ const Expr<SomeType> &x, const semantics::Scope &, FoldingContext &);
+extern template void CheckSpecificationExpr(
+ const Expr<SomeInteger> &x, const semantics::Scope &, FoldingContext &);
extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
+ const semantics::Scope &, FoldingContext &);
extern template void CheckSpecificationExpr(
- const std::optional<Expr<SomeType>> &x, parser::ContextualMessages &,
- const semantics::Scope &, const IntrinsicProcTable &);
+ const std::optional<Expr<SomeType>> &x, const semantics::Scope &,
+ FoldingContext &);
extern template void CheckSpecificationExpr(
- const std::optional<Expr<SomeInteger>> &x, parser::ContextualMessages &,
- const semantics::Scope &, const IntrinsicProcTable &);
+ const std::optional<Expr<SomeInteger>> &x, const semantics::Scope &,
+ FoldingContext &);
extern template void CheckSpecificationExpr(
- const std::optional<Expr<SubscriptInteger>> &x,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
+ const std::optional<Expr<SubscriptInteger>> &x, const semantics::Scope &,
+ FoldingContext &);
// Simple contiguity (9.5.4)
-template <typename A>
-bool IsSimplyContiguous(const A &, const IntrinsicProcTable &);
+template <typename A> bool IsSimplyContiguous(const A &, FoldingContext &);
extern template bool IsSimplyContiguous(
- const Expr<SomeType> &, const IntrinsicProcTable &);
+ const Expr<SomeType> &, FoldingContext &);
+
+template <typename A> bool IsErrorExpr(const A &);
+extern template bool IsErrorExpr(const Expr<SomeType> &);
} // namespace Fortran::evaluate
#endif
bool flushSubnormalsToZero() const { return flushSubnormalsToZero_; }
bool bigEndian() const { return bigEndian_; }
const semantics::DerivedTypeSpec *pdtInstance() const { return pdtInstance_; }
- const evaluate::IntrinsicProcTable &intrinsics() const { return intrinsics_; }
+ const IntrinsicProcTable &intrinsics() const { return intrinsics_; }
ConstantSubscript &StartImpliedDo(parser::CharBlock, ConstantSubscript = 1);
std::optional<ConstantSubscript> GetImpliedDo(parser::CharBlock) const;
// are known.
bool CheckConformance(parser::ContextualMessages &, const Shape &left,
const Shape &right, const char *leftIs = "left operand",
- const char *rightIs = "right operand");
+ const char *rightIs = "right operand", bool leftScalarExpandable = true,
+ bool rightScalarExpandable = true);
// Increments one-based subscripts in element order (first varies fastest)
// and returns true when they remain in range; resets them all to one and
while (const Component * component{std::get_if<Component>(&ref->u)}) {
ref = &component->base();
}
- return std::holds_alternative<ArrayRef>(ref->u);
+ if (const auto *coarrayRef{std::get_if<CoarrayRef>(&ref->u)}) {
+ return !coarrayRef->subscript().empty();
+ } else {
+ return std::holds_alternative<ArrayRef>(ref->u);
+ }
} else {
return false;
}
// Check for references to impure procedures; returns the name
// of one to complain about, if any exist.
std::optional<std::string> FindImpureCall(
- const IntrinsicProcTable &, const Expr<SomeType> &);
+ FoldingContext &, const Expr<SomeType> &);
std::optional<std::string> FindImpureCall(
- const IntrinsicProcTable &, const ProcedureRef &);
+ FoldingContext &, const ProcedureRef &);
// Predicate: is a scalar expression suitable for naive scalar expansion
// in the flattening of an array expression?
const std::optional<characteristics::Procedure> &lhsProcedure,
const characteristics::Procedure *rhsProcedure);
+// Scalar constant expansion
+class ScalarConstantExpander {
+public:
+ explicit ScalarConstantExpander(ConstantSubscripts &&extents)
+ : extents_{std::move(extents)} {}
+ ScalarConstantExpander(
+ ConstantSubscripts &&extents, std::optional<ConstantSubscripts> &&lbounds)
+ : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
+ ScalarConstantExpander(
+ ConstantSubscripts &&extents, ConstantSubscripts &&lbounds)
+ : extents_{std::move(extents)}, lbounds_{std::move(lbounds)} {}
+
+ template <typename A> A Expand(A &&x) const {
+ return std::move(x); // default case
+ }
+ template <typename T> Constant<T> Expand(Constant<T> &&x) {
+ auto expanded{x.Reshape(std::move(extents_))};
+ if (lbounds_) {
+ expanded.set_lbounds(std::move(*lbounds_));
+ }
+ return expanded;
+ }
+ template <typename T> Constant<T> Expand(Parentheses<T> &&x) {
+ return Expand(std::move(x)); // Constant<> can be parenthesized
+ }
+ template <typename T> Expr<T> Expand(Expr<T> &&x) {
+ return std::visit([&](auto &&x) { return Expr<T>{Expand(std::move(x))}; },
+ std::move(x.u));
+ }
+
+private:
+ ConstantSubscripts extents_;
+ std::optional<ConstantSubscripts> lbounds_;
+};
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
bool IsSaved(const Symbol &); // saved implicitly or explicitly
bool IsDummy(const Symbol &);
bool IsFunctionResult(const Symbol &);
+bool IsKindTypeParameter(const Symbol &);
+bool IsLenTypeParameter(const Symbol &);
// Follow use, host, and construct assocations to a variable, if any.
const Symbol *GetAssociationRoot(const Symbol &);
int SelectedRealKind(
std::int64_t precision = 0, std::int64_t range = 0, std::int64_t radix = 2);
-// Utilities
-bool IsKindTypeParameter(const semantics::Symbol &);
-
// For generating "[extern] template class", &c. boilerplate
#define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \
M(P, S, 1) M(P, S, 2) M(P, S, 4) M(P, S, 8) M(P, S, 16)
CharBlock at() const { return at_; }
Messages *messages() const { return messages_; }
+ Message::Reference contextMessage() const { return contextMessage_; }
bool empty() const { return !messages_ || messages_->empty(); }
// Set CharBlock for messages; restore when the returned value is deleted
return common::ScopedSet(at_, std::move(at));
}
+ common::Restorer<Message::Reference> SetContext(Message *m) {
+ if (!m) {
+ m = contextMessage_.get();
+ }
+ return common::ScopedSet(contextMessage_, m);
+ }
+
// Diverts messages to another buffer; restored when the returned
// value is deleted.
common::Restorer<Messages *> SetMessages(Messages &buffer) {
template <typename... A> Message *Say(CharBlock at, A &&...args) {
if (messages_ != nullptr) {
- return &messages_->Say(at, std::forward<A>(args)...);
+ auto &msg{messages_->Say(at, std::forward<A>(args)...)};
+ if (contextMessage_) {
+ msg.SetContext(contextMessage_.get());
+ }
+ return &msg;
} else {
return nullptr;
}
private:
CharBlock at_;
Messages *messages_{nullptr};
+ Message::Reference contextMessage_;
};
} // namespace Fortran::parser
#endif // FORTRAN_PARSER_MESSAGE_H_
bool IsDerivedType() const { return kind_ == Kind::DerivedType; }
bool IsStmtFunction() const;
bool IsParameterizedDerivedType() const;
+ bool IsParameterizedDerivedTypeInstantiation() const {
+ return kind_ == Kind::DerivedType && !symbol_;
+ }
Symbol *symbol() { return symbol_; }
const Symbol *symbol() const { return symbol_; }
void add_importName(const SourceName &);
+ // These members pertain to instantiations of parameterized derived types.
const DerivedTypeSpec *derivedTypeSpec() const { return derivedTypeSpec_; }
DerivedTypeSpec *derivedTypeSpec() { return derivedTypeSpec_; }
void set_derivedTypeSpec(DerivedTypeSpec &spec) { derivedTypeSpec_ = &spec; }
+ parser::Message::Reference instantiationContext() const {
+ return instantiationContext_;
+ };
+ void set_instantiationContext(parser::Message::Reference &&mref) {
+ instantiationContext_ = std::move(mref);
+ }
bool hasSAVE() const { return hasSAVE_; }
void set_hasSAVE(bool yes = true) { hasSAVE_ = yes; }
std::optional<ImportKind> importKind_;
std::set<SourceName> importNames_;
DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this
+ parser::Message::Reference instantiationContext_;
bool hasSAVE_{false}; // scope has a bare SAVE statement
// When additional data members are added to Scope, remember to
// copy them, if appropriate, in InstantiateDerivedType().
MaybeExpr &init() { return init_; }
const MaybeExpr &init() const { return init_; }
void set_init(MaybeExpr &&expr) { init_ = std::move(expr); }
- bool initWasValidated() const { return initWasValidated_; }
- void set_initWasValidated(bool yes = true) { initWasValidated_ = yes; }
ArraySpec &shape() { return shape_; }
const ArraySpec &shape() const { return shape_; }
ArraySpec &coshape() { return coshape_; }
private:
MaybeExpr init_;
- bool initWasValidated_{false};
ArraySpec shape_;
ArraySpec coshape_;
const Symbol *commonBlock_{nullptr}; // common block this object is in
bool IsEventTypeOrLockType(const DerivedTypeSpec *);
bool IsOrContainsEventOrLockComponent(const Symbol &);
bool CanBeTypeBoundProc(const Symbol *);
-bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false);
+bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false,
+ const Symbol *derivedType = nullptr);
bool HasIntrinsicTypeName(const Symbol &);
bool IsSeparateModuleProcedureInterface(const Symbol *);
bool IsAutomatic(const Symbol &);
return std::visit(
common::visitors{
[&](const semantics::ObjectEntityDetails &object) {
- auto result{Characterize(object)};
+ auto result{Characterize(object, context)};
if (result &&
result->type().category() == TypeCategory::Character) {
if (auto len{DataRef{symbol}.LEN()}) {
return std::optional<TypeAndShape>{};
}
},
+ [&](const semantics::TypeParamDetails &tp) {
+ if (auto type{DynamicType::From(tp.type())}) {
+ return std::optional<TypeAndShape>{std::move(*type)};
+ } else {
+ return std::optional<TypeAndShape>{};
+ }
+ },
[&](const semantics::UseDetails &use) {
return Characterize(use.symbol(), context);
},
}
std::optional<TypeAndShape> TypeAndShape::Characterize(
- const semantics::ObjectEntityDetails &object) {
+ const semantics::ObjectEntityDetails &object, FoldingContext &context) {
if (auto type{DynamicType::From(object.type())}) {
TypeAndShape result{std::move(*type)};
- result.AcquireShape(object);
+ result.AcquireShape(object, context);
return result;
} else {
return std::nullopt;
return false;
}
return isElemental ||
- CheckConformance(messages, shape_, that.shape_, thisIs, thatIs);
+ CheckConformance(messages, shape_, that.shape_, thisIs, thatIs, false,
+ false /* no scalar expansion */);
}
std::optional<Expr<SubscriptInteger>> TypeAndShape::MeasureSizeInBytes(
}
}
-void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
+void TypeAndShape::AcquireShape(
+ const semantics::ObjectEntityDetails &object, FoldingContext &context) {
CHECK(shape_.empty() && !attrs_.test(Attr::AssumedRank));
corank_ = object.coshape().Rank();
if (object.IsAssumedRank()) {
extent =
std::move(extent) + Expr<SubscriptInteger>{1} - std::move(*lbound);
}
- shape_.emplace_back(std::move(extent));
+ shape_.emplace_back(Fold(context, std::move(extent)));
} else {
shape_.push_back(std::nullopt);
}
}
std::optional<DummyDataObject> DummyDataObject::Characterize(
- const semantics::Symbol &symbol) {
+ const semantics::Symbol &symbol, FoldingContext &context) {
if (const auto *obj{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- if (auto type{TypeAndShape::Characterize(*obj)}) {
+ if (auto type{TypeAndShape::Characterize(*obj, context)}) {
std::optional<DummyDataObject> result{std::move(*type)};
using semantics::Attr;
CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
}
std::optional<DummyProcedure> DummyProcedure::Characterize(
- const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
- if (auto procedure{Procedure::Characterize(symbol, intrinsics)}) {
+ const semantics::Symbol &symbol, FoldingContext &context) {
+ if (auto procedure{Procedure::Characterize(symbol, context)}) {
// Dummy procedures may not be elemental. Elemental dummy procedure
// interfaces are errors when the interface is not intrinsic, and that
// error is caught elsewhere. Elemental intrinsic interfaces are
}
std::optional<DummyArgument> DummyArgument::Characterize(
- const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
+ const semantics::Symbol &symbol, FoldingContext &context) {
auto name{symbol.name().ToString()};
if (symbol.has<semantics::ObjectEntityDetails>()) {
- if (auto obj{DummyDataObject::Characterize(symbol)}) {
+ if (auto obj{DummyDataObject::Characterize(symbol, context)}) {
return DummyArgument{std::move(name), std::move(obj.value())};
}
- } else if (auto proc{DummyProcedure::Characterize(symbol, intrinsics)}) {
+ } else if (auto proc{DummyProcedure::Characterize(symbol, context)}) {
return DummyArgument{std::move(name), std::move(proc.value())};
}
return std::nullopt;
TypeAndShape{DynamicType::TypelessIntrinsicArgument()}});
},
[&](const ProcedureDesignator &designator) {
- if (auto proc{Procedure::Characterize(
- designator, context.intrinsics())}) {
+ if (auto proc{Procedure::Characterize(designator, context)}) {
return std::make_optional<DummyArgument>(
std::move(name), DummyProcedure{std::move(*proc)});
} else {
}
},
[&](const ProcedureRef &call) {
- if (auto proc{
- Procedure::Characterize(call, context.intrinsics())}) {
+ if (auto proc{Procedure::Characterize(call, context)}) {
return std::make_optional<DummyArgument>(
std::move(name), DummyProcedure{std::move(*proc)});
} else {
}
std::optional<FunctionResult> FunctionResult::Characterize(
- const Symbol &symbol, const IntrinsicProcTable &intrinsics) {
+ const Symbol &symbol, FoldingContext &context) {
if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- if (auto type{TypeAndShape::Characterize(*object)}) {
+ if (auto type{TypeAndShape::Characterize(*object, context)}) {
FunctionResult result{std::move(*type)};
CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
{
});
return result;
}
- } else if (auto maybeProc{Procedure::Characterize(symbol, intrinsics)}) {
+ } else if (auto maybeProc{Procedure::Characterize(symbol, context)}) {
FunctionResult result{std::move(*maybeProc)};
result.attrs.set(FunctionResult::Attr::Pointer);
return result;
}
std::optional<Procedure> Procedure::Characterize(
- const semantics::Symbol &original, const IntrinsicProcTable &intrinsics) {
+ const semantics::Symbol &original, FoldingContext &context) {
Procedure result;
const auto &symbol{ResolveAssociations(original)};
CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
[&](const semantics::SubprogramDetails &subp)
-> std::optional<Procedure> {
if (subp.isFunction()) {
- if (auto fr{FunctionResult::Characterize(
- subp.result(), intrinsics)}) {
+ if (auto fr{
+ FunctionResult::Characterize(subp.result(), context)}) {
result.functionResult = std::move(fr);
} else {
return std::nullopt;
if (!arg) {
result.dummyArguments.emplace_back(AlternateReturn{});
} else if (auto argCharacteristics{
- DummyArgument::Characterize(*arg, intrinsics)}) {
+ DummyArgument::Characterize(*arg, context)}) {
result.dummyArguments.emplace_back(
std::move(argCharacteristics.value()));
} else {
[&](const semantics::ProcEntityDetails &proc)
-> std::optional<Procedure> {
if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
- return intrinsics.IsSpecificIntrinsicFunction(
+ return context.intrinsics().IsSpecificIntrinsicFunction(
symbol.name().ToString());
}
const semantics::ProcInterface &interface{proc.interface()};
if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
- return Characterize(*interfaceSymbol, intrinsics);
+ return Characterize(*interfaceSymbol, context);
} else {
result.attrs.set(Attr::ImplicitInterface);
const semantics::DeclTypeSpec *type{interface.type()};
}
},
[&](const semantics::ProcBindingDetails &binding) {
- if (auto result{Characterize(binding.symbol(), intrinsics)}) {
+ if (auto result{Characterize(binding.symbol(), context)}) {
if (!symbol.attrs().test(semantics::Attr::NOPASS)) {
auto passName{binding.passName()};
for (auto &dummy : result->dummyArguments) {
}
},
[&](const semantics::UseDetails &use) {
- return Characterize(use.symbol(), intrinsics);
+ return Characterize(use.symbol(), context);
},
[&](const semantics::HostAssocDetails &assoc) {
- return Characterize(assoc.symbol(), intrinsics);
+ return Characterize(assoc.symbol(), context);
},
[](const auto &) { return std::optional<Procedure>{}; },
},
}
std::optional<Procedure> Procedure::Characterize(
- const ProcedureDesignator &proc, const IntrinsicProcTable &intrinsics) {
+ const ProcedureDesignator &proc, FoldingContext &context) {
if (const auto *symbol{proc.GetSymbol()}) {
if (auto result{characteristics::Procedure::Characterize(
- ResolveAssociations(*symbol), intrinsics)}) {
+ ResolveAssociations(*symbol), context)}) {
return result;
}
} else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {
}
std::optional<Procedure> Procedure::Characterize(
- const ProcedureRef &ref, const IntrinsicProcTable &intrinsics) {
- if (auto callee{Characterize(ref.proc(), intrinsics)}) {
+ const ProcedureRef &ref, FoldingContext &context) {
+ if (auto callee{Characterize(ref.proc(), context)}) {
if (callee->functionResult) {
if (const Procedure *
proc{callee->functionResult->IsProcedurePointer()}) {
//===----------------------------------------------------------------------===//
#include "flang/Evaluate/check-expression.h"
+#include "flang/Evaluate/characteristics.h"
#include "flang/Evaluate/intrinsics.h"
#include "flang/Evaluate/traverse.h"
#include "flang/Evaluate/type.h"
using Base::operator();
bool operator()(const TypeParamInquiry &inq) const {
- return IsKindTypeParameter(inq.parameter());
+ return semantics::IsKindTypeParameter(inq.parameter());
}
bool operator()(const semantics::Symbol &symbol) const {
const auto &ultimate{symbol.GetUltimate()};
template bool IsConstantExpr(const Expr<SubscriptInteger> &);
template bool IsConstantExpr(const StructureConstructor &);
+// IsActuallyConstant()
+struct IsActuallyConstantHelper {
+ template <typename A> bool operator()(const A &) { return false; }
+ template <typename T> bool operator()(const Constant<T> &) { return true; }
+ template <typename T> bool operator()(const Parentheses<T> &x) {
+ return (*this)(x.left());
+ }
+ template <typename T> bool operator()(const Expr<T> &x) {
+ return std::visit([=](const auto &y) { return (*this)(y); }, x.u);
+ }
+ template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
+ template <typename A> bool operator()(const std::optional<A> &x) {
+ return x && (*this)(*x);
+ }
+};
+
+template <typename A> bool IsActuallyConstant(const A &x) {
+ return IsActuallyConstantHelper{}(x);
+}
+
+template bool IsActuallyConstant(const Expr<SomeType> &);
+
// Object pointer initialization checking predicate IsInitialDataTarget().
// This code determines whether an expression is allowable as the static
// data address used to initialize a pointer with "=> x". See C765.
}
}
+class ScalarExpansionVisitor : public AnyTraverse<ScalarExpansionVisitor,
+ std::optional<Expr<SomeType>>> {
+public:
+ using Result = std::optional<Expr<SomeType>>;
+ using Base = AnyTraverse<ScalarExpansionVisitor, Result>;
+ ScalarExpansionVisitor(
+ ConstantSubscripts &&shape, std::optional<ConstantSubscripts> &&lb)
+ : Base{*this}, shape_{std::move(shape)}, lbounds_{std::move(lb)} {}
+ using Base::operator();
+ template <typename T> Result operator()(const Constant<T> &x) {
+ auto expanded{x.Reshape(std::move(shape_))};
+ if (lbounds_) {
+ expanded.set_lbounds(std::move(*lbounds_));
+ }
+ return AsGenericExpr(std::move(expanded));
+ }
+
+private:
+ ConstantSubscripts shape_;
+ std::optional<ConstantSubscripts> lbounds_;
+};
+
+// Converts, folds, and then checks type, rank, and shape of an
+// initialization expression for a named constant, a non-pointer
+// variable static initializatio, a component default initializer,
+// a type parameter default value, or instantiated type parameter value.
+std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
+ Expr<SomeType> &&x, FoldingContext &context,
+ const semantics::Scope *instantiation) {
+ CHECK(!IsPointer(symbol));
+ if (auto symTS{
+ characteristics::TypeAndShape::Characterize(symbol, context)}) {
+ auto xType{x.GetType()};
+ if (auto converted{ConvertToType(symTS->type(), std::move(x))}) {
+ auto folded{Fold(context, std::move(*converted))};
+ if (IsActuallyConstant(folded)) {
+ int symRank{GetRank(symTS->shape())};
+ if (IsImpliedShape(symbol)) {
+ if (folded.Rank() == symRank) {
+ return {std::move(folded)};
+ } else {
+ context.messages().Say(
+ "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
+ symbol.name(), symRank, folded.Rank());
+ }
+ } else if (auto extents{AsConstantExtents(context, symTS->shape())}) {
+ if (folded.Rank() == 0 && symRank > 0) {
+ return ScalarConstantExpander{std::move(*extents),
+ AsConstantExtents(
+ context, GetLowerBounds(context, NamedEntity{symbol}))}
+ .Expand(std::move(folded));
+ } else if (auto resultShape{GetShape(context, folded)}) {
+ if (CheckConformance(context.messages(), symTS->shape(),
+ *resultShape, "initialized object",
+ "initialization expression", false, false)) {
+ return {std::move(folded)};
+ }
+ }
+ } else if (IsNamedConstant(symbol)) {
+ if (IsExplicitShape(symbol)) {
+ context.messages().Say(
+ "Named constant '%s' array must have constant shape"_err_en_US,
+ symbol.name());
+ } else {
+ // Declaration checking handles other cases
+ }
+ } else {
+ context.messages().Say(
+ "Shape of initialized object '%s' must be constant"_err_en_US,
+ symbol.name());
+ }
+ } else if (IsErrorExpr(folded)) {
+ } else if (IsLenTypeParameter(symbol)) {
+ return {std::move(folded)};
+ } else if (IsKindTypeParameter(symbol)) {
+ if (instantiation) {
+ context.messages().Say(
+ "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
+ symbol.name(), folded.AsFortran());
+ } else {
+ return {std::move(folded)};
+ }
+ } else if (IsNamedConstant(symbol)) {
+ context.messages().Say(
+ "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
+ symbol.name(), folded.AsFortran());
+ } else {
+ context.messages().Say(
+ "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
+ symbol.name(), folded.AsFortran());
+ }
+ } else if (xType) {
+ context.messages().Say(
+ "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
+ symbol.name(), xType->AsFortran());
+ } else {
+ context.messages().Say(
+ "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
+ symbol.name());
+ }
+ }
+ return std::nullopt;
+}
+
// Specification expression validation (10.1.11(2), C1010)
class CheckSpecificationExprHelper
: public AnyTraverse<CheckSpecificationExprHelper,
using Result = std::optional<std::string>;
using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
explicit CheckSpecificationExprHelper(
- const semantics::Scope &s, const IntrinsicProcTable &table)
- : Base{*this}, scope_{s}, table_{table} {}
+ const semantics::Scope &s, FoldingContext &context)
+ : Base{*this}, scope_{s}, context_{context} {}
using Base::operator();
Result operator()(const ProcedureDesignator &) const {
} else {
const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
if (scope_.IsDerivedType()) { // C750, C754
- if ((table_.IsIntrinsic(intrin.name) &&
+ if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
badIntrinsicsForComponents_.find(intrin.name) !=
badIntrinsicsForComponents_.end()) ||
IsProhibitedFunction(intrin.name)) {
"' not allowed for derived type components or type parameter"
" values";
}
- if (table_.GetIntrinsicClass(intrin.name) ==
+ if (context_.intrinsics().GetIntrinsicClass(intrin.name) ==
IntrinsicClass::inquiryFunction &&
!IsConstantExpr(x)) {
return "non-constant reference to inquiry intrinsic '"s +
private:
const semantics::Scope &scope_;
- const IntrinsicProcTable &table_;
+ FoldingContext &context_;
const std::set<std::string> badIntrinsicsForComponents_{
"allocated", "associated", "extends_type_of", "present", "same_type_as"};
static bool IsProhibitedFunction(std::string name) { return false; }
};
template <typename A>
-void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages,
- const semantics::Scope &scope, const IntrinsicProcTable &table) {
- if (auto why{CheckSpecificationExprHelper{scope, table}(x)}) {
- messages.Say("Invalid specification expression: %s"_err_en_US, *why);
+void CheckSpecificationExpr(
+ const A &x, const semantics::Scope &scope, FoldingContext &context) {
+ if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
+ context.messages().Say(
+ "Invalid specification expression: %s"_err_en_US, *why);
}
}
-template void CheckSpecificationExpr(const Expr<SomeType> &,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
-template void CheckSpecificationExpr(const Expr<SomeInteger> &,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
-template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
+template void CheckSpecificationExpr(
+ const Expr<SomeType> &, const semantics::Scope &, FoldingContext &);
+template void CheckSpecificationExpr(
+ const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &);
+template void CheckSpecificationExpr(
+ const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &);
template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
+ const semantics::Scope &, FoldingContext &);
template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
- parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &);
+ const semantics::Scope &, FoldingContext &);
template void CheckSpecificationExpr(
- const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &,
- const semantics::Scope &, const IntrinsicProcTable &);
+ const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
+ FoldingContext &);
// IsSimplyContiguous() -- 9.5.4
class IsSimplyContiguousHelper
public:
using Result = std::optional<bool>; // tri-state
using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
- explicit IsSimplyContiguousHelper(const IntrinsicProcTable &t)
- : Base{*this}, table_{t} {}
+ explicit IsSimplyContiguousHelper(FoldingContext &c)
+ : Base{*this}, context_{c} {}
using Base::operator();
Result operator()(const semantics::Symbol &symbol) const {
template <typename T> Result operator()(const FunctionRef<T> &x) const {
if (auto chars{
- characteristics::Procedure::Characterize(x.proc(), table_)}) {
+ characteristics::Procedure::Characterize(x.proc(), context_)}) {
if (chars->functionResult) {
const auto &result{*chars->functionResult};
return !result.IsProcedurePointer() &&
return rank;
}
- const IntrinsicProcTable &table_;
+ FoldingContext &context_;
};
template <typename A>
-bool IsSimplyContiguous(const A &x, const IntrinsicProcTable &table) {
+bool IsSimplyContiguous(const A &x, FoldingContext &context) {
if (IsVariable(x)) {
- auto known{IsSimplyContiguousHelper{table}(x)};
+ auto known{IsSimplyContiguousHelper{context}(x)};
return known && *known;
} else {
return true; // not a variable
}
}
-template bool IsSimplyContiguous(
- const Expr<SomeType> &, const IntrinsicProcTable &);
+template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &);
+
+// IsErrorExpr()
+struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
+ using Result = bool;
+ using Base = AnyTraverse<IsErrorExprHelper, Result>;
+ IsErrorExprHelper() : Base{*this} {}
+ using Base::operator();
+
+ bool operator()(const SpecificIntrinsic &x) {
+ return x.name == IntrinsicProcTable::InvalidName;
+ }
+};
+
+template <typename A> bool IsErrorExpr(const A &x) {
+ return IsErrorExprHelper{}(x);
+}
+
+template bool IsErrorExpr(const Expr<SomeType> &);
} // namespace Fortran::evaluate
template <typename T> class Folder {
public:
explicit Folder(FoldingContext &c) : context_{c} {}
- std::optional<Expr<T>> GetNamedConstantValue(const Symbol &);
- std::optional<Constant<T>> GetFoldedNamedConstantValue(const Symbol &);
+ std::optional<Constant<T>> GetNamedConstant(const Symbol &);
std::optional<Constant<T>> ApplySubscripts(const Constant<T> &array,
const std::vector<Constant<SubscriptInteger>> &subscripts);
std::optional<Constant<T>> ApplyComponent(Constant<SomeDerived> &&,
Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
template <typename T>
-std::optional<Expr<T>> Folder<T>::GetNamedConstantValue(const Symbol &symbol0) {
+std::optional<Constant<T>> Folder<T>::GetNamedConstant(const Symbol &symbol0) {
const Symbol &symbol{ResolveAssociations(symbol0)};
if (IsNamedConstant(symbol)) {
if (const auto *object{
symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- if (object->initWasValidated()) {
- const auto *constant{UnwrapConstantValue<T>(object->init())};
- return Expr<T>{DEREF(constant)};
+ if (const auto *constant{UnwrapConstantValue<T>(object->init())}) {
+ return *constant;
}
- if (const auto &init{object->init()}) {
- if (auto dyType{DynamicType::From(symbol)}) {
- semantics::ObjectEntityDetails *mutableObject{
- const_cast<semantics::ObjectEntityDetails *>(object)};
- auto converted{
- ConvertToType(*dyType, std::move(mutableObject->init().value()))};
- // Reset expression now to prevent infinite loops if the init
- // expression depends on symbol itself.
- mutableObject->set_init(std::nullopt);
- if (converted) {
- *converted = Fold(context_, std::move(*converted));
- auto *unwrapped{UnwrapExpr<Expr<T>>(*converted)};
- CHECK(unwrapped);
- if (auto *constant{UnwrapConstantValue<T>(*unwrapped)}) {
- if (symbol.Rank() > 0) {
- if (constant->Rank() == 0) {
- // scalar expansion
- if (auto extents{GetConstantExtents(context_, symbol)}) {
- *constant = constant->Reshape(std::move(*extents));
- CHECK(constant->Rank() == symbol.Rank());
- }
- }
- if (constant->Rank() == symbol.Rank()) {
- NamedEntity base{symbol};
- if (auto lbounds{AsConstantExtents(
- context_, GetLowerBounds(context_, base))}) {
- constant->set_lbounds(*std::move(lbounds));
- }
- }
- }
- mutableObject->set_init(AsGenericExpr(Expr<T>{*constant}));
- if (auto constShape{GetShape(context_, *constant)}) {
- if (auto symShape{GetShape(context_, symbol)}) {
- if (CheckConformance(context_.messages(), *constShape,
- *symShape, "initialization expression",
- "PARAMETER")) {
- mutableObject->set_initWasValidated();
- return std::move(*unwrapped);
- }
- } else {
- context_.messages().Say(symbol.name(),
- "Could not determine the shape of the PARAMETER"_err_en_US);
- }
- } else {
- context_.messages().Say(symbol.name(),
- "Could not determine the shape of the initialization expression"_err_en_US);
- }
- mutableObject->set_init(std::nullopt);
- } else {
- context_.messages().Say(symbol.name(),
- "Initialization expression for PARAMETER '%s' (%s) cannot be computed as a constant value"_err_en_US,
- symbol.name(), unwrapped->AsFortran());
- }
- } else {
- context_.messages().Say(symbol.name(),
- "Initialization expression for PARAMETER '%s' (%s) cannot be converted to its type (%s)"_err_en_US,
- symbol.name(), init->AsFortran(), dyType->AsFortran());
- }
- }
- }
- }
- }
- return std::nullopt;
-}
-
-template <typename T>
-std::optional<Constant<T>> Folder<T>::GetFoldedNamedConstantValue(
- const Symbol &symbol) {
- if (auto value{GetNamedConstantValue(symbol)}) {
- Expr<T> folded{Fold(context_, std::move(*value))};
- if (const Constant<T> *value{UnwrapConstantValue<T>(folded)}) {
- return *value;
}
}
return std::nullopt;
if (Component * component{aRef.base().UnwrapComponent()}) {
return GetConstantComponent(*component, &subscripts);
} else if (std::optional<Constant<T>> array{
- GetFoldedNamedConstantValue(aRef.base().GetLastSymbol())}) {
+ GetNamedConstant(aRef.base().GetLastSymbol())}) {
return ApplySubscripts(*array, subscripts);
} else {
return std::nullopt;
if (std::optional<Constant<SomeDerived>> structures{std::visit(
common::visitors{
[&](const Symbol &symbol) {
- return Folder<SomeDerived>{context_}
- .GetFoldedNamedConstantValue(symbol);
+ return Folder<SomeDerived>{context_}.GetNamedConstant(symbol);
},
[&](ArrayRef &aRef) {
return Folder<SomeDerived>{context_}.Folding(aRef);
return std::visit(
common::visitors{
[&](SymbolRef &&symbol) {
- if (auto constant{GetFoldedNamedConstantValue(*symbol)}) {
+ if (auto constant{GetNamedConstant(*symbol)}) {
return Expr<T>{std::move(*constant)};
}
return Expr<T>{std::move(designator)};
} else if (name == "is_contiguous") {
if (args.at(0)) {
if (auto *expr{args[0]->UnwrapExpr()}) {
- if (IsSimplyContiguous(*expr, context.intrinsics())) {
+ if (IsSimplyContiguous(*expr, context)) {
return Expr<T>{true};
}
}
ss.u);
}
-// TODO: Put this in a more central location if it would be useful elsewhere
-class ScalarConstantExpander {
-public:
- explicit ScalarConstantExpander(ConstantSubscripts &extents)
- : extents_{extents} {}
-
- template <typename A> A Expand(A &&x) const {
- return std::move(x); // default case
- }
- template <typename T> Constant<T> Expand(Constant<T> &&x) {
- return x.Reshape(std::move(extents_));
- }
- template <typename T> Expr<T> Expand(Expr<T> &&x) {
- return std::visit([&](auto &&x) { return Expr<T>{Expand(std::move(x))}; },
- std::move(x.u));
- }
-
-private:
- ConstantSubscripts &extents_;
-};
-
Expr<SomeDerived> FoldOperation(
FoldingContext &context, StructureConstructor &&structure) {
StructureConstructor ctor{structure.derivedTypeSpec()};
bool constantExtents{true};
for (auto &&[symbol, value] : std::move(structure)) {
auto expr{Fold(context, std::move(value.value()))};
- if (!IsProcedurePointer(symbol)) {
+ if (!IsPointer(symbol)) {
+ bool ok{false};
if (auto valueShape{GetConstantExtents(context, expr)}) {
- if (!IsPointer(symbol)) {
- if (auto componentShape{GetConstantExtents(context, symbol)}) {
- if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0) {
- expr = ScalarConstantExpander{*componentShape}.Expand(
- std::move(expr));
- constantExtents = constantExtents && expr.Rank() > 0;
- } else {
- constantExtents =
- constantExtents && *valueShape == *componentShape;
- }
+ if (auto componentShape{GetConstantExtents(context, symbol)}) {
+ if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0) {
+ expr = ScalarConstantExpander{std::move(*componentShape)}.Expand(
+ std::move(expr));
+ ok = expr.Rank() > 0;
} else {
- constantExtents = false;
+ ok = *valueShape == *componentShape;
}
}
- } else {
+ }
+ if (!ok) {
constantExtents = false;
}
}
private:
DynamicType GetSpecificType(const TypePattern &) const;
- SpecificCall HandleNull(
- ActualArguments &, FoldingContext &, const IntrinsicProcTable &) const;
+ SpecificCall HandleNull(ActualArguments &, FoldingContext &) const;
std::optional<SpecificCall> HandleC_F_Pointer(
ActualArguments &, FoldingContext &) const;
// The NULL() intrinsic is a special case.
SpecificCall IntrinsicProcTable::Implementation::HandleNull(
- ActualArguments &arguments, FoldingContext &context,
- const IntrinsicProcTable &intrinsics) const {
+ ActualArguments &arguments, FoldingContext &context) const {
static const char *const keywords[]{"mold", nullptr};
if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 1) &&
arguments[0]) {
const Symbol *last{GetLastSymbol(*mold)};
CHECK(last);
auto procPointer{
- characteristics::Procedure::Characterize(*last, intrinsics)};
+ characteristics::Procedure::Characterize(*last, context)};
// procPointer is null if there was an error with the analysis
// associated with the procedure pointer
if (procPointer) {
}
}
-static bool CheckAssociated(SpecificCall &call,
- parser::ContextualMessages &messages,
- const IntrinsicProcTable &intrinsics) {
+static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
bool ok{true};
if (const auto &pointerArg{call.arguments[0]}) {
if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) {
if (const Symbol * pointerSymbol{GetLastSymbol(*pointerExpr)}) {
if (!pointerSymbol->attrs().test(semantics::Attr::POINTER)) {
- AttachDeclaration(
- messages.Say("POINTER= argument of ASSOCIATED() must be a "
- "POINTER"_err_en_US),
+ AttachDeclaration(context.messages().Say(
+ "POINTER= argument of ASSOCIATED() must be a "
+ "POINTER"_err_en_US),
*pointerSymbol);
} else {
const auto pointerProc{characteristics::Procedure::Characterize(
- *pointerSymbol, intrinsics)};
+ *pointerSymbol, context)};
if (const auto &targetArg{call.arguments[1]}) {
if (const auto *targetExpr{targetArg->UnwrapExpr()}) {
std::optional<characteristics::Procedure> targetProc{
std::get_if<ProcedureRef>(&targetExpr->u)}) {
if (auto targetRefedChars{
characteristics::Procedure::Characterize(
- *targetProcRef, intrinsics)}) {
+ *targetProcRef, context)}) {
targetProc = *targetRefedChars;
targetName = targetProcRef->proc().GetName() + "()";
isCall = true;
} else if (targetSymbol && !targetProc) {
// proc that's not a call
targetProc = characteristics::Procedure::Characterize(
- *targetSymbol, intrinsics);
+ *targetSymbol, context);
targetName = targetSymbol->name().ToString();
}
CheckProcCompatibility(
isCall, pointerProc, &*targetProc)}) {
AttachDeclaration(
- messages.Say(std::move(*msg),
+ context.messages().Say(std::move(*msg),
"pointer '" + pointerSymbol->name().ToString() +
"'",
targetName),
// procedure pointer and object target
if (!IsNullPointer(*targetExpr)) {
AttachDeclaration(
- messages.Say(
+ context.messages().Say(
"POINTER= argument '%s' is a procedure "
"pointer but the TARGET= argument '%s' is not a "
"procedure or procedure pointer"_err_en_US,
} else if (targetProc) {
// object pointer and procedure target
AttachDeclaration(
- messages.Say("POINTER= argument '%s' is an object pointer "
- "but the TARGET= argument '%s' is a "
- "procedure designator"_err_en_US,
+ context.messages().Say(
+ "POINTER= argument '%s' is an object pointer "
+ "but the TARGET= argument '%s' is a "
+ "procedure designator"_err_en_US,
pointerSymbol->name(), targetName),
*pointerSymbol);
} else {
targetSymbol->attrs().test(
semantics::Attr::TARGET))) {
AttachDeclaration(
- messages.Say("TARGET= argument '%s' must have either "
- "the POINTER or the TARGET "
- "attribute"_err_en_US,
+ context.messages().Say(
+ "TARGET= argument '%s' must have either "
+ "the POINTER or the TARGET "
+ "attribute"_err_en_US,
targetName),
*targetSymbol);
}
ok = false;
}
if (!ok) {
- messages.Say(
+ context.messages().Say(
"Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US);
}
return ok;
}
// Applies any semantic checks peculiar to an intrinsic.
-static bool ApplySpecificChecks(SpecificCall &call,
- parser::ContextualMessages &messages,
- const IntrinsicProcTable &intrinsics) {
+static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
bool ok{true};
const std::string &name{call.specificIntrinsic.name};
if (name == "allocated") {
}
}
if (!ok) {
- messages.Say(
+ context.messages().Say(
"Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US);
}
} else if (name == "associated") {
- return CheckAssociated(call, messages, intrinsics);
+ return CheckAssociated(call, context);
} else if (name == "loc") {
if (const auto &arg{call.arguments[0]}) {
ok = arg->GetAssumedTypeDummy() || GetLastSymbol(arg->UnwrapExpr());
}
if (!ok) {
- messages.Say(
+ context.messages().Say(
"Argument of LOC() must be an object or procedure"_err_en_US);
}
} else if (name == "present") {
}
}
if (!ok) {
- messages.Say(
+ context.messages().Say(
"Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
}
}
}
} else {
if (call.name == "null") {
- return HandleNull(arguments, context, intrinsics);
+ return HandleNull(arguments, context);
}
}
for (auto iter{genericRange.first}; iter != genericRange.second; ++iter) {
if (auto specificCall{
matchOrBufferMessages(*iter->second, genericBuffer)}) {
- ApplySpecificChecks(*specificCall, context.messages(), intrinsics);
+ ApplySpecificChecks(*specificCall, context);
return specificCall;
}
}
bool IsImpliedShape(const Symbol &symbol0) {
const Symbol &symbol{ResolveAssociations(symbol0)};
- if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- if (symbol.attrs().test(semantics::Attr::PARAMETER) && details->init()) {
- return details->shape().IsImpliedShape();
- }
- }
- return false;
+ const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()};
+ return symbol.attrs().test(semantics::Attr::PARAMETER) && details &&
+ details->shape().IsImpliedShape();
}
bool IsExplicitShape(const Symbol &symbol0) {
// Check conformance of the passed shapes. Only return true if we can verify
// that they conform
bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
- const Shape &right, const char *leftIs, const char *rightIs) {
+ const Shape &right, const char *leftIs, const char *rightIs,
+ bool leftScalarExpandable, bool rightScalarExpandable) {
int n{GetRank(left)};
+ if (n == 0 && leftScalarExpandable) {
+ return true;
+ }
int rn{GetRank(right)};
- if (n != 0 && rn != 0) {
- if (n != rn) {
- messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
- leftIs, n, rightIs, rn);
+ if (rn == 0 && rightScalarExpandable) {
+ return true;
+ }
+ if (n != rn) {
+ messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
+ leftIs, n, rightIs, rn);
+ return false;
+ }
+ for (int j{0}; j < n; ++j) {
+ auto leftDim{ToInt64(left[j])};
+ auto rightDim{ToInt64(right[j])};
+ if (!leftDim || !rightDim) {
+ return false;
+ }
+ if (*leftDim != *rightDim) {
+ messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
+ "but %4$s has extent %5$jd"_err_en_US,
+ j + 1, leftIs, *leftDim, rightIs, *rightDim);
return false;
- } else {
- for (int j{0}; j < n; ++j) {
- auto leftDim{ToInt64(left[j])};
- auto rightDim{ToInt64(right[j])};
- if (!leftDim || !rightDim) {
- return false;
- }
- if (*leftDim != *rightDim) {
- messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
- "but %4$s has extent %5$jd"_err_en_US,
- j + 1, leftIs, *leftDim, rightIs, *rightDim);
- return false;
- }
- }
}
}
return true;
parser::Message *AttachDeclaration(
parser::Message *message, const Symbol &symbol) {
- if (message) {
- AttachDeclaration(*message, symbol);
- }
- return message;
+ return message ? AttachDeclaration(*message, symbol) : nullptr;
}
class FindImpureCallHelper
using Base = AnyTraverse<FindImpureCallHelper, Result>;
public:
- explicit FindImpureCallHelper(const IntrinsicProcTable &intrinsics)
- : Base{*this}, intrinsics_{intrinsics} {}
+ explicit FindImpureCallHelper(FoldingContext &c) : Base{*this}, context_{c} {}
using Base::operator();
Result operator()(const ProcedureRef &call) const {
- if (auto chars{characteristics::Procedure::Characterize(
- call.proc(), intrinsics_)}) {
+ if (auto chars{
+ characteristics::Procedure::Characterize(call.proc(), context_)}) {
if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
return (*this)(call.arguments());
}
}
private:
- const IntrinsicProcTable &intrinsics_;
+ FoldingContext &context_;
};
std::optional<std::string> FindImpureCall(
- const IntrinsicProcTable &intrinsics, const Expr<SomeType> &expr) {
- return FindImpureCallHelper{intrinsics}(expr);
+ FoldingContext &context, const Expr<SomeType> &expr) {
+ return FindImpureCallHelper{context}(expr);
}
std::optional<std::string> FindImpureCall(
- const IntrinsicProcTable &intrinsics, const ProcedureRef &proc) {
- return FindImpureCallHelper{intrinsics}(proc);
+ FoldingContext &context, const ProcedureRef &proc) {
+ return FindImpureCallHelper{context}(proc);
}
// Compare procedure characteristics for equality except that lhs may be
symbol.get<ProcEntityDetails>().isFuncResult());
}
+bool IsKindTypeParameter(const Symbol &symbol) {
+ const auto *param{symbol.detailsIf<TypeParamDetails>()};
+ return param && param->attr() == common::TypeParamAttr::Kind;
+}
+
+bool IsLenTypeParameter(const Symbol &symbol) {
+ const auto *param{symbol.detailsIf<TypeParamDetails>()};
+ return param && param->attr() == common::TypeParamAttr::Len;
+}
+
int CountLenParameters(const DerivedTypeSpec &type) {
return std::count_if(type.parameters().begin(), type.parameters().end(),
[](const auto &pair) { return pair.second.isLen(); });
}
}
-bool IsKindTypeParameter(const semantics::Symbol &symbol) {
- const auto *param{symbol.detailsIf<semantics::TypeParamDetails>()};
- return param && param->attr() == common::TypeParamAttr::Kind;
-}
-
// Do the kind type parameters of type1 have the same values as the
// corresponding kind type parameters of type2?
static bool AreKindCompatible(const semantics::DerivedTypeSpec &type1,
text += ToString();
const AllSources &sources{allCooked.allSources()};
sources.EmitMessage(o, provenanceRange, text, echoSourceLine);
- if (attachmentIsContext_) {
- for (const Message *context{attachment_.get()}; context;
- context = context->attachment_.get()) {
- std::optional<ProvenanceRange> contextProvenance{
- context->GetProvenanceRange(allCooked)};
+ bool isContext{attachmentIsContext_};
+ for (const Message *attachment{attachment_.get()}; attachment;
+ attachment = attachment->attachment_.get()) {
+ text.clear();
+ if (isContext) {
text = "in the context: ";
- text += context->ToString();
- // TODO: don't echo the source lines of a context when it's the
- // same line (or maybe just never echo source for context)
- sources.EmitMessage(o, contextProvenance, text,
- echoSourceLine && contextProvenance != provenanceRange);
- provenanceRange = contextProvenance;
- }
- } else {
- for (const Message *attachment{attachment_.get()}; attachment;
- attachment = attachment->attachment_.get()) {
- sources.EmitMessage(o, attachment->GetProvenanceRange(allCooked),
- attachment->ToString(), echoSourceLine);
}
+ text += attachment->ToString();
+ sources.EmitMessage(
+ o, attachment->GetProvenanceRange(allCooked), text, echoSourceLine);
+ isContext = attachment->attachmentIsContext_;
}
}
if (!attachment_) {
attachment_ = m;
} else {
+ if (attachment_->references() > 1) {
+ // Don't attach to a shared context attachment; copy it first.
+ attachment_ = new Message{*attachment_};
+ }
attachment_->Attach(m);
}
return *this;
llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Name &x) {
return os << x.ToString();
}
-
} // namespace Fortran::parser
// Sequence association (15.5.2.11) applies -- rank need not match
// if the actual argument is an array or array element designator.
} else {
+ // Let CheckConformance accept scalars; storage association
+ // cases are checked here below.
CheckConformance(messages, dummy.type.shape(), actualType.shape(),
- "dummy argument", "actual argument");
+ "dummy argument", "actual argument", true, true);
}
} else {
const auto &len{actualType.LEN()};
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
bool dummyIsContiguous{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)};
- bool actualIsContiguous{IsSimplyContiguous(actual, context.intrinsics())};
+ bool actualIsContiguous{IsSimplyContiguous(actual, context)};
bool dummyIsAssumedRank{dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)};
bool dummyIsAssumedShape{dummy.type.attrs().test(
// Static declaration checking
#include "check-declarations.h"
+#include "pointer-assignment.h"
#include "flang/Evaluate/check-expression.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/tools.h"
void Check(const DeclTypeSpec &, bool canHaveAssumedTypeParameters);
void Check(const Symbol &);
void Check(const Scope &);
- void CheckInitialization(const Symbol &);
const Procedure *Characterize(const Symbol &);
private:
template <typename A> void CheckSpecExpr(const A &x) {
- evaluate::CheckSpecificationExpr(
- x, messages_, DEREF(scope_), context_.intrinsics());
+ evaluate::CheckSpecificationExpr(x, DEREF(scope_), foldingContext_);
}
void CheckValue(const Symbol &, const DerivedTypeSpec *);
void CheckVolatile(
const Symbol &proc, const Symbol *interface, const WithPassArg &);
void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
+ void CheckPointerInitialization(const Symbol &);
void CheckArraySpec(const Symbol &, const ArraySpec &);
void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
void CheckSubprogram(const Symbol &, const SubprogramDetails &);
}
}
bool IsResultOkToDiffer(const FunctionResult &);
- bool IsScopePDT() const {
- return scope_ && scope_->IsParameterizedDerivedType();
- }
SemanticsContext &context_;
evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
parser::ContextualMessages &messages_{foldingContext_.messages()};
const Scope *scope_{nullptr};
+ bool scopeIsUninstantiatedPDT_{false};
// This symbol is the one attached to the innermost enclosing scope
// that has a symbol.
const Symbol *innermostSymbol_{nullptr};
if (context_.HasError(symbol)) {
return;
}
- const DeclTypeSpec *type{symbol.GetType()};
- const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
auto restorer{messages_.SetLocation(symbol.name())};
context_.set_location(symbol.name());
+ const DeclTypeSpec *type{symbol.GetType()};
+ const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
bool isAssociated{symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()};
if (symbol.attrs().test(Attr::VOLATILE)) {
CheckVolatile(symbol, isAssociated, derived);
}
}
}
- bool badInit{false};
- if (symbol.owner().kind() != Scope::Kind::DerivedType &&
- IsInitialized(symbol, true /*ignore DATA, already caught*/)) { // C808
+ if (IsInitialized(symbol, true /* ignore DATA inits */)) { // C808
+ CheckPointerInitialization(symbol);
if (IsAutomatic(symbol)) {
- badInit = true;
- messages_.Say("An automatic variable must not be initialized"_err_en_US);
+ messages_.Say(
+ "An automatic variable or component must not be initialized"_err_en_US);
} else if (IsDummy(symbol)) {
- badInit = true;
messages_.Say("A dummy argument must not be initialized"_err_en_US);
} else if (IsFunctionResult(symbol)) {
- badInit = true;
messages_.Say("A function result must not be initialized"_err_en_US);
} else if (IsInBlankCommon(symbol)) {
- badInit = true;
messages_.Say(
"A variable in blank COMMON should not be initialized"_en_US);
}
}
- if (symbol.owner().kind() == Scope::Kind::BlockData &&
- IsInitialized(symbol)) {
+ if (symbol.owner().kind() == Scope::Kind::BlockData) {
if (IsAllocatable(symbol)) {
messages_.Say(
"An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
- } else if (!FindCommonBlockContaining(symbol)) {
+ } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
messages_.Say(
"An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
}
symbol.name());
}
}
- if (!badInit && !IsScopePDT()) {
- CheckInitialization(symbol);
- }
}
-void CheckHelper::CheckInitialization(const Symbol &symbol) {
- const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
- if (!details) {
- // not an object
- } else if (const auto &init{details->init()}) { // 8.2 para 4
- int initRank{init->Rank()};
- int symbolRank{details->shape().Rank()};
- if (IsPointer(symbol)) {
- // Pointer initialization rank/shape errors are caught earlier in
- // name resolution
- } else if (details->shape().IsImpliedShape() ||
- details->shape().IsDeferredShape()) {
- if (symbolRank != initRank) {
- messages_.Say(
- "%s-shape array '%s' has rank %d, but its initializer has rank %d"_err_en_US,
- details->shape().IsImpliedShape() ? "Implied" : "Deferred",
- symbol.name(), symbolRank, initRank);
+void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
+ if (IsPointer(symbol) && !context_.HasError(symbol) &&
+ !scopeIsUninstantiatedPDT_) {
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (object->init()) { // C764, C765; C808
+ if (auto dyType{evaluate::DynamicType::From(symbol)}) {
+ if (auto designator{evaluate::TypedWrapper<evaluate::Designator>(
+ *dyType, evaluate::DataRef{symbol})}) {
+ auto restorer{messages_.SetLocation(symbol.name())};
+ context_.set_location(symbol.name());
+ CheckInitialTarget(foldingContext_, *designator, *object->init());
+ }
+ }
}
- } else if (symbolRank != initRank && initRank != 0) {
- // Pointer initializer rank errors are caught elsewhere
- messages_.Say(
- "'%s' has rank %d, but its initializer has rank %d"_err_en_US,
- symbol.name(), symbolRank, initRank);
- } else if (auto symbolShape{evaluate::GetShape(foldingContext_, symbol)}) {
- if (!evaluate::AsConstantExtents(foldingContext_, *symbolShape)) {
- // C762
- messages_.Say(
- "Shape of '%s' is not implied, deferred, nor constant"_err_en_US,
- symbol.name());
- } else if (auto initShape{evaluate::GetShape(foldingContext_, *init)}) {
- if (initRank == symbolRank) {
- evaluate::CheckConformance(
- messages_, *symbolShape, *initShape, "object", "initializer");
+ } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+ if (proc->init() && *proc->init()) {
+ // C1519 - must be nonelemental external or module procedure,
+ // or an unrestricted specific intrinsic function.
+ const Symbol &ultimate{(*proc->init())->GetUltimate()};
+ if (ultimate.attrs().test(Attr::INTRINSIC)) {
+ } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
+ ultimate.owner().kind() != Scope::Kind::Module) {
+ context_.Say("Procedure pointer '%s' initializer '%s' is neither "
+ "an external nor a module procedure"_err_en_US,
+ symbol.name(), ultimate.name());
+ } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
+ context_.Say("Procedure pointer '%s' cannot be initialized with the "
+ "elemental procedure '%s"_err_en_US,
+ symbol.name(), ultimate.name());
} else {
- CHECK(initRank == 0);
- // TODO: expand scalar now, or in lowering?
+ // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
}
}
}
}
} else if (IsNamedConstant(symbol)) {
if (!isExplicit && !isImplied) {
- msg = "Named constant '%s' array must have explicit or"
+ msg = "Named constant '%s' array must have constant or"
" implied shape"_err_en_US;
}
} else if (!IsAllocatableOrPointer(symbol) && !isExplicit) {
CheckPassArg(symbol, details.interface().symbol(), details);
}
if (symbol.attrs().test(Attr::POINTER)) {
+ CheckPointerInitialization(symbol);
if (const Symbol * interface{details.interface().symbol()}) {
if (interface->attrs().test(Attr::ELEMENTAL) &&
!interface->attrs().test(Attr::INTRINSIC)) {
} else if (subprogramDetails && details.isFunction() &&
subprogramDetails->isFunction()) {
auto result{FunctionResult::Characterize(
- details.result(), context_.intrinsics())};
+ details.result(), context_.foldingContext())};
auto subpResult{FunctionResult::Characterize(
- subprogramDetails->result(), context_.intrinsics())};
+ subprogramDetails->result(), context_.foldingContext())};
if (result && subpResult && *result != *subpResult &&
(!IsResultOkToDiffer(*result) || !IsResultOkToDiffer(*subpResult))) {
error =
ok = false;
} else { // check that all LEN type parameters are assumed
for (auto ref : OrderParameterDeclarations(derivedType)) {
- if (const auto *paramDetails{ref->detailsIf<TypeParamDetails>()}) {
- if (paramDetails->attr() == common::TypeParamAttr::Len) {
- const auto *value{
- ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
- if (!value || !value->isAssumed()) {
- SayWithDeclaration(*errSym, finalName,
- "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
- subroutine.name(), derivedType.name(), ref->name());
- ok = false;
- }
+ if (IsLenTypeParameter(*ref)) {
+ const auto *value{
+ ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
+ if (!value || !value->isAssumed()) {
+ SayWithDeclaration(*errSym, finalName,
+ "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
+ subroutine.name(), derivedType.name(), ref->name());
+ ok = false;
}
}
}
auto it{characterizeCache_.find(symbol)};
if (it == characterizeCache_.end()) {
auto pair{characterizeCache_.emplace(SymbolRef{symbol},
- Procedure::Characterize(symbol, context_.intrinsics()))};
+ Procedure::Characterize(symbol, context_.foldingContext()))};
it = pair.first;
}
return common::GetPtrFromOptional(it->second);
common::Restorer<const Symbol *> restorer{innermostSymbol_};
if (const Symbol * symbol{scope.symbol()}) {
innermostSymbol_ = symbol;
- } else if (scope.IsDerivedType()) {
- // PDT instantiations have no symbol.
- return;
}
- for (const auto &set : scope.equivalenceSets()) {
- CheckEquivalenceSet(set);
- }
- for (const auto &pair : scope) {
- Check(*pair.second);
- }
- for (const Scope &child : scope.children()) {
- Check(child);
- }
- if (scope.kind() == Scope::Kind::BlockData) {
- CheckBlockData(scope);
+ if (scope.IsParameterizedDerivedTypeInstantiation()) {
+ auto restorer{common::ScopedSet(scopeIsUninstantiatedPDT_, false)};
+ auto restorer2{context_.foldingContext().messages().SetContext(
+ scope.instantiationContext().get())};
+ for (const auto &pair : scope) {
+ CheckPointerInitialization(*pair.second);
+ }
+ } else {
+ auto restorer{common::ScopedSet(
+ scopeIsUninstantiatedPDT_, scope.IsParameterizedDerivedType())};
+ for (const auto &set : scope.equivalenceSets()) {
+ CheckEquivalenceSet(set);
+ }
+ for (const auto &pair : scope) {
+ Check(*pair.second);
+ }
+ for (const Scope &child : scope.children()) {
+ Check(child);
+ }
+ if (scope.kind() == Scope::Kind::BlockData) {
+ CheckBlockData(scope);
+ }
+ CheckGenericOps(scope);
}
- CheckGenericOps(scope);
}
void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &set) {
void CheckDeclarations(SemanticsContext &context) {
CheckHelper{context}.Check();
}
-
-void CheckInstantiatedDerivedType(
- SemanticsContext &context, const DerivedTypeSpec &type) {
- if (const Scope * scope{type.scope()}) {
- CheckHelper checker{context};
- for (const auto &pair : *scope) {
- checker.CheckInitialization(*pair.second);
- }
- }
-}
-
} // namespace Fortran::semantics
#define FORTRAN_SEMANTICS_CHECK_DECLARATIONS_H_
namespace Fortran::semantics {
class SemanticsContext;
-class DerivedTypeSpec;
void CheckDeclarations(SemanticsContext &);
-void CheckInstantiatedDerivedType(SemanticsContext &, const DerivedTypeSpec &);
} // namespace Fortran::semantics
#endif
}
template <typename T> void CheckForImpureCall(const T &x) {
- const auto &intrinsics{context_.foldingContext().intrinsics()};
- if (auto bad{FindImpureCall(intrinsics, x)}) {
+ if (auto bad{FindImpureCall(context_.foldingContext(), x)}) {
context_.Say(
"Impure procedure '%s' may not be referenced in a %s"_err_en_US, *bad,
LoopKindName());
if (IsPointer(symbol)) {
mutableObject.set_init(
initialization.image.AsConstantDataPointer(*symbolType));
- mutableObject.set_initWasValidated();
} else {
if (auto extents{evaluate::GetConstantExtents(context, symbol)}) {
mutableObject.set_init(
initialization.image.AsConstant(context, *symbolType, *extents));
- mutableObject.set_initWasValidated();
} else {
exprAnalyzer.Say(symbol.name(),
"internal: unknown shape for '%s' while constructing initializer from DATA"_err_en_US,
GetRank(*valueShape), symbol->name()),
*symbol);
} else if (CheckConformance(messages, *componentShape,
- *valueShape, "component", "value")) {
+ *valueShape, "component", "value", false,
+ true /* can expand scalar value */)) {
if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0 &&
!IsExpandableScalar(*converted)) {
AttachDeclaration(
}
if (std::optional<characteristics::Procedure> procedure{
characteristics::Procedure::Characterize(
- ProcedureDesignator{specific}, context_.intrinsics())}) {
+ ProcedureDesignator{specific}, context_.foldingContext())}) {
ActualArguments localActuals{actuals};
if (specific.has<semantics::ProcBindingDetails>()) {
if (!adjustActuals.value()(specific, localActuals)) {
std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
parser::CharBlock callSite, const ProcedureDesignator &proc,
ActualArguments &arguments) {
- auto chars{
- characteristics::Procedure::Characterize(proc, context_.intrinsics())};
+ auto chars{characteristics::Procedure::Characterize(
+ proc, context_.foldingContext())};
if (chars) {
bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) {
auto rhShape{GetShape(foldingContext, *rhs)};
if (lhShape && rhShape) {
return evaluate::CheckConformance(foldingContext.messages(), *lhShape,
- *rhShape, "left operand", "right operand");
+ *rhShape, "left operand", "right operand", true,
+ true /* scalar expansion is allowed */);
}
}
}
PointerAssignmentChecker(evaluate::FoldingContext &context, const Symbol &lhs)
: context_{context}, source_{lhs.name()},
description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs},
- procedure_{Procedure::Characterize(lhs, context.intrinsics())} {
+ procedure_{Procedure::Characterize(lhs, context)} {
set_lhsType(TypeAndShape::Characterize(lhs, context));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
} else if (const auto *intrinsic{f.proc().GetSpecificIntrinsic()}) {
funcName = intrinsic->name;
}
- auto proc{Procedure::Characterize(f.proc(), context_.intrinsics())};
+ auto proc{Procedure::Characterize(f.proc(), context_)};
if (!proc) {
return false;
}
}
bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
- if (auto chars{Procedure::Characterize(d, context_.intrinsics())}) {
+ if (auto chars{Procedure::Characterize(d, context_)}) {
return Check(d.GetName(), false, &*chars);
} else {
return Check(d.GetName(), false);
bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
const Procedure *procedure{nullptr};
- auto chars{Procedure::Characterize(ref, context_.intrinsics())};
+ auto chars{Procedure::Characterize(ref, context_)};
if (chars) {
procedure = &*chars;
if (chars->functionResult) {
template <typename... A>
parser::Message *PointerAssignmentChecker::Say(A &&...x) {
auto *msg{context_.messages().Say(std::forward<A>(x)...)};
- if (lhs_) {
- return evaluate::AttachDeclaration(msg, *lhs_);
- } else if (!source_.empty()) {
- msg->Attach(source_, "Declaration of %s"_en_US, description_);
+ if (msg) {
+ if (lhs_) {
+ return evaluate::AttachDeclaration(msg, *lhs_);
+ }
+ if (!source_.empty()) {
+ msg->Attach(source_, "Declaration of %s"_en_US, description_);
+ }
}
return msg;
}
}
}
if (isBoundsRemapping && rhs.Rank() != 1 &&
- !evaluate::IsSimplyContiguous(rhs, context.intrinsics())) {
+ !evaluate::IsSimplyContiguous(rhs, context)) {
messages.Say("Pointer bounds remapping target must have rank 1 or be"
" simply contiguous"_err_en_US); // 10.2.2.3(9)
}
}
template <typename T>
- MaybeExpr EvaluateConvertedExpr(
+ MaybeExpr EvaluateNonPointerInitializer(
const Symbol &symbol, const T &expr, parser::CharBlock source) {
- if (context().HasError(symbol)) {
- return std::nullopt;
- }
- if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) {
- if (auto converted{
- evaluate::ConvertToType(symbol, std::move(*maybeExpr))}) {
- return FoldExpr(std::move(*converted));
- }
- if (auto exprType{maybeExpr->GetType()}) {
- Say(source,
- "Initialization expression could not be converted to declared type of '%s' from %s"_err_en_US,
- symbol.name(), exprType->AsFortran());
- } else {
- Say(source,
- "Initialization expression could not be converted to declared type of '%s'"_err_en_US,
- symbol.name());
+ if (!context().HasError(symbol)) {
+ if (auto maybeExpr{AnalyzeExpr(*context_, expr)}) {
+ auto restorer{GetFoldingContext().messages().SetLocation(source)};
+ return evaluate::NonPointerInitializationExpr(
+ symbol, std::move(*maybeExpr), GetFoldingContext());
}
}
return std::nullopt;
void PointerInitialization(
const parser::Name &, const parser::ProcPointerInit &);
void NonPointerInitialization(
- const parser::Name &, const parser::ConstantExpr &, bool inComponentDecl);
+ const parser::Name &, const parser::ConstantExpr &);
void CheckExplicitInterface(const parser::Name &);
void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &);
bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
bool IsUplevelReference(const Symbol &);
const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
- bool CheckInitialDataTarget(const Symbol &, const SomeExpr &, SourceName);
- void CheckInitialProcTarget(const Symbol &, const parser::Name &, SourceName);
void Initialization(const parser::Name &, const parser::Initialization &,
bool inComponentDecl);
bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol);
const auto &expr{std::get<parser::ConstantExpr>(x.t)};
ApplyImplicitRules(symbol);
Walk(expr);
- if (auto converted{
- EvaluateConvertedExpr(symbol, expr, expr.thing.value().source)}) {
+ if (auto converted{EvaluateNonPointerInitializer(
+ symbol, expr, expr.thing.value().source)}) {
symbol.get<ObjectEntityDetails>().set_init(std::move(*converted));
}
return false;
SetType(name, *type);
if (auto &init{
std::get<std::optional<parser::ScalarIntConstantExpr>>(decl.t)}) {
- if (auto maybeExpr{EvaluateConvertedExpr(
+ if (auto maybeExpr{EvaluateNonPointerInitializer(
*symbol, *init, init->thing.thing.thing.value().source)}) {
- auto *intExpr{std::get_if<SomeIntExpr>(&maybeExpr->u)};
- CHECK(intExpr);
- symbol->get<TypeParamDetails>().set_init(std::move(*intExpr));
+ if (auto *intExpr{std::get_if<SomeIntExpr>(&maybeExpr->u)}) {
+ symbol->get<TypeParamDetails>().set_init(std::move(*intExpr));
+ }
}
}
}
return nullptr;
}
-// C764, C765
-bool DeclarationVisitor::CheckInitialDataTarget(
- const Symbol &pointer, const SomeExpr &expr, SourceName source) {
- auto &context{GetFoldingContext()};
- auto restorer{context.messages().SetLocation(source)};
- auto dyType{evaluate::DynamicType::From(pointer)};
- CHECK(dyType);
- auto designator{evaluate::TypedWrapper<evaluate::Designator>(
- *dyType, evaluate::DataRef{pointer})};
- CHECK(designator);
- return CheckInitialTarget(context, *designator, expr);
-}
-
-void DeclarationVisitor::CheckInitialProcTarget(
- const Symbol &pointer, const parser::Name &target, SourceName source) {
- // C1519 - must be nonelemental external or module procedure,
- // or an unrestricted specific intrinsic function.
- if (const Symbol * targetSym{target.symbol}) {
- const Symbol &ultimate{targetSym->GetUltimate()};
- if (ultimate.attrs().test(Attr::INTRINSIC)) {
- } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
- ultimate.owner().kind() != Scope::Kind::Module) {
- Say(source,
- "Procedure pointer '%s' initializer '%s' is neither "
- "an external nor a module procedure"_err_en_US,
- pointer.name(), ultimate.name());
- } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
- Say(source,
- "Procedure pointer '%s' cannot be initialized with the "
- "elemental procedure '%s"_err_en_US,
- pointer.name(), ultimate.name());
- } else {
- // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
- }
- }
-}
-
void DeclarationVisitor::Initialization(const parser::Name &name,
const parser::Initialization &init, bool inComponentDecl) {
// Traversal of the initializer was deferred to here so that the
}
Symbol &ultimate{name.symbol->GetUltimate()};
if (IsAllocatable(ultimate)) {
- Say(name, "Allocatable component '%s' cannot be initialized"_err_en_US);
- return;
- }
- if (std::holds_alternative<parser::InitialDataTarget>(init.u)) {
- // Defer analysis further to the end of the specification parts so that
- // forward references and attribute checks (e.g., SAVE) work better.
- // TODO: But pointer initializers of components in named constants of
- // derived types may still need more attention.
+ Say(name, "Allocatable object '%s' cannot be initialized"_err_en_US);
return;
}
if (auto *object{ultimate.detailsIf<ObjectEntityDetails>()}) {
std::visit(
common::visitors{
[&](const parser::ConstantExpr &expr) {
- NonPointerInitialization(name, expr, inComponentDecl);
+ NonPointerInitialization(name, expr);
},
[&](const parser::NullInit &null) {
Walk(null);
}
},
[&](const parser::InitialDataTarget &) {
- DIE("InitialDataTarget can't appear here");
+ // Defer analysis to the end of the specification part
+ // so that forward references and attribute checks like SAVE
+ // work better.
},
[&](const std::list<Indirection<parser::DataStmtValue>> &) {
// TODO: Need to Walk(init.u); when implementing this case
CHECK(!details->init());
Walk(target);
if (MaybeExpr expr{EvaluateExpr(target)}) {
- CheckInitialDataTarget(ultimate, *expr, target.value().source);
+ // Validation is done in declaration checking.
details->set_init(std::move(*expr));
}
}
CHECK(!details.init());
Walk(target);
if (const auto *targetName{std::get_if<parser::Name>(&target.u)}) {
- CheckInitialProcTarget(ultimate, *targetName, name.source);
if (targetName->symbol) {
+ // Validation is done in declaration checking.
details.set_init(*targetName->symbol);
}
} else {
}
}
-void DeclarationVisitor::NonPointerInitialization(const parser::Name &name,
- const parser::ConstantExpr &expr, bool inComponentDecl) {
+void DeclarationVisitor::NonPointerInitialization(
+ const parser::Name &name, const parser::ConstantExpr &expr) {
if (name.symbol) {
Symbol &ultimate{name.symbol->GetUltimate()};
if (!context().HasError(ultimate)) {
} else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
CHECK(!details->init());
Walk(expr);
- if (inComponentDecl) {
- // TODO: check C762 - all bounds and type parameters of component
- // are colons or constant expressions if component is initialized
+ if (ultimate.owner().IsParameterizedDerivedType()) {
// Can't convert to type of component, which might not yet
- // be known; that's done later during instantiation.
+ // be known; that's done later during PDT instantiation.
if (MaybeExpr value{EvaluateExpr(expr)}) {
details->set_init(std::move(*value));
}
- } else if (MaybeExpr folded{EvaluateConvertedExpr(
+ } else if (MaybeExpr folded{EvaluateNonPointerInitializer(
ultimate, expr, expr.thing.value().source)}) {
details->set_init(std::move(*folded));
}
return; // error occurred creating scope
}
SetScope(*node.scope());
- // The initializers of pointers, pointer components, and non-deferred
- // type-bound procedure bindings have not yet been traversed.
+ // The initializers of pointers, the default initializers of pointer
+ // components, and non-deferred type-bound procedure bindings have not
+ // yet been traversed.
// We do that now, when any (formerly) forward references that appear
- // in those initializers will resolve to the right symbols.
+ // in those initializers will resolve to the right symbols without
+ // incurring spurious errors with IMPLICIT NONE.
DeferredCheckVisitor{*this}.Walk(node.spec());
DeferredCheckVisitor{*this}.Walk(node.exec()); // for BLOCK
for (Scope &childScope : currScope().children()) {
- if (childScope.IsDerivedType() && !childScope.symbol()) {
+ if (childScope.IsParameterizedDerivedTypeInstantiation()) {
FinishDerivedTypeInstantiation(childScope);
}
}
}
}
-// Fold object pointer initializer designators with the actual
-// type parameter values of a particular instantiation.
+// Duplicate and fold component object pointer default initializer designators
+// using the actual type parameter values of each particular instantiation.
+// Validation is done later in declaration checking.
void ResolveNamesVisitor::FinishDerivedTypeInstantiation(Scope &scope) {
CHECK(scope.IsDerivedType() && !scope.symbol());
if (DerivedTypeSpec * spec{scope.derivedTypeSpec()}) {
}
}
-bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements) {
+bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements,
+ const Symbol *derivedTypeSymbol) {
if (!ignoreDATAstatements && symbol.test(Symbol::Flag::InDataStmt)) {
return true;
} else if (IsNamedConstant(symbol)) {
return true;
} else if (!IsPointer(symbol) && object->type()) {
if (const auto *derived{object->type()->AsDerived()}) {
- if (derived->HasDefaultInitialization()) {
+ if (&derived->typeSymbol() == derivedTypeSymbol) {
+ // error recovery: avoid infinite recursion on invalid
+ // recursive usage of a derived type
+ } else if (derived->HasDefaultInitialization()) {
return true;
}
}
if (!FindParameter(name)) {
const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
if (details.init()) {
- auto expr{
- evaluate::Fold(foldingContext, common::Clone(details.init()))};
- AddParamValue(name, ParamValue{std::move(*expr), details.attr()});
+ auto expr{evaluate::Fold(foldingContext, SomeExpr{*details.init()})};
+ AddParamValue(name,
+ ParamValue{
+ std::move(std::get<SomeIntExpr>(expr.u)), details.attr()});
} else if (!context.HasError(symbol)) {
messages.Say(name_,
"Type parameter '%s' lacks a value and has no default"_err_en_US,
bool DerivedTypeSpec::HasDefaultInitialization() const {
DirectComponentIterator components{*this};
- return bool{std::find_if(components.begin(), components.end(),
- [](const Symbol &component) { return IsInitialized(component); })};
+ return bool{std::find_if(
+ components.begin(), components.end(), [&](const Symbol &component) {
+ return IsInitialized(component, false, &typeSymbol());
+ })};
}
ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
}
}
}
+ if (!IsPointer(symbol)) {
+ if (auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (MaybeExpr & init{object->init()}) {
+ auto restorer{foldingContext.messages().SetLocation(symbol.name())};
+ init = evaluate::NonPointerInitializationExpr(
+ symbol, std::move(*init), foldingContext);
+ }
+ }
+ }
}
return;
}
Scope &newScope{containingScope.MakeScope(Scope::Kind::DerivedType)};
newScope.set_derivedTypeSpec(*this);
ReplaceScope(newScope);
+ auto restorer{foldingContext.WithPDTInstance(*this)};
+ std::string desc{typeSymbol_.name().ToString()};
+ char sep{'('};
for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {
const SourceName &name{symbol.name()};
if (typeScope.find(symbol.name()) != typeScope.end()) {
const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
paramValue->set_attr(details.attr());
if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
- // Ensure that any kind type parameters with values are
- // constant by now.
- if (details.attr() == common::TypeParamAttr::Kind) {
- // Any errors in rank and type will have already elicited
- // messages, so don't pile on by complaining further here.
- if (auto maybeDynamicType{expr->GetType()}) {
- if (expr->Rank() == 0 &&
- maybeDynamicType->category() == TypeCategory::Integer) {
- if (!evaluate::ToInt64(*expr)) {
- if (auto *msg{foldingContext.messages().Say(
- "Value of kind type parameter '%s' (%s) is not "
- "a scalar INTEGER constant"_err_en_US,
- name, expr->AsFortran())}) {
- msg->Attach(name, "declared here"_en_US);
- }
- }
- }
+ if (auto folded{evaluate::NonPointerInitializationExpr(symbol,
+ SomeExpr{std::move(*expr)}, foldingContext, &newScope)}) {
+ desc += sep;
+ desc += name.ToString();
+ desc += '=';
+ desc += folded->AsFortran();
+ sep = ',';
+ TypeParamDetails instanceDetails{details.attr()};
+ if (const DeclTypeSpec * type{details.type()}) {
+ instanceDetails.set_type(*type);
}
+ instanceDetails.set_init(
+ std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*folded))));
+ newScope.try_emplace(name, std::move(instanceDetails));
}
- TypeParamDetails instanceDetails{details.attr()};
- if (const DeclTypeSpec * type{details.type()}) {
- instanceDetails.set_type(*type);
- }
- instanceDetails.set_init(std::move(*expr));
- newScope.try_emplace(name, std::move(instanceDetails));
}
}
}
}
+ parser::Message *contextMessage{nullptr};
+ if (sep != '(') {
+ desc += ')';
+ contextMessage = new parser::Message{foldingContext.messages().at(),
+ "instantiation of parameterized derived type '%s'"_en_US, desc};
+ if (auto outer{containingScope.instantiationContext()}) {
+ contextMessage->SetContext(outer.get());
+ }
+ newScope.set_instantiationContext(contextMessage);
+ }
// Instantiate every non-parameter symbol from the original derived
// type's scope into the new instance.
- auto restorer{foldingContext.WithPDTInstance(*this)};
newScope.AddSourceRange(typeScope.sourceRange());
+ auto restorer2{foldingContext.messages().SetContext(contextMessage)};
InstantiateHelper{context, newScope}.InstantiateComponents(typeScope);
- CheckInstantiatedDerivedType(context, *this);
}
void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {
if (const DeclTypeSpec * newType{InstantiateType(newSymbol)}) {
details->ReplaceType(*newType);
}
- details->set_init(Fold(std::move(details->init())));
for (ShapeSpec &dim : details->shape()) {
if (dim.lbound().isExplicit()) {
dim.lbound().SetExplicit(Fold(std::move(dim.lbound().GetExplicit())));
dim.ubound().SetExplicit(Fold(std::move(dim.ubound().GetExplicit())));
}
}
+ if (MaybeExpr & init{details->init()}) {
+ // Non-pointer components with default initializers are
+ // processed now so that those default initializers can be used
+ // in PARAMETER structure constructors.
+ auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
+ init = IsPointer(newSymbol)
+ ? evaluate::Fold(foldingContext(), std::move(*init))
+ : evaluate::NonPointerInitializationExpr(
+ newSymbol, std::move(*init), foldingContext());
+ }
}
}
!ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name
real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)]
+ !ERROR: Value of named constant 'bad2' ([INTEGER(4)::(int(j,kind=4),INTEGER(8)::j=1_8,1_8,0_8)]) cannot be computed as a constant value
!ERROR: The stride of an implied DO loop must not be zero
integer, parameter :: bad2(*) = [(j, j=1,1,0)]
end subroutine checkC7115
end type
type(large) largeNumber
type(large), allocatable :: allocatableLarge
- !ERROR: An automatic variable must not be initialized
+ !ERROR: An automatic variable or component must not be initialized
type(large) :: largeNumberArray(i)
type(large) :: largeArray(5)
character :: name(i)
subroutine dataobjects(j)
integer, intent(in) :: j
real, parameter :: x1(*) = [1., 2.]
-!ERROR: Implied-shape array 'x2' has rank 2, but its initializer has rank 1
+!ERROR: Implied-shape parameter 'x2' has rank 2 but its initializer has rank 1
real, parameter :: x2(*,*) = [1., 2.]
-!ERROR: Shape of 'x3' is not implied, deferred, nor constant
+!ERROR: Named constant 'x3' array must have constant shape
real, parameter :: x3(j) = [1., 2.]
-!ERROR: An automatic variable must not be initialized
+!ERROR: Shape of initialized object 'x4' must be constant
real :: x4(j) = [1., 2.]
-!ERROR: 'x5' has rank 2, but its initializer has rank 1
+!ERROR: Rank of initialized object is 2, but initialization expression has rank 1
real :: x5(2,2) = [1., 2., 3., 4.]
real :: x6(2,2) = 5.
-!ERROR: 'x7' has rank 0, but its initializer has rank 1
+!ERROR: Rank of initialized object is 0, but initialization expression has rank 1
real :: x7 = [1.]
real :: x8(2,2) = reshape([1., 2., 3., 4.], [2, 2])
-!ERROR: Dimension 1 of object has extent 3, but initializer has extent 2
+!ERROR: Dimension 1 of initialized object has extent 3, but initialization expression has extent 2
real :: x9(3) = [1., 2.]
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
real :: x10(2,3) = reshape([real::(k,k=1,6)], [3, 2])
end subroutine
real, save :: a3
real, target, save :: a4
type :: t1
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
real :: x1(2) = [1., 2., 3.]
end type
type :: t2(kind, len)
integer, kind :: kind
integer, len :: len
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
real :: x1(2) = [1., 2., 3.]
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
real :: x2(kind) = [1., 2., 3.]
+!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
+!ERROR: An automatic variable or component must not be initialized
real :: x3(len) = [1., 2., 3.]
real, pointer :: p1(:) => a1
!ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
+!ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
real, pointer :: p2 => a2
!ERROR: An initial data target may not be a reference to an object 'a3' that lacks the TARGET attribute
+!ERROR: An initial data target may not be a reference to an object 'a3' that lacks the TARGET attribute
real, pointer :: p3 => a3
!ERROR: Pointer has rank 0 but target has rank 1
+!ERROR: Pointer has rank 0 but target has rank 1
real, pointer :: p4 => a1
!ERROR: Pointer has rank 1 but target has rank 0
+!ERROR: Pointer has rank 1 but target has rank 0
real, pointer :: p5(:) => a4
end type
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
type(t2(3,3)) :: o1
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
-!ERROR: Dimension 1 of object has extent 2, but initializer has extent 3
type(t2(2,2)) :: o2
end subroutine
real :: u(l*2)
!ERROR: Must have INTEGER type, but is REAL(4)
character(len=l) :: v
-!ERROR: Initialization expression for PARAMETER 'o' (o) cannot be computed as a constant value
+!ERROR: Value of named constant 'o' (o) cannot be computed as a constant value
real, parameter :: o = o
!ERROR: Must be a constant value
integer, parameter :: p = 0/0
integer, kind :: kind
integer, len :: len
!ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+ !ERROR: An automatic variable or component must not be initialized
type(recursive2(kind,len)) :: bad1
type(recursive2(kind,len)), pointer :: ok1
type(recursive2(kind,len)), allocatable :: ok2
!ERROR: Recursive use of the derived type requires POINTER or ALLOCATABLE
+ !ERROR: An automatic variable or component must not be initialized
!ERROR: CLASS entity 'bad2' must be a dummy argument or have ALLOCATABLE or POINTER attribute
class(recursive2(kind,len)) :: bad2
class(recursive2(kind,len)), pointer :: ok3
real :: b(*,*) ! C836
!ERROR: Implied-shape array 'c' must be a named constant
real :: c(*) ! C836
- !ERROR: Named constant 'd' array must have explicit or implied shape
+ !ERROR: Named constant 'd' array must have constant or implied shape
integer, parameter :: d(:) = [1, 2, 3]
end
end type derived
type (derived(constVal, 3)) :: constDerivedKind
-!ERROR: Value of kind type parameter 'typekind' (nonconstval) is not a scalar INTEGER constant
+!ERROR: Value of kind type parameter 'typekind' (nonconstval) must be a scalar INTEGER constant
!ERROR: Invalid specification expression: reference to local entity 'nonconstval'
type (derived(nonConstVal, 3)) :: nonConstDerivedKind
integer(kind=ik) :: ix = 0
real(kind=rk) :: rx = 0.
complex(kind=zk) :: zx = (0.,0.)
+ !ERROR: An automatic variable or component must not be initialized
character(kind=ck,len=len) :: cx = ' '
logical(kind=lk) :: lx = .false.
real(kind=rk), pointer :: rp => NULL()
// Temporary Fortran front end driver main program for development scaffolding.
+#include "f18_version.h"
#include "flang/Common/Fortran-features.h"
#include "flang/Common/default-kinds.h"
#include "flang/Evaluate/expression.h"
#include "llvm/Support/Errno.h"
#include "llvm/Support/FileSystem.h"
#include "llvm/Support/Program.h"
+#include "llvm/Support/Signals.h"
#include "llvm/Support/raw_ostream.h"
#include <cstdio>
#include <cstring>
#include <string>
#include <vector>
-#include "f18_version.h"
-
static std::list<std::string> argList(int argc, char *const argv[]) {
std::list<std::string> result;
for (int j = 0; j < argc; ++j) {
return exitStatus;
} else if (arg == "-V" || arg == "--version") {
return printVersion();
+ } else if (arg == "-fdebug-stack-trace") {
+ llvm::sys::PrintStackTraceOnErrorSignal(llvm::StringRef{}, true);
} else {
driver.F18_FCArgs.push_back(arg);
if (arg == "-v") {