* `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()`
[-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
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); }
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; }
#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"
// 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_
}
return false;
}
+
} // namespace Fortran::evaluate
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 &);
// 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 &);
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)};
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;
}
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_;
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
CHECK(!symbol_);
type_ = &type;
}
+
} // namespace Fortran::semantics
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
} 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;