[flang] Implement SIMPLE procedure support (parsing, semantics, diagnostics) (#161285)

Implement support for the Fortran 2023 `SIMPLE` procedure specifier.

This change includes:
- Parsing and attribute registration for `SIMPLE` procedures
- Adding `SIMPLE` to procedure characteristics
- Semantic support for `SIMPLE`, including treating `SIMPLE` procedures
as `PURE` (`SIMPLE` implies `PURE`)
- Rejecting `SIMPLE` + `IMPURE` combinations
- Emitting and reading `SIMPLE` in mod files
- Adding parser, semantic, and modfile tests to validate `SIMPLE`
behavior

`SIMPLE` procedures satisfy `PURE` requirements, while `PURE` procedures
do not imply `SIMPLE`.

flang/docs/F202X.md

@@ -167,6 +167,17 @@ I don't expect any codes to rush to change their `PURE` procedures
 to be `SIMPLE`, since it buys little and reduces portability.
 This makes `SIMPLE` a lower-priority feature.
 
+### Current status
+
+- Parsing and symbol attribute support for `SIMPLE` procedures: implemented
+- `SIMPLE` is represented in procedure characteristics
+- `SIMPLE` procedures are accepted where PURE procedures are required
+- `PURE` procedures do not satisfy `SIMPLE` requirements
+- `SIMPLE`/`IMPURE` conflicts are diagnosed
+- Use-associated `SIMPLE` procedures are correctly recognized
+- Additional `SIMPLE` semantic constraints remain to be implemented
+- Intrinsic procedures are not yet marked as `SIMPLE` (planned as follow-up work)
+
 #### Conditional expressions and actual arguments
 
 Next on the list of "big ticket" items are C-style conditional

flang/include/flang/Evaluate/call.h

@@ -220,6 +220,7 @@ struct ProcedureDesignator {
   int Rank() const;
   bool IsElemental() const;
   bool IsPure() const;
+  bool IsSimple() const;
   std::optional<Expr<SubscriptInteger>> LEN() const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
 

flang/include/flang/Evaluate/characteristics.h

@@ -365,8 +365,8 @@ struct FunctionResult {
 
 // 15.3.1
 struct Procedure {
-  ENUM_CLASS(Attr, Pure, Elemental, BindC, ImplicitInterface, NullPointer,
-      NullAllocatable, Subroutine)
+  ENUM_CLASS(Attr, Pure, Simple, Elemental, BindC, ImplicitInterface,
+      NullPointer, NullAllocatable, Subroutine)
   using Attrs = common::EnumSet<Attr, Attr_enumSize>;
   Procedure(){};
   Procedure(FunctionResult &&, DummyArguments &&, Attrs);
@@ -398,6 +398,7 @@ struct Procedure {
   bool IsSubroutine() const { return attrs.test(Attr::Subroutine); }
 
   bool IsPure() const { return attrs.test(Attr::Pure); }
+  bool IsSimple() const { return attrs.test(Attr::Simple); }
   bool IsElemental() const { return attrs.test(Attr::Elemental); }
   bool IsBindC() const { return attrs.test(Attr::BindC); }
   bool HasExplicitInterface() const {

flang/include/flang/Evaluate/tools.h

@@ -1593,6 +1593,8 @@ inline bool IsAlternateEntry(const Symbol *symbol) {
 bool IsVariableName(const Symbol &);
 bool IsPureProcedure(const Symbol &);
 bool IsPureProcedure(const Scope &);
+bool IsSimpleProcedure(const Symbol &);
+bool IsSimpleProcedure(const Scope &);
 bool IsExplicitlyImpureProcedure(const Symbol &);
 bool IsElementalProcedure(const Symbol &);
 bool IsFunction(const Symbol &);

flang/include/flang/Parser/dump-parse-tree.h

@@ -827,6 +827,7 @@ public:
   NODE(PrefixSpec, Non_Recursive)
   NODE(PrefixSpec, Pure)
   NODE(PrefixSpec, Recursive)
+  NODE(PrefixSpec, Simple)
   NODE(PrefixSpec, Attributes)
   NODE(PrefixSpec, Launch_Bounds)
   NODE(PrefixSpec, Cluster_Dims)

flang/include/flang/Parser/parse-tree.h

@@ -3103,7 +3103,7 @@ struct ProcedureDeclarationStmt {
 
 // R1527 prefix-spec ->
 //         declaration-type-spec | ELEMENTAL | IMPURE | MODULE |
-//         NON_RECURSIVE | PURE | RECURSIVE |
+//         NON_RECURSIVE | PURE | RECURSIVE | SIMPLE |
 // (CUDA)  ATTRIBUTES ( (DEVICE | GLOBAL | GRID_GLOBAL | HOST)... )
 //         LAUNCH_BOUNDS(expr-list) | CLUSTER_DIMS(expr-list)
 struct PrefixSpec {
@@ -3114,11 +3114,12 @@ struct PrefixSpec {
   EMPTY_CLASS(Non_Recursive);
   EMPTY_CLASS(Pure);
   EMPTY_CLASS(Recursive);
+  EMPTY_CLASS(Simple);
   WRAPPER_CLASS(Attributes, std::list<common::CUDASubprogramAttrs>);
   WRAPPER_CLASS(Launch_Bounds, std::list<ScalarIntConstantExpr>);
   WRAPPER_CLASS(Cluster_Dims, std::list<ScalarIntConstantExpr>);
   std::variant<DeclarationTypeSpec, Elemental, Impure, Module, Non_Recursive,
-      Pure, Recursive, Attributes, Launch_Bounds, Cluster_Dims>
+      Pure, Recursive, Simple, Attributes, Launch_Bounds, Cluster_Dims>
       u;
 };
 

flang/include/flang/Semantics/attr.h

@@ -25,7 +25,7 @@ ENUM_CLASS(Attr, ABSTRACT, ALLOCATABLE, ASYNCHRONOUS, BIND_C, CONTIGUOUS,
     DEFERRED, ELEMENTAL, EXTENDS, EXTERNAL, IMPURE, INTENT_IN, INTENT_INOUT,
     INTENT_OUT, INTRINSIC, MODULE, NON_OVERRIDABLE, NON_RECURSIVE, NOPASS,
     OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PUBLIC, PURE,
-    RECURSIVE, SAVE, TARGET, VALUE, VOLATILE)
+    RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE)
 
 // Set of attributes
 class Attrs : public common::EnumSet<Attr, Attr_enumSize> {

flang/lib/Evaluate/call.cpp

@@ -158,6 +158,20 @@ bool ProcedureDesignator::IsPure() const {
   return false;
 }
 
+bool ProcedureDesignator::IsSimple() const {
+  if (const Symbol *interface{GetInterfaceSymbol()}) {
+    return IsSimpleProcedure(*interface);
+  } else if (const Symbol *symbol{GetSymbol()}) {
+    return IsSimpleProcedure(*symbol);
+  } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
+    return intrinsic->characteristics.value().attrs.test(
+        characteristics::Procedure::Attr::Simple);
+  } else {
+    DIE("ProcedureDesignator::IsSimple(): no case");
+  }
+  return false;
+}
+
 const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {
   return std::get_if<SpecificIntrinsic>(&u);
 }

flang/lib/Evaluate/characteristics.cpp

@@ -787,6 +787,7 @@ static std::optional<Procedure> CharacterizeProcedure(
     CopyAttrs<Procedure, Procedure::Attr>(symbol, *result,
         {
             {semantics::Attr::BIND_C, Procedure::Attr::BindC},
+            {semantics::Attr::SIMPLE, Procedure::Attr::Simple},
         });
     CopyAttrs<Procedure, Procedure::Attr>(DEREF(GetMainEntry(&symbol)), *result,
         {
@@ -1331,6 +1332,9 @@ bool Procedure::IsCompatibleWith(const Procedure &actual,
   if (!attrs.test(Attr::Pure)) {
     actualAttrs.reset(Attr::Pure);
   }
+  if (!attrs.test(Attr::Simple)) {
+    actualAttrs.reset(Attr::Simple);
+  }
   if (!attrs.test(Attr::Elemental) && specificIntrinsic) {
     actualAttrs.reset(Attr::Elemental);
   }

flang/lib/Evaluate/intrinsics.cpp

@@ -2867,6 +2867,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
   if (elementalRank > 0) {
     attrs.set(characteristics::Procedure::Attr::Elemental);
   }
+  // TODO: Mark intrinsic procedures that are SIMPLE per F2023
   if (call.isSubroutineCall) {
     if (intrinsicClass == IntrinsicClass::pureSubroutine /* MOVE_ALLOC */ ||
         intrinsicClass == IntrinsicClass::elementalSubroutine /* MVBITS */) {

flang/lib/Evaluate/tools.cpp

@@ -2182,6 +2182,9 @@ static bool IsPureProcedureImpl(
     }
     return true; // statement function was not found to be impure
   }
+  if (symbol.attrs().test(Attr::SIMPLE)) {
+    return true; // SIMPLE implies PURE; F2023 15.8
+  }
   return symbol.attrs().test(Attr::PURE) ||
       (symbol.attrs().test(Attr::ELEMENTAL) &&
           !symbol.attrs().test(Attr::IMPURE));
@@ -2197,6 +2200,18 @@ bool IsPureProcedure(const Scope &scope) {
   return symbol && IsPureProcedure(*symbol);
 }
 
+bool IsSimpleProcedure(const Symbol &original) {
+  // An ENTRY is SIMPLE if its containing subprogram is
+  return DEREF(GetMainEntry(&original.GetUltimate()))
+      .attrs()
+      .test(Attr::SIMPLE);
+}
+
+bool IsSimpleProcedure(const Scope &scope) {
+  const Symbol *symbol{scope.GetSymbol()};
+  return symbol && IsSimpleProcedure(*symbol);
+}
+
 bool IsExplicitlyImpureProcedure(const Symbol &original) {
   // An ENTRY is IMPURE if its containing subprogram is so
   return DEREF(GetMainEntry(&original.GetUltimate()))

flang/lib/Parser/program-parsers.cpp

@@ -553,7 +553,7 @@ TYPE_PARSER(construct<AltReturnSpec>(star >> label))
 
 // R1527 prefix-spec ->
 //         declaration-type-spec | ELEMENTAL | IMPURE | MODULE |
-//         NON_RECURSIVE | PURE | RECURSIVE |
+//         NON_RECURSIVE | PURE | RECURSIVE | SIMPLE |
 // (CUDA)  ATTRIBUTES ( (DEVICE | GLOBAL | GRID_GLOBAL | HOST)... ) |
 //         LAUNCH_BOUNDS(expr-list) | CLUSTER_DIMS(expr-list)
 TYPE_PARSER(withMessage(
@@ -570,6 +570,7 @@ TYPE_PARSER(first(construct<PrefixSpec>(declarationTypeSpec),
         construct<PrefixSpec::Non_Recursive>("NON_RECURSIVE"_tok)),
     construct<PrefixSpec>(construct<PrefixSpec::Pure>("PURE"_tok)),
     construct<PrefixSpec>(construct<PrefixSpec::Recursive>("RECURSIVE"_tok)),
+    construct<PrefixSpec>(construct<PrefixSpec::Simple>("SIMPLE"_tok)),
     extension<LanguageFeature::CUDA>(
         construct<PrefixSpec>(construct<PrefixSpec::Attributes>(
             localRecovery("expected valid ATTRIBUTES specification"_err_en_US,

flang/lib/Parser/unparse.cpp

@@ -1770,6 +1770,7 @@ public:
   void Post(const PrefixSpec::Non_Recursive) { Word("NON_RECURSIVE"); }
   void Post(const PrefixSpec::Pure) { Word("PURE"); }
   void Post(const PrefixSpec::Recursive) { Word("RECURSIVE"); }
+  void Post(const PrefixSpec::Simple) { Word("SIMPLE"); }
   void Unparse(const PrefixSpec::Attributes &x) {
     Word("ATTRIBUTES("), Walk(x.v), Word(")");
   }

flang/lib/Semantics/check-declarations.cpp

@@ -1596,6 +1596,12 @@ void CheckHelper::CheckSubprogram(
       context_.SetError(symbol);
     }
   }
+  // F2023 C1553
+  if (symbol.attrs().test(Attr::SIMPLE) && symbol.attrs().test(Attr::IMPURE)) {
+    messages_.Say(symbol.name(),
+        "A procedure may not have both the SIMPLE and IMPURE attributes"_err_en_US);
+    context_.SetError(symbol);
+  }
   if (const Symbol *iface{FindSeparateModuleSubprogramInterface(&symbol)}) {
     SubprogramMatchHelper{*this}.Check(symbol, *iface);
   }

flang/lib/Semantics/mod-file.cpp

@@ -664,7 +664,8 @@ void ModFileWriter::PutDECStructure(
 
 // Attributes that may be in a subprogram prefix
 static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE,
-    Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::RECURSIVE};
+    Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::SIMPLE,
+    Attr::RECURSIVE};
 
 static void PutOpenACCDeviceTypeRoutineInfo(
     llvm::raw_ostream &os, const OpenACCRoutineDeviceTypeInfo &info) {

flang/lib/Semantics/resolve-names.cpp

@@ -271,6 +271,7 @@ public:
   HANDLE_ATTR_CLASS(PrefixSpec::Non_Recursive, NON_RECURSIVE)
   HANDLE_ATTR_CLASS(PrefixSpec::Pure, PURE)
   HANDLE_ATTR_CLASS(PrefixSpec::Recursive, RECURSIVE)
+  HANDLE_ATTR_CLASS(PrefixSpec::Simple, SIMPLE)
   HANDLE_ATTR_CLASS(TypeAttrSpec::BindC, BIND_C)
   HANDLE_ATTR_CLASS(BindAttr::Deferred, DEFERRED)
   HANDLE_ATTR_CLASS(BindAttr::Non_Overridable, NON_OVERRIDABLE)

flang/test/Parser/simple-unparse.f90

@@ -0,0 +1,13 @@
+! Test that SIMPLE function specifier is recognized
+! by the parser and the unparser. This test does not
+! exercise semantic checks.
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+
+simple function foo()
+  return
+end function
+
+! CHECK: SIMPLE FUNCTION foo()
+! CHECK-NEXT: RETURN
+! CHECK-NEXT: END FUNCTION
+

flang/test/Parser/simple.f90

@@ -0,0 +1,8 @@
+! Check that SIMPLE is recognized in the parse tree
+! RUN: %flang_fc1 -fdebug-dump-parse-tree %s | FileCheck %s
+
+simple function foo()
+  return
+end function
+
+! CHECK: Simple

flang/test/Semantics/modfile-simple.f90

@@ -0,0 +1,91 @@
+! Test modfile emission for subprograms, including SIMPLE procedure attributes
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+
+! Module with SIMPLE subprograms and function result declarations
+module m1
+  type :: t
+  end type
+contains
+  simple subroutine Ss(x, y) bind(c)
+    logical(1) x
+    intent(inout) y
+    intent(in) x
+  end subroutine
+  real function f1() result(x)
+    x = 1.0
+  end function
+  function f2(y)
+    complex y
+    f2 = 2.0
+  end function
+end module m1
+
+!Expect: m1.mod
+!module m1
+!type::t
+!end type
+!contains
+!simple subroutine ss(x,y) bind(c)
+!logical(1),intent(in)::x
+!real(4),intent(inout)::y
+!end
+!function f1() result(x)
+!real(4)::x
+!end
+!function f2(y)
+!complex(4)::y
+!real(4)::f2
+!end
+!end
+
+! Module using m1 with local derived types and implicit typing
+module m2
+contains
+  type(t) function f3(x)
+    use m1
+    integer, parameter :: a = 2
+    type t2(b)
+      integer, kind :: b = a
+      integer :: y
+    end type
+    type(t2) :: x
+  end
+  function f4() result(x)
+    implicit complex(x)
+  end function
+end module m2
+
+!Expect: m2.mod
+!module m2
+!contains
+!function f3(x)
+! use m1,only:t
+! type::t2(b)
+!  integer(4),kind::b=2_4
+!  integer(4)::y
+! end type
+! type(t2(b=2_4))::x
+! type(t)::f3
+!end
+!function f4() result(x)
+!complex(4)::x
+!end
+!end
+
+! Alternate returns; ensure modfile emission unaffected by SIMPLE
+module m3
+contains
+  subroutine altReturn(arg1, arg2, *, *)
+    real :: arg1
+    real :: arg2
+  end subroutine
+end module m3
+
+!Expect: m3.mod
+!module m3
+!contains
+!subroutine altreturn(arg1,arg2,*,*)
+!real(4)::arg1
+!real(4)::arg2
+!end
+!end

flang/test/Semantics/simple-positive.f90

@@ -0,0 +1,119 @@
+! Test accepted SIMPLE procedure cases.
+! RUN: %flang_fc1 -fsyntax-only %s
+
+! SIMPLE procedures satisfy PURE requirements.
+module simple_satisfies_pure
+  implicit none
+  abstract interface
+    pure integer function pure_iface(x)
+      integer, intent(in) :: x
+    end function
+  end interface
+contains
+  simple integer function simple_impl(x)
+    integer, intent(in) :: x
+    simple_impl = x
+  end function
+
+  pure integer function apply_requires_pure(f, x)
+    procedure(pure_iface) :: f
+    integer, intent(in) :: x
+    apply_requires_pure = f(x)
+  end function
+
+  integer function test()
+    test = apply_requires_pure(simple_impl, 1)
+  end function
+end module
+
+! Use-associated SIMPLE procedures are recognized.
+module simple_use_assoc_m
+contains
+  simple subroutine s()
+  end subroutine
+end module
+
+program simple_use_assoc_p
+  use simple_use_assoc_m
+  implicit none
+  call needs_simple(s)
+contains
+  subroutine needs_simple(p)
+    abstract interface
+      simple subroutine simple_proc()
+      end subroutine
+    end interface
+    procedure(simple_proc) :: p
+  end subroutine
+end program
+
+! SIMPLE functions returning non-trivial CHARACTER results.
+module simple_character_result
+contains
+  simple function fixed_len_character() result(res)
+    character(len=5) :: res
+    res = "hello"
+  end function
+
+  simple function dependent_len_character(x) result(res)
+    character(*), intent(in) :: x
+    character(len=len(x)) :: res
+    res = x
+  end function
+
+  subroutine test()
+    character(len=3) :: a
+    character(len=7) :: b
+    a = dependent_len_character("abc")
+    b = dependent_len_character("testing")
+  end subroutine
+end module
+
+! SIMPLE and PURE may both appear in either order.
+module simple_pure_order
+contains
+  simple pure subroutine simple_pure_sub()
+  end subroutine
+
+  pure simple subroutine pure_simple_sub()
+  end subroutine
+
+  subroutine test()
+    call simple_pure_sub()
+    call pure_simple_sub()
+  end subroutine
+end module
+
+! SIMPLE separate module function is accepted.
+module m_smf
+  interface
+    simple module function f(x) result(res)
+      integer, intent(in) :: x
+      integer :: res
+    end function
+  end interface
+end module
+
+submodule(m_smf) sm_smf
+contains
+  module procedure f
+    res = x
+  end procedure
+end submodule
+
+! MODULE SIMPLE function prefix order is accepted.
+module m_msf
+  interface
+    module simple function g(x) result(res)
+      integer, intent(in) :: x
+      integer :: res
+    end function
+  end interface
+end module
+
+submodule(m_msf) sm_msf
+contains
+  module procedure g
+    res = x
+  end procedure
+end submodule

flang/test/Semantics/simple-pure-attribute-conflicts.f90

@@ -0,0 +1,55 @@
+! Test invalid SIMPLE procedure attribute combinations and procedure argument
+! compatibility checks.
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+! --- CASE 1: SIMPLE + IMPURE conflict
+!ERROR: A procedure may not have both the SIMPLE and IMPURE attributes
+simple impure subroutine bug()
+end subroutine
+
+! --- CASE 2: IMPURE + SIMPLE conflict
+!ERROR: A procedure may not have both the SIMPLE and IMPURE attributes
+impure simple subroutine bug2()
+end subroutine
+
+! --- CASE 3: PURE does NOT satisfy SIMPLE
+module pure_not_enough_for_simple
+  abstract interface
+    simple subroutine simple_proc()
+    end subroutine
+  end interface
+contains
+  subroutine needs_simple(p)
+    procedure(simple_proc) :: p
+  end subroutine
+  pure subroutine pure_only()
+  end subroutine
+  subroutine test()
+    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible procedure attributes: Simple
+    call needs_simple(pure_only)
+  end subroutine
+end module
+
+! --- CASE 4: Neither PURE nor SIMPLE does NOT satisfy PURE
+module m
+  implicit none
+  abstract interface
+    pure integer function iproc(x)
+      integer, intent(in) :: x
+    end function
+  end interface
+contains
+  integer function impure(x)
+    integer, intent(in) :: x
+    impure = x
+  end function
+  pure integer function apply_pure(f, x)
+    procedure(iproc) :: f
+    integer, intent(in) :: x
+    apply_pure = f(x)
+  end function
+  integer function test()
+    !ERROR: Actual procedure argument has interface incompatible with dummy argument 'f=': incompatible procedure attributes: Pure
+    test = apply_pure(impure, 1)
+  end function
+end module