[flang-commits] [flang] [flang] Fix inheritance of IMPLICIT typing rules (PR #102692)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/102692

Interfaces don't inherit the IMPLICIT typing rules of their enclosing scope, and separate MODULE PROCEDUREs inherit the IMPLICIT typing rules of submodule in which they are defined, not the rules from their interface.

Fixes https://github.com/llvm/llvm-project/issues/102558.

>From afded7678bebf48bb2fbf9a71e0037ab0c19d513 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Fri, 9 Aug 2024 15:44:22 -0700
Subject: [PATCH] [flang] Fix inheritance of IMPLICIT typing rules

Interfaces don't inherit the IMPLICIT typing rules of their
enclosing scope, and separate MODULE PROCEDUREs inherit the
IMPLICIT typing rules of submodule in which they are defined,
not the rules from their interface.

Fixes https://github.com/llvm/llvm-project/issues/102558.
---
 flang/lib/Semantics/resolve-names.cpp | 12 +++----
 flang/test/Semantics/implicit15.f90   | 50 +++++++++++++++++++++++++++
 2 files changed, 56 insertions(+), 6 deletions(-)
 create mode 100644 flang/test/Semantics/implicit15.f90

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index b4875d87d172c..c0478fd439007 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -62,10 +62,9 @@ class ScopeHandler;
 // When inheritFromParent is set, defaults come from the parent rules.
 class ImplicitRules {
 public:
-  ImplicitRules(SemanticsContext &context, ImplicitRules *parent)
-      : parent_{parent}, context_{context} {
-    inheritFromParent_ = parent != nullptr;
-  }
+  ImplicitRules(SemanticsContext &context, const ImplicitRules *parent)
+      : parent_{parent}, context_{context},
+        inheritFromParent_{parent != nullptr} {}
   bool isImplicitNoneType() const;
   bool isImplicitNoneExternal() const;
   void set_isImplicitNoneType(bool x) { isImplicitNoneType_ = x; }
@@ -82,7 +81,7 @@ class ImplicitRules {
 private:
   static char Incr(char ch);
 
-  ImplicitRules *parent_;
+  const ImplicitRules *parent_;
   SemanticsContext &context_;
   bool inheritFromParent_{false}; // look in parent if not specified here
   bool isImplicitNoneType_{
@@ -3380,6 +3379,7 @@ bool ModuleVisitor::BeginSubmodule(
     parentScope = &currScope();
   }
   BeginModule(name, true);
+  set_inheritFromParent(false); // submodules don't inherit parents' implicits
   if (ancestor && !ancestor->AddSubmodule(name.source, currScope())) {
     Say(name, "Module '%s' already has a submodule named '%s'"_err_en_US,
         ancestorName.source, name.source);
@@ -4487,7 +4487,7 @@ Symbol &SubprogramVisitor::PushSubprogramScope(const parser::Name &name,
         CHECK(context().HasError(genericSymbol));
       }
     }
-    set_inheritFromParent(hasModulePrefix);
+    set_inheritFromParent(false); // interfaces don't inherit, even if MODULE
   }
   if (Symbol * found{FindSymbol(name)};
       found && found->has<HostAssocDetails>()) {
diff --git a/flang/test/Semantics/implicit15.f90 b/flang/test/Semantics/implicit15.f90
new file mode 100644
index 0000000000000..d7cfa543e84a5
--- /dev/null
+++ b/flang/test/Semantics/implicit15.f90
@@ -0,0 +1,50 @@
+!RUN: %flang_fc1 -fdebug-unparse  %s  2>&1 | FileCheck %s
+!Test inheritance of implicit rules in submodules and separate module
+!procedures.
+
+module m
+  implicit integer(1)(a-z)
+  interface
+    module subroutine mp(da) ! integer(2)
+      implicit integer(2)(a-z)
+    end
+  end interface
+  save :: mv ! integer(1)
+end
+
+submodule(m) sm1
+  implicit integer(8)(a-z)
+  save :: sm1v ! integer(8)
+  interface
+    module subroutine sm1p(da) ! default real
+    end
+  end interface
+end
+
+submodule(m:sm1) sm2
+  implicit integer(2)(a-c,e-z)
+  save :: sm2v ! integer(2)
+ contains
+  module subroutine sm1p(da) ! default real
+    save :: sm1pv ! inherited integer(2)
+    !CHECK: PRINT *, 1_4, 8_4, 2_4, 4_4, 2_4
+    print *, kind(mv), kind(sm1v), kind(sm2v), kind(da), kind(sm1pv)
+  end
+end
+
+submodule(m:sm2) sm3
+  implicit integer(8)(a-z)
+  save :: sm3v ! integer(8)
+ contains
+  module procedure mp
+    save :: mpv ! inherited integer(8)
+    call sm1p(1.)
+    !CHECK: PRINT *, 1_4, 8_4, 2_4, 8_4, 2_4, 8_4
+    print *, kind(mv), kind(sm1v), kind(sm2v), kind(sm3v), kind(da), kind(mpv)
+  end
+end
+
+program main
+  use m
+  call mp(1_2)
+end