[llvm-branch-commits] [flang] 641ede9 - [flang] Improve initializer semantics, esp. for component default values
peter klausler via llvm-branch-commits
llvm-branch-commits at lists.llvm.org
Mon Dec 7 14:45:41 PST 2020
Author: peter klausler
Date: 2020-12-07T14:40:41-08:00
New Revision: 641ede93efd664cc2e1d1788b195a80b50b36f66
URL: https://github.com/llvm/llvm-project/commit/641ede93efd664cc2e1d1788b195a80b50b36f66
DIFF: https://github.com/llvm/llvm-project/commit/641ede93efd664cc2e1d1788b195a80b50b36f66.diff
LOG: [flang] Improve initializer semantics, esp. for component default values
This patch plugs many holes in static initializer semantics, improves error
messages for default initial values and other component properties in
parameterized derived type instantiations, and cleans up several small
issues noticed during development. We now do proper scalar expansion,
folding, and type, rank, and shape conformance checking for component
default initializers in derived types and PDT instantiations.
The initial values of named constants are now guaranteed to have been folded
when installed in the symbol table, and are no longer folded or
scalar-expanded at each use in expression folding. Semantics documentation
was extended with information about the various kinds of initializations
in Fortran and when each of them are processed in the compiler.
Some necessary concomitant changes have bulked this patch out a bit:
* contextual messages attachments, which are now produced for parameterized
derived type instantiations so that the user can figure out which
instance caused a problem with a component, have been added as part
of ContextualMessages, and their implementation was debugged
* several APIs in evaluate::characteristics was changed so that a FoldingContext
is passed as an argument rather than just its intrinsic procedure table;
this affected client call sites in many files
* new tools in Evaluate/check-expression.cpp to determine when an Expr
actually is a single constant value and to validate a non-pointer
variable initializer or object component default value
* shape conformance checking has additional arguments that control
whether scalar expansion is allowed
* several now-unused functions and data members noticed and removed
* several crashes and bogus errors exposed by testing this new code
were fixed
* a -fdebug-stack-trace option to enable LLVM's stack tracing on
a crash, which might be useful in the future
TL;DR: Initialization processing does more and takes place at the right
times for all of the various kinds of things that can be initialized.
Differential Review: https://reviews.llvm.org/D92783
Added:
Modified:
flang/docs/Semantics.md
flang/include/flang/Common/reference-counted.h
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/check-expression.h
flang/include/flang/Evaluate/common.h
flang/include/flang/Evaluate/shape.h
flang/include/flang/Evaluate/tools.h
flang/include/flang/Evaluate/type.h
flang/include/flang/Parser/message.h
flang/include/flang/Semantics/scope.h
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/check-expression.cpp
flang/lib/Evaluate/fold-implementation.h
flang/lib/Evaluate/fold-logical.cpp
flang/lib/Evaluate/fold.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/shape.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Parser/message.cpp
flang/lib/Parser/parse-tree.cpp
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/check-declarations.h
flang/lib/Semantics/check-do-forall.cpp
flang/lib/Semantics/data-to-inits.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/tools.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/array-constr-values.f90
flang/test/Semantics/data04.f90
flang/test/Semantics/init01.f90
flang/test/Semantics/resolve37.f90
flang/test/Semantics/resolve44.f90
flang/test/Semantics/resolve58.f90
flang/test/Semantics/resolve69.f90
flang/test/Semantics/structconst02.f90
flang/tools/f18/f18.cpp
Removed:
################################################################################
diff --git a/flang/docs/Semantics.md b/flang/docs/Semantics.md
index 361426c936c2..270a1033c4c9 100644
--- a/flang/docs/Semantics.md
+++ b/flang/docs/Semantics.md
@@ -147,6 +147,49 @@ By this phase, all names and expressions that can be successfully resolved
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
diff --git a/flang/include/flang/Common/reference-counted.h b/flang/include/flang/Common/reference-counted.h
index 6aae6cface46..de91d4fb6ee8 100644
--- a/flang/include/flang/Common/reference-counted.h
+++ b/flang/include/flang/Common/reference-counted.h
@@ -19,6 +19,7 @@ namespace Fortran::common {
template <typename A> class ReferenceCounted {
public:
ReferenceCounted() {}
+ int references() const { return references_; }
void TakeReference() { ++references_; }
void DropReference() {
if (--references_ == 0) {
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 7ca8f9ad5d68..bd0e1bf8186e 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -32,9 +32,6 @@ namespace llvm {
class raw_ostream;
}
-namespace Fortran::evaluate {
-class IntrinsicProcTable;
-}
namespace Fortran::evaluate::characteristics {
struct Procedure;
}
@@ -82,7 +79,7 @@ class TypeAndShape {
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(
@@ -160,7 +157,7 @@ class TypeAndShape {
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:
@@ -184,7 +181,8 @@ struct DummyDataObject {
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;
@@ -202,7 +200,7 @@ struct DummyProcedure {
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};
@@ -228,7 +226,7 @@ struct DummyArgument {
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;
@@ -259,7 +257,7 @@ struct FunctionResult {
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;
@@ -297,11 +295,11 @@ struct Procedure {
// 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.
diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h
index c5f5f39a73d0..f1aab7b57947 100644
--- a/flang/include/flang/Evaluate/check-expression.h
+++ b/flang/include/flang/Evaluate/check-expression.h
@@ -24,7 +24,6 @@ class Scope;
}
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
@@ -35,6 +34,12 @@ extern template bool IsConstantExpr(const Expr<SomeInteger> &);
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
@@ -46,38 +51,44 @@ bool IsInitialProcedureTarget(const Symbol &);
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
diff --git a/flang/include/flang/Evaluate/common.h b/flang/include/flang/Evaluate/common.h
index d726ebfb1034..5328f007bf40 100644
--- a/flang/include/flang/Evaluate/common.h
+++ b/flang/include/flang/Evaluate/common.h
@@ -236,7 +236,7 @@ class FoldingContext {
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;
diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h
index 08fb70efb564..dc76afe57b40 100644
--- a/flang/include/flang/Evaluate/shape.h
+++ b/flang/include/flang/Evaluate/shape.h
@@ -210,7 +210,8 @@ std::optional<ConstantSubscripts> GetConstantExtents(
// 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
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 7df91e13dc58..e7305d47ed10 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -233,7 +233,11 @@ bool IsArrayElement(const Expr<T> &expr, bool intoSubstring = false) {
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;
}
@@ -830,9 +834,9 @@ parser::Message *SayWithDeclaration(
// 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?
@@ -857,6 +861,41 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
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 {
@@ -875,6 +914,8 @@ bool IsProcedurePointer(const Symbol &);
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 &);
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index fc274bf05398..3326857fc34f 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -421,9 +421,6 @@ int SelectedIntKind(std::int64_t precision = 0);
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)
diff --git a/flang/include/flang/Parser/message.h b/flang/include/flang/Parser/message.h
index 8286384bb210..13f30879dc4f 100644
--- a/flang/include/flang/Parser/message.h
+++ b/flang/include/flang/Parser/message.h
@@ -255,6 +255,7 @@ class ContextualMessages {
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
@@ -265,6 +266,13 @@ class ContextualMessages {
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) {
@@ -277,7 +285,11 @@ class ContextualMessages {
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;
}
@@ -290,6 +302,7 @@ class ContextualMessages {
private:
CharBlock at_;
Messages *messages_{nullptr};
+ Message::Reference contextMessage_;
};
} // namespace Fortran::parser
#endif // FORTRAN_PARSER_MESSAGE_H_
diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h
index a69263b44e6a..cae94dfac9e8 100644
--- a/flang/include/flang/Semantics/scope.h
+++ b/flang/include/flang/Semantics/scope.h
@@ -94,6 +94,9 @@ class Scope {
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_; }
@@ -207,9 +210,16 @@ class Scope {
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; }
@@ -249,6 +259,7 @@ class Scope {
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().
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index 833e3ab77720..dc7196cfd5ea 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -167,8 +167,6 @@ class ObjectEntityDetails : public EntityDetails {
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_; }
@@ -190,7 +188,6 @@ class ObjectEntityDetails : public EntityDetails {
private:
MaybeExpr init_;
- bool initWasValidated_{false};
ArraySpec shape_;
ArraySpec coshape_;
const Symbol *commonBlock_{nullptr}; // common block this object is in
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 033c496c24b4..ffbb1d840a26 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -102,7 +102,8 @@ bool IsIsoCType(const DerivedTypeSpec *);
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 &);
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index e4e904cc1bbb..f88e518b4891 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -65,7 +65,7 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
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()}) {
@@ -84,6 +84,13 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
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);
},
@@ -99,10 +106,10 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
}
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;
@@ -153,7 +160,8 @@ bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
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(
@@ -170,7 +178,8 @@ 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()) {
@@ -196,7 +205,7 @@ void TypeAndShape::AcquireShape(const semantics::ObjectEntityDetails &object) {
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);
}
@@ -251,9 +260,9 @@ static common::Intent GetIntent(const semantics::Attrs &attrs) {
}
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,
@@ -320,8 +329,8 @@ bool DummyProcedure::operator==(const DummyProcedure &that) const {
}
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
@@ -360,13 +369,13 @@ bool DummyArgument::operator==(const DummyArgument &that) const {
}
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;
@@ -387,8 +396,7 @@ std::optional<DummyArgument> DummyArgument::FromActual(
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 {
@@ -396,8 +404,7 @@ std::optional<DummyArgument> DummyArgument::FromActual(
}
},
[&](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 {
@@ -497,9 +504,9 @@ bool FunctionResult::operator==(const FunctionResult &that) const {
}
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,
{
@@ -509,7 +516,7 @@ std::optional<FunctionResult> FunctionResult::Characterize(
});
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;
@@ -623,7 +630,7 @@ bool Procedure::CanOverride(
}
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,
@@ -641,8 +648,8 @@ std::optional<Procedure> Procedure::Characterize(
[&](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;
@@ -654,7 +661,7 @@ std::optional<Procedure> Procedure::Characterize(
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 {
@@ -666,12 +673,12 @@ std::optional<Procedure> Procedure::Characterize(
[&](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()};
@@ -692,7 +699,7 @@ std::optional<Procedure> Procedure::Characterize(
}
},
[&](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) {
@@ -709,10 +716,10 @@ std::optional<Procedure> Procedure::Characterize(
}
},
[&](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>{}; },
},
@@ -720,10 +727,10 @@ std::optional<Procedure> Procedure::Characterize(
}
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()}) {
@@ -733,8 +740,8 @@ std::optional<Procedure> Procedure::Characterize(
}
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()}) {
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index a56d31db3dca..6714588b9b6e 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -7,6 +7,7 @@
//===----------------------------------------------------------------------===//
#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"
@@ -30,7 +31,7 @@ class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
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()};
@@ -99,6 +100,28 @@ template bool IsConstantExpr(const Expr<SomeInteger> &);
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.
@@ -243,6 +266,110 @@ bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
}
}
+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,
@@ -251,8 +378,8 @@ class 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 {
@@ -338,7 +465,7 @@ class CheckSpecificationExprHelper
} 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)) {
@@ -346,7 +473,7 @@ class CheckSpecificationExprHelper
"' 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 +
@@ -367,38 +494,34 @@ class CheckSpecificationExprHelper
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
@@ -406,8 +529,8 @@ 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 {
@@ -448,7 +571,7 @@ class IsSimplyContiguousHelper
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() &&
@@ -487,20 +610,37 @@ class IsSimplyContiguousHelper
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
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 4b22a593df91..4fa5f6a4c883 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -49,8 +49,7 @@ 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> &&,
@@ -142,87 +141,14 @@ Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
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;
@@ -242,7 +168,7 @@ std::optional<Constant<T>> Folder<T>::Folding(ArrayRef &aRef) {
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;
@@ -373,8 +299,7 @@ std::optional<Constant<T>> Folder<T>::GetConstantComponent(Component &component,
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);
@@ -413,7 +338,7 @@ template <typename T> Expr<T> Folder<T>::Folding(Designator<T> &&designator) {
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)};
diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp
index b22c742b0ea6..827127f14862 100644
--- a/flang/lib/Evaluate/fold-logical.cpp
+++ b/flang/lib/Evaluate/fold-logical.cpp
@@ -101,7 +101,7 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
} 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};
}
}
diff --git a/flang/lib/Evaluate/fold.cpp b/flang/lib/Evaluate/fold.cpp
index 971149af1f7c..4f888ea20147 100644
--- a/flang/lib/Evaluate/fold.cpp
+++ b/flang/lib/Evaluate/fold.cpp
@@ -55,50 +55,26 @@ std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
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;
}
}
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 2d8ad85a1e59..0fe5ac8ab75b 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1635,8 +1635,7 @@ class IntrinsicProcTable::Implementation {
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;
@@ -1760,8 +1759,7 @@ bool CheckAndRearrangeArguments(ActualArguments &arguments,
// 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]) {
@@ -1775,7 +1773,7 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
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) {
@@ -1900,21 +1898,19 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
}
}
-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{
@@ -1926,7 +1922,7 @@ static bool CheckAssociated(SpecificCall &call,
std::get_if<ProcedureRef>(&targetExpr->u)}) {
if (auto targetRefedChars{
characteristics::Procedure::Characterize(
- *targetProcRef, intrinsics)}) {
+ *targetProcRef, context)}) {
targetProc = *targetRefedChars;
targetName = targetProcRef->proc().GetName() + "()";
isCall = true;
@@ -1934,7 +1930,7 @@ static bool CheckAssociated(SpecificCall &call,
} else if (targetSymbol && !targetProc) {
// proc that's not a call
targetProc = characteristics::Procedure::Characterize(
- *targetSymbol, intrinsics);
+ *targetSymbol, context);
targetName = targetSymbol->name().ToString();
}
@@ -1945,7 +1941,7 @@ static bool CheckAssociated(SpecificCall &call,
CheckProcCompatibility(
isCall, pointerProc, &*targetProc)}) {
AttachDeclaration(
- messages.Say(std::move(*msg),
+ context.messages().Say(std::move(*msg),
"pointer '" + pointerSymbol->name().ToString() +
"'",
targetName),
@@ -1955,7 +1951,7 @@ static bool CheckAssociated(SpecificCall &call,
// 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,
@@ -1966,9 +1962,10 @@ static bool CheckAssociated(SpecificCall &call,
} 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 {
@@ -1978,9 +1975,10 @@ static bool CheckAssociated(SpecificCall &call,
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);
}
@@ -2002,16 +2000,14 @@ static bool CheckAssociated(SpecificCall &call,
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") {
@@ -2023,17 +2019,17 @@ static bool ApplySpecificChecks(SpecificCall &call,
}
}
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") {
@@ -2045,7 +2041,7 @@ static bool ApplySpecificChecks(SpecificCall &call,
}
}
if (!ok) {
- messages.Say(
+ context.messages().Say(
"Argument of PRESENT() must be the name of an OPTIONAL dummy argument"_err_en_US);
}
}
@@ -2085,7 +2081,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
}
} else {
if (call.name == "null") {
- return HandleNull(arguments, context, intrinsics);
+ return HandleNull(arguments, context);
}
}
@@ -2134,7 +2130,7 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
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;
}
}
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index c672cc1a0cd7..37373ae95692 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -24,12 +24,9 @@ namespace Fortran::evaluate {
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) {
@@ -685,28 +682,32 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
// 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;
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index afad30271c1c..1ae0fce193b1 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -815,10 +815,7 @@ parser::Message *AttachDeclaration(
parser::Message *AttachDeclaration(
parser::Message *message, const Symbol &symbol) {
- if (message) {
- AttachDeclaration(*message, symbol);
- }
- return message;
+ return message ? AttachDeclaration(*message, symbol) : nullptr;
}
class FindImpureCallHelper
@@ -827,12 +824,11 @@ 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());
}
@@ -841,16 +837,16 @@ class FindImpureCallHelper
}
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
@@ -1066,6 +1062,16 @@ bool IsFunctionResult(const Symbol &symbol) {
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(); });
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index e370f2b05b95..aa9db16b1e50 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -301,11 +301,6 @@ static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
}
}
-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,
diff --git a/flang/lib/Parser/message.cpp b/flang/lib/Parser/message.cpp
index bef55f3d8176..d1c29fb76a8d 100644
--- a/flang/lib/Parser/message.cpp
+++ b/flang/lib/Parser/message.cpp
@@ -197,25 +197,17 @@ void Message::Emit(llvm::raw_ostream &o, const AllCookedSources &allCooked,
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_;
}
}
@@ -237,6 +229,10 @@ Message &Message::Attach(Message *m) {
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;
diff --git a/flang/lib/Parser/parse-tree.cpp b/flang/lib/Parser/parse-tree.cpp
index e86735c0bcb0..b81a659364f0 100644
--- a/flang/lib/Parser/parse-tree.cpp
+++ b/flang/lib/Parser/parse-tree.cpp
@@ -246,5 +246,4 @@ CharBlock Variable::GetSource() const {
llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const Name &x) {
return os << x.ToString();
}
-
} // namespace Fortran::parser
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 8e6a74280640..959ad3384f61 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -157,8 +157,10 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// 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()};
@@ -351,7 +353,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
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(
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 782e4c864421..0d2e2e86241c 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -9,6 +9,7 @@
// 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"
@@ -45,13 +46,11 @@ class CheckHelper {
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(
@@ -61,6 +60,7 @@ class CheckHelper {
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 &);
@@ -101,14 +101,12 @@ class CheckHelper {
}
}
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};
@@ -170,10 +168,10 @@ void CheckHelper::Check(const Symbol &symbol) {
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);
@@ -482,30 +480,25 @@ void CheckHelper::CheckObjectEntity(
}
}
}
- 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);
}
@@ -519,47 +512,39 @@ void CheckHelper::CheckObjectEntity(
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.
}
}
}
@@ -627,7 +612,7 @@ void CheckHelper::CheckArraySpec(
}
} 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) {
@@ -670,6 +655,7 @@ void CheckHelper::CheckProcEntity(
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)) {
@@ -768,9 +754,9 @@ void CheckHelper::CheckSubprogram(
} 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 =
@@ -949,16 +935,14 @@ bool CheckHelper::CheckFinal(
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;
}
}
}
@@ -1281,7 +1265,7 @@ const Procedure *CheckHelper::Characterize(const Symbol &symbol) {
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);
@@ -1517,23 +1501,31 @@ void CheckHelper::Check(const Scope &scope) {
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) {
@@ -1926,15 +1918,4 @@ void DistinguishabilityHelper::AttachDeclaration(
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
diff --git a/flang/lib/Semantics/check-declarations.h b/flang/lib/Semantics/check-declarations.h
index f1e4caf794c7..3b50bac4f5e7 100644
--- a/flang/lib/Semantics/check-declarations.h
+++ b/flang/lib/Semantics/check-declarations.h
@@ -12,8 +12,6 @@
#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
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index ae1fcb610385..382a7e04fdcf 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -727,8 +727,7 @@ class DoContext {
}
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());
diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp
index 0cfc5c209a1e..381a0b17f2d7 100644
--- a/flang/lib/Semantics/data-to-inits.cpp
+++ b/flang/lib/Semantics/data-to-inits.cpp
@@ -515,12 +515,10 @@ void ConstructInitializer(const Symbol &symbol,
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,
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index ecbcad34b7fd..0241d1ff030c 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1640,7 +1640,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(
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(
@@ -1930,7 +1931,7 @@ const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
}
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)) {
@@ -2233,8 +2234,8 @@ static bool IsExternalCalledImplicitly(
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()) {
@@ -2937,7 +2938,8 @@ bool ArgumentAnalyzer::CheckConformance() const {
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 */);
}
}
}
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 761d66482e24..dc5611cb257b 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -45,7 +45,7 @@ class PointerAssignmentChecker {
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));
@@ -143,7 +143,7 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
} 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;
}
@@ -262,7 +262,7 @@ bool PointerAssignmentChecker::Check(
}
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);
@@ -271,7 +271,7 @@ bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
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) {
@@ -299,10 +299,13 @@ bool PointerAssignmentChecker::LhsOkForUnlimitedPoly() const {
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;
}
@@ -358,7 +361,7 @@ static bool CheckPointerBounds(
}
}
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)
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 78ce019ec4b8..0d2b8813c7bb 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -183,24 +183,13 @@ class BaseVisitor {
}
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;
@@ -835,7 +824,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
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 &);
@@ -935,8 +924,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
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);
@@ -3263,8 +3250,8 @@ bool DeclarationVisitor::Pre(const parser::NamedConstantDef &x) {
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;
@@ -3835,11 +3822,11 @@ void DeclarationVisitor::Post(const parser::TypeParamDefStmt &x) {
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));
+ }
}
}
}
@@ -5690,43 +5677,6 @@ const parser::Name *DeclarationVisitor::FindComponent(
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
@@ -5737,14 +5687,7 @@ void DeclarationVisitor::Initialization(const parser::Name &name,
}
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>()}) {
@@ -5753,7 +5696,7 @@ void DeclarationVisitor::Initialization(const parser::Name &name,
std::visit(
common::visitors{
[&](const parser::ConstantExpr &expr) {
- NonPointerInitialization(name, expr, inComponentDecl);
+ NonPointerInitialization(name, expr);
},
[&](const parser::NullInit &null) {
Walk(null);
@@ -5770,7 +5713,9 @@ void DeclarationVisitor::Initialization(const parser::Name &name,
}
},
[&](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
@@ -5796,7 +5741,7 @@ void DeclarationVisitor::PointerInitialization(
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));
}
}
@@ -5818,8 +5763,8 @@ void DeclarationVisitor::PointerInitialization(
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 {
@@ -5835,8 +5780,8 @@ void DeclarationVisitor::PointerInitialization(
}
}
-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)) {
@@ -5846,15 +5791,13 @@ void DeclarationVisitor::NonPointerInitialization(const parser::Name &name,
} 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));
}
@@ -6565,14 +6508,16 @@ void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
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);
}
}
@@ -6581,8 +6526,9 @@ void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
}
}
-// 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()}) {
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index b27c8b7cc867..2c8fd91f033d 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -540,7 +540,8 @@ bool CanBeTypeBoundProc(const Symbol *symbol) {
}
}
-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)) {
@@ -554,7 +555,10 @@ bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements) {
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;
}
}
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 5274db649152..2107f47c3faf 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -148,9 +148,10 @@ void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) {
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,
@@ -176,8 +177,10 @@ bool DerivedTypeSpec::IsForwardReferenced() const {
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) {
@@ -235,12 +238,24 @@ void DerivedTypeSpec::Instantiate(
}
}
}
+ 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()) {
@@ -251,41 +266,40 @@ void DerivedTypeSpec::Instantiate(
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) {
@@ -309,7 +323,6 @@ void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {
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())));
@@ -326,6 +339,16 @@ void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {
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());
+ }
}
}
diff --git a/flang/test/Semantics/array-constr-values.f90 b/flang/test/Semantics/array-constr-values.f90
index 38d1024cf957..b0b21fbf7f07 100644
--- a/flang/test/Semantics/array-constr-values.f90
+++ b/flang/test/Semantics/array-constr-values.f90
@@ -57,6 +57,7 @@ subroutine checkC7115()
!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
diff --git a/flang/test/Semantics/data04.f90 b/flang/test/Semantics/data04.f90
index f1f772e48051..b2f391cb7591 100644
--- a/flang/test/Semantics/data04.f90
+++ b/flang/test/Semantics/data04.f90
@@ -62,7 +62,7 @@ subroutine CheckObject(i)
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)
diff --git a/flang/test/Semantics/init01.f90 b/flang/test/Semantics/init01.f90
index 56df41db6e0d..f896943acce1 100644
--- a/flang/test/Semantics/init01.f90
+++ b/flang/test/Semantics/init01.f90
@@ -28,21 +28,21 @@ subroutine objectpointers(j)
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
@@ -52,29 +52,34 @@ subroutine components
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
diff --git a/flang/test/Semantics/resolve37.f90 b/flang/test/Semantics/resolve37.f90
index 0e9d20be3a61..1db9d13ddb17 100644
--- a/flang/test/Semantics/resolve37.f90
+++ b/flang/test/Semantics/resolve37.f90
@@ -23,7 +23,7 @@
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
diff --git a/flang/test/Semantics/resolve44.f90 b/flang/test/Semantics/resolve44.f90
index 3ad70d49c82a..5d1530183d0d 100644
--- a/flang/test/Semantics/resolve44.f90
+++ b/flang/test/Semantics/resolve44.f90
@@ -20,10 +20,12 @@ program main
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
diff --git a/flang/test/Semantics/resolve58.f90 b/flang/test/Semantics/resolve58.f90
index 30257ae52c5b..ca4359059c44 100644
--- a/flang/test/Semantics/resolve58.f90
+++ b/flang/test/Semantics/resolve58.f90
@@ -30,7 +30,7 @@ subroutine s3(a, b)
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
diff --git a/flang/test/Semantics/resolve69.f90 b/flang/test/Semantics/resolve69.f90
index 6fa6c65df809..a1c8cf6b8168 100644
--- a/flang/test/Semantics/resolve69.f90
+++ b/flang/test/Semantics/resolve69.f90
@@ -36,7 +36,7 @@ subroutine s1()
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
diff --git a/flang/test/Semantics/structconst02.f90 b/flang/test/Semantics/structconst02.f90
index f65508fbe16d..71a743ab7150 100644
--- a/flang/test/Semantics/structconst02.f90
+++ b/flang/test/Semantics/structconst02.f90
@@ -14,6 +14,7 @@ end function realfunc
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()
diff --git a/flang/tools/f18/f18.cpp b/flang/tools/f18/f18.cpp
index ef8c87a76248..918bb6accef8 100644
--- a/flang/tools/f18/f18.cpp
+++ b/flang/tools/f18/f18.cpp
@@ -8,6 +8,7 @@
// 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"
@@ -26,6 +27,7 @@
#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>
@@ -37,8 +39,6 @@
#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) {
@@ -655,6 +655,8 @@ int main(int argc, char *const argv[]) {
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") {
More information about the llvm-branch-commits
mailing list