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

[via flang-commits]

Author: Peter Klausler
Date: 2024-08-20T12:03:15-07:00
New Revision: 90d753ab75afdaab998cad20620b8197610e6dbd

URL: https://github.com/llvm/llvm-project/commit/90d753ab75afdaab998cad20620b8197610e6dbd
DIFF: https://github.com/llvm/llvm-project/commit/90d753ab75afdaab998cad20620b8197610e6dbd.diff

LOG: [flang] Fix inheritance of IMPLICIT typing rules (#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.

Added: 
    flang/test/Semantics/implicit15.f90

Modified: 
    flang/lib/Semantics/resolve-names.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index b4875d87d172c2..c0478fd4390076 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 00000000000000..d7cfa543e84a51
--- /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