[flang-commits] [flang] 4171f80 - [flang] DATA stmt processing (part 3/4): Remaining prep work
peter klausler via flang-commits
flang-commits at lists.llvm.org
Fri Jun 19 09:10:21 PDT 2020
Author: peter klausler
Date: 2020-06-19T09:09:05-07:00
New Revision: 4171f80d5416eccbeebe8864410d576d7dc61eaa
URL: https://github.com/llvm/llvm-project/commit/4171f80d5416eccbeebe8864410d576d7dc61eaa
DIFF: https://github.com/llvm/llvm-project/commit/4171f80d5416eccbeebe8864410d576d7dc61eaa.diff
LOG: [flang] DATA stmt processing (part 3/4): Remaining prep work
Rolls up small changes across the frontend to prepare for the large
forthcoming patch (part 4/4) that completes DATA statement processing
via conversion to initializers.
Reviewed By: PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D82137
Added:
Modified:
flang/documentation/FortranForCProgrammers.md
flang/include/flang/Common/interval.h
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Evaluate/check-expression.h
flang/include/flang/Evaluate/constant.h
flang/include/flang/Evaluate/fold.h
flang/include/flang/Evaluate/tools.h
flang/include/flang/Parser/parse-tree.h
flang/include/flang/Parser/tools.h
flang/include/flang/Semantics/expression.h
flang/include/flang/Semantics/scope.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/call.cpp
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/check-expression.cpp
flang/lib/Evaluate/fold-implementation.h
flang/lib/Evaluate/fold.cpp
flang/lib/Evaluate/shape.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Parser/Fortran-parsers.cpp
flang/lib/Parser/tools.cpp
flang/lib/Semantics/check-data.cpp
flang/lib/Semantics/check-data.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/check-do-forall.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/lib/Semantics/pointer-assignment.h
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/rewrite-parse-tree.cpp
flang/lib/Semantics/tools.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/data01.f90
flang/test/Semantics/data04.f90
flang/test/Semantics/entry01.f90
flang/test/Semantics/init01.f90
flang/test/Semantics/resolve30.f90
flang/test/Semantics/resolve40.f90
flang/test/Semantics/symbol09.f90
Removed:
################################################################################
diff --git a/flang/documentation/FortranForCProgrammers.md b/flang/documentation/FortranForCProgrammers.md
index 6038c7ce348a..ce4a0b7072b0 100644
--- a/flang/documentation/FortranForCProgrammers.md
+++ b/flang/documentation/FortranForCProgrammers.md
@@ -91,7 +91,7 @@ byte sizes of the data.
(For `COMPLEX`, the kind type parameter value is the byte size of one of the
two `REAL` components, or half of the total size.)
The legacy `DOUBLE PRECISION` intrinsic type is an alias for a kind of `REAL`
-that should be bigger than the default `REAL`.
+that should be more precise, and bigger, than the default `REAL`.
`COMPLEX` is a simple structure that comprises two `REAL` components.
@@ -363,3 +363,9 @@ result; e.g., if there is a `PRINT` statement in function `F`, it
may or may not be executed by the assignment statement `X=0*F()`.
(Well, it probably will be, in practice, but compilers always reserve
the right to optimize better.)
+
+Unless they have an explicit suffix (`1.0_8`, `2.0_8`) or a `D`
+exponent (`3.0D0`), real literal constants in Fortran have the
+default `REAL` type -- *not* `double` as in the case in C and C++.
+If you're not careful, you can lose precision at compilation time
+from your constant values and never know it.
diff --git a/flang/include/flang/Common/interval.h b/flang/include/flang/Common/interval.h
index baaa35b9efc5..c1ef8d72eb30 100644
--- a/flang/include/flang/Common/interval.h
+++ b/flang/include/flang/Common/interval.h
@@ -31,12 +31,26 @@ template <typename A> class Interval {
constexpr Interval &operator=(const Interval &) = default;
constexpr Interval &operator=(Interval &&) = default;
+ constexpr bool operator<(const Interval &that) const {
+ return start_ < that.start_ ||
+ (start_ == that.start_ && size_ < that.size_);
+ }
+ constexpr bool operator<=(const Interval &that) const {
+ return start_ < that.start_ ||
+ (start_ == that.start_ && size_ <= that.size_);
+ }
constexpr bool operator==(const Interval &that) const {
return start_ == that.start_ && size_ == that.size_;
}
constexpr bool operator!=(const Interval &that) const {
return !(*this == that);
}
+ constexpr bool operator>=(const Interval &that) const {
+ return !(*this < that);
+ }
+ constexpr bool operator>(const Interval &that) const {
+ return !(*this <= that);
+ }
constexpr const A &start() const { return start_; }
constexpr std::size_t size() const { return size_; }
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 5233c5785d95..b59640fe8cf8 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -278,7 +278,7 @@ struct Procedure {
const ProcedureRef &, const IntrinsicProcTable &);
// At most one of these will return true.
- // For "EXTERNAL P" with no calls to P, both will be false.
+ // For "EXTERNAL P" with no type for or calls to P, both will be false.
bool IsFunction() const { return functionResult.has_value(); }
bool IsSubroutine() const { return attrs.test(Attr::Subroutine); }
diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h
index 16fe0bf11ae3..c5f5f39a73d0 100644
--- a/flang/include/flang/Evaluate/check-expression.h
+++ b/flang/include/flang/Evaluate/check-expression.h
@@ -33,12 +33,19 @@ template <typename A> bool IsConstantExpr(const A &);
extern template bool IsConstantExpr(const Expr<SomeType> &);
extern template bool IsConstantExpr(const Expr<SomeInteger> &);
extern template bool IsConstantExpr(const Expr<SubscriptInteger> &);
+extern template bool IsConstantExpr(const StructureConstructor &);
// 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
+// will be generated if and only if the result of the function is false.
bool IsInitialDataTarget(
const Expr<SomeType> &, parser::ContextualMessages * = nullptr);
+bool IsInitialProcedureTarget(const Symbol &);
+bool IsInitialProcedureTarget(const ProcedureDesignator &);
+bool IsInitialProcedureTarget(const Expr<SomeType> &);
+
// Check whether an expression is a specification expression
// (10.1.11(2), C1010). Constant expressions are always valid
// specification expressions.
diff --git a/flang/include/flang/Evaluate/constant.h b/flang/include/flang/Evaluate/constant.h
index 04ebc991d215..1617bdd086dc 100644
--- a/flang/include/flang/Evaluate/constant.h
+++ b/flang/include/flang/Evaluate/constant.h
@@ -32,9 +32,9 @@ using SymbolRef = common::Reference<const Symbol>;
// Wraps a constant value in a class templated by its resolved type.
// This Constant<> template class should be instantiated only for
// concrete intrinsic types and SomeDerived. There is no instance
-// Constant<Expr<SomeType>> since there is no way to constrain each
+// Constant<SomeType> since there is no way to constrain each
// element of its array to hold the same type. To represent a generic
-// constants, use a generic expression like Expr<SomeInteger> &
+// constant, use a generic expression like Expr<SomeInteger> or
// Expr<SomeType>) to wrap the appropriate instantiation of Constant<>.
template <typename> class Constant;
@@ -50,7 +50,7 @@ std::size_t TotalElementCount(const ConstantSubscripts &);
// Validate dimension re-ordering like ORDER in RESHAPE.
// On success, return a vector that can be used as dimOrder in
-// ConstantBound::IncrementSubscripts.
+// ConstantBound::IncrementSubscripts().
std::optional<std::vector<int>> ValidateDimensionOrder(
int rank, const std::vector<int> &order);
@@ -71,8 +71,8 @@ class ConstantBounds {
// If no optional dimension order argument is passed, increments a vector of
// subscripts in Fortran array order (first dimension varying most quickly).
// Otherwise, increments the vector of subscripts according to the given
- // dimension order (dimension dimOrder[0] varying most quickly. Dimensions
- // indexing is zero based here.) Returns false when last element was visited.
+ // dimension order (dimension dimOrder[0] varying most quickly; dimension
+ // indexing is zero based here). Returns false when last element was visited.
bool IncrementSubscripts(
ConstantSubscripts &, const std::vector<int> *dimOrder = nullptr) const;
@@ -158,7 +158,8 @@ class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
CLASS_BOILERPLATE(Constant)
explicit Constant(const Scalar<Result> &);
explicit Constant(Scalar<Result> &&);
- Constant(ConstantSubscript, std::vector<Element> &&, ConstantSubscripts &&);
+ Constant(
+ ConstantSubscript length, std::vector<Element> &&, ConstantSubscripts &&);
~Constant();
bool operator==(const Constant &that) const {
@@ -191,8 +192,6 @@ class Constant<Type<TypeCategory::Character, KIND>> : public ConstantBounds {
private:
Scalar<Result> values_; // one contiguous string
ConstantSubscript length_;
- ConstantSubscripts shape_;
- ConstantSubscripts lbounds_;
};
class StructureConstructor;
diff --git a/flang/include/flang/Evaluate/fold.h b/flang/include/flang/Evaluate/fold.h
index ae06a9f138e0..f04e6060577c 100644
--- a/flang/include/flang/Evaluate/fold.h
+++ b/flang/include/flang/Evaluate/fold.h
@@ -10,7 +10,7 @@
#define FORTRAN_EVALUATE_FOLD_H_
// Implements expression tree rewriting, particularly constant expression
-// evaluation.
+// and designator reference evaluation.
#include "common.h"
#include "constant.h"
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 1fc80e590360..84de29bd7fec 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -913,6 +913,7 @@ bool IsDummy(const Symbol &);
const Symbol *GetAssociationRoot(const Symbol &);
const Symbol *FindCommonBlockContaining(const Symbol &);
int CountLenParameters(const DerivedTypeSpec &);
+int CountNonConstantLenParameters(const DerivedTypeSpec &);
const Symbol &GetUsedModule(const UseDetails &);
} // namespace Fortran::semantics
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index 4852011c05d2..c561c9e60903 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -1400,7 +1400,8 @@ using TypedExpr = std::unique_ptr<evaluate::GenericExprWrapper,
// R845 data-stmt-constant ->
// scalar-constant | scalar-constant-subobject |
// signed-int-literal-constant | signed-real-literal-constant |
-// null-init | initial-data-target | structure-constructor
+// null-init | initial-data-target |
+// constant-structure-constructor <- added "constant-"
struct DataStmtConstant {
UNION_CLASS_BOILERPLATE(DataStmtConstant);
CharBlock source;
@@ -1408,7 +1409,7 @@ struct DataStmtConstant {
std::variant<Scalar<ConstantValue>, Scalar<ConstantSubobject>,
SignedIntLiteralConstant, SignedRealLiteralConstant,
SignedComplexLiteralConstant, NullInit, InitialDataTarget,
- StructureConstructor>
+ Constant<StructureConstructor>>
u;
};
@@ -1424,6 +1425,7 @@ struct DataStmtRepeat {
// R843 data-stmt-value -> [data-stmt-repeat *] data-stmt-constant
struct DataStmtValue {
TUPLE_CLASS_BOILERPLATE(DataStmtValue);
+ mutable std::size_t repetitions{1}; // replaced during semantics
std::tuple<std::optional<DataStmtRepeat>, DataStmtConstant> t;
};
diff --git a/flang/include/flang/Parser/tools.h b/flang/include/flang/Parser/tools.h
index 94f5f2371524..c918425a2978 100644
--- a/flang/include/flang/Parser/tools.h
+++ b/flang/include/flang/Parser/tools.h
@@ -28,6 +28,19 @@ const Name &GetLastName(const FunctionReference &);
const Name &GetLastName(const Variable &);
const Name &GetLastName(const AllocateObject &);
+// GetFirstName() isolates and returns a reference to the leftmost Name
+// in a variable.
+const Name &GetFirstName(const Name &);
+const Name &GetFirstName(const StructureComponent &);
+const Name &GetFirstName(const DataRef &);
+const Name &GetFirstName(const Substring &);
+const Name &GetFirstName(const Designator &);
+const Name &GetFirstName(const ProcComponentRef &);
+const Name &GetFirstName(const ProcedureDesignator &);
+const Name &GetFirstName(const Call &);
+const Name &GetFirstName(const FunctionReference &);
+const Name &GetFirstName(const Variable &);
+
// When a parse tree node is an instance of a specific type wrapped in
// layers of packaging, return a pointer to that object.
// Implemented with mutually recursive template functions that are
diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 74552732b3ed..1b94ce62a996 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -131,8 +131,11 @@ class ExpressionAnalyzer {
bool CheckIntrinsicSize(TypeCategory, std::int64_t size);
// Manage a set of active implied DO loops.
- bool AddImpliedDo(parser::CharBlock, int);
+ bool AddImpliedDo(parser::CharBlock, int kind);
void RemoveImpliedDo(parser::CharBlock);
+
+ // When the argument is the name of an active implied DO index, returns
+ // its INTEGER kind type parameter.
std::optional<int> IsImpliedDo(parser::CharBlock) const;
Expr<SubscriptInteger> AnalyzeKindSelector(common::TypeCategory category,
@@ -141,7 +144,7 @@ class ExpressionAnalyzer {
MaybeExpr Analyze(const parser::Expr &);
MaybeExpr Analyze(const parser::Variable &);
MaybeExpr Analyze(const parser::Designator &);
- MaybeExpr Analyze(const parser::DataStmtConstant &);
+ MaybeExpr Analyze(const parser::DataStmtValue &);
template <typename A> MaybeExpr Analyze(const common::Indirection<A> &x) {
return Analyze(x.value());
@@ -241,6 +244,7 @@ class ExpressionAnalyzer {
MaybeExpr Analyze(const parser::BOZLiteralConstant &);
MaybeExpr Analyze(const parser::NamedConstant &);
MaybeExpr Analyze(const parser::NullInit &);
+ MaybeExpr Analyze(const parser::DataStmtConstant &);
MaybeExpr Analyze(const parser::Substring &);
MaybeExpr Analyze(const parser::ArrayElement &);
MaybeExpr Analyze(const parser::CoindexedNamedObject &);
@@ -420,17 +424,19 @@ class ExprChecker {
bool Walk(const parser::Program &);
bool Pre(const parser::Expr &x) {
- AnalyzeExpr(context_, x);
+ exprAnalyzer_.Analyze(x);
return false;
}
bool Pre(const parser::Variable &x) {
- AnalyzeExpr(context_, x);
+ exprAnalyzer_.Analyze(x);
return false;
}
- bool Pre(const parser::DataStmtConstant &x) {
- AnalyzeExpr(context_, x);
+ bool Pre(const parser::DataStmtValue &x) {
+ exprAnalyzer_.Analyze(x);
return false;
}
+ bool Pre(const parser::DataImpliedDo &);
+
bool Pre(const parser::CallStmt &x) {
AnalyzeCallStmt(context_, x);
return false;
@@ -445,28 +451,29 @@ class ExprChecker {
}
template <typename A> bool Pre(const parser::Scalar<A> &x) {
- AnalyzeExpr(context_, x);
+ exprAnalyzer_.Analyze(x);
return false;
}
template <typename A> bool Pre(const parser::Constant<A> &x) {
- AnalyzeExpr(context_, x);
+ exprAnalyzer_.Analyze(x);
return false;
}
template <typename A> bool Pre(const parser::Integer<A> &x) {
- AnalyzeExpr(context_, x);
+ exprAnalyzer_.Analyze(x);
return false;
}
template <typename A> bool Pre(const parser::Logical<A> &x) {
- AnalyzeExpr(context_, x);
+ exprAnalyzer_.Analyze(x);
return false;
}
template <typename A> bool Pre(const parser::DefaultChar<A> &x) {
- AnalyzeExpr(context_, x);
+ exprAnalyzer_.Analyze(x);
return false;
}
private:
SemanticsContext &context_;
+ evaluate::ExpressionAnalyzer exprAnalyzer_{context_};
};
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_EXPRESSION_H_
diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h
index 878536aa06da..3913889ac27b 100644
--- a/flang/include/flang/Semantics/scope.h
+++ b/flang/include/flang/Semantics/scope.h
@@ -207,6 +207,9 @@ class Scope {
DerivedTypeSpec *derivedTypeSpec() { return derivedTypeSpec_; }
void set_derivedTypeSpec(DerivedTypeSpec &spec) { derivedTypeSpec_ = &spec; }
+ bool hasSAVE() const { return hasSAVE_; }
+ void set_hasSAVE(bool yes = true) { hasSAVE_ = yes; }
+
// The range of the source of this and nested scopes.
const parser::CharBlock &sourceRange() const { return sourceRange_; }
void AddSourceRange(const parser::CharBlock &);
@@ -243,6 +246,7 @@ class Scope {
std::optional<ImportKind> importKind_;
std::set<SourceName> importNames_;
DerivedTypeSpec *derivedTypeSpec_{nullptr}; // dTS->scope() == this
+ 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/tools.h b/flang/include/flang/Semantics/tools.h
index e8b5335f7ea2..86a766bf963c 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -84,7 +84,7 @@ bool IsStmtFunctionResult(const Symbol &);
bool IsPointerDummy(const Symbol &);
bool IsBindCProcedure(const Symbol &);
bool IsBindCProcedure(const Scope &);
-bool IsProcName(const Symbol &symbol); // proc-name
+bool IsProcName(const Symbol &); // proc-name
bool IsFunctionResult(const Symbol &);
bool IsFunctionResultWithSameNameAsFunction(const Symbol &);
bool IsExtensibleType(const DerivedTypeSpec *);
@@ -96,9 +96,10 @@ bool IsIsoCType(const DerivedTypeSpec *);
bool IsEventTypeOrLockType(const DerivedTypeSpec *);
bool IsOrContainsEventOrLockComponent(const Symbol &);
bool CanBeTypeBoundProc(const Symbol *);
-bool IsInitialized(const Symbol &);
+bool IsInitialized(const Symbol &, bool ignoreDATAstatements = false);
bool HasIntrinsicTypeName(const Symbol &);
bool IsSeparateModuleProcedureInterface(const Symbol *);
+bool IsAutomatic(const Symbol &);
// Return an ultimate component of type that matches predicate, or nullptr.
const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
@@ -237,15 +238,17 @@ bool ExprTypeKindIsDefault(
const SomeExpr &expr, const SemanticsContext &context);
struct GetExprHelper {
- const SomeExpr *Get(const parser::Expr &);
- const SomeExpr *Get(const parser::Variable &);
- template <typename T> const SomeExpr *Get(const common::Indirection<T> &x) {
+ static const SomeExpr *Get(const parser::Expr &);
+ static const SomeExpr *Get(const parser::Variable &);
+ static const SomeExpr *Get(const parser::DataStmtConstant &);
+ template <typename T>
+ static const SomeExpr *Get(const common::Indirection<T> &x) {
return Get(x.value());
}
- template <typename T> const SomeExpr *Get(const std::optional<T> &x) {
+ template <typename T> static const SomeExpr *Get(const std::optional<T> &x) {
return x ? Get(*x) : nullptr;
}
- template <typename T> const SomeExpr *Get(const T &x) {
+ template <typename T> static const SomeExpr *Get(const T &x) {
if constexpr (ConstraintTrait<T>) {
return Get(x.thing);
} else if constexpr (WrapperTrait<T>) {
@@ -521,5 +524,6 @@ class LabelEnforce {
parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
parser::CharBlock constructLocation);
};
+
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_TOOLS_H_
diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp
index ae1786c9290d..c9d6fe0ddb80 100644
--- a/flang/lib/Evaluate/call.cpp
+++ b/flang/lib/Evaluate/call.cpp
@@ -98,6 +98,7 @@ std::optional<DynamicType> ProcedureDesignator::GetType() const {
int ProcedureDesignator::Rank() const {
if (const Symbol * symbol{GetSymbol()}) {
+ // Subtle: will be zero for functions returning procedure pointers
return symbol->Rank();
}
if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
@@ -107,9 +108,9 @@ int ProcedureDesignator::Rank() const {
characteristics::TypeAndShape::Attr::AssumedRank));
return typeAndShape->Rank();
}
+ // Otherwise, intrinsic returns a procedure pointer (e.g. NULL(MOLD=pptr))
}
}
- DIE("ProcedureDesignator::Rank(): no case");
return 0;
}
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 6c4ec1446774..dde108a725dc 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -563,8 +563,9 @@ bool Procedure::CanOverride(
}
std::optional<Procedure> Procedure::Characterize(
- const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) {
+ const semantics::Symbol &original, const IntrinsicProcTable &intrinsics) {
Procedure result;
+ const auto &symbol{ResolveAssociations(original)};
CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
{
{semantics::Attr::PURE, Procedure::Attr::Pure},
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index b6c3b20b2ec4..9ac1a12e0f4e 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -33,7 +33,9 @@ class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
return IsKindTypeParameter(inq.parameter());
}
bool operator()(const semantics::Symbol &symbol) const {
- return IsNamedConstant(symbol) || IsImpliedDoIndex(symbol);
+ const auto &ultimate{symbol.GetUltimate()};
+ return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
+ IsInitialProcedureTarget(ultimate);
}
bool operator()(const CoarrayRef &) const { return false; }
bool operator()(const semantics::ParamValue ¶m) const {
@@ -49,11 +51,7 @@ class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
}
bool operator()(const StructureConstructor &constructor) const {
for (const auto &[symRef, expr] : constructor) {
- if (IsAllocatable(*symRef)) {
- return IsNullPointer(expr.value());
- } else if (IsPointer(*symRef)) {
- return IsNullPointer(expr.value()) || IsInitialDataTarget(expr.value());
- } else if (!(*this)(expr.value())) {
+ if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
return false;
}
}
@@ -73,6 +71,21 @@ class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
return false;
}
}
+
+ bool operator()(const Constant<SomeDerived> &) const { return true; }
+
+private:
+ bool IsConstantStructureConstructorComponent(
+ const Symbol &component, const Expr<SomeType> &expr) const {
+ if (IsAllocatable(component)) {
+ return IsNullPointer(expr);
+ } else if (IsPointer(component)) {
+ return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
+ IsInitialProcedureTarget(expr);
+ } else {
+ return (*this)(expr);
+ }
+ }
};
template <typename A> bool IsConstantExpr(const A &x) {
@@ -81,12 +94,11 @@ template <typename A> bool IsConstantExpr(const A &x) {
template bool IsConstantExpr(const Expr<SomeType> &);
template bool IsConstantExpr(const Expr<SomeInteger> &);
template bool IsConstantExpr(const Expr<SubscriptInteger> &);
+template bool IsConstantExpr(const StructureConstructor &);
// 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.
-// If messages are requested, errors may be generated without returning
-// a false result.
class IsInitialDataTargetHelper
: public AllTraverse<IsInitialDataTargetHelper, true> {
public:
@@ -95,45 +107,47 @@ class IsInitialDataTargetHelper
explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
: Base{*this}, messages_{m} {}
+ bool emittedMessage() const { return emittedMessage_; }
+
bool operator()(const BOZLiteralConstant &) const { return false; }
bool operator()(const NullPointer &) const { return true; }
template <typename T> bool operator()(const Constant<T> &) const {
return false;
}
- bool operator()(const semantics::Symbol &symbol) const {
+ bool operator()(const semantics::Symbol &symbol) {
const Symbol &ultimate{symbol.GetUltimate()};
if (IsAllocatable(ultimate)) {
if (messages_) {
messages_->Say(
"An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
ultimate.name());
- } else {
- return false;
+ emittedMessage_ = true;
}
+ return false;
} else if (ultimate.Corank() > 0) {
if (messages_) {
messages_->Say(
"An initial data target may not be a reference to a coarray '%s'"_err_en_US,
ultimate.name());
- } else {
- return false;
+ emittedMessage_ = true;
}
+ return false;
} else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
if (messages_) {
messages_->Say(
"An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
ultimate.name());
- } else {
- return false;
+ emittedMessage_ = true;
}
+ return false;
} else if (!IsSaved(ultimate)) {
if (messages_) {
messages_->Say(
"An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
ultimate.name());
- } else {
- return false;
+ emittedMessage_ = true;
}
+ return false;
}
return true;
}
@@ -179,11 +193,50 @@ class IsInitialDataTargetHelper
private:
parser::ContextualMessages *messages_;
+ bool emittedMessage_{false};
};
bool IsInitialDataTarget(
const Expr<SomeType> &x, parser::ContextualMessages *messages) {
- return IsInitialDataTargetHelper{messages}(x);
+ IsInitialDataTargetHelper helper{messages};
+ bool result{helper(x)};
+ if (!result && messages && !helper.emittedMessage()) {
+ messages->Say(
+ "An initial data target must be a designator with constant subscripts"_err_en_US);
+ }
+ return result;
+}
+
+bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
+ const auto &ultimate{symbol.GetUltimate()};
+ return std::visit(
+ common::visitors{
+ [](const semantics::SubprogramDetails &) { return true; },
+ [](const semantics::SubprogramNameDetails &) { return true; },
+ [&](const semantics::ProcEntityDetails &proc) {
+ return !semantics::IsPointer(ultimate) && !proc.isDummy();
+ },
+ [](const auto &) { return false; },
+ },
+ ultimate.details());
+}
+
+bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
+ if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
+ return !intrin->isRestrictedSpecific;
+ } else if (proc.GetComponent()) {
+ return false;
+ } else {
+ return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
+ }
+}
+
+bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
+ if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
+ return IsInitialProcedureTarget(*proc);
+ } else {
+ return IsNullPointer(expr);
+ }
}
// Specification expression validation (10.1.11(2), C1010)
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 05068a2d143a..85e35613d640 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -150,11 +150,9 @@ std::optional<Expr<T>> Folder<T>::GetNamedConstantValue(const Symbol &symbol0) {
if (symbol.Rank() > 0) {
if (constant->Rank() == 0) {
// scalar expansion
- if (auto symShape{GetShape(context_, symbol)}) {
- if (auto extents{AsConstantExtents(context_, *symShape)}) {
- *constant = constant->Reshape(std::move(*extents));
- CHECK(constant->Rank() == symbol.Rank());
- }
+ if (auto extents{GetConstantExtents(context_, symbol)}) {
+ *constant = constant->Reshape(std::move(*extents));
+ CHECK(constant->Rank() == symbol.Rank());
}
}
if (constant->Rank() == symbol.Rank()) {
diff --git a/flang/lib/Evaluate/fold.cpp b/flang/lib/Evaluate/fold.cpp
index b878bb351c42..971149af1f7c 100644
--- a/flang/lib/Evaluate/fold.cpp
+++ b/flang/lib/Evaluate/fold.cpp
@@ -55,13 +55,60 @@ 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 result{structure.derivedTypeSpec()};
+ StructureConstructor ctor{structure.derivedTypeSpec()};
+ bool constantExtents{true};
for (auto &&[symbol, value] : std::move(structure)) {
- result.Add(symbol, Fold(context, std::move(value.value())));
+ auto expr{Fold(context, std::move(value.value()))};
+ if (!IsProcedurePointer(symbol)) {
+ 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;
+ }
+ } else {
+ constantExtents = false;
+ }
+ }
+ } else {
+ constantExtents = false;
+ }
+ }
+ ctor.Add(symbol, Fold(context, std::move(expr)));
+ }
+ if (constantExtents && IsConstantExpr(ctor)) {
+ return Expr<SomeDerived>{Constant<SomeDerived>{std::move(ctor)}};
+ } else {
+ return Expr<SomeDerived>{std::move(ctor)};
}
- return Expr<SomeDerived>{Constant<SomeDerived>{std::move(result)}};
}
Component FoldOperation(FoldingContext &context, Component &&component) {
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index c5b8a5e88ce7..507de428b54a 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -439,6 +439,7 @@ auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
[&](const semantics::HostAssocDetails &assoc) {
return (*this)(assoc.symbol());
},
+ [](const semantics::TypeParamDetails &) { return Scalar(); },
[](const auto &) { return Result{}; },
},
symbol.details());
@@ -653,4 +654,22 @@ bool CheckConformance(parser::ContextualMessages &messages, const Shape &left,
}
return true;
}
+
+bool IncrementSubscripts(
+ ConstantSubscripts &indices, const ConstantSubscripts &extents) {
+ std::size_t rank(indices.size());
+ CHECK(rank <= extents.size());
+ for (std::size_t j{0}; j < rank; ++j) {
+ if (extents[j] < 1) {
+ return false;
+ }
+ }
+ for (std::size_t j{0}; j < rank; ++j) {
+ if (indices[j]++ < extents[j]) {
+ return true;
+ }
+ indices[j] = 1;
+ }
+ return false;
+}
} // namespace Fortran::evaluate
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 5b45f8447b17..3538cd587f97 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -981,28 +981,39 @@ bool IsProcedurePointer(const Symbol &symbol) {
return symbol.has<ProcEntityDetails>() && IsPointer(symbol);
}
-bool IsSaved(const Symbol &symbol) {
- auto scopeKind{symbol.owner().kind()};
- if (scopeKind == Scope::Kind::Module || scopeKind == Scope::Kind::BlockData) {
- return true;
- } else if (scopeKind == Scope::Kind::DerivedType) {
- return false; // this is a component
- } else if (IsNamedConstant(symbol)) {
- return false;
- } else if (symbol.attrs().test(Attr::SAVE)) {
- return true;
- } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
- object && object->init()) {
- return true;
- } else if (IsProcedurePointer(symbol) &&
- symbol.get<ProcEntityDetails>().init()) {
- return true;
- } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
- block && block->attrs().test(Attr::SAVE)) {
- return true;
- } else {
- return false;
+bool IsSaved(const Symbol &original) {
+ if (const Symbol * root{GetAssociationRoot(original)}) {
+ const Symbol &symbol{*root};
+ const Scope *scope{&symbol.owner()};
+ auto scopeKind{scope->kind()};
+ if (scopeKind == Scope::Kind::Module) {
+ return true; // BLOCK DATA entities must all be in COMMON, handled below
+ } else if (symbol.attrs().test(Attr::SAVE)) {
+ return true;
+ } else if (scopeKind == Scope::Kind::DerivedType) {
+ return false; // this is a component
+ } else if (IsNamedConstant(symbol)) {
+ return false;
+ } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
+ object && object->init()) {
+ return true;
+ } else if (IsProcedurePointer(symbol) &&
+ symbol.get<ProcEntityDetails>().init()) {
+ return true;
+ } else if (const Symbol * block{FindCommonBlockContaining(symbol)};
+ block && block->attrs().test(Attr::SAVE)) {
+ return true;
+ } else if (IsDummy(symbol)) {
+ return false;
+ } else {
+ for (; !scope->IsGlobal(); scope = &scope->parent()) {
+ if (scope->hasSAVE()) {
+ return true;
+ }
+ }
+ }
}
+ return false;
}
bool IsDummy(const Symbol &symbol) {
@@ -1020,6 +1031,19 @@ int CountLenParameters(const DerivedTypeSpec &type) {
[](const auto &pair) { return pair.second.isLen(); });
}
+int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
+ return std::count_if(
+ type.parameters().begin(), type.parameters().end(), [](const auto &pair) {
+ if (!pair.second.isLen()) {
+ return false;
+ } else if (const auto &expr{pair.second.GetExplicit()}) {
+ return !IsConstantExpr(*expr);
+ } else {
+ return true;
+ }
+ });
+}
+
const Symbol &GetUsedModule(const UseDetails &details) {
return DEREF(details.symbol().owner().symbol());
}
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 7d23b9273330..0a823cd20398 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -472,7 +472,7 @@ DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
bool DynamicType::RequiresDescriptor() const {
return IsPolymorphic() || IsUnknownLengthCharacter() ||
- (derived_ && CountLenParameters(*derived_) > 0);
+ (derived_ && CountNonConstantLenParameters(*derived_) > 0);
}
bool DynamicType::HasDeferredTypeParameter() const {
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 3192781d4bcc..6368b985d1aa 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -833,7 +833,7 @@ TYPE_PARSER(sourced(first(
construct<DataStmtConstant>(scalar(Parser<ConstantValue>{})),
construct<DataStmtConstant>(nullInit),
construct<DataStmtConstant>(scalar(constantSubobject)) / !"("_tok,
- construct<DataStmtConstant>(Parser<StructureConstructor>{}),
+ construct<DataStmtConstant>(constant(Parser<StructureConstructor>{})),
construct<DataStmtConstant>(signedRealLiteralConstant),
construct<DataStmtConstant>(signedIntLiteralConstant),
extension<LanguageFeature::SignedComplexLiteral>(
diff --git a/flang/lib/Parser/tools.cpp b/flang/lib/Parser/tools.cpp
index 98aa6897c6cd..0a21e73839ed 100644
--- a/flang/lib/Parser/tools.cpp
+++ b/flang/lib/Parser/tools.cpp
@@ -68,6 +68,61 @@ const Name &GetLastName(const AllocateObject &x) {
[](const auto &y) -> const Name & { return GetLastName(y); }, x.u);
}
+const Name &GetFirstName(const Name &x) { return x; }
+
+const Name &GetFirstName(const StructureComponent &x) {
+ return GetFirstName(x.base);
+}
+
+const Name &GetFirstName(const DataRef &x) {
+ return std::visit(
+ common::visitors{
+ [](const Name &name) -> const Name & { return name; },
+ [](const common::Indirection<StructureComponent> &sc)
+ -> const Name & { return GetFirstName(sc.value()); },
+ [](const common::Indirection<ArrayElement> &sc) -> const Name & {
+ return GetFirstName(sc.value().base);
+ },
+ [](const common::Indirection<CoindexedNamedObject> &ci)
+ -> const Name & { return GetFirstName(ci.value().base); },
+ },
+ x.u);
+}
+
+const Name &GetFirstName(const Substring &x) {
+ return GetFirstName(std::get<DataRef>(x.t));
+}
+
+const Name &GetFirstName(const Designator &x) {
+ return std::visit(
+ [](const auto &y) -> const Name & { return GetFirstName(y); }, x.u);
+}
+
+const Name &GetFirstName(const ProcComponentRef &x) {
+ return GetFirstName(x.v.thing);
+}
+
+const Name &GetFirstName(const ProcedureDesignator &x) {
+ return std::visit(
+ [](const auto &y) -> const Name & { return GetFirstName(y); }, x.u);
+}
+
+const Name &GetFirstName(const Call &x) {
+ return GetFirstName(std::get<ProcedureDesignator>(x.t));
+}
+
+const Name &GetFirstName(const FunctionReference &x) {
+ return GetFirstName(x.v);
+}
+
+const Name &GetFirstName(const Variable &x) {
+ return std::visit(
+ [](const auto &indirect) -> const Name & {
+ return GetFirstName(indirect.value());
+ },
+ x.u);
+}
+
const CoindexedNamedObject *GetCoindexedNamedObject(const DataRef &base) {
return std::visit(
common::visitors{
diff --git a/flang/lib/Semantics/check-data.cpp b/flang/lib/Semantics/check-data.cpp
index 4b2d2fc734f7..7c5557714f46 100644
--- a/flang/lib/Semantics/check-data.cpp
+++ b/flang/lib/Semantics/check-data.cpp
@@ -12,23 +12,6 @@
namespace Fortran::semantics {
-void DataChecker::Leave(const parser::DataStmtConstant &dataConst) {
- if (auto *structure{
- std::get_if<parser::StructureConstructor>(&dataConst.u)}) {
- for (const auto &component :
- std::get<std::list<parser::ComponentSpec>>(structure->t)) {
- const parser::Expr &parsedExpr{
- std::get<parser::ComponentDataSource>(component.t).v.value()};
- if (const auto *expr{GetExpr(parsedExpr)}) {
- if (!evaluate::IsConstantExpr(*expr)) { // C884
- exprAnalyzer_.Say(parsedExpr.source,
- "Structure constructor in data value must be a constant expression"_err_en_US);
- }
- }
- }
- }
-}
-
// Ensures that references to an implied DO loop control variable are
// represented as such in the "body" of the implied DO loop.
void DataChecker::Enter(const parser::DataImpliedDo &x) {
@@ -234,21 +217,4 @@ void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
}
}
}
-
-void DataChecker::Leave(const parser::DataStmtRepeat &dataRepeat) {
- if (const auto *designator{parser::Unwrap<parser::Designator>(dataRepeat)}) {
- if (auto *dataRef{std::get_if<parser::DataRef>(&designator->u)}) {
- if (MaybeExpr checked{exprAnalyzer_.Analyze(*dataRef)}) {
- auto expr{evaluate::Fold(
- exprAnalyzer_.GetFoldingContext(), std::move(checked))};
- if (auto i64{ToInt64(expr)}) {
- if (*i64 < 0) { // C882
- exprAnalyzer_.Say(designator->source,
- "Repeat count for data value must not be negative"_err_en_US);
- }
- }
- }
- }
- }
-}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/check-data.h b/flang/lib/Semantics/check-data.h
index d13a768d0e80..fa65737ecefb 100644
--- a/flang/lib/Semantics/check-data.h
+++ b/flang/lib/Semantics/check-data.h
@@ -19,8 +19,6 @@ namespace Fortran::semantics {
class DataChecker : public virtual BaseChecker {
public:
explicit DataChecker(SemanticsContext &context) : exprAnalyzer_{context} {}
- void Leave(const parser::DataStmtRepeat &);
- void Leave(const parser::DataStmtConstant &);
void Leave(const parser::DataStmtObject &);
void Enter(const parser::DataImpliedDo &);
void Leave(const parser::DataImpliedDo &);
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 871bb8283543..c98f7a542be7 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -283,6 +283,11 @@ void CheckHelper::Check(const Symbol &symbol) {
messages_.Say(
"A dummy argument may not have the SAVE attribute"_err_en_US);
}
+ } else if (IsFunctionResult(symbol)) {
+ if (IsSaved(symbol)) {
+ messages_.Say(
+ "A function result may not have the SAVE attribute"_err_en_US);
+ }
}
if (symbol.owner().IsDerivedType() &&
(symbol.attrs().test(Attr::CONTIGUOUS) &&
@@ -458,20 +463,26 @@ void CheckHelper::CheckObjectEntity(
}
}
if (symbol.owner().kind() != Scope::Kind::DerivedType &&
+ IsInitialized(symbol, true /*ignore DATA, already caught*/)) { // C808
+ if (IsAutomatic(symbol)) {
+ messages_.Say("An automatic variable must not be initialized"_err_en_US);
+ } else if (IsDummy(symbol)) {
+ messages_.Say("A dummy argument must not be initialized"_err_en_US);
+ } else if (IsFunctionResult(symbol)) {
+ messages_.Say("A function result must not be initialized"_err_en_US);
+ } else if (IsInBlankCommon(symbol)) {
+ messages_.Say(
+ "A variable in blank COMMON should not be initialized"_en_US);
+ }
+ }
+ if (symbol.owner().kind() == Scope::Kind::BlockData &&
IsInitialized(symbol)) {
- if (details.commonBlock()) {
- if (details.commonBlock()->name().empty()) {
- messages_.Say(
- "A variable in blank COMMON should not be initialized"_en_US);
- }
- } else 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 {
- messages_.Say(
- "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
- }
+ if (IsAllocatable(symbol)) {
+ messages_.Say(
+ "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
+ } else if (!FindCommonBlockContaining(symbol)) {
+ messages_.Say(
+ "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
}
}
if (const DeclTypeSpec * type{details.type()}) { // C708
@@ -596,6 +607,10 @@ void CheckHelper::CheckProcEntity(
symbol.name()); // C1517
}
}
+ } else if (symbol.attrs().test(Attr::SAVE)) {
+ messages_.Say(
+ "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US,
+ symbol.name());
}
}
diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
index a53df602c0d7..68be15e620ba 100644
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -208,7 +208,7 @@ class DoConcurrentBodyEnforce {
const char *reason{"block exit"};
for (auto &pair : blockScope) {
const Symbol &entity{*pair.second};
- if (IsAllocatable(entity) && !entity.attrs().test(Attr::SAVE) &&
+ if (IsAllocatable(entity) && !IsSaved(entity) &&
MightDeallocatePolymorphic(entity, DeallocateAll)) {
SayDeallocateOfPolymorph(endBlockStmt.source, entity, reason);
}
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 76d0ffe32d6c..afd70d065108 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -338,7 +338,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {
// A utility subroutine to repackage optional expressions of various levels
// of type specificity as fully general MaybeExpr values.
template <typename A> common::IfNoLvalue<MaybeExpr, A> AsMaybeExpr(A &&x) {
- return std::make_optional(AsGenericExpr(std::move(x)));
+ return AsGenericExpr(std::move(x));
}
template <typename A> MaybeExpr AsMaybeExpr(std::optional<A> &&x) {
if (x) {
@@ -529,7 +529,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(
auto &realExpr{std::get<Expr<SomeReal>>(result->u)};
if (auto sign{std::get<std::optional<parser::Sign>>(x.t)}) {
if (sign == parser::Sign::Negative) {
- return {AsGenericExpr(-std::move(realExpr))};
+ return AsGenericExpr(-std::move(realExpr));
}
}
return result;
@@ -722,6 +722,26 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::InitialDataTarget &x) {
return Analyze(x.value());
}
+MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) {
+ if (const auto &repeat{
+ std::get<std::optional<parser::DataStmtRepeat>>(x.t)}) {
+ x.repetitions = 0;
+ if (MaybeExpr expr{Analyze(repeat->u)}) {
+ Expr<SomeType> folded{Fold(std::move(*expr))};
+ if (auto value{ToInt64(folded)}) {
+ if (*value >= 0) { // C882
+ x.repetitions = *value;
+ } else {
+ Say(FindSourceLocation(repeat),
+ "Repeat count (%jd) for data value must not be negative"_err_en_US,
+ *value);
+ }
+ }
+ }
+ }
+ return Analyze(std::get<parser::DataStmtConstant>(x.t));
+}
+
// Substring references
std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::GetSubstringBound(
const std::optional<parser::ScalarIntExpr> &bound) {
@@ -806,8 +826,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(
.Push(cp->GetScalarValue().value());
Substring substring{std::move(staticData), std::move(lower.value()),
std::move(upper.value())};
- return AsGenericExpr(Expr<SomeCharacter>{
- Expr<Result>{Designator<Result>{std::move(substring)}}});
+ return AsGenericExpr(
+ Expr<Result>{Designator<Result>{std::move(substring)}});
},
std::move(charExpr->u));
}
@@ -1000,7 +1020,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
ComplexPart{std::move(*dataRef), part}});
},
zExpr->u)};
- return {AsGenericExpr(std::move(realExpr))};
+ return AsGenericExpr(std::move(realExpr));
}
}
} else if (kind == MiscKind::KindParamInquiry ||
@@ -1360,13 +1380,13 @@ MaybeExpr ExpressionAnalyzer::Analyze(
bool anyKeyword{false};
StructureConstructor result{spec};
bool checkConflicts{true}; // until we hit one
+ auto &messages{GetContextualMessages()};
for (const auto &component :
std::get<std::list<parser::ComponentSpec>>(structure.t)) {
const parser::Expr &expr{
std::get<parser::ComponentDataSource>(component.t).v.value()};
parser::CharBlock source{expr.source};
- auto &messages{GetContextualMessages()};
auto restorer{messages.SetLocation(source)};
const Symbol *symbol{nullptr};
MaybeExpr value{Analyze(expr)};
@@ -1494,7 +1514,37 @@ MaybeExpr ExpressionAnalyzer::Analyze(
result.Add(*symbol, Fold(std::move(*value)));
} else if (MaybeExpr converted{
ConvertToType(*symbol, std::move(*value))}) {
- result.Add(*symbol, std::move(*converted));
+ if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {
+ if (auto valueShape{GetShape(GetFoldingContext(), *converted)}) {
+ if (GetRank(*componentShape) == 0 && GetRank(*valueShape) > 0) {
+ AttachDeclaration(
+ Say(expr.source,
+ "Rank-%d array value is not compatible with scalar component '%s'"_err_en_US,
+ symbol->name()),
+ *symbol);
+ } else if (CheckConformance(messages, *componentShape,
+ *valueShape, "component", "value")) {
+ if (GetRank(*componentShape) > 0 && GetRank(*valueShape) == 0 &&
+ !IsExpandableScalar(*converted)) {
+ AttachDeclaration(
+ Say(expr.source,
+ "Scalar value cannot be expanded to shape of array component '%s'"_err_en_US,
+ symbol->name()),
+ *symbol);
+ } else {
+ result.Add(*symbol, std::move(*converted));
+ }
+ }
+ } else {
+ Say(expr.source, "Shape of value cannot be determined"_err_en_US);
+ }
+ } else {
+ AttachDeclaration(
+ Say(expr.source,
+ "Shape of component '%s' cannot be determined"_err_en_US,
+ symbol->name()),
+ *symbol);
+ }
} else if (IsAllocatable(*symbol) &&
std::holds_alternative<NullPointer>(value->u)) {
// NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE
@@ -2973,9 +3023,9 @@ std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
if (std::optional<DynamicType> type{GetType(i)}) {
return type->category() == TypeCategory::Derived
? "TYPE("s + type->AsFortran() + ')'
- : type->category() == TypeCategory::Character
- ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
- : ToUpperCase(type->AsFortran());
+ : type->category() == TypeCategory::Character
+ ? "CHARACTER(KIND="s + std::to_string(type->kind()) + ')'
+ : ToUpperCase(type->AsFortran());
} else {
return "untyped";
}
@@ -3017,6 +3067,22 @@ const evaluate::Assignment *AnalyzePointerAssignmentStmt(
ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}
+bool ExprChecker::Pre(const parser::DataImpliedDo &ido) {
+ parser::Walk(std::get<parser::DataImpliedDo::Bounds>(ido.t), *this);
+ const auto &bounds{std::get<parser::DataImpliedDo::Bounds>(ido.t)};
+ auto name{bounds.name.thing.thing};
+ int kind{evaluate::ResultType<evaluate::ImpliedDoIndex>::kind};
+ if (const auto dynamicType{evaluate::DynamicType::From(*name.symbol)}) {
+ if (dynamicType->category() == TypeCategory::Integer) {
+ kind = dynamicType->kind();
+ }
+ }
+ exprAnalyzer_.AddImpliedDo(name.source, kind);
+ parser::Walk(std::get<std::list<parser::DataIDoObject>>(ido.t), *this);
+ exprAnalyzer_.RemoveImpliedDo(name.source);
+ return false;
+}
+
bool ExprChecker::Walk(const parser::Program &program) {
parser::Walk(program, *this);
return !context_.AnyFatalError();
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index cb6fcaa933af..9adc998ec645 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -54,18 +54,18 @@ class PointerAssignmentChecker {
PointerAssignmentChecker &set_isContiguous(bool);
PointerAssignmentChecker &set_isVolatile(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
- void Check(const SomeExpr &);
+ bool Check(const SomeExpr &);
private:
- template <typename T> void Check(const T &);
- template <typename T> void Check(const evaluate::Expr<T> &);
- template <typename T> void Check(const evaluate::FunctionRef<T> &);
- template <typename T> void Check(const evaluate::Designator<T> &);
- void Check(const evaluate::NullPointer &);
- void Check(const evaluate::ProcedureDesignator &);
- void Check(const evaluate::ProcedureRef &);
+ template <typename T> bool Check(const T &);
+ template <typename T> bool Check(const evaluate::Expr<T> &);
+ template <typename T> bool Check(const evaluate::FunctionRef<T> &);
+ template <typename T> bool Check(const evaluate::Designator<T> &);
+ bool Check(const evaluate::NullPointer &);
+ bool Check(const evaluate::ProcedureDesignator &);
+ bool Check(const evaluate::ProcedureRef &);
// Target is a procedure
- void Check(
+ bool Check(
parser::CharBlock rhsName, bool isCall, const Procedure * = nullptr);
bool LhsOkForUnlimitedPoly() const;
template <typename... A> parser::Message *Say(A &&...);
@@ -105,34 +105,37 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
return *this;
}
-template <typename T> void PointerAssignmentChecker::Check(const T &) {
+template <typename T> bool PointerAssignmentChecker::Check(const T &) {
// Catch-all case for really bad target expression
Say("Target associated with %s must be a designator or a call to a"
" pointer-valued function"_err_en_US,
description_);
+ return false;
}
template <typename T>
-void PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
- std::visit([&](const auto &x) { Check(x); }, x.u);
+bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
+ return std::visit([&](const auto &x) { return Check(x); }, x.u);
}
-void PointerAssignmentChecker::Check(const SomeExpr &rhs) {
+bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
if (HasVectorSubscript(rhs)) { // C1025
Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
+ return false;
} else if (ExtractCoarrayRef(rhs)) { // C1026
Say("A coindexed object may not be a pointer target"_err_en_US);
+ return false;
} else {
- std::visit([&](const auto &x) { Check(x); }, rhs.u);
+ return std::visit([&](const auto &x) { return Check(x); }, rhs.u);
}
}
-void PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
- // P => NULL() without MOLD=; always OK
+bool PointerAssignmentChecker::Check(const evaluate::NullPointer &) {
+ return true; // P => NULL() without MOLD=; always OK
}
template <typename T>
-void PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
+bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
std::string funcName;
const auto *symbol{f.proc().GetSymbol()};
if (symbol) {
@@ -142,7 +145,7 @@ void PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
}
auto proc{Procedure::Characterize(f.proc(), context_.intrinsics())};
if (!proc) {
- return;
+ return false;
}
std::optional<MessageFixedText> msg;
const auto &funcResult{proc->functionResult}; // C1025
@@ -174,17 +177,19 @@ void PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
if (msg) {
auto restorer{common::ScopedSet(lhs_, symbol)};
Say(*msg, description_, funcName);
+ return false;
}
+ return true;
}
template <typename T>
-void PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
+bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
const Symbol *last{d.GetLastSymbol()};
const Symbol *base{d.GetBaseObject().symbol()};
if (!last || !base) {
// P => "character literal"(1:3)
context_.messages().Say("Pointer target is not a named entity"_err_en_US);
- return;
+ return false;
}
std::optional<std::variant<MessageFixedText, MessageFormattedText>> msg;
if (procedure_) {
@@ -240,7 +245,9 @@ void PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
} else {
Say(std::get<MessageFormattedText>(*msg));
}
+ return false;
}
+ return true;
}
// Compare procedure characteristics for equality except that lhs may be
@@ -257,7 +264,7 @@ static bool CharacteristicsMatch(const Procedure &lhs, const Procedure &rhs) {
}
// Common handling for procedure pointer right-hand sides
-void PointerAssignmentChecker::Check(
+bool PointerAssignmentChecker::Check(
parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) {
std::optional<MessageFixedText> msg;
if (!procedure_) {
@@ -297,18 +304,20 @@ void PointerAssignmentChecker::Check(
}
if (msg) {
Say(std::move(*msg), description_, rhsName);
+ return false;
}
+ return true;
}
-void PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
+bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
if (auto chars{Procedure::Characterize(d, context_.intrinsics())}) {
- Check(d.GetName(), false, &*chars);
+ return Check(d.GetName(), false, &*chars);
} else {
- Check(d.GetName(), false);
+ return Check(d.GetName(), false);
}
}
-void PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
+bool PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
const Procedure *procedure{nullptr};
auto chars{Procedure::Characterize(ref, context_.intrinsics())};
if (chars) {
@@ -319,7 +328,7 @@ void PointerAssignmentChecker::Check(const evaluate::ProcedureRef &ref) {
}
}
}
- Check(ref.proc().GetName(), true, procedure);
+ return Check(ref.proc().GetName(), true, procedure);
}
// The target can be unlimited polymorphic if the pointer is, or if it is
@@ -404,44 +413,53 @@ static bool CheckPointerBounds(
return isBoundsRemapping;
}
-void CheckPointerAssignment(
+bool CheckPointerAssignment(
evaluate::FoldingContext &context, const evaluate::Assignment &assignment) {
- const SomeExpr &lhs{assignment.lhs};
- const SomeExpr &rhs{assignment.rhs};
+ return CheckPointerAssignment(context, assignment.lhs, assignment.rhs,
+ CheckPointerBounds(context, assignment));
+}
+
+bool CheckPointerAssignment(evaluate::FoldingContext &context,
+ const SomeExpr &lhs, const SomeExpr &rhs, bool isBoundsRemapping) {
const Symbol *pointer{GetLastSymbol(lhs)};
if (!pointer) {
- return; // error was reported
+ return false; // error was reported
}
if (!IsPointer(*pointer)) {
evaluate::SayWithDeclaration(context.messages(), *pointer,
"'%s' is not a pointer"_err_en_US, pointer->name());
- return;
+ return false;
}
if (pointer->has<ProcEntityDetails>() && evaluate::ExtractCoarrayRef(lhs)) {
context.messages().Say( // C1027
"Procedure pointer may not be a coindexed object"_err_en_US);
- return;
+ return false;
}
- bool isBoundsRemapping{CheckPointerBounds(context, assignment)};
- PointerAssignmentChecker{context, *pointer}
+ return PointerAssignmentChecker{context, *pointer}
.set_isBoundsRemapping(isBoundsRemapping)
.Check(rhs);
}
-void CheckPointerAssignment(
+bool CheckPointerAssignment(
evaluate::FoldingContext &context, const Symbol &lhs, const SomeExpr &rhs) {
CHECK(IsPointer(lhs));
- PointerAssignmentChecker{context, lhs}.Check(rhs);
+ return PointerAssignmentChecker{context, lhs}.Check(rhs);
}
-void CheckPointerAssignment(evaluate::FoldingContext &context,
+bool CheckPointerAssignment(evaluate::FoldingContext &context,
parser::CharBlock source, const std::string &description,
const DummyDataObject &lhs, const SomeExpr &rhs) {
- PointerAssignmentChecker{context, source, description}
+ return PointerAssignmentChecker{context, source, description}
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
.Check(rhs);
}
+bool CheckInitialTarget(evaluate::FoldingContext &context,
+ const SomeExpr &pointer, const SomeExpr &init) {
+ return evaluate::IsInitialDataTarget(init, &context.messages()) &&
+ CheckPointerAssignment(context, pointer, init);
+}
+
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/pointer-assignment.h b/flang/lib/Semantics/pointer-assignment.h
index fc64fb7e1656..670e4e7ed5ea 100644
--- a/flang/lib/Semantics/pointer-assignment.h
+++ b/flang/lib/Semantics/pointer-assignment.h
@@ -26,14 +26,21 @@ namespace Fortran::semantics {
class Symbol;
-void CheckPointerAssignment(
+bool CheckPointerAssignment(
evaluate::FoldingContext &, const evaluate::Assignment &);
-void CheckPointerAssignment(
+bool CheckPointerAssignment(evaluate::FoldingContext &, const SomeExpr &lhs,
+ const SomeExpr &rhs, bool isBoundsRemapping = false);
+bool CheckPointerAssignment(
evaluate::FoldingContext &, const Symbol &lhs, const SomeExpr &rhs);
-void CheckPointerAssignment(evaluate::FoldingContext &,
+bool CheckPointerAssignment(evaluate::FoldingContext &,
parser::CharBlock source, const std::string &description,
const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs);
+// Checks whether an expression is a valid static initializer for a
+// particular pointer designator.
+bool CheckInitialTarget(
+ evaluate::FoldingContext &, const SomeExpr &pointer, const SomeExpr &init);
+
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_POINTER_ASSIGNMENT_H_
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 0cf93c6f0344..9efc7991b4ae 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1,5 +1,4 @@
//===-- lib/Semantics/resolve-names.cpp -----------------------------------===//
-//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
@@ -10,6 +9,7 @@
#include "assignment.h"
#include "check-omp-structure.h"
#include "mod-file.h"
+#include "pointer-assignment.h"
#include "program-tree.h"
#include "resolve-names-utils.h"
#include "rewrite-parse-tree.h"
@@ -18,7 +18,9 @@
#include "flang/Common/indirection.h"
#include "flang/Common/restorer.h"
#include "flang/Evaluate/characteristics.h"
+#include "flang/Evaluate/check-expression.h"
#include "flang/Evaluate/common.h"
+#include "flang/Evaluate/fold-designator.h"
#include "flang/Evaluate/fold.h"
#include "flang/Evaluate/intrinsics.h"
#include "flang/Evaluate/tools.h"
@@ -808,6 +810,8 @@ class DeclarationVisitor : public ArraySpecVisitor,
const parser::Name &, const parser::InitialDataTarget &);
void PointerInitialization(
const parser::Name &, const parser::ProcPointerInit &);
+ void NonPointerInitialization(
+ const parser::Name &, const parser::ConstantExpr &, bool inComponentDecl);
void CheckExplicitInterface(const parser::Name &);
void CheckBindings(const parser::TypeBoundProcedureStmt::WithoutInterface &);
@@ -909,7 +913,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
void SetSaveAttr(Symbol &);
bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
- void CheckInitialDataTarget(const Symbol &, const SomeExpr &, SourceName);
+ 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);
@@ -972,6 +976,7 @@ class ConstructVisitor : public virtual DeclarationVisitor {
bool Pre(const parser::AcSpec &);
bool Pre(const parser::AcImpliedDo &);
bool Pre(const parser::DataImpliedDo &);
+ bool Pre(const parser::DataIDoObject &);
bool Pre(const parser::DataStmtObject &);
bool Pre(const parser::DataStmtValue &);
bool Pre(const parser::DoConstruct &);
@@ -4372,6 +4377,7 @@ void DeclarationVisitor::CheckEquivalenceSets() {
bool DeclarationVisitor::Pre(const parser::SaveStmt &x) {
if (x.v.empty()) {
saveInfo_.saveAll = currStmtSource();
+ currScope().set_hasSAVE();
} else {
for (const parser::SavedEntity &y : x.v) {
auto kind{std::get<parser::SavedEntity::Kind>(y.t)};
@@ -4399,6 +4405,7 @@ void DeclarationVisitor::CheckSaveStmts() {
*saveInfo_.saveAll, "Global SAVE statement"_en_US);
} else if (auto msg{CheckSaveAttr(*symbol)}) {
Say(name, std::move(*msg));
+ context().SetError(*symbol);
} else {
SetSaveAttr(*symbol);
}
@@ -4450,10 +4457,9 @@ std::optional<MessageFixedText> DeclarationVisitor::CheckSaveAttr(
}
}
-// Instead of setting SAVE attribute, record the name in saveInfo_.entities.
+// Record SAVEd names in saveInfo_.entities.
Attrs DeclarationVisitor::HandleSaveName(const SourceName &name, Attrs attrs) {
if (attrs.test(Attr::SAVE)) {
- attrs.set(Attr::SAVE, false);
AddSaveName(saveInfo_.entities, name);
}
return attrs;
@@ -5007,23 +5013,32 @@ bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) {
return false;
}
+// Sets InDataStmt flag on a variable (or misidentified function) in a DATA
+// statement so that the predicate IsInitialized(base symbol) will be true
+// during semantic analysis before the symbol's initializer is constructed.
+bool ConstructVisitor::Pre(const parser::DataIDoObject &x) {
+ std::visit(
+ common::visitors{
+ [&](const parser::Scalar<Indirection<parser::Designator>> &y) {
+ Walk(y.thing.value());
+ const parser::Name &first{parser::GetFirstName(y.thing.value())};
+ if (first.symbol) {
+ first.symbol->set(Symbol::Flag::InDataStmt);
+ }
+ },
+ [&](const Indirection<parser::DataImpliedDo> &y) { Walk(y.value()); },
+ },
+ x.u);
+ return false;
+}
+
bool ConstructVisitor::Pre(const parser::DataStmtObject &x) {
std::visit(common::visitors{
[&](const Indirection<parser::Variable> &y) {
Walk(y.value());
- if (const auto *designator{
- std::get_if<Indirection<parser::Designator>>(
- &y.value().u)}) {
- if (const parser::Name *
- name{ResolveDesignator(designator->value())}) {
- if (name->symbol) {
- name->symbol->set(Symbol::Flag::InDataStmt);
- }
- }
- // TODO check C874 - C881
- } else {
- // TODO report C875 error: variable is not a designator
- // here?
+ const parser::Name &first{parser::GetFirstName(y.value())};
+ if (first.symbol) {
+ first.symbol->set(Symbol::Flag::InDataStmt);
}
},
[&](const parser::DataImpliedDo &y) {
@@ -5044,8 +5059,9 @@ bool ConstructVisitor::Pre(const parser::DataStmtValue &x) {
if (const Symbol * symbol{FindSymbol(*name)}) {
if (const Symbol * ultimate{GetAssociationRoot(*symbol)}) {
if (ultimate->has<DerivedTypeDetails>()) {
- mutableData.u = elem->ConvertToStructureConstructor(
- DerivedTypeSpec{name->source, *ultimate});
+ mutableData.u = parser::Constant<parser::StructureConstructor>{
+ elem->ConvertToStructureConstructor(
+ DerivedTypeSpec{name->source, *ultimate})};
}
}
}
@@ -5619,25 +5635,16 @@ const parser::Name *DeclarationVisitor::FindComponent(
}
// C764, C765
-void DeclarationVisitor::CheckInitialDataTarget(
+bool DeclarationVisitor::CheckInitialDataTarget(
const Symbol &pointer, const SomeExpr &expr, SourceName source) {
- auto &messages{GetFoldingContext().messages()};
- auto restorer{messages.SetLocation(source)};
- if (!evaluate::IsInitialDataTarget(expr, &messages)) {
- Say(source,
- "Pointer '%s' cannot be initialized with a reference to a designator with non-constant subscripts"_err_en_US,
- pointer.name());
- return;
- }
- if (pointer.Rank() != expr.Rank()) {
- Say(source,
- "Pointer '%s' of rank %d cannot be initialized with a target of
diff erent rank (%d)"_err_en_US,
- pointer.name(), pointer.Rank(), expr.Rank());
- return;
- }
- // TODO: check type compatibility
- // TODO: check non-deferred type parameter values
- // TODO: check contiguity if pointer is CONTIGUOUS
+ 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(
@@ -5666,52 +5673,42 @@ void DeclarationVisitor::CheckInitialProcTarget(
void DeclarationVisitor::Initialization(const parser::Name &name,
const parser::Initialization &init, bool inComponentDecl) {
+ // Traversal of the initializer was deferred to here so that the
+ // symbol being declared can be available for use in the expression, e.g.:
+ // real, parameter :: x = tiny(x)
if (!name.symbol) {
return;
}
+ 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 to the end of the specification parts so that forward
- // references work better.
+ // 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.
return;
}
- // Traversal of the initializer was deferred to here so that the
- // symbol being declared can be available for use in the expression, e.g.:
- // real, parameter :: x = tiny(x)
- Walk(init.u);
- Symbol &ultimate{name.symbol->GetUltimate()};
if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
// TODO: check C762 - all bounds and type parameters of component
// are colons or constant expressions if component is initialized
- bool isPointer{false};
+ bool isNullPointer{false};
std::visit(
common::visitors{
[&](const parser::ConstantExpr &expr) {
- if (inComponentDecl) {
- // Can't convert to type of component, which might not yet
- // be known; that's done later during instantiation.
- if (MaybeExpr value{EvaluateExpr(expr)}) {
- details->set_init(std::move(*value));
- }
- } else {
- if (MaybeExpr folded{EvaluateConvertedExpr(
- ultimate, expr, expr.thing.value().source)}) {
- details->set_init(std::move(*folded));
- }
- }
+ NonPointerInitialization(name, expr, inComponentDecl);
},
[&](const parser::NullInit &) {
- isPointer = true;
+ isNullPointer = true;
details->set_init(SomeExpr{evaluate::NullPointer{}});
},
- [&](const parser::InitialDataTarget &initExpr) {
- isPointer = true;
- if (MaybeExpr expr{EvaluateExpr(initExpr)}) {
- CheckInitialDataTarget(
- ultimate, *expr, initExpr.value().source);
- details->set_init(std::move(*expr));
- }
+ [&](const parser::InitialDataTarget &) {
+ DIE("InitialDataTarget can't appear here");
},
[&](const std::list<Indirection<parser::DataStmtValue>> &) {
+ // TODO: Need to Walk(init.u); when implementing this case
if (inComponentDecl) {
Say(name,
"Component '%s' initialized with DATA statement values"_err_en_US);
@@ -5721,18 +5718,14 @@ void DeclarationVisitor::Initialization(const parser::Name &name,
},
},
init.u);
- if (isPointer) {
+ if (isNullPointer) {
if (!IsPointer(ultimate)) {
Say(name,
- "Non-pointer component '%s' initialized with pointer target"_err_en_US);
- }
- } else {
- if (IsPointer(ultimate)) {
- Say(name,
- "Object pointer component '%s' initialized with non-pointer expression"_err_en_US);
- } else if (IsAllocatable(ultimate)) {
- Say(name, "Allocatable component '%s' cannot be initialized"_err_en_US);
+ "Non-pointer component '%s' initialized with null pointer"_err_en_US);
}
+ } else if (IsPointer(ultimate)) {
+ Say(name,
+ "Object pointer component '%s' initialized with non-pointer expression"_err_en_US);
}
}
}
@@ -5786,6 +5779,31 @@ void DeclarationVisitor::PointerInitialization(
}
}
+void DeclarationVisitor::NonPointerInitialization(const parser::Name &name,
+ const parser::ConstantExpr &expr, bool inComponentDecl) {
+ if (name.symbol) {
+ Symbol &ultimate{name.symbol->GetUltimate()};
+ if (IsPointer(ultimate)) {
+ Say(name, "'%s' is a pointer but is not initialized like one"_err_en_US);
+ } else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
+ CHECK(!details->init());
+ Walk(expr);
+ // TODO: check C762 - all bounds and type parameters of component
+ // are colons or constant expressions if component is initialized
+ if (inComponentDecl) {
+ // Can't convert to type of component, which might not yet
+ // be known; that's done later during instantiation.
+ if (MaybeExpr value{EvaluateExpr(expr)}) {
+ details->set_init(std::move(*value));
+ }
+ } else if (MaybeExpr folded{EvaluateConvertedExpr(
+ ultimate, expr, expr.thing.value().source)}) {
+ details->set_init(std::move(*folded));
+ }
+ }
+ }
+}
+
void ResolveNamesVisitor::HandleCall(
Symbol::Flag procFlag, const parser::Call &call) {
std::visit(
@@ -6064,9 +6082,11 @@ void ResolveNamesVisitor::FinishSpecificationPart() {
CheckGenericProcedures(symbol);
}
if (inModule && symbol.attrs().test(Attr::EXTERNAL) &&
- !symbol.test(Symbol::Flag::Function)) {
+ !symbol.test(Symbol::Flag::Function) &&
+ !symbol.test(Symbol::Flag::Subroutine)) {
// in a module, external proc without return type is subroutine
- symbol.set(Symbol::Flag::Subroutine);
+ symbol.set(
+ symbol.GetType() ? Symbol::Flag::Function : Symbol::Flag::Subroutine);
}
}
currScope().InstantiateDerivedTypes(context());
diff --git a/flang/lib/Semantics/rewrite-parse-tree.cpp b/flang/lib/Semantics/rewrite-parse-tree.cpp
index 435bafc73849..42962c8694f1 100644
--- a/flang/lib/Semantics/rewrite-parse-tree.cpp
+++ b/flang/lib/Semantics/rewrite-parse-tree.cpp
@@ -21,10 +21,12 @@ namespace Fortran::semantics {
using namespace parser::literals;
-/// Convert mis-identified statement functions to array element assignments.
-/// Convert mis-identified format expressions to namelist group names.
-/// Convert mis-identified character variables in I/O units to integer
+/// Convert misidentified statement functions to array element assignments.
+/// Convert misidentified format expressions to namelist group names.
+/// Convert misidentified character variables in I/O units to integer
/// unit number expressions.
+/// Convert misidentified named constants in data statement values to
+/// initial data targets
class RewriteMutator {
public:
RewriteMutator(SemanticsContext &context)
@@ -41,8 +43,10 @@ class RewriteMutator {
void Post(parser::IoUnit &);
void Post(parser::ReadStmt &);
void Post(parser::WriteStmt &);
+ void Post(parser::DataStmtConstant &);
// Name resolution yet implemented:
+ // TODO: Can some/all of these now be enabled?
bool Pre(parser::EquivalenceStmt &) { return false; }
bool Pre(parser::Keyword &) { return false; }
bool Pre(parser::EntryStmt &) { return false; }
@@ -150,6 +154,19 @@ void RewriteMutator::Post(parser::WriteStmt &x) {
FixMisparsedUntaggedNamelistName(x);
}
+void RewriteMutator::Post(parser::DataStmtConstant &x) {
+ if (auto *scalar{std::get_if<parser::Scalar<parser::ConstantValue>>(&x.u)}) {
+ if (auto *named{std::get_if<parser::NamedConstant>(&scalar->thing.u)}) {
+ if (const Symbol * symbol{named->v.symbol}) {
+ if (!IsNamedConstant(*symbol) && symbol->attrs().test(Attr::TARGET)) {
+ x.u = parser::InitialDataTarget{
+ parser::Designator{parser::DataRef{parser::Name{named->v}}}};
+ }
+ }
+ }
+ }
+}
+
bool RewriteParseTree(SemanticsContext &context, parser::Program &program) {
RewriteMutator mutator{context};
parser::Walk(program, mutator);
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 9aaa138305f8..e5ba3994b82d 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -340,6 +340,10 @@ const SomeExpr *GetExprHelper::Get(const parser::Variable &x) {
CheckMissingAnalysis(!x.typedExpr, x);
return common::GetPtrFromOptional(x.typedExpr->v);
}
+const SomeExpr *GetExprHelper::Get(const parser::DataStmtConstant &x) {
+ CheckMissingAnalysis(!x.typedExpr, x);
+ return common::GetPtrFromOptional(x.typedExpr->v);
+}
const evaluate::Assignment *GetAssignment(const parser::AssignmentStmt &x) {
CheckMissingAnalysis(!x.typedAssignment, x);
@@ -506,16 +510,19 @@ bool CanBeTypeBoundProc(const Symbol *symbol) {
}
}
-bool IsInitialized(const Symbol &symbol) {
- if (symbol.test(Symbol::Flag::InDataStmt)) {
+bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements) {
+ if (!ignoreDATAstatements && symbol.test(Symbol::Flag::InDataStmt)) {
return true;
} else if (IsNamedConstant(symbol)) {
return false;
} else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
- if (IsAllocatable(symbol) || object->init()) {
+ if (object->init()) {
return true;
- }
- if (!IsPointer(symbol) && object->type()) {
+ } else if (object->isDummy() || IsFunctionResult(symbol)) {
+ return false;
+ } else if (IsAllocatable(symbol)) {
+ return true;
+ } else if (!IsPointer(symbol) && object->type()) {
if (const auto *derived{object->type()->AsDerived()}) {
if (derived->HasDefaultInitialization()) {
return true;
@@ -553,6 +560,49 @@ bool IsSeparateModuleProcedureInterface(const Symbol *symbol) {
return false;
}
+// 3.11 automatic data object
+bool IsAutomatic(const Symbol &symbol) {
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) {
+ if (const DeclTypeSpec * type{symbol.GetType()}) {
+ // If a type parameter value is not a constant expression, the
+ // object is automatic.
+ if (type->category() == DeclTypeSpec::Character) {
+ if (const auto &length{
+ type->characterTypeSpec().length().GetExplicit()}) {
+ if (!evaluate::IsConstantExpr(*length)) {
+ return true;
+ }
+ }
+ } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
+ for (const auto &pair : derived->parameters()) {
+ if (const auto &value{pair.second.GetExplicit()}) {
+ if (!evaluate::IsConstantExpr(*value)) {
+ return true;
+ }
+ }
+ }
+ }
+ }
+ // If an array bound is not a constant expression, the object is
+ // automatic.
+ for (const ShapeSpec &dim : object->shape()) {
+ if (const auto &lb{dim.lbound().GetExplicit()}) {
+ if (!evaluate::IsConstantExpr(*lb)) {
+ return true;
+ }
+ }
+ if (const auto &ub{dim.ubound().GetExplicit()}) {
+ if (!evaluate::IsConstantExpr(*ub)) {
+ return true;
+ }
+ }
+ }
+ }
+ }
+ return false;
+}
+
bool IsFinalizable(const Symbol &symbol) {
if (const DeclTypeSpec * type{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
@@ -620,17 +670,8 @@ bool IsAssumedLengthCharacter(const Symbol &symbol) {
}
bool IsInBlankCommon(const Symbol &symbol) {
- if (FindCommonBlockContaining(symbol)) {
- if (const auto *details{
- symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
- if (details->commonBlock()) {
- if (details->commonBlock()->name().empty()) {
- return true;
- }
- }
- }
- }
- return false;
+ const Symbol *block{FindCommonBlockContaining(symbol)};
+ return block && block->name().empty();
}
// C722 and C723: For a function to be assumed length, it must be external and
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 75f728eef4e1..57b6c7544256 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -174,16 +174,9 @@ bool DerivedTypeSpec::IsForwardReferenced() const {
}
bool DerivedTypeSpec::HasDefaultInitialization() const {
- for (const Scope *scope{scope_}; scope;
- scope = scope->GetDerivedTypeParent()) {
- for (const auto &pair : *scope) {
- const Symbol &symbol{*pair.second};
- if (IsAllocatable(symbol) || IsInitialized(symbol)) {
- return true;
- }
- }
- }
- return false;
+ DirectComponentIterator components{*this};
+ return bool{std::find_if(components.begin(), components.end(),
+ [](const Symbol &component) { return IsInitialized(component); })};
}
ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
diff --git a/flang/test/Semantics/data01.f90 b/flang/test/Semantics/data01.f90
index 65664517645f..8fa36991801e 100644
--- a/flang/test/Semantics/data01.f90
+++ b/flang/test/Semantics/data01.f90
@@ -15,10 +15,10 @@ subroutine CheckRepeat
!ERROR: Missing initialization for parameter 'uninitialized'
integer, parameter :: uninitialized
!C882
- !ERROR: Repeat count for data value must not be negative
+ !ERROR: Repeat count (-1) for data value must not be negative
DATA myName%age / repeat * 35 /
!C882
- !ERROR: Repeat count for data value must not be negative
+ !ERROR: Repeat count (-11) for data value must not be negative
DATA myName%age / digits(1) * 35 /
!C882
!ERROR: Must be a constant value
@@ -47,7 +47,7 @@ subroutine CheckValue
!ERROR: 'persn' is not an array
data myname / persn(2, 'Abcd Efgh') /
!C884
- !ERROR: Structure constructor in data value must be a constant expression
+ !ERROR: Must be a constant value
data myname / person(myAge, 'Abcd Ijkl') /
integer, parameter :: a(5) =(/11, 22, 33, 44, 55/)
integer :: b(5) =(/11, 22, 33, 44, 55/)
diff --git a/flang/test/Semantics/data04.f90 b/flang/test/Semantics/data04.f90
index 98030ff52749..a34f59337f71 100644
--- a/flang/test/Semantics/data04.f90
+++ b/flang/test/Semantics/data04.f90
@@ -62,6 +62,7 @@ subroutine CheckObject(i)
end type
type(large) largeNumber
type(large), allocatable :: allocatableLarge
+ !ERROR: An automatic variable must not be initialized
type(large) :: largeNumberArray(i)
type(large) :: largeArray(5)
character :: name(i)
diff --git a/flang/test/Semantics/entry01.f90 b/flang/test/Semantics/entry01.f90
index 1e1d82ff44cd..b441c95c13f0 100644
--- a/flang/test/Semantics/entry01.f90
+++ b/flang/test/Semantics/entry01.f90
@@ -54,6 +54,7 @@ subroutine subr(goodarg1)
end type
common /badarg3/ x
namelist /badarg4/ x
+ !ERROR: A dummy argument must not be initialized
!ERROR: A dummy argument may not have the SAVE attribute
integer :: badarg5 = 2
entry okargs(goodarg1, goodarg2)
diff --git a/flang/test/Semantics/init01.f90 b/flang/test/Semantics/init01.f90
index 8f8b59d26a6c..f14c63cb00df 100644
--- a/flang/test/Semantics/init01.f90
+++ b/flang/test/Semantics/init01.f90
@@ -16,9 +16,9 @@ subroutine test(j)
real, pointer :: p3 => x3
!ERROR: An initial data target may not be a reference to an object 'x4' that lacks the SAVE attribute
real, pointer :: p4 => x4
-!ERROR: Pointer 'p5' cannot be initialized with a reference to a designator with non-constant subscripts
+!ERROR: An initial data target must be a designator with constant subscripts
real, pointer :: p5 => x5(j)
-!ERROR: Pointer 'p6' of rank 0 cannot be initialized with a target of
diff erent rank (1)
+!ERROR: Pointer has rank 0 but target has rank 1
real, pointer :: p6 => x5
!TODO: type incompatibility, non-deferred type parameter values, contiguity
diff --git a/flang/test/Semantics/resolve30.f90 b/flang/test/Semantics/resolve30.f90
index 1274e95b8b16..f42da9684e09 100644
--- a/flang/test/Semantics/resolve30.f90
+++ b/flang/test/Semantics/resolve30.f90
@@ -23,8 +23,9 @@ subroutine s3
import, none
!ERROR: No explicit type declared for 'i'
real :: a(16) = [(i, i=1, 16)]
+ real :: b(16)
!ERROR: No explicit type declared for 'j'
- data(a(j), j=1, 16) / 16 * 0.0 /
+ data(b(j), j=1, 16) / 16 * 0.0 /
end block
end
@@ -32,10 +33,7 @@ subroutine s4
real :: i, j
!ERROR: Must have INTEGER type, but is REAL(4)
real :: a(16) = [(i, i=1, 16)]
- data(
- !ERROR: Must have INTEGER type, but is REAL(4)
- a(j), &
- !ERROR: Must have INTEGER type, but is REAL(4)
- j=1, 16 &
- ) / 16 * 0.0 /
+ real :: b(16)
+ !ERROR: Must have INTEGER type, but is REAL(4)
+ data(b(j), j=1, 16) / 16 * 0.0 /
end
diff --git a/flang/test/Semantics/resolve40.f90 b/flang/test/Semantics/resolve40.f90
index 05c70b92c561..3ac59ac91903 100644
--- a/flang/test/Semantics/resolve40.f90
+++ b/flang/test/Semantics/resolve40.f90
@@ -69,7 +69,7 @@ subroutine s8
end
subroutine s9
- real :: x(4)
+ real :: x(2,2)
!ERROR: 'i' is already declared in this scoping unit
data ((x(i,i),i=1,2),i=1,2)/4*0.0/
end
diff --git a/flang/test/Semantics/symbol09.f90 b/flang/test/Semantics/symbol09.f90
index 45cb59db28a3..17ddccc49c5b 100644
--- a/flang/test/Semantics/symbol09.f90
+++ b/flang/test/Semantics/symbol09.f90
@@ -47,7 +47,7 @@ subroutine s3
!REF: /s3/n
integer, parameter :: n2 = n*n
!REF: /s3/n
- !DEF: /s3/x ObjectEntity REAL(4)
+ !DEF: /s3/x (InDataStmt) ObjectEntity REAL(4)
real, dimension(n,n) :: x
!REF: /s3/x
!DEF: /s3/ImpliedDos1/k (Implicit) ObjectEntity INTEGER(4)
@@ -129,8 +129,8 @@ subroutine s7
subroutine s8
!DEF: /s8/one PARAMETER ObjectEntity REAL(4)
real, parameter :: one = 1.0
- !DEF: /s8/y ObjectEntity REAL(4)
- !DEF: /s8/z ObjectEntity REAL(4)
+ !DEF: /s8/y (InDataStmt) ObjectEntity REAL(4)
+ !DEF: /s8/z (InDataStmt) ObjectEntity REAL(4)
real y(10), z(10)
!REF: /s8/y
!DEF: /s8/ImpliedDos1/i (Implicit) ObjectEntity INTEGER(4)
More information about the flang-commits
mailing list