[flang-commits] [flang] ebe74d9 - [flang] Support disabled alternative PARAMETER statement
peter klausler via flang-commits
flang-commits at lists.llvm.org
Fri Jan 29 15:30:19 PST 2021
Author: peter klausler
Date: 2021-01-29T15:30:06-08:00
New Revision: ebe74d9592d097501f376c2086e58d35aa318896
URL: https://github.com/llvm/llvm-project/commit/ebe74d9592d097501f376c2086e58d35aa318896
DIFF: https://github.com/llvm/llvm-project/commit/ebe74d9592d097501f376c2086e58d35aa318896.diff
LOG: [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
Added:
flang/test/Semantics/oldparam01.f90
flang/test/Semantics/oldparam02.f90
flang/test/Semantics/oldparam03.f90
Modified:
flang/docs/Extensions.md
flang/include/flang/Common/Fortran-features.h
flang/include/flang/Semantics/scope.h
flang/include/flang/Semantics/tools.h
flang/lib/Evaluate/shape.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/scope.cpp
flang/lib/Semantics/tools.cpp
flang/lib/Semantics/type.cpp
flang/tools/f18/f18.cpp
Removed:
################################################################################
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index ea90db1aa77c..24983456ea0c 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -52,7 +52,6 @@ accepted if enabled by command-line options.
* `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 @@ accepted if enabled by command-line options.
[-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
index 23c2e95fd564..92eb61045796 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -47,6 +47,7 @@ class LanguageFeatureControl {
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
index 535e2bd50dce..e547074ce094 100644
--- a/flang/include/flang/Semantics/scope.h
+++ b/flang/include/flang/Semantics/scope.h
@@ -194,6 +194,7 @@ class Scope {
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
index e809b300b3ad..3e8d1993f9a0 100644
--- 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 @@ class LabelEnforce {
// 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/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 6dc2edd2355b..a899d9647075 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -810,4 +810,5 @@ bool IncrementSubscripts(
}
return false;
}
+
} // namespace Fortran::evaluate
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 2b7ee045bc8f..fafccc1eb74d 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -741,6 +741,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
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 @@ class DeclarationVisitor : public ArraySpecVisitor,
// 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 @@ bool DeclarationVisitor::Pre(const parser::BindEntity &x) {
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 @@ bool DeclarationVisitor::Pre(const parser::NamedConstantDef &x) {
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/flang/lib/Semantics/scope.cpp b/flang/lib/Semantics/scope.cpp
index 7beb4e33a7d8..901e655ffc20 100644
--- a/flang/lib/Semantics/scope.cpp
+++ b/flang/lib/Semantics/scope.cpp
@@ -202,6 +202,49 @@ DeclTypeSpec &Scope::MakeDerivedType(
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/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 10ef54e98f19..d93cb7434a8c 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1451,4 +1451,22 @@ const std::optional<parser::Name> &MaybeGetNodeName(
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/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index e7b0fabe8cac..741b25332297 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -657,4 +657,5 @@ void ProcInterface::set_type(const DeclTypeSpec &type) {
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
index 000000000000..43f33a52f364
--- /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
index 000000000000..72ea5c410c7a
--- /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
index 000000000000..cbdb07057226
--- /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
index 7cb0129fc494..fecd37d49936 100644
--- a/flang/tools/f18/f18.cpp
+++ b/flang/tools/f18/f18.cpp
@@ -518,6 +518,9 @@ int main(int argc, char *const argv[]) {
} 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;
More information about the flang-commits
mailing list