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 @@ -12,6 +12,7 @@ #define FORTRAN_EVALUATE_CHECK_EXPRESSION_H_ #include "expression.h" +#include "intrinsics.h" #include "type.h" #include @@ -41,24 +42,38 @@ // Check whether an expression is a specification expression // (10.1.11(2), C1010). Constant expressions are always valid // specification expressions. + +// There are two contexts where specification expressions appear -- array +// bounds and type param expressions. We need to differentiate them because +// additional checks are required for array bounds expressions in declarations +// of derived type components (see C750). +ENUM_CLASS(SpecificationExprContext, TYPE_PARAM, BOUND) + template -void CheckSpecificationExpr( - const A &, parser::ContextualMessages &, const semantics::Scope &); +void CheckSpecificationExpr(const A &, parser::ContextualMessages &, + const semantics::Scope &, const IntrinsicProcTable &, + SpecificationExprContext); extern template void CheckSpecificationExpr(const Expr &x, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); extern template void CheckSpecificationExpr(const Expr &x, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); extern template void CheckSpecificationExpr(const Expr &x, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); extern template void CheckSpecificationExpr( const std::optional> &x, parser::ContextualMessages &, - const semantics::Scope &); + const semantics::Scope &, const IntrinsicProcTable &, + SpecificationExprContext); extern template void CheckSpecificationExpr( const std::optional> &x, parser::ContextualMessages &, - const semantics::Scope &); + const semantics::Scope &, const IntrinsicProcTable &, + SpecificationExprContext); extern template void CheckSpecificationExpr( const std::optional> &x, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); // Simple contiguity (9.5.4) template diff --git a/flang/include/flang/Evaluate/intrinsics.h b/flang/include/flang/Evaluate/intrinsics.h --- a/flang/include/flang/Evaluate/intrinsics.h +++ b/flang/include/flang/Evaluate/intrinsics.h @@ -55,6 +55,11 @@ // All argument and result types are intrinsic types with default kinds. }; +// Generic intrinsic classes from table 16.1 +ENUM_CLASS(IntrinsicClass, atomicSubroutine, collectiveSubroutine, + elementalFunction, elementalSubroutine, inquiryFunction, pureSubroutine, + impureSubroutine, transformationalFunction, noClass) + class IntrinsicProcTable { private: class Implementation; @@ -68,6 +73,9 @@ // statement. bool IsIntrinsic(const std::string &) const; + // Inquiry intrinsics are defined in section 16.7, table 16.1 + IntrinsicClass GetIntrinsicClass(const std::string &) const; + // Probe the intrinsics for a match against a specific call. // On success, the actual arguments are transferred to the result // in dummy argument order; on failure, the actual arguments remain 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,10 +7,13 @@ //===----------------------------------------------------------------------===// #include "flang/Evaluate/check-expression.h" +#include "flang/Evaluate/intrinsics.h" #include "flang/Evaluate/traverse.h" #include "flang/Evaluate/type.h" #include "flang/Semantics/symbol.h" #include "flang/Semantics/tools.h" +#include +#include namespace Fortran::evaluate { @@ -171,6 +174,7 @@ return (*this)(x.left()); } bool operator()(const Relational &) const { return false; } + private: parser::ContextualMessages *messages_; }; @@ -187,8 +191,10 @@ public: using Result = std::optional; using Base = AnyTraverse; - explicit CheckSpecificationExprHelper(const semantics::Scope &s) - : Base{*this}, scope_{s} {} + explicit CheckSpecificationExprHelper(const semantics::Scope &s, + const IntrinsicProcTable &table, SpecificationExprContext specExprContext) + : Base{*this}, scope_{s}, table_{table}, specExprContext_{ + specExprContext} {} using Base::operator(); Result operator()(const ProcedureDesignator &) const { @@ -199,6 +205,10 @@ Result operator()(const semantics::Symbol &symbol) const { if (semantics::IsNamedConstant(symbol)) { return std::nullopt; + } else if (scope_.IsDerivedType() && IsVariableName(symbol) && + specExprContext_ == SpecificationExprContext::BOUND) { // C750 + return "reference to variable '"s + symbol.name().ToString() + + "' not allowed for derived type components"; } else if (symbol.IsDummy()) { if (symbol.attrs().test(semantics::Attr::OPTIONAL)) { return "reference to OPTIONAL dummy argument '"s + @@ -243,16 +253,51 @@ return std::nullopt; } + template + Result operator()(const TypeParamInquiry &inq) const { + if (scope_.IsDerivedType() && !IsConstantExpr(inq) && + inq.parameter().owner() != scope_ && + specExprContext_ == SpecificationExprContext::BOUND) { // C750 + return "non-constant reference to a type parameter inquiry " + "not allowed for derived type components"; + } + return std::nullopt; + } + template Result operator()(const FunctionRef &x) const { if (const auto *symbol{x.proc().GetSymbol()}) { if (!semantics::IsPureProcedure(*symbol)) { return "reference to impure function '"s + symbol->name().ToString() + "'"; } + if (semantics::IsStmtFunction(*symbol)) { + return "reference to statement function '"s + + symbol->name().ToString() + "'"; + } + if (scope_.IsDerivedType() && + specExprContext_ == SpecificationExprContext::BOUND) { // C750 + return "reference to function '"s + symbol->name().ToString() + + "' not allowed for derived type components"; + } // TODO: other checks for standard module procedures } else { const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; - if (intrin.name == "present") { + if (scope_.IsDerivedType() && + specExprContext_ == SpecificationExprContext::BOUND) { // C750 + if ((table_.IsIntrinsic(intrin.name) && + badIntrinsicsForComponents_.find(intrin.name) != + badIntrinsicsForComponents_.end()) || + IsProhibitedFunction(intrin.name)) { + return "reference to intrinsic '"s + intrin.name + + "' not allowed for derived type components"; + } + if (table_.GetIntrinsicClass(intrin.name) == + IntrinsicClass::inquiryFunction && + !IsConstantExpr(x)) { + return "non-constant reference to inquiry intrinsic '"s + + intrin.name + "' not allowed for derived type components"; + } + } else if (intrin.name == "present") { return std::nullopt; // no need to check argument(s) } if (IsConstantExpr(x)) { @@ -265,29 +310,42 @@ private: const semantics::Scope &scope_; + const IntrinsicProcTable &table_; + const SpecificationExprContext specExprContext_; + 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) { - if (auto why{CheckSpecificationExprHelper{scope}(x)}) { + const semantics::Scope &scope, const IntrinsicProcTable &table, + SpecificationExprContext specExprContext) { + if (auto why{ + CheckSpecificationExprHelper{scope, table, specExprContext}(x)}) { messages.Say("Invalid specification expression: %s"_err_en_US, *why); } } template void CheckSpecificationExpr(const Expr &, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); template void CheckSpecificationExpr(const Expr &, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); template void CheckSpecificationExpr(const Expr &, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); template void CheckSpecificationExpr(const std::optional> &, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); template void CheckSpecificationExpr(const std::optional> &, - parser::ContextualMessages &, const semantics::Scope &); + parser::ContextualMessages &, const semantics::Scope &, + const IntrinsicProcTable &, SpecificationExprContext); template void CheckSpecificationExpr( const std::optional> &, parser::ContextualMessages &, - const semantics::Scope &); + const semantics::Scope &, const IntrinsicProcTable &, + SpecificationExprContext); // IsSimplyContiguous() -- 9.5.4 class IsSimplyContiguousHelper 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 @@ -229,6 +229,7 @@ IntrinsicDummyArgument dummy[maxArguments]; TypePattern result; Rank rank{Rank::elemental}; + IntrinsicClass intrinsicClass{IntrinsicClass::elementalFunction}; std::optional Match(const CallCharacteristics &, const common::IntrinsicTypeDefaultKinds &, ActualArguments &, FoldingContext &context) const; @@ -265,19 +266,21 @@ {"aimag", {{"x", SameComplex}}, SameReal}, {"aint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal}, {"all", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, - Rank::dimReduced}, - {"allocated", {{"array", AnyData, Rank::array}}, DefaultLogical}, - {"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical}, + Rank::dimReduced, IntrinsicClass::transformationalFunction}, + {"allocated", {{"array", AnyData, Rank::array}}, DefaultLogical, + Rank::elemental, IntrinsicClass::inquiryFunction}, + {"allocated", {{"scalar", AnyData, Rank::scalar}}, DefaultLogical, + Rank::elemental, IntrinsicClass::inquiryFunction}, {"anint", {{"a", SameReal}, MatchingDefaultKIND}, KINDReal}, {"any", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, - Rank::dimReduced}, + Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"asin", {{"x", SameFloating}}, SameFloating}, {"asind", {{"x", SameFloating}}, SameFloating}, {"asinh", {{"x", SameFloating}}, SameFloating}, {"associated", {{"pointer", Addressable, Rank::known}, {"target", Addressable, Rank::known, Optionality::optional}}, - DefaultLogical}, + DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, {"atan", {{"x", SameFloating}}, SameFloating}, {"atand", {{"x", SameFloating}}, SameFloating}, {"atan", {{"y", OperandReal}, {"x", OperandReal}}, OperandReal}, @@ -291,14 +294,14 @@ {"bessel_jn", {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar}, {"x", SameReal, Rank::scalar}}, - SameReal, Rank::vector}, + SameReal, Rank::vector, IntrinsicClass::transformationalFunction}, {"bessel_y0", {{"x", SameReal}}, SameReal}, {"bessel_y1", {{"x", SameReal}}, SameReal}, {"bessel_yn", {{"n", AnyInt}, {"x", SameReal}}, SameReal}, {"bessel_yn", {{"n1", AnyInt, Rank::scalar}, {"n2", AnyInt, Rank::scalar}, {"x", SameReal, Rank::scalar}}, - SameReal, Rank::vector}, + SameReal, Rank::vector, IntrinsicClass::transformationalFunction}, {"bge", {{"i", AnyInt, Rank::elementalOrBOZ}, {"j", AnyInt, Rank::elementalOrBOZ}}, @@ -308,7 +311,7 @@ {"j", AnyInt, Rank::elementalOrBOZ}}, DefaultLogical}, {"bit_size", {{"i", SameInt, Rank::anyOrAssumedRank}}, SameInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"ble", {{"i", AnyInt, Rank::elementalOrBOZ}, {"j", AnyInt, Rank::elementalOrBOZ}}, @@ -327,34 +330,36 @@ {"y", AnyIntOrReal, Rank::elementalOrBOZ, Optionality::optional}, DefaultingKIND}, KINDComplex}, - {"command_argument_count", {}, DefaultInt, Rank::scalar}, + {"command_argument_count", {}, DefaultInt, Rank::scalar, + IntrinsicClass::transformationalFunction}, {"conjg", {{"z", SameComplex}}, SameComplex}, {"cos", {{"x", SameFloating}}, SameFloating}, {"cosd", {{"x", SameFloating}}, SameFloating}, {"cosh", {{"x", SameFloating}}, SameFloating}, {"count", {{"mask", AnyLogical, Rank::array}, OptionalDIM, DefaultingKIND}, - KINDInt, Rank::dimReduced}, + KINDInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"cshift", {{"array", SameType, Rank::array}, {"shift", AnyInt, Rank::dimRemoved}, OptionalDIM}, - SameType, Rank::conformable}, + SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, {"dble", {{"a", AnyNumeric, Rank::elementalOrBOZ}}, DoublePrecision}, {"digits", {{"x", AnyIntOrReal, Rank::anyOrAssumedRank}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"dim", {{"x", OperandIntOrReal}, {"y", OperandIntOrReal}}, OperandIntOrReal}, {"dot_product", {{"vector_a", AnyLogical, Rank::vector}, {"vector_b", AnyLogical, Rank::vector}}, - ResultLogical, Rank::scalar}, + ResultLogical, Rank::scalar, IntrinsicClass::transformationalFunction}, {"dot_product", {{"vector_a", AnyComplex, Rank::vector}, {"vector_b", AnyNumeric, Rank::vector}}, - ResultNumeric, Rank::scalar}, // conjugates vector_a + ResultNumeric, Rank::scalar, // conjugates vector_a + IntrinsicClass::transformationalFunction}, {"dot_product", {{"vector_a", AnyIntOrReal, Rank::vector}, {"vector_b", AnyNumeric, Rank::vector}}, - ResultNumeric, Rank::scalar}, + ResultNumeric, Rank::scalar, IntrinsicClass::transformationalFunction}, {"dprod", {{"x", DefaultReal}, {"y", DefaultReal}}, DoublePrecision}, {"dshiftl", {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}, @@ -372,68 +377,72 @@ {"boundary", SameIntrinsic, Rank::dimRemoved, Optionality::optional}, OptionalDIM}, - SameIntrinsic, Rank::conformable}, + SameIntrinsic, Rank::conformable, + IntrinsicClass::transformationalFunction}, {"eoshift", {{"array", SameDerivedType, Rank::array}, {"shift", AnyInt, Rank::dimRemoved}, {"boundary", SameDerivedType, Rank::dimRemoved}, OptionalDIM}, - SameDerivedType, Rank::conformable}, + SameDerivedType, Rank::conformable, + IntrinsicClass::transformationalFunction}, {"epsilon", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"erf", {{"x", SameReal}}, SameReal}, {"erfc", {{"x", SameReal}}, SameReal}, {"erfc_scaled", {{"x", SameReal}}, SameReal}, {"exp", {{"x", SameFloating}}, SameFloating}, + {"exp", {{"x", SameFloating}}, SameFloating}, {"exponent", {{"x", AnyReal}}, DefaultInt}, + {"exp", {{"x", SameFloating}}, SameFloating}, {"extends_type_of", {{"a", ExtensibleDerived, Rank::anyOrAssumedRank}, {"mold", ExtensibleDerived, Rank::anyOrAssumedRank}}, - DefaultLogical, Rank::scalar}, + DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, {"findloc", {{"array", AnyNumeric, Rank::array}, {"value", AnyNumeric, Rank::scalar}, RequiredDIM, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::dimRemoved}, + KINDInt, Rank::dimRemoved, IntrinsicClass::transformationalFunction}, {"findloc", {{"array", AnyNumeric, Rank::array}, {"value", AnyNumeric, Rank::scalar}, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::vector}, + KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, {"findloc", {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar}, RequiredDIM, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::dimRemoved}, + KINDInt, Rank::dimRemoved, IntrinsicClass::transformationalFunction}, {"findloc", {{"array", SameChar, Rank::array}, {"value", SameChar, Rank::scalar}, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::vector}, + KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, {"findloc", {{"array", AnyLogical, Rank::array}, {"value", AnyLogical, Rank::scalar}, RequiredDIM, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::dimRemoved}, + KINDInt, Rank::dimRemoved, IntrinsicClass::transformationalFunction}, {"findloc", {{"array", AnyLogical, Rank::array}, {"value", AnyLogical, Rank::scalar}, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::vector}, + KINDInt, Rank::vector, IntrinsicClass::transformationalFunction}, {"floor", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, {"fraction", {{"x", SameReal}}, SameReal}, {"gamma", {{"x", SameReal}}, SameReal}, {"huge", {{"x", SameIntOrReal, Rank::anyOrAssumedRank}}, SameIntOrReal, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"hypot", {{"x", OperandReal}, {"y", OperandReal}}, OperandReal}, {"iachar", {{"c", AnyChar}, DefaultingKIND}, KINDInt}, {"iall", {{"array", SameInt, Rank::array}, OptionalDIM, OptionalMASK}, - SameInt, Rank::dimReduced}, + SameInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"iany", {{"array", SameInt, Rank::array}, OptionalDIM, OptionalMASK}, - SameInt, Rank::dimReduced}, + SameInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"iparity", {{"array", SameInt, Rank::array}, OptionalDIM, OptionalMASK}, - SameInt, Rank::dimReduced}, + SameInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"iand", {{"i", SameInt}, {"j", SameInt, Rank::elementalOrBOZ}}, SameInt}, {"iand", {{"i", BOZ}, {"j", SameInt}}, SameInt}, {"ibclr", {{"i", SameInt}, {"pos", AnyInt}}, SameInt}, @@ -461,19 +470,20 @@ {"size", AnyInt, Rank::elemental, Optionality::optional}}, SameInt}, {"is_contiguous", {{"array", Addressable, Rank::anyOrAssumedRank}}, - DefaultLogical}, + DefaultLogical, Rank::elemental, IntrinsicClass::inquiryFunction}, {"is_iostat_end", {{"i", AnyInt}}, DefaultLogical}, {"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical}, - {"kind", {{"x", AnyIntrinsic}}, DefaultInt}, + {"kind", {{"x", AnyIntrinsic}}, DefaultInt, Rank::elemental, + IntrinsicClass::inquiryFunction}, {"lbound", {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM, SizeDefaultKIND}, - KINDInt, Rank::scalar}, + KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"lbound", {{"array", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, - KINDInt, Rank::vector}, + KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, {"leadz", {{"i", AnyInt}}, DefaultInt}, {"len", {{"string", AnyChar, Rank::anyOrAssumedRank}, DefaultingKIND}, - KINDInt, Rank::scalar}, + KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"len_trim", {{"string", AnyChar}, DefaultingKIND}, KINDInt}, {"lge", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, {"lgt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, @@ -488,27 +498,27 @@ {"matmul", {{"array_a", AnyLogical, Rank::vector}, {"array_b", AnyLogical, Rank::matrix}}, - ResultLogical, Rank::vector}, + ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction}, {"matmul", {{"array_a", AnyLogical, Rank::matrix}, {"array_b", AnyLogical, Rank::vector}}, - ResultLogical, Rank::vector}, + ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction}, {"matmul", {{"array_a", AnyLogical, Rank::matrix}, {"array_b", AnyLogical, Rank::matrix}}, - ResultLogical, Rank::matrix}, + ResultLogical, Rank::matrix, IntrinsicClass::transformationalFunction}, {"matmul", {{"array_a", AnyNumeric, Rank::vector}, {"array_b", AnyNumeric, Rank::matrix}}, - ResultNumeric, Rank::vector}, + ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction}, {"matmul", {{"array_a", AnyNumeric, Rank::matrix}, {"array_b", AnyNumeric, Rank::vector}}, - ResultNumeric, Rank::vector}, + ResultNumeric, Rank::vector, IntrinsicClass::transformationalFunction}, {"matmul", {{"array_a", AnyNumeric, Rank::matrix}, {"array_b", AnyNumeric, Rank::matrix}}, - ResultNumeric, Rank::matrix}, + ResultNumeric, Rank::matrix, IntrinsicClass::transformationalFunction}, {"maskl", {{"i", AnyInt}, DefaultingKIND}, KINDInt}, {"maskr", {{"i", AnyInt}, DefaultingKIND}, KINDInt}, {"max", @@ -520,15 +530,16 @@ {"a3", SameChar, Rank::elemental, Optionality::repeats}}, SameChar}, {"maxexponent", {{"x", AnyReal, Rank::anyOrAssumedRank}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"maxloc", {{"array", AnyRelatable, Rank::array}, OptionalDIM, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::dimReduced}, + KINDInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"maxval", {{"array", SameRelatable, Rank::array}, OptionalDIM, OptionalMASK}, - SameRelatable, Rank::dimReduced}, + SameRelatable, Rank::dimReduced, + IntrinsicClass::transformationalFunction}, {"merge", {{"tsource", SameType}, {"fsource", SameType}, {"mask", AnyLogical}}, SameType}, @@ -548,25 +559,26 @@ {"a3", SameChar, Rank::elemental, Optionality::repeats}}, SameChar}, {"minexponent", {{"x", AnyReal, Rank::anyOrAssumedRank}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"minloc", {{"array", AnyRelatable, Rank::array}, OptionalDIM, OptionalMASK, SizeDefaultKIND, {"back", AnyLogical, Rank::scalar, Optionality::optional}}, - KINDInt, Rank::dimReduced}, + KINDInt, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"minval", {{"array", SameRelatable, Rank::array}, OptionalDIM, OptionalMASK}, - SameRelatable, Rank::dimReduced}, + SameRelatable, Rank::dimReduced, + IntrinsicClass::transformationalFunction}, {"mod", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}}, OperandIntOrReal}, {"modulo", {{"a", OperandIntOrReal}, {"p", OperandIntOrReal}}, OperandIntOrReal}, {"nearest", {{"x", SameReal}, {"s", AnyReal}}, SameReal}, {"new_line", {{"x", SameChar, Rank::anyOrAssumedRank}}, SameChar, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"nint", {{"a", AnyReal}, DefaultingKIND}, KINDInt}, {"norm2", {{"x", SameReal, Rank::array}, OptionalDIM}, SameReal, - Rank::dimReduced}, + Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"not", {{"i", SameInt}}, SameInt}, // NULL() is a special case handled in Probe() below {"out_of_range", @@ -581,24 +593,25 @@ {{"array", SameType, Rank::array}, {"mask", AnyLogical, Rank::conformable}, {"vector", SameType, Rank::vector, Optionality::optional}}, - SameType, Rank::vector}, + SameType, Rank::vector, IntrinsicClass::transformationalFunction}, {"parity", {{"mask", SameLogical, Rank::array}, OptionalDIM}, SameLogical, - Rank::dimReduced}, + Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"popcnt", {{"i", AnyInt}}, DefaultInt}, {"poppar", {{"i", AnyInt}}, DefaultInt}, {"product", {{"array", SameNumeric, Rank::array}, OptionalDIM, OptionalMASK}, - SameNumeric, Rank::dimReduced}, + SameNumeric, Rank::dimReduced, + IntrinsicClass::transformationalFunction}, {"precision", {{"x", AnyFloating, Rank::anyOrAssumedRank}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"present", {{"a", Addressable, Rank::anyOrAssumedRank}}, DefaultLogical, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"radix", {{"x", AnyIntOrReal, Rank::anyOrAssumedRank}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, {"range", {{"x", AnyNumeric, Rank::anyOrAssumedRank}}, DefaultInt, - Rank::scalar}, - {"rank", {{"a", AnyData, Rank::anyOrAssumedRank}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::inquiryFunction}, + {"rank", {{"a", AnyData, Rank::anyOrAssumedRank}}, DefaultInt, Rank::scalar, + IntrinsicClass::inquiryFunction}, {"real", {{"a", SameComplex, Rank::elemental}}, SameReal}, // 16.9.160(4)(ii) {"real", {{"a", AnyNumeric, Rank::elementalOrBOZ}, DefaultingKIND}, @@ -608,19 +621,19 @@ {"operation", SameType, Rank::reduceOperation}, OptionalDIM, OptionalMASK, {"identity", SameType, Rank::scalar}, {"ordered", AnyLogical, Rank::scalar, Optionality::optional}}, - SameType, Rank::dimReduced}, + SameType, Rank::dimReduced, IntrinsicClass::transformationalFunction}, {"repeat", {{"string", SameChar, Rank::scalar}, {"ncopies", AnyInt}}, - SameChar, Rank::scalar}, + SameChar, Rank::scalar, IntrinsicClass::transformationalFunction}, {"reshape", {{"source", SameType, Rank::array}, {"shape", AnyInt, Rank::shape}, {"pad", SameType, Rank::array, Optionality::optional}, {"order", AnyInt, Rank::vector, Optionality::optional}}, - SameType, Rank::shaped}, + SameType, Rank::shaped, IntrinsicClass::transformationalFunction}, {"rrspacing", {{"x", SameReal}}, SameReal}, {"same_type_as", {{"a", ExtensibleDerived, Rank::anyOrAssumedRank}, {"b", ExtensibleDerived, Rank::anyOrAssumedRank}}, - DefaultLogical, Rank::scalar}, + DefaultLogical, Rank::scalar, IntrinsicClass::inquiryFunction}, {"scale", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, {"scan", {{"string", SameChar}, {"set", SameChar}, @@ -628,27 +641,27 @@ DefaultingKIND}, KINDInt}, {"selected_char_kind", {{"name", DefaultChar, Rank::scalar}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::transformationalFunction}, {"selected_int_kind", {{"r", AnyInt, Rank::scalar}}, DefaultInt, - Rank::scalar}, + Rank::scalar, IntrinsicClass::transformationalFunction}, {"selected_real_kind", {{"p", AnyInt, Rank::scalar}, {"r", AnyInt, Rank::scalar, Optionality::optional}, {"radix", AnyInt, Rank::scalar, Optionality::optional}}, - DefaultInt, Rank::scalar}, + DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, {"selected_real_kind", {{"p", AnyInt, Rank::scalar, Optionality::optional}, {"r", AnyInt, Rank::scalar}, {"radix", AnyInt, Rank::scalar, Optionality::optional}}, - DefaultInt, Rank::scalar}, + DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, {"selected_real_kind", {{"p", AnyInt, Rank::scalar, Optionality::optional}, {"r", AnyInt, Rank::scalar, Optionality::optional}, {"radix", AnyInt, Rank::scalar}}, - DefaultInt, Rank::scalar}, + DefaultInt, Rank::scalar, IntrinsicClass::transformationalFunction}, {"set_exponent", {{"x", SameReal}, {"i", AnyInt}}, SameReal}, {"shape", {{"source", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, - KINDInt, Rank::vector}, + KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, {"shifta", {{"i", SameInt}, {"shift", AnyInt}}, SameInt}, {"shiftl", {{"i", SameInt}, {"shift", AnyInt}}, SameInt}, {"shiftr", {{"i", SameInt}, {"shift", AnyInt}}, SameInt}, @@ -659,45 +672,49 @@ {"size", {{"array", AnyData, Rank::anyOrAssumedRank}, OptionalDIM, SizeDefaultKIND}, - KINDInt, Rank::scalar}, + KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"spacing", {{"x", SameReal}}, SameReal}, {"spread", {{"source", SameType, Rank::known}, RequiredDIM, {"ncopies", AnyInt, Rank::scalar}}, - SameType, Rank::rankPlus1}, + SameType, Rank::rankPlus1, IntrinsicClass::transformationalFunction}, {"sqrt", {{"x", SameFloating}}, SameFloating}, {"storage_size", {{"a", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, - KINDInt, Rank::scalar}, + KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"sum", {{"array", SameNumeric, Rank::array}, OptionalDIM, OptionalMASK}, - SameNumeric, Rank::dimReduced}, + SameNumeric, Rank::dimReduced, + IntrinsicClass::transformationalFunction}, {"tan", {{"x", SameFloating}}, SameFloating}, {"tand", {{"x", SameFloating}}, SameFloating}, {"tanh", {{"x", SameFloating}}, SameFloating}, - {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar}, + {"tiny", {{"x", SameReal, Rank::anyOrAssumedRank}}, SameReal, Rank::scalar, + IntrinsicClass::inquiryFunction}, {"trailz", {{"i", AnyInt}}, DefaultInt}, {"transfer", {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::scalar}}, - SameType, Rank::scalar}, + SameType, Rank::scalar, IntrinsicClass::transformationalFunction}, {"transfer", {{"source", AnyData, Rank::known}, {"mold", SameType, Rank::array}}, - SameType, Rank::vector}, + SameType, Rank::vector, IntrinsicClass::transformationalFunction}, {"transfer", {{"source", AnyData, Rank::anyOrAssumedRank}, {"mold", SameType, Rank::anyOrAssumedRank}, {"size", AnyInt, Rank::scalar}}, - SameType, Rank::vector}, - {"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix}, - {"trim", {{"string", SameChar, Rank::scalar}}, SameChar, Rank::scalar}, + SameType, Rank::vector, IntrinsicClass::transformationalFunction}, + {"transpose", {{"matrix", SameType, Rank::matrix}}, SameType, Rank::matrix, + IntrinsicClass::transformationalFunction}, + {"trim", {{"string", SameChar, Rank::scalar}}, SameChar, Rank::scalar, + IntrinsicClass::transformationalFunction}, {"ubound", {{"array", AnyData, Rank::anyOrAssumedRank}, RequiredDIM, SizeDefaultKIND}, - KINDInt, Rank::scalar}, + KINDInt, Rank::scalar, IntrinsicClass::inquiryFunction}, {"ubound", {{"array", AnyData, Rank::anyOrAssumedRank}, SizeDefaultKIND}, - KINDInt, Rank::vector}, + KINDInt, Rank::vector, IntrinsicClass::inquiryFunction}, {"unpack", {{"vector", SameType, Rank::vector}, {"mask", AnyLogical, Rank::array}, {"field", SameType, Rank::conformable}}, - SameType, Rank::conformable}, + SameType, Rank::conformable, IntrinsicClass::transformationalFunction}, {"verify", {{"string", SameChar}, {"set", SameChar}, {"back", AnyLogical, Rank::elemental, Optionality::optional}, @@ -900,33 +917,34 @@ }; static const IntrinsicInterface intrinsicSubroutine[]{ - {"cpu_time", {{"time", AnyReal, Rank::scalar}}, {}}, + {"cpu_time", {{"time", AnyReal, Rank::scalar}}, {}, Rank::elemental, + IntrinsicClass::impureSubroutine}, {"date_and_time", {{"date", DefaultChar, Rank::scalar, Optionality::optional}, {"time", DefaultChar, Rank::scalar, Optionality::optional}, {"zone", DefaultChar, Rank::scalar, Optionality::optional}, {"values", AnyInt, Rank::vector, Optionality::optional}}, - {}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"execute_command_line", {{"command", DefaultChar, Rank::scalar}, {"wait", AnyLogical, Rank::scalar, Optionality::optional}, {"exitstat", AnyInt, Rank::scalar, Optionality::optional}, {"cmdstat", AnyInt, Rank::scalar, Optionality::optional}, {"cmdmsg", DefaultChar, Rank::scalar, Optionality::optional}}, - {}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"get_command", {{"command", DefaultChar, Rank::scalar, Optionality::optional}, {"length", AnyInt, Rank::scalar, Optionality::optional}, {"status", AnyInt, Rank::scalar, Optionality::optional}, {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, - {}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"get_command_argument", {{"number", AnyInt, Rank::scalar}, {"value", DefaultChar, Rank::scalar, Optionality::optional}, {"length", AnyInt, Rank::scalar, Optionality::optional}, {"status", AnyInt, Rank::scalar, Optionality::optional}, {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, - {}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"get_environment_variable", {{"name", DefaultChar, Rank::scalar}, {"value", DefaultChar, Rank::scalar, Optionality::optional}, @@ -934,31 +952,34 @@ {"status", AnyInt, Rank::scalar, Optionality::optional}, {"trim_name", AnyLogical, Rank::scalar, Optionality::optional}, {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, - {}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, {"move_alloc", {{"from", SameType, Rank::known}, {"to", SameType, Rank::known}, {"stat", AnyInt, Rank::scalar, Optionality::optional}, {"errmsg", DefaultChar, Rank::scalar, Optionality::optional}}, - {}}, + {}, Rank::elemental, IntrinsicClass::pureSubroutine}, {"mvbits", {{"from", SameInt}, {"frompos", AnyInt}, {"len", AnyInt}, {"to", SameInt}, {"topos", AnyInt}}, - {}}, // elemental + {}, Rank::elemental, IntrinsicClass::elementalSubroutine}, // elemental {"random_init", {{"repeatable", AnyLogical, Rank::scalar}, {"image_distinct", AnyLogical, Rank::scalar}}, - {}}, - {"random_number", {{"harvest", AnyReal, Rank::known}}, {}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, + {"random_number", {{"harvest", AnyReal, Rank::known}}, {}, Rank::elemental, + IntrinsicClass::impureSubroutine}, {"random_seed", {{"size", DefaultInt, Rank::scalar, Optionality::optional}, {"put", DefaultInt, Rank::vector, Optionality::optional}, {"get", DefaultInt, Rank::vector, Optionality::optional}}, - {}}, // TODO: at most one argument can be present + {}, Rank::elemental, + IntrinsicClass::impureSubroutine}, // TODO: at most one argument can be + // present {"system_clock", {{"count", AnyInt, Rank::scalar, Optionality::optional}, {"count_rate", AnyIntOrReal, Rank::scalar, Optionality::optional}, {"count_max", AnyInt, Rank::scalar, Optionality::optional}}, - {}}, + {}, Rank::elemental, IntrinsicClass::impureSubroutine}, }; // TODO: Intrinsic subroutine EVENT_QUERY @@ -1532,6 +1553,8 @@ bool IsIntrinsic(const std::string &) const; + IntrinsicClass GetIntrinsicClass(const std::string &) const; + std::optional Probe(const CallCharacteristics &, ActualArguments &, FoldingContext &, const IntrinsicProcTable &) const; @@ -1571,6 +1594,23 @@ return name == "null" || name == "__builtin_c_f_pointer"; } +IntrinsicClass IntrinsicProcTable::Implementation::GetIntrinsicClass( + const std::string &name) const { + auto specificIntrinsic{specificFuncs_.find(name)}; + if (specificIntrinsic != specificFuncs_.end()) { + return specificIntrinsic->second->intrinsicClass; + } + auto genericIntrinsic{genericFuncs_.find(name)}; + if (genericIntrinsic != genericFuncs_.end()) { + return genericIntrinsic->second->intrinsicClass; + } + auto subrIntrinsic{subroutines_.find(name)}; + if (subrIntrinsic != subroutines_.end()) { + return subrIntrinsic->second->intrinsicClass; + } + return IntrinsicClass::noClass; +} + bool CheckAndRearrangeArguments(ActualArguments &arguments, parser::ContextualMessages &messages, const char *const dummyKeywords[], std::size_t trailingOptionals) { @@ -2014,6 +2054,11 @@ return DEREF(impl_).IsIntrinsic(name); } +IntrinsicClass IntrinsicProcTable::GetIntrinsicClass( + const std::string &name) const { + return DEREF(impl_).GetIntrinsicClass(name); +} + std::optional IntrinsicProcTable::Probe( const CallCharacteristics &call, ActualArguments &arguments, FoldingContext &context) const { 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 @@ -33,7 +33,10 @@ void Check() { Check(context_.globalScope()); } void Check(const ParamValue &, bool canBeAssumed); - void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); } + void Check(const Bound &bound) { + CheckSpecExpr( + bound.GetExplicit(), evaluate::SpecificationExprContext::BOUND); + } void Check(const ShapeSpec &spec) { Check(spec.lbound()); Check(spec.ubound()); @@ -44,7 +47,9 @@ void Check(const Scope &); private: - template void CheckSpecExpr(const A &x) { + template + void CheckSpecExpr( + const A &x, const evaluate::SpecificationExprContext specExprContext) { if (symbolBeingChecked_ && IsSaved(*symbolBeingChecked_)) { if (!evaluate::IsConstantExpr(x)) { messages_.Say( @@ -52,18 +57,23 @@ symbolBeingChecked_->name()); } } else { - evaluate::CheckSpecificationExpr(x, messages_, DEREF(scope_)); + evaluate::CheckSpecificationExpr( + x, messages_, DEREF(scope_), context_.intrinsics(), specExprContext); } } - template void CheckSpecExpr(const std::optional &x) { + template + void CheckSpecExpr(const std::optional &x, + const evaluate::SpecificationExprContext specExprContext) { if (x) { - CheckSpecExpr(*x); + CheckSpecExpr(*x, specExprContext); } } - template void CheckSpecExpr(A &x) { + template + void CheckSpecExpr( + A &x, const evaluate::SpecificationExprContext specExprContext) { x = Fold(foldingContext_, std::move(x)); const A &constx{x}; - CheckSpecExpr(constx); + CheckSpecExpr(constx, specExprContext); } void CheckValue(const Symbol &, const DerivedTypeSpec *); void CheckVolatile( @@ -131,7 +141,8 @@ " external function result"_err_en_US); } } else { - CheckSpecExpr(value.GetExplicit()); + CheckSpecExpr( + value.GetExplicit(), evaluate::SpecificationExprContext::TYPE_PARAM); } } @@ -384,15 +395,25 @@ CheckAssumedTypeEntity(symbol, details); symbolBeingChecked_ = nullptr; if (!details.coshape().empty()) { + bool isDeferredShape{details.coshape().IsDeferredShape()}; if (IsAllocatable(symbol)) { - if (!details.coshape().IsDeferredShape()) { // C827 - messages_.Say( - "ALLOCATABLE coarray must have a deferred coshape"_err_en_US); + if (!isDeferredShape) { // C827 + messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred" + " coshape"_err_en_US, + symbol.name()); } + } else if (symbol.owner().IsDerivedType()) { // C746 + std::string deferredMsg{ + isDeferredShape ? "" : " and have a deferred coshape"}; + messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE" + " attribute%s"_err_en_US, + symbol.name(), deferredMsg); } else { if (!details.coshape().IsAssumedSize()) { // C828 messages_.Say( - "Non-ALLOCATABLE coarray must have an explicit coshape"_err_en_US); + "Component '%s' is a non-ALLOCATABLE coarray and must have" + " an explicit coshape"_err_en_US, + symbol.name()); } } } @@ -409,7 +430,8 @@ "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US); } } - if (InPure() && !IsPointer(symbol) && !IsIntentIn(symbol) && + if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) && + !IsPointer(symbol) && !IsIntentIn(symbol) && !symbol.attrs().test(Attr::VALUE)) { if (InFunction()) { // C1583 messages_.Say( 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 @@ -2092,13 +2092,14 @@ } semantics::CheckArguments(*chars, arguments, GetFoldingContext(), context_.FindScope(callSite), treatExternalAsImplicit); - if (!chars->attrs.test(characteristics::Procedure::Attr::Pure)) { + const Symbol *procSymbol{proc.GetSymbol()}; + if (procSymbol && !IsPureProcedure(*procSymbol)) { if (const semantics::Scope * pure{semantics::FindPureProcedureContaining( context_.FindScope(callSite))}) { Say(callSite, "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US, - DEREF(proc.GetSymbol()).name(), DEREF(pure->symbol()).name()); + procSymbol->name(), DEREF(pure->symbol()).name()); } } } 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 @@ -3679,7 +3679,7 @@ if (symbol->has() && !paramNames.count(name)) { SayDerivedType(name, "'%s' is not a type parameter of this derived type"_err_en_US, - currScope()); // C742 + currScope()); // C741 } } Walk(std::get>>(x.t)); @@ -3820,14 +3820,50 @@ !attrs.HasAny({Attr::PUBLIC, Attr::PRIVATE})) { attrs.set(Attr::PRIVATE); } - if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { - if (const auto *declType{GetDeclTypeSpec()}) { - if (const auto *derived{declType->AsDerived()}) { + if (const auto *declType{GetDeclTypeSpec()}) { + if (const auto *derived{declType->AsDerived()}) { + if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C744 Say("Recursive use of the derived type requires " "POINTER or ALLOCATABLE"_err_en_US); } } + if (!coarraySpec().empty()) { // C747 + if (IsTeamType(derived)) { + Say("A coarray component may not be of type TEAM_TYPE from " + "ISO_FORTRAN_ENV"_err_en_US); + } else { + if (IsIsoCType(derived)) { + Say("A coarray component may not be of type C_PTR or C_FUNPTR from " + "ISO_C_BINDING"_err_en_US); + } + } + } + if (auto it{FindCoarrayUltimateComponent(*derived)}) { // C748 + std::string ultimateName{it.BuildResultDesignatorName()}; + // Strip off the leading "%" + if (ultimateName.length() > 1) { + ultimateName.erase(0, 1); + if (attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) { + evaluate::AttachDeclaration( + Say(name.source, + "A component with a POINTER or ALLOCATABLE attribute may " + "not " + "be of a type with a coarray ultimate component (named " + "'%s')"_err_en_US, + ultimateName), + derived->typeSymbol()); + } + if (!arraySpec().empty() || !coarraySpec().empty()) { + evaluate::AttachDeclaration( + Say(name.source, + "An array or coarray component may not be of a type with a " + "coarray ultimate component (named '%s')"_err_en_US, + ultimateName), + derived->typeSymbol()); + } + } + } } } if (OkToAddComponent(name)) { @@ -4741,7 +4777,7 @@ const SourceName &name, Details &&details) { Scope &derivedType{currScope()}; CHECK(derivedType.IsDerivedType()); - if (auto *symbol{FindInScope(derivedType, name)}) { + if (auto *symbol{FindInScope(derivedType, name)}) { // C742 Say2(name, "Type parameter, component, or procedure binding '%s'" " already defined in this type"_err_en_US, 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 @@ -270,6 +270,24 @@ } else if (!IsProcedure(symbol)) { return false; } + if (IsStmtFunction(symbol)) { + // Section 15.7(1) states that a statement function is PURE if it does not + // reference an IMPURE procedure or a VOLATILE variable + const MaybeExpr &expr{symbol.get().stmtFunction()}; + if (expr) { + for (const Symbol &refSymbol : evaluate::CollectSymbols(*expr)) { + if (IsFunction(refSymbol) && !IsPureProcedure(refSymbol)) { + return false; + } + if (const Symbol * root{GetAssociationRoot(refSymbol)}) { + if (root->attrs().test(Attr::VOLATILE)) { + return false; + } + } + } + } + return true; // statement function was not found to be impure + } return symbol.attrs().test(Attr::PURE) || (symbol.attrs().test(Attr::ELEMENTAL) && !symbol.attrs().test(Attr::IMPURE)); @@ -1356,4 +1374,5 @@ context.Say(stmtLocation, message) .Attach(constructLocation, GetEnclosingConstructMsg()); } + } // namespace Fortran::semantics diff --git a/flang/test/Semantics/allocate11.f90 b/flang/test/Semantics/allocate11.f90 --- a/flang/test/Semantics/allocate11.f90 +++ b/flang/test/Semantics/allocate11.f90 @@ -38,6 +38,7 @@ type B type(A) y + !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named 'y%x') type(B), pointer :: forward real :: u end type @@ -47,6 +48,7 @@ end type type D + !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named 'x') type(A), pointer :: potential end type diff --git a/flang/test/Semantics/call12.f90 b/flang/test/Semantics/call12.f90 --- a/flang/test/Semantics/call12.f90 +++ b/flang/test/Semantics/call12.f90 @@ -15,7 +15,7 @@ real, pointer :: p end type type :: hasCoarray - real :: co[*] + real, allocatable :: co[:] end type contains pure function test(ptr, in, hpd) diff --git a/flang/test/Semantics/call14.f90 b/flang/test/Semantics/call14.f90 --- a/flang/test/Semantics/call14.f90 +++ b/flang/test/Semantics/call14.f90 @@ -3,7 +3,7 @@ module m type :: hasCoarray - real :: coarray[*] + real, allocatable :: coarray[:] end type contains !ERROR: VALUE attribute may apply only to a dummy data object diff --git a/flang/test/Semantics/misc-declarations.f90 b/flang/test/Semantics/misc-declarations.f90 --- a/flang/test/Semantics/misc-declarations.f90 +++ b/flang/test/Semantics/misc-declarations.f90 @@ -4,12 +4,12 @@ ! - 8.5.19 constraints on the VOLATILE attribute module m - !ERROR: ALLOCATABLE coarray must have a deferred coshape + !ERROR: 'mustbedeferred' is an ALLOCATABLE coarray and must have a deferred coshape real, allocatable :: mustBeDeferred[*] ! C827 - !ERROR: Non-ALLOCATABLE coarray must have an explicit coshape + !ERROR: Component 'mustbeexplicit' is a non-ALLOCATABLE coarray and must have an explicit coshape real :: mustBeExplicit[:] ! C828 type :: hasCoarray - real :: coarray[*] + real, allocatable :: coarray[:] end type real :: coarray[*] type(hasCoarray) :: coarrayComponent diff --git a/flang/test/Semantics/modfile24.f90 b/flang/test/Semantics/modfile24.f90 --- a/flang/test/Semantics/modfile24.f90 +++ b/flang/test/Semantics/modfile24.f90 @@ -36,8 +36,8 @@ ! coarray-spec in components and with non-constants bounds module m3 type t - real :: c[1:10,1:*] - complex, codimension[5,*] :: d + real, allocatable :: c[:,:] + complex, allocatable, codimension[:,:] :: d end type real, allocatable :: e[:,:,:] contains @@ -50,8 +50,8 @@ !Expect: m3.mod !module m3 ! type::t -! real(4)::c[1_8:10_8,1_8:*] -! complex(4)::d[1_8:5_8,1_8:*] +! real(4),allocatable::c[:,:] +! complex(4),allocatable::d[:,:] ! end type ! real(4),allocatable::e[:,:,:] !contains diff --git a/flang/test/Semantics/resolve33.f90 b/flang/test/Semantics/resolve33.f90 --- a/flang/test/Semantics/resolve33.f90 +++ b/flang/test/Semantics/resolve33.f90 @@ -2,6 +2,12 @@ ! Derived type parameters ! C731 The same type-param-name shall not appear more than once in a given ! derived-type-stmt. +! C741 A type-param-name in a type-param-def-stmt in a derived-type-def shall +! be one of the type-paramnames in the derived-type-stmt of that +! derived-type-def. +! C742 Each type-param-name in the derived-type-stmt in a derived-type-def +! shall appear exactly once as a type-param-name in a type-param-def-stmt +! in that derived-type-def. module m !ERROR: Duplicate type parameter name: 'a' 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 @@ -1,5 +1,8 @@ ! RUN: %B/test/Semantics/test_errors.sh %s %flang %t ! Error tests for recursive use of derived types. +! C744 If neither the POINTER nor the ALLOCATABLE attribute is specified, the +! declaration-type-spec in the component-def-stmt shall specify an intrinsic +! type or a previously defined derived type. program main type :: recursive1 diff --git a/flang/test/Semantics/resolve88.f90 b/flang/test/Semantics/resolve88.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve88.f90 @@ -0,0 +1,75 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +! C746, C747, and C748 +module m + use ISO_FORTRAN_ENV + use ISO_C_BINDING + + ! C746 If a coarray-spec appears, it shall be a deferred-coshape-spec-list and + ! the component shall have the ALLOCATABLE attribute. + + type testCoArrayType + real, allocatable, codimension[:] :: allocatableField + !ERROR: Component 'deferredfield' is a coarray and must have the ALLOCATABLE attribute + real, codimension[:] :: deferredField + !ERROR: 'pointerfield' may not have the POINTER attribute because it is a coarray + !ERROR: Component 'pointerfield' is a coarray and must have the ALLOCATABLE attribute + real, pointer, codimension[:] :: pointerField + !ERROR: Component 'realfield' is a coarray and must have the ALLOCATABLE attribute and have a deferred coshape + real, codimension[*] :: realField + !ERROR: 'realfield2' is an ALLOCATABLE coarray and must have a deferred coshape + real, allocatable, codimension[*] :: realField2 + end type testCoArrayType + + ! C747 If a coarray-spec appears, the component shall not be of type C_PTR or + ! C_FUNPTR from the intrinsic module ISO_C_BINDING (18.2), or of type + ! TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV (16.10.2). + + type goodCoarrayType + real, allocatable, codimension[:] :: field + end type goodCoarrayType + + type goodTeam_typeCoarrayType + type(team_type), allocatable :: field + end type goodTeam_typeCoarrayType + + type goodC_ptrCoarrayType + type(c_ptr), allocatable :: field + end type goodC_ptrCoarrayType + + type goodC_funptrCoarrayType + type(c_funptr), allocatable :: field + end type goodC_funptrCoarrayType + + type team_typeCoarrayType + !ERROR: A coarray component may not be of type TEAM_TYPE from ISO_FORTRAN_ENV + type(team_type), allocatable, codimension[:] :: field + end type team_typeCoarrayType + + type c_ptrCoarrayType + !ERROR: A coarray component may not be of type C_PTR or C_FUNPTR from ISO_C_BINDING + type(c_ptr), allocatable, codimension[:] :: field + end type c_ptrCoarrayType + + type c_funptrCoarrayType + !ERROR: A coarray component may not be of type C_PTR or C_FUNPTR from ISO_C_BINDING + type(c_funptr), allocatable, codimension[:] :: field + end type c_funptrCoarrayType + +! C748 A data component whose type has a coarray ultimate component shall be a +! nonpointer nonallocatable scalar and shall not be a coarray. + + type coarrayType + real, allocatable, codimension[:] :: goodCoarrayField + end type coarrayType + + type testType + type(coarrayType) :: goodField + !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named 'goodcoarrayfield') + type(coarrayType), pointer :: pointerField + !ERROR: A component with a POINTER or ALLOCATABLE attribute may not be of a type with a coarray ultimate component (named 'goodcoarrayfield') + type(coarrayType), allocatable :: allocatableField + !ERROR: An array or coarray component may not be of a type with a coarray ultimate component (named 'goodcoarrayfield') + type(coarrayType), dimension(3) :: arrayField + end type testType + +end module m diff --git a/flang/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve89.f90 @@ -0,0 +1,110 @@ +! RUN: %B/test/Semantics/test_errors.sh %s %flang %t +! C750 Each bound in the explicit-shape-spec shall be a specification +! expression in which there are no references to specification functions or +! the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_- TYPE_OF, PRESENT, +! or SAME_TYPE_AS, every specification inquiry reference is a constant +! expression, and the value does not depend on the value of a variable. +impure function impureFunc() + integer :: impureFunc + + impureFunc = 3 +end function impureFunc + +pure function pureFunc() + integer :: pureFunc + + pureFunc = 3 +end function pureFunc + +module m + real, allocatable :: mVar +end module m + +subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg) + use m + implicit logical(l) + integer, intent(in) :: iArg + real, allocatable, intent(in) :: allocArg + real, pointer, intent(in) :: pointerArg + integer, dimension(:), intent(in) :: arrayArg + integer, intent(inout) :: ioArg + real, optional, intent(in) :: optionalArg + + ! These declarations are OK since they're not in a derived type + real :: realVar + real, volatile :: volatileVar + real, dimension(merge(1, 2, allocated(allocArg))) :: realVar1 + real, dimension(merge(1, 2, associated(pointerArg))) :: realVar2 + real, dimension(merge(1, 2, is_contiguous(arrayArg))) :: realVar3 + real, dimension(ioArg) :: realVar4 + real, dimension(merge(1, 2, present(optionalArg))) :: realVar5 + + ! statement functions referenced below + iVolatileStmtFunc() = 3 * volatileVar + iImpureStmtFunc() = 3 * impureFunc() + iPureStmtFunc() = 3 * pureFunc() + + ! This is OK + real, dimension(merge(1, 2, allocated(mVar))) :: rVar + + + integer :: var = 3 + !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc' + real, dimension(iVolatileStmtFunc()) :: arrayVarWithVolatile + !ERROR: Invalid specification expression: reference to impure function 'iimpurestmtfunc' + real, dimension(iImpureStmtFunc()) :: arrayVarWithImpureFunction + !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc' + real, dimension(iPureStmtFunc()) :: arrayVarWithPureFunction + real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic + + type arrayType + !ERROR: Invalid specification expression: reference to variable 'var' not allowed for derived type components + real, dimension(var) :: varField + !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc' + real, dimension(iVolatileStmtFunc()) :: arrayFieldWithVolatile + !ERROR: Invalid specification expression: reference to impure function 'iimpurestmtfunc' + real, dimension(iImpureStmtFunc()) :: arrayFieldWithImpureFunction + !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc' + real, dimension(iPureStmtFunc()) :: arrayFieldWithPureFunction + !ERROR: Invalid specification expression: reference to variable 'iarg' not allowed for derived type components + real, dimension(iabs(iArg)) :: arrayFieldWithIntrinsic + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + real, dimension(merge(1, 2, allocated(allocArg))) :: realField1 + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + real, dimension(merge(1, 2, associated(pointerArg))) :: realField2 + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components + real, dimension(merge(1, 2, is_contiguous(arrayArg))) :: realField3 + !ERROR: Invalid specification expression: reference to variable 'ioarg' not allowed for derived type components + real, dimension(ioArg) :: realField4 + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + real, dimension(merge(1, 2, present(optionalArg))) :: realField5 + end type arrayType + +end subroutine s + +subroutine s1() + ! C750, check for a constant specification inquiry that's a type parameter + ! inquiry which are defined in 9.4.5 + type derived(kindParam, lenParam) + integer, kind :: kindParam = 3 + integer, len :: lenParam = 3 + end type + + contains + subroutine inner (derivedArg) + type(derived), intent(in), dimension(3) :: derivedArg + integer :: localInt + + type(derived), parameter :: localderived = derived() + + type localDerivedType + ! OK because the specification inquiry is a constant + integer, dimension(localDerived%kindParam) :: goodField + !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components + integer, dimension(derivedArg%lenParam) :: badField + end type localDerivedType + + ! OK because we're not defining a component + integer, dimension(derivedArg%kindParam) :: localVar + end subroutine inner +end subroutine s1