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