diff --git a/flang/documentation/FortranForCProgrammers.md b/flang/documentation/FortranForCProgrammers.md --- a/flang/documentation/FortranForCProgrammers.md +++ b/flang/documentation/FortranForCProgrammers.md @@ -91,7 +91,7 @@ (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 @@ 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 --- a/flang/include/flang/Common/interval.h +++ b/flang/include/flang/Common/interval.h @@ -31,12 +31,26 @@ 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 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -278,7 +278,7 @@ 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 --- a/flang/include/flang/Evaluate/check-expression.h +++ b/flang/include/flang/Evaluate/check-expression.h @@ -33,12 +33,19 @@ extern template bool IsConstantExpr(const Expr &); extern template bool IsConstantExpr(const Expr &); extern template bool IsConstantExpr(const Expr &); +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 &, parser::ContextualMessages * = nullptr); +bool IsInitialProcedureTarget(const Symbol &); +bool IsInitialProcedureTarget(const ProcedureDesignator &); +bool IsInitialProcedureTarget(const Expr &); + // 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 --- a/flang/include/flang/Evaluate/constant.h +++ b/flang/include/flang/Evaluate/constant.h @@ -32,9 +32,9 @@ // 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> since there is no way to constrain each +// Constant 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 & +// constant, use a generic expression like Expr or // Expr) to wrap the appropriate instantiation of Constant<>. template class Constant; @@ -50,7 +50,7 @@ // 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> ValidateDimensionOrder( int rank, const std::vector &order); @@ -71,8 +71,8 @@ // 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 *dimOrder = nullptr) const; @@ -158,7 +158,8 @@ CLASS_BOILERPLATE(Constant) explicit Constant(const Scalar &); explicit Constant(Scalar &&); - Constant(ConstantSubscript, std::vector &&, ConstantSubscripts &&); + Constant( + ConstantSubscript length, std::vector &&, ConstantSubscripts &&); ~Constant(); bool operator==(const Constant &that) const { @@ -191,8 +192,6 @@ private: Scalar 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 --- 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 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -913,6 +913,7 @@ 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 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -1400,7 +1400,8 @@ // 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 @@ std::variant, Scalar, SignedIntLiteralConstant, SignedRealLiteralConstant, SignedComplexLiteralConstant, NullInit, InitialDataTarget, - StructureConstructor> + Constant> u; }; @@ -1424,6 +1425,7 @@ // 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, DataStmtConstant> t; }; diff --git a/flang/include/flang/Parser/tools.h b/flang/include/flang/Parser/tools.h --- a/flang/include/flang/Parser/tools.h +++ b/flang/include/flang/Parser/tools.h @@ -28,6 +28,19 @@ 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 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -131,8 +131,11 @@ 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 IsImpliedDo(parser::CharBlock) const; Expr AnalyzeKindSelector(common::TypeCategory category, @@ -141,7 +144,7 @@ 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 MaybeExpr Analyze(const common::Indirection &x) { return Analyze(x.value()); @@ -241,6 +244,7 @@ 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 @@ 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 @@ } template bool Pre(const parser::Scalar &x) { - AnalyzeExpr(context_, x); + exprAnalyzer_.Analyze(x); return false; } template bool Pre(const parser::Constant &x) { - AnalyzeExpr(context_, x); + exprAnalyzer_.Analyze(x); return false; } template bool Pre(const parser::Integer &x) { - AnalyzeExpr(context_, x); + exprAnalyzer_.Analyze(x); return false; } template bool Pre(const parser::Logical &x) { - AnalyzeExpr(context_, x); + exprAnalyzer_.Analyze(x); return false; } template bool Pre(const parser::DefaultChar &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 --- a/flang/include/flang/Semantics/scope.h +++ b/flang/include/flang/Semantics/scope.h @@ -207,6 +207,9 @@ 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 @@ std::optional importKind_; std::set 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 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -84,7 +84,7 @@ 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 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 @@ const SomeExpr &expr, const SemanticsContext &context); struct GetExprHelper { - const SomeExpr *Get(const parser::Expr &); - const SomeExpr *Get(const parser::Variable &); - template const SomeExpr *Get(const common::Indirection &x) { + static const SomeExpr *Get(const parser::Expr &); + static const SomeExpr *Get(const parser::Variable &); + static const SomeExpr *Get(const parser::DataStmtConstant &); + template + static const SomeExpr *Get(const common::Indirection &x) { return Get(x.value()); } - template const SomeExpr *Get(const std::optional &x) { + template static const SomeExpr *Get(const std::optional &x) { return x ? Get(*x) : nullptr; } - template const SomeExpr *Get(const T &x) { + template static const SomeExpr *Get(const T &x) { if constexpr (ConstraintTrait) { return Get(x.thing); } else if constexpr (WrapperTrait) { @@ -521,5 +524,6 @@ 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 --- a/flang/lib/Evaluate/call.cpp +++ b/flang/lib/Evaluate/call.cpp @@ -98,6 +98,7 @@ 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(&u)}) { @@ -107,9 +108,9 @@ 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 --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -563,8 +563,9 @@ } std::optional Procedure::Characterize( - const semantics::Symbol &symbol, const IntrinsicProcTable &intrinsics) { + const semantics::Symbol &original, const IntrinsicProcTable &intrinsics) { Procedure result; + const auto &symbol{ResolveAssociations(original)}; CopyAttrs(symbol, result, { {semantics::Attr::PURE, Procedure::Attr::Pure}, diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -33,7 +33,9 @@ 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 @@ } 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 @@ return false; } } + + bool operator()(const Constant &) const { return true; } + +private: + bool IsConstantStructureConstructorComponent( + const Symbol &component, const Expr &expr) const { + if (IsAllocatable(component)) { + return IsNullPointer(expr); + } else if (IsPointer(component)) { + return IsNullPointer(expr) || IsInitialDataTarget(expr) || + IsInitialProcedureTarget(expr); + } else { + return (*this)(expr); + } + } }; template bool IsConstantExpr(const A &x) { @@ -81,12 +94,11 @@ template bool IsConstantExpr(const Expr &); template bool IsConstantExpr(const Expr &); template bool IsConstantExpr(const Expr &); +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 { public: @@ -95,45 +107,47 @@ 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 bool operator()(const Constant &) 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 @@ private: parser::ContextualMessages *messages_; + bool emittedMessage_{false}; }; bool IsInitialDataTarget( const Expr &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 &expr) { + if (const auto *proc{std::get_if(&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 --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -150,11 +150,9 @@ 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 --- a/flang/lib/Evaluate/fold.cpp +++ b/flang/lib/Evaluate/fold.cpp @@ -55,13 +55,60 @@ 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 A Expand(A &&x) const { + return std::move(x); // default case + } + template Constant Expand(Constant &&x) { + return x.Reshape(std::move(extents_)); + } + template Expr Expand(Expr &&x) { + return std::visit([&](auto &&x) { return Expr{Expand(std::move(x))}; }, + std::move(x.u)); + } + +private: + ConstantSubscripts &extents_; +}; + Expr 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{Constant{std::move(ctor)}}; + } else { + return Expr{std::move(ctor)}; } - return Expr{Constant{std::move(result)}}; } Component FoldOperation(FoldingContext &context, Component &&component) { diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -439,6 +439,7 @@ [&](const semantics::HostAssocDetails &assoc) { return (*this)(assoc.symbol()); }, + [](const semantics::TypeParamDetails &) { return Scalar(); }, [](const auto &) { return Result{}; }, }, symbol.details()); @@ -653,4 +654,22 @@ } 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 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -981,28 +981,39 @@ return symbol.has() && 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()}; - object && object->init()) { - return true; - } else if (IsProcedurePointer(symbol) && - symbol.get().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()}; + object && object->init()) { + return true; + } else if (IsProcedurePointer(symbol) && + symbol.get().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 @@ [](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 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -472,7 +472,7 @@ 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 --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -833,7 +833,7 @@ construct(scalar(Parser{})), construct(nullInit), construct(scalar(constantSubobject)) / !"("_tok, - construct(Parser{}), + construct(constant(Parser{})), construct(signedRealLiteralConstant), construct(signedIntLiteralConstant), extension( diff --git a/flang/lib/Parser/tools.cpp b/flang/lib/Parser/tools.cpp --- a/flang/lib/Parser/tools.cpp +++ b/flang/lib/Parser/tools.cpp @@ -68,6 +68,61 @@ [](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 &sc) + -> const Name & { return GetFirstName(sc.value()); }, + [](const common::Indirection &sc) -> const Name & { + return GetFirstName(sc.value().base); + }, + [](const common::Indirection &ci) + -> const Name & { return GetFirstName(ci.value().base); }, + }, + x.u); +} + +const Name &GetFirstName(const Substring &x) { + return GetFirstName(std::get(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(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.h b/flang/lib/Semantics/check-data.h --- a/flang/lib/Semantics/check-data.h +++ b/flang/lib/Semantics/check-data.h @@ -19,8 +19,6 @@ 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-data.cpp b/flang/lib/Semantics/check-data.cpp --- 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(&dataConst.u)}) { - for (const auto &component : - std::get>(structure->t)) { - const parser::Expr &parsedExpr{ - std::get(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::DataStmtRepeat &dataRepeat) { - if (const auto *designator{parser::Unwrap(dataRepeat)}) { - if (auto *dataRef{std::get_if(&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-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -283,6 +283,11 @@ 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 @@ } } 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 @@ 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 --- a/flang/lib/Semantics/check-do-forall.cpp +++ b/flang/lib/Semantics/check-do-forall.cpp @@ -208,7 +208,7 @@ 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 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -338,7 +338,7 @@ // A utility subroutine to repackage optional expressions of various levels // of type specificity as fully general MaybeExpr values. template common::IfNoLvalue AsMaybeExpr(A &&x) { - return std::make_optional(AsGenericExpr(std::move(x))); + return AsGenericExpr(std::move(x)); } template MaybeExpr AsMaybeExpr(std::optional &&x) { if (x) { @@ -529,7 +529,7 @@ auto &realExpr{std::get>(result->u)}; if (auto sign{std::get>(x.t)}) { if (sign == parser::Sign::Negative) { - return {AsGenericExpr(-std::move(realExpr))}; + return AsGenericExpr(-std::move(realExpr)); } } return result; @@ -722,6 +722,26 @@ return Analyze(x.value()); } +MaybeExpr ExpressionAnalyzer::Analyze(const parser::DataStmtValue &x) { + if (const auto &repeat{ + std::get>(x.t)}) { + x.repetitions = 0; + if (MaybeExpr expr{Analyze(repeat->u)}) { + Expr 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(x.t)); +} + // Substring references std::optional> ExpressionAnalyzer::GetSubstringBound( const std::optional &bound) { @@ -806,8 +826,8 @@ .Push(cp->GetScalarValue().value()); Substring substring{std::move(staticData), std::move(lower.value()), std::move(upper.value())}; - return AsGenericExpr(Expr{ - Expr{Designator{std::move(substring)}}}); + return AsGenericExpr( + Expr{Designator{std::move(substring)}}); }, std::move(charExpr->u)); } @@ -1000,7 +1020,7 @@ 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 @@ bool anyKeyword{false}; StructureConstructor result{spec}; bool checkConflicts{true}; // until we hit one + auto &messages{GetContextualMessages()}; for (const auto &component : std::get>(structure.t)) { const parser::Expr &expr{ std::get(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 @@ 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(value->u)) { // NULL() with no arguments allowed by 7.5.10 para 6 for ALLOCATABLE @@ -2973,9 +3023,9 @@ if (std::optional 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 @@ ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {} +bool ExprChecker::Pre(const parser::DataImpliedDo &ido) { + parser::Walk(std::get(ido.t), *this); + const auto &bounds{std::get(ido.t)}; + auto name{bounds.name.thing.thing}; + int kind{evaluate::ResultType::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>(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.h b/flang/lib/Semantics/pointer-assignment.h --- a/flang/lib/Semantics/pointer-assignment.h +++ b/flang/lib/Semantics/pointer-assignment.h @@ -26,14 +26,21 @@ 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/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -54,18 +54,18 @@ PointerAssignmentChecker &set_isContiguous(bool); PointerAssignmentChecker &set_isVolatile(bool); PointerAssignmentChecker &set_isBoundsRemapping(bool); - void Check(const SomeExpr &); + bool Check(const SomeExpr &); private: - template void Check(const T &); - template void Check(const evaluate::Expr &); - template void Check(const evaluate::FunctionRef &); - template void Check(const evaluate::Designator &); - void Check(const evaluate::NullPointer &); - void Check(const evaluate::ProcedureDesignator &); - void Check(const evaluate::ProcedureRef &); + template bool Check(const T &); + template bool Check(const evaluate::Expr &); + template bool Check(const evaluate::FunctionRef &); + template bool Check(const evaluate::Designator &); + 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 parser::Message *Say(A &&...); @@ -105,34 +105,37 @@ return *this; } -template void PointerAssignmentChecker::Check(const T &) { +template 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 -void PointerAssignmentChecker::Check(const evaluate::Expr &x) { - std::visit([&](const auto &x) { Check(x); }, x.u); +bool PointerAssignmentChecker::Check(const evaluate::Expr &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 -void PointerAssignmentChecker::Check(const evaluate::FunctionRef &f) { +bool PointerAssignmentChecker::Check(const evaluate::FunctionRef &f) { std::string funcName; const auto *symbol{f.proc().GetSymbol()}; if (symbol) { @@ -142,7 +145,7 @@ } auto proc{Procedure::Characterize(f.proc(), context_.intrinsics())}; if (!proc) { - return; + return false; } std::optional msg; const auto &funcResult{proc->functionResult}; // C1025 @@ -174,17 +177,19 @@ if (msg) { auto restorer{common::ScopedSet(lhs_, symbol)}; Say(*msg, description_, funcName); + return false; } + return true; } template -void PointerAssignmentChecker::Check(const evaluate::Designator &d) { +bool PointerAssignmentChecker::Check(const evaluate::Designator &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> msg; if (procedure_) { @@ -240,7 +245,9 @@ } else { Say(std::get(*msg)); } + return false; } + return true; } // Compare procedure characteristics for equality except that lhs may be @@ -257,7 +264,7 @@ } // Common handling for procedure pointer right-hand sides -void PointerAssignmentChecker::Check( +bool PointerAssignmentChecker::Check( parser::CharBlock rhsName, bool isCall, const Procedure *rhsProcedure) { std::optional msg; if (!procedure_) { @@ -297,18 +304,20 @@ } 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 @@ } } } - 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 @@ 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() && 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/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- 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 @@ 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 @@ 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 @@ 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 @@ 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(y.t)}; @@ -4399,6 +4405,7 @@ *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 @@ } } -// 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 @@ 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> &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 &y) { Walk(y.value()); }, + }, + x.u); + return false; +} + bool ConstructVisitor::Pre(const parser::DataStmtObject &x) { std::visit(common::visitors{ [&](const Indirection &y) { Walk(y.value()); - if (const auto *designator{ - std::get_if>( - &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 @@ if (const Symbol * symbol{FindSymbol(*name)}) { if (const Symbol * ultimate{GetAssociationRoot(*symbol)}) { if (ultimate->has()) { - mutableData.u = elem->ConvertToStructureConstructor( - DerivedTypeSpec{name->source, *ultimate}); + mutableData.u = parser::Constant{ + elem->ConvertToStructureConstructor( + DerivedTypeSpec{name->source, *ultimate})}; } } } @@ -5619,25 +5635,16 @@ } // 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 different 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( + *dyType, evaluate::DataRef{pointer})}; + CHECK(designator); + return CheckInitialTarget(context, *designator, expr); } void DeclarationVisitor::CheckInitialProcTarget( @@ -5666,52 +5673,42 @@ 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(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()}) { // 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> &) { + // 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 @@ }, }, 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::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()}) { + 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 @@ 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 --- a/flang/lib/Semantics/rewrite-parse-tree.cpp +++ b/flang/lib/Semantics/rewrite-parse-tree.cpp @@ -21,10 +21,12 @@ 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 @@ 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 @@ FixMisparsedUntaggedNamelistName(x); } +void RewriteMutator::Post(parser::DataStmtConstant &x) { + if (auto *scalar{std::get_if>(&x.u)}) { + if (auto *named{std::get_if(&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 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -340,6 +340,10 @@ 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 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()}) { - 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 @@ return false; } +// 3.11 automatic data object +bool IsAutomatic(const Symbol &symbol) { + if (const auto *object{symbol.detailsIf()}) { + 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 IsInBlankCommon(const Symbol &symbol) { - if (FindCommonBlockContaining(symbol)) { - if (const auto *details{ - symbol.detailsIf()}) { - 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 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -174,16 +174,9 @@ } 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 --- a/flang/test/Semantics/data01.f90 +++ b/flang/test/Semantics/data01.f90 @@ -15,10 +15,10 @@ !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 @@ !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 --- a/flang/test/Semantics/data04.f90 +++ b/flang/test/Semantics/data04.f90 @@ -62,6 +62,7 @@ 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 --- a/flang/test/Semantics/entry01.f90 +++ b/flang/test/Semantics/entry01.f90 @@ -54,6 +54,7 @@ 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 --- a/flang/test/Semantics/init01.f90 +++ b/flang/test/Semantics/init01.f90 @@ -16,9 +16,9 @@ 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 different 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 --- a/flang/test/Semantics/resolve30.f90 +++ b/flang/test/Semantics/resolve30.f90 @@ -23,8 +23,9 @@ 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 @@ 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 --- a/flang/test/Semantics/resolve40.f90 +++ b/flang/test/Semantics/resolve40.f90 @@ -69,7 +69,7 @@ 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 --- a/flang/test/Semantics/symbol09.f90 +++ b/flang/test/Semantics/symbol09.f90 @@ -47,7 +47,7 @@ !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 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)