diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -52,7 +52,6 @@ * `X` prefix/suffix as synonym for `Z` on hexadecimal literals * `B`, `O`, `Z`, and `X` accepted as suffixes as well as prefixes * Triplets allowed in array constructors -* Old-style `PARAMETER pi=3.14` statement without parentheses * `%LOC`, `%VAL`, and `%REF` * Leading comma allowed before I/O item list * Empty parentheses allowed in `PROGRAM P()` @@ -153,6 +152,8 @@ [-fimplicit-none-type-always] * Ignore occurrences of `IMPLICIT NONE` and `IMPLICIT NONE(TYPE)` [-fimplicit-none-type-never] +* Old-style `PARAMETER pi=3.14` statement without parentheses + [-falternative-parameter-statement] ### Extensions and legacy features deliberately not supported diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h --- a/flang/include/flang/Common/Fortran-features.h +++ b/flang/include/flang/Common/Fortran-features.h @@ -47,6 +47,7 @@ disable_.set(LanguageFeature::BackslashEscapes); disable_.set(LanguageFeature::LogicalAbbreviations); disable_.set(LanguageFeature::XOROperator); + disable_.set(LanguageFeature::OldStyleParameter); } LanguageFeatureControl(const LanguageFeatureControl &) = default; void Enable(LanguageFeature f, bool yes = true) { disable_.set(f, !yes); } 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 @@ -194,6 +194,7 @@ DeclTypeSpec &MakeDerivedType(DeclTypeSpec::Category, DerivedTypeSpec &&); const DeclTypeSpec &MakeTypeStarType(); const DeclTypeSpec &MakeClassStarType(); + const DeclTypeSpec *GetType(const SomeExpr &); std::size_t size() const { return size_; } void set_size(std::size_t size) { size_ = size; } 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 @@ -14,6 +14,7 @@ #include "flang/Common/Fortran.h" #include "flang/Evaluate/expression.h" +#include "flang/Evaluate/shape.h" #include "flang/Evaluate/type.h" #include "flang/Evaluate/variable.h" #include "flang/Parser/message.h" @@ -559,5 +560,12 @@ // Return the (possibly null) name of the ConstructNode const std::optional &MaybeGetNodeName( const ConstructNode &construct); + +// Convert evaluate::GetShape() result into an ArraySpec +std::optional ToArraySpec( + evaluate::FoldingContext &, const evaluate::Shape &); +std::optional ToArraySpec( + evaluate::FoldingContext &, const std::optional &); + } // namespace Fortran::semantics #endif // FORTRAN_SEMANTICS_TOOLS_H_ 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 @@ -810,4 +810,5 @@ } return false; } + } // namespace Fortran::evaluate 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 @@ -741,6 +741,7 @@ bool Pre(const parser::BindStmt &) { return BeginAttrs(); } void Post(const parser::BindStmt &) { EndAttrs(); } bool Pre(const parser::BindEntity &); + bool Pre(const parser::OldParameterStmt &); bool Pre(const parser::NamedConstantDef &); bool Pre(const parser::NamedConstant &); void Post(const parser::EnumDef &); @@ -907,6 +908,8 @@ // Enum value must hold inside a C_INT (7.6.2). std::optional value{0}; } enumerationState_; + // Set for OldParameterStmt processing + bool inOldStyleParameterStmt_{false}; bool HandleAttributeStmt(Attr, const std::list &); Symbol &HandleAttributeStmt(Attr, const parser::Name &); @@ -3285,6 +3288,12 @@ SetBindNameOn(*symbol); return false; } +bool DeclarationVisitor::Pre(const parser::OldParameterStmt &x) { + inOldStyleParameterStmt_ = true; + Walk(x.v); + inOldStyleParameterStmt_ = false; + return false; +} bool DeclarationVisitor::Pre(const parser::NamedConstantDef &x) { auto &name{std::get(x.t).v}; auto &symbol{HandleAttributeStmt(Attr::PARAMETER, name)}; @@ -3296,11 +3305,44 @@ return false; } const auto &expr{std::get(x.t)}; - ApplyImplicitRules(symbol); - Walk(expr); - if (auto converted{EvaluateNonPointerInitializer( - symbol, expr, expr.thing.value().source)}) { - symbol.get().set_init(std::move(*converted)); + auto &details{symbol.get()}; + if (inOldStyleParameterStmt_) { + // non-standard extension PARAMETER statement (no parentheses) + Walk(expr); + auto folded{EvaluateExpr(expr)}; + if (details.type()) { + SayWithDecl(name, symbol, + "Alternative style PARAMETER '%s' must not already have an explicit type"_err_en_US); + } else if (folded) { + auto at{expr.thing.value().source}; + if (evaluate::IsActuallyConstant(*folded)) { + if (const auto *type{currScope().GetType(*folded)}) { + if (type->IsPolymorphic()) { + Say(at, "The expression must not be polymorphic"_err_en_US); + } else if (auto shape{ToArraySpec( + GetFoldingContext(), evaluate::GetShape(*folded))}) { + // The type of the named constant is assumed from the expression. + details.set_type(*type); + details.set_init(std::move(*folded)); + details.set_shape(std::move(*shape)); + } else { + Say(at, "The expression must have constant shape"_err_en_US); + } + } else { + Say(at, "The expression must have a known type"_err_en_US); + } + } else { + Say(at, "The expression must be a constant of known type"_err_en_US); + } + } + } else { + // standard-conforming PARAMETER statement (with parentheses) + ApplyImplicitRules(symbol); + Walk(expr); + if (auto converted{EvaluateNonPointerInitializer( + symbol, expr, expr.thing.value().source)}) { + details.set_init(std::move(*converted)); + } } return false; } diff --git a/flang/lib/Semantics/scope.cpp b/flang/lib/Semantics/scope.cpp --- a/flang/lib/Semantics/scope.cpp +++ b/flang/lib/Semantics/scope.cpp @@ -202,6 +202,49 @@ return declTypeSpecs_.emplace_back(category, std::move(spec)); } +const DeclTypeSpec *Scope::GetType(const SomeExpr &expr) { + if (auto dyType{expr.GetType()}) { + if (dyType->IsAssumedType()) { + return &MakeTypeStarType(); + } else if (dyType->IsUnlimitedPolymorphic()) { + return &MakeClassStarType(); + } else { + switch (dyType->category()) { + case TypeCategory::Integer: + case TypeCategory::Real: + case TypeCategory::Complex: + return &MakeNumericType(dyType->category(), KindExpr{dyType->kind()}); + case TypeCategory::Character: + if (const ParamValue * lenParam{dyType->charLength()}) { + return &MakeCharacterType( + ParamValue{*lenParam}, KindExpr{dyType->kind()}); + } else { + auto lenExpr{dyType->GetCharLength()}; + if (!lenExpr) { + lenExpr = + std::get>(expr.u).LEN(); + } + if (lenExpr) { + return &MakeCharacterType( + ParamValue{SomeIntExpr{std::move(*lenExpr)}, + common::TypeParamAttr::Len}, + KindExpr{dyType->kind()}); + } + } + break; + case TypeCategory::Logical: + return &MakeLogicalType(KindExpr{dyType->kind()}); + case TypeCategory::Derived: + return &MakeDerivedType(dyType->IsPolymorphic() + ? DeclTypeSpec::ClassDerived + : DeclTypeSpec::TypeDerived, + DerivedTypeSpec{dyType->GetDerivedTypeSpec()}); + } + } + } + return nullptr; +} + Scope::ImportKind Scope::GetImportKind() const { if (importKind_) { return *importKind_; 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 @@ -1451,4 +1451,22 @@ construct); } +std::optional ToArraySpec( + evaluate::FoldingContext &context, const evaluate::Shape &shape) { + if (auto extents{evaluate::AsConstantExtents(context, shape)}) { + ArraySpec result; + for (const auto &extent : *extents) { + result.emplace_back(ShapeSpec::MakeExplicit(Bound{extent})); + } + return {std::move(result)}; + } else { + return std::nullopt; + } +} + +std::optional ToArraySpec(evaluate::FoldingContext &context, + const std::optional &shape) { + return shape ? ToArraySpec(context, *shape) : std::nullopt; +} + } // namespace Fortran::semantics 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 @@ -657,4 +657,5 @@ CHECK(!symbol_); type_ = &type; } + } // namespace Fortran::semantics diff --git a/flang/test/Semantics/oldparam01.f90 b/flang/test/Semantics/oldparam01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/oldparam01.f90 @@ -0,0 +1,25 @@ +! RUN: %f18 -falternative-parameter-statement -fdebug-dump-symbols -fparse-only %s 2>&1 | FileCheck %s + +! Non-error tests for "old style" PARAMETER statements + +type :: t + integer(kind=4) :: n +end type +!CHECK: x1, PARAMETER size=4 offset=0: ObjectEntity type: INTEGER(4) init:1_4 +parameter x1 = 1_4 ! integer scalar +!CHECK: x2, PARAMETER size=4 offset=4: ObjectEntity type: INTEGER(4) shape: 1_8:1_8 init:[INTEGER(4)::2_4] +parameter x2 = [2_4] ! integer vector +!CHECK: x3, PARAMETER size=4 offset=8: ObjectEntity type: TYPE(t) init:t(n=3_4) +parameter x3 = t(3) ! derived scalar +!CHECK: x4, PARAMETER size=8 offset=12: ObjectEntity type: TYPE(t) shape: 1_8:2_8 init:[t::t(n=4_4),t(n=5_4)] +parameter x4 = [t(4), t(5)] ! derived vector +!CHECK: x5, PARAMETER size=3 offset=20: ObjectEntity type: CHARACTER(3_8,1) init:"abc" +parameter x5 = 1_"abc" ! character scalar +!CHECK: x6, PARAMETER size=12 offset=23: ObjectEntity type: CHARACTER(4_8,1) shape: 1_8:3_8 init:[CHARACTER(KIND=1,LEN=4)::"defg","h ","ij "] +parameter x6 = [1_"defg", 1_"h", 1_"ij"] ! character scalar +!CHECK: x7, PARAMETER size=4 offset=36: ObjectEntity type: INTEGER(4) init:5_4 +!CHECK: x8, PARAMETER size=4 offset=40: ObjectEntity type: INTEGER(4) init:4_4 +parameter x7 = 2+3, x8 = 4 ! folding, multiple definitions +!CHECK: x9, PARAMETER size=4 offset=44: ObjectEntity type: LOGICAL(4) init:.true._4 +parameter x9 = .true. +end diff --git a/flang/test/Semantics/oldparam02.f90 b/flang/test/Semantics/oldparam02.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/oldparam02.f90 @@ -0,0 +1,27 @@ +! RUN: not %f18 -falternative-parameter-statement -fdebug-dump-symbols -fparse-only %s 2>&1 | FileCheck %s + +! Error tests for "old style" PARAMETER statements +subroutine subr(x1,x2,x3,x4,x5) + type(*), intent(in) :: x1 + class(*), intent(in) :: x2 + real, intent(in) :: x3(*) + real, intent(in) :: x4(:) + character(*), intent(in) :: x5 + !CHECK: error: TYPE(*) dummy argument may only be used as an actual argument + parameter p1 = x1 + !CHECK: error: Must be a constant value + parameter p2 = x2 + !CHECK: error: Whole assumed-size array 'x3' may not appear here without subscripts + parameter p3 = x3 + !CHECK: error: Must be a constant value + parameter p4 = x4 + !CHECK: error: Must be a constant value + parameter p5 = x5 + !CHECK: The expression must be a constant of known type + parameter p6 = z'feedfacedeadbeef' + !CHECK: error: Must be a constant value + parameter p7 = len(x5) + real :: p8 + !CHECK: error: Alternative style PARAMETER 'p8' must not already have an explicit type + parameter p8 = 666 +end diff --git a/flang/test/Semantics/oldparam03.f90 b/flang/test/Semantics/oldparam03.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/oldparam03.f90 @@ -0,0 +1,7 @@ +! RUN: not %f18 -fparse-only %s 2>&1 | FileCheck %s + +! Ensure that old-style PARAMETER statements are disabled by default. + +!CHECK: error: expected '(' +parameter x = 666 +end 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 @@ -518,6 +518,9 @@ } else if (arg == "-fimplicit-none-type-never") { options.features.Enable( Fortran::common::LanguageFeature::ImplicitNoneTypeNever); + } else if (arg == "-falternative-parameter-statement") { + options.features.Enable( + Fortran::common::LanguageFeature::OldStyleParameter, true); } else if (arg == "-fdebug-dump-provenance") { driver.dumpProvenance = true; options.needProvenanceRangeToCharBlockMappings = true;