[flang] Support disabled alternative PARAMETER statement
Legacy Fortran implementations support an alternative form of the
PARAMETER statement; it differs syntactically from the standard's
PARAMETER statement by lacking parentheses, and semantically by
using the type and shape of the initialization expression to define
the attributes of the named constant. (GNU Fortran gets that part
wrong; Intel Fortran and nvfortran have full support.)
This patch disables the old style PARAMETER statement by default, as
it is syntactically ambiguous with conforming assignment statements;
adds a new "-falternative-parameter-statement" option to enable it;
and implements it correctly when enabled.
Fixes https://bugs.llvm.org/show_bug.cgi?id=48774, in which a user
tripped over the syntactic ambiguity.
Differential Revision: https://reviews.llvm.org/D95697
GitOrigin-RevId: ebe74d9592d097501f376c2086e58d35aa318896
diff --git a/docs/Extensions.md b/docs/Extensions.md
index ea90db1..2498345 100644
--- a/docs/Extensions.md
+++ b/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/include/flang/Common/Fortran-features.h b/include/flang/Common/Fortran-features.h
index 23c2e95..92eb610 100644
--- a/include/flang/Common/Fortran-features.h
+++ b/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/include/flang/Semantics/scope.h b/include/flang/Semantics/scope.h
index 535e2bd..e547074 100644
--- a/include/flang/Semantics/scope.h
+++ b/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/include/flang/Semantics/tools.h b/include/flang/Semantics/tools.h
index e809b30..3e8d199 100644
--- a/include/flang/Semantics/tools.h
+++ b/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<parser::Name> &MaybeGetNodeName(
const ConstructNode &construct);
+
+// Convert evaluate::GetShape() result into an ArraySpec
+std::optional<ArraySpec> ToArraySpec(
+ evaluate::FoldingContext &, const evaluate::Shape &);
+std::optional<ArraySpec> ToArraySpec(
+ evaluate::FoldingContext &, const std::optional<evaluate::Shape> &);
+
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_TOOLS_H_
diff --git a/lib/Evaluate/shape.cpp b/lib/Evaluate/shape.cpp
index 6dc2edd..a899d96 100644
--- a/lib/Evaluate/shape.cpp
+++ b/lib/Evaluate/shape.cpp
@@ -810,4 +810,5 @@
}
return false;
}
+
} // namespace Fortran::evaluate
diff --git a/lib/Semantics/resolve-names.cpp b/lib/Semantics/resolve-names.cpp
index 2b7ee04..fafccc1 100644
--- a/lib/Semantics/resolve-names.cpp
+++ b/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<int> value{0};
} enumerationState_;
+ // Set for OldParameterStmt processing
+ bool inOldStyleParameterStmt_{false};
bool HandleAttributeStmt(Attr, const std::list<parser::Name> &);
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<parser::NamedConstant>(x.t).v};
auto &symbol{HandleAttributeStmt(Attr::PARAMETER, name)};
@@ -3296,11 +3305,44 @@
return false;
}
const auto &expr{std::get<parser::ConstantExpr>(x.t)};
- ApplyImplicitRules(symbol);
- Walk(expr);
- if (auto converted{EvaluateNonPointerInitializer(
- symbol, expr, expr.thing.value().source)}) {
- symbol.get<ObjectEntityDetails>().set_init(std::move(*converted));
+ auto &details{symbol.get<ObjectEntityDetails>()};
+ 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/lib/Semantics/scope.cpp b/lib/Semantics/scope.cpp
index 7beb4e3..901e655 100644
--- a/lib/Semantics/scope.cpp
+++ b/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<evaluate::Expr<evaluate::SomeCharacter>>(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/lib/Semantics/tools.cpp b/lib/Semantics/tools.cpp
index 10ef54e..d93cb74 100644
--- a/lib/Semantics/tools.cpp
+++ b/lib/Semantics/tools.cpp
@@ -1451,4 +1451,22 @@
construct);
}
+std::optional<ArraySpec> 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<ArraySpec> ToArraySpec(evaluate::FoldingContext &context,
+ const std::optional<evaluate::Shape> &shape) {
+ return shape ? ToArraySpec(context, *shape) : std::nullopt;
+}
+
} // namespace Fortran::semantics
diff --git a/lib/Semantics/type.cpp b/lib/Semantics/type.cpp
index e7b0fab..741b253 100644
--- a/lib/Semantics/type.cpp
+++ b/lib/Semantics/type.cpp
@@ -657,4 +657,5 @@
CHECK(!symbol_);
type_ = &type;
}
+
} // namespace Fortran::semantics
diff --git a/test/Semantics/oldparam01.f90 b/test/Semantics/oldparam01.f90
new file mode 100644
index 0000000..43f33a5
--- /dev/null
+++ b/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/test/Semantics/oldparam02.f90 b/test/Semantics/oldparam02.f90
new file mode 100644
index 0000000..72ea5c4
--- /dev/null
+++ b/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/test/Semantics/oldparam03.f90 b/test/Semantics/oldparam03.f90
new file mode 100644
index 0000000..cbdb070
--- /dev/null
+++ b/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/tools/f18/f18.cpp b/tools/f18/f18.cpp
index 7cb0129..fecd37d 100644
--- a/tools/f18/f18.cpp
+++ b/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;
