[flang] Support disabled alternative PARAMETER statement

[klausler]

Summary

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.

[awarzynski]

Thank you for working on this. I added -falternative-parameter-statement" to our progress tracker for the new driver.

flang/docs/Extensions.md

 * Signed complex literal constants
 * DEC `STRUCTURE`, `RECORD`, `UNION`, and `MAP`
 * Structure field access with `.field`
 * `BYTE` as synonym for `INTEGER(KIND=1)`
 * Quad precision REAL literals with `Q`
 * `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()`
 * Missing parentheses allowed in `FUNCTION F`
 * Cray based `POINTER(p,x)` and `LOC()` intrinsic (with `%LOC()` as
   an alias)
 * Arithmetic `IF`.  (Which branch should NaN take? Fall through?)
 * `ASSIGN` statement, assigned `GO TO`, and assigned format
* The default `INTEGER` type is required by the standard to occupy
   `FINDLOC`, `MAXLOC`, and `MINLOC` in the absence of an explicit
   `KIND=` actual argument.  We return `INTEGER(KIND=8)` by default in
   these cases when the `-flarge-sizes` option is enabled.
   `SIZEOF` and `C_SIZEOF` always return `INTEGER(KIND=8)`.
 * Treat each specification-part like is has `IMPLICIT NONE`
   [-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
 
 * `.LG.` as synonym for `.NE.`
 * `REDIMENSION`
 * Allocatable `COMMON`
 * Expressions in formats
 * `ACCEPT` as synonym for `READ *`

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

LanguageFeatureControl() {
     disable_.set(LanguageFeature::OpenMP);
     disable_.set(LanguageFeature::ImplicitNoneTypeNever);
     disable_.set(LanguageFeature::ImplicitNoneTypeAlways);
     // These features, if enabled, conflict with valid standard usage,
     // so there are disabled here by default.
     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); }
   void EnableWarning(LanguageFeature f, bool yes = true) { warn_.set(f, yes); }
   void WarnOnAllNonstandard(bool yes = true) { warnAll_ = yes; }
   bool IsEnabled(LanguageFeature f) const { return !disable_.test(f); }
   bool ShouldWarn(LanguageFeature f) const {
     return (warnAll_ && f != LanguageFeature::OpenMP &&

flang/include/flang/Semantics/scope.h

public:
   const DeclTypeSpec *FindType(const DeclTypeSpec &) const;
   const DeclTypeSpec &MakeNumericType(TypeCategory, KindExpr &&kind);
   const DeclTypeSpec &MakeLogicalType(KindExpr &&kind);
   const DeclTypeSpec &MakeCharacterType(
       ParamValue &&length, KindExpr &&kind = KindExpr{0});
   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; }
   std::optional<std::size_t> alignment() const { return alignment_; }
 
   void SetAlignment(std::size_t n) {
     alignment_ = std::max(alignment_.value_or(0), n);
   }

flang/include/flang/Semantics/tools.h

 //===-- include/flang/Semantics/tools.h -------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_SEMANTICS_TOOLS_H_
 #define FORTRAN_SEMANTICS_TOOLS_H_
 
 // Simple predicates and look-up functions that are best defined
 // canonically for use in semantic checking.
 
 #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"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/attr.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/semantics.h"
 #include <functional>
private:
   parser::MessageFormattedText GetEnclosingConstructMsg();
   void SayWithConstruct(SemanticsContext &context,
       parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
       parser::CharBlock constructLocation);
 };
 // 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

bool IncrementSubscripts(
   for (std::size_t j{0}; j < rank; ++j) {
     if (indices[j]++ < extents[j]) {
       return true;
     }
     indices[j] = 1;
   }
   return false;
 }
+
 } // namespace Fortran::evaluate

flang/lib/Semantics/resolve-names.cpp

public:
 
   bool Pre(const parser::Initialization &);
   void Post(const parser::EntityDecl &);
   void Post(const parser::ObjectDecl &);
   void Post(const parser::PointerDecl &);
   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 &);
   bool Pre(const parser::Enumerator &);
   bool Pre(const parser::AccessSpec &);
   bool Pre(const parser::AsynchronousStmt &);
   bool Pre(const parser::ContiguousStmt &);
   bool Pre(const parser::ExternalStmt &);
private:
   const parser::Name *interfaceName_{nullptr};
   // Map type-bound generic to binding names of its specific bindings
   std::multimap<Symbol *, const parser::Name *> genericBindings_;
   // Info about current ENUM
   struct EnumeratorState {
     // 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 &);
   Symbol &DeclareUnknownEntity(const parser::Name &, Attrs);
   Symbol &DeclareProcEntity(const parser::Name &, Attrs, const ProcInterface &);
   void SetType(const parser::Name &, const DeclTypeSpec &);
   std::optional<DerivedTypeSpec> ResolveDerivedType(const parser::Name &);
   std::optional<DerivedTypeSpec> ResolveExtendsType(
if (kind == parser::BindEntity::Kind::Object) {
     symbol = &HandleAttributeStmt(Attr::BIND_C, name);
   } else {
     symbol = &MakeCommonBlockSymbol(name);
     symbol->attrs().set(Attr::BIND_C);
   }
   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)};
   if (!ConvertToObjectEntity(symbol) ||
       symbol.test(Symbol::Flag::CrayPointer) ||
       symbol.test(Symbol::Flag::CrayPointee)) {
     SayWithDecl(
         name, symbol, "PARAMETER attribute not allowed on '%s'"_err_en_US);
     return false;
   }
   const auto &expr{std::get<parser::ConstantExpr>(x.t)};
+  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)}) {
-    symbol.get<ObjectEntityDetails>().set_init(std::move(*converted));
+      details.set_init(std::move(*converted));
+    }
   }
   return false;
 }
 bool DeclarationVisitor::Pre(const parser::NamedConstant &x) {
   const parser::Name &name{x.v};
   if (!FindSymbol(name)) {
     Say(name, "Named constant '%s' not found"_err_en_US);
   } else {

flang/lib/Semantics/scope.cpp

return declTypeSpecs_.emplace_back(
       CharacterTypeSpec{std::move(length), std::move(kind)});
 }
 
 DeclTypeSpec &Scope::MakeDerivedType(
     DeclTypeSpec::Category category, DerivedTypeSpec &&spec) {
   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_;
   }
   if (symbol_ && !symbol_->attrs().test(Attr::MODULE)) {
     if (auto *details{symbol_->detailsIf<SubprogramDetails>()}) {
       if (details->isInterface()) {
         return ImportKind::None; // default for non-mod-proc interface body

flang/lib/Semantics/tools.cpp

return std::visit(
           },
           [&](const auto *a) -> const std::optional<parser::Name> & {
             return std::get<0>(std::get<0>(a->t).statement.t);
           },
       },
       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

 void ProcInterface::set_symbol(const Symbol &symbol) {
   CHECK(!type_);
   symbol_ = &symbol;
 }
 void ProcInterface::set_type(const DeclTypeSpec &type) {
   CHECK(!symbol_);
   type_ = &type;
 }
+
 } // namespace Fortran::semantics

flang/test/Semantics/oldparam01.f90

+! 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

+! 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

+! 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

if (arg.empty()) {
           Fortran::parser::LanguageFeature::LogicalAbbreviations,
           arg == "-flogical-abbreviations");
     } else if (arg == "-fimplicit-none-type-always") {
       options.features.Enable(
           Fortran::common::LanguageFeature::ImplicitNoneTypeAlways);
     } 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;
     } else if (arg == "-fdebug-dump-parse-tree") {
       driver.dumpParseTree = true;
     } else if (arg == "-fdebug-pre-fir-tree") {
       driver.dumpPreFirTree = true;
     } else if (arg == "-fdebug-dump-symbols") {