[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

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
 

flang/include/flang/Common/Fortran-features.h

@@ -47,6 +47,7 @@ public:
     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); }

flang/include/flang/Semantics/scope.h

@@ -194,6 +194,7 @@ public:
   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; }

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 @@ private:
 // 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_

flang/lib/Evaluate/shape.cpp

@@ -810,4 +810,5 @@ bool IncrementSubscripts(
   }
   return false;
 }
+
 } // namespace Fortran::evaluate

flang/lib/Semantics/resolve-names.cpp

@@ -741,6 +741,7 @@ public:
   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 @@ private:
     // 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;
 }

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_;

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

flang/lib/Semantics/type.cpp

@@ -657,4 +657,5 @@ void ProcInterface::set_type(const DeclTypeSpec &type) {
   CHECK(!symbol_);
   type_ = &type;
 }
+
 } // namespace Fortran::semantics

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

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

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

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;