[flang-commits] [flang] e19faed - [flang] Catch doubly-nested internal subprograms (#175992)

[via flang-commits]

Author: Peter Klausler
Date: 2026-01-19T11:00:05-08:00
New Revision: e19faed907d722a48e482a44d28774ff51d6b405

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

LOG: [flang] Catch doubly-nested internal subprograms (#175992)

The check for double-nested internal subprograms is missing cases nested
in main programs.

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

Added: 
    flang/test/Semantics/bug150820.f90

Modified: 
    flang/lib/Semantics/check-purity.cpp
    flang/lib/Semantics/check-purity.h
    flang/test/Semantics/misc-intrinsics.f90
    flang/test/Semantics/symbol03.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-purity.cpp b/flang/lib/Semantics/check-purity.cpp
index 1046f363e9485..b327282f390e5 100644
--- a/flang/lib/Semantics/check-purity.cpp
+++ b/flang/lib/Semantics/check-purity.cpp
@@ -17,6 +17,7 @@ void PurityChecker::Enter(const parser::ExecutableConstruct &exec) {
         "An image control statement may not appear in a pure subprogram"_err_en_US);
   }
 }
+
 void PurityChecker::Enter(const parser::SubroutineSubprogram &subr) {
   const auto &stmt{std::get<parser::Statement<parser::SubroutineStmt>>(subr.t)};
   Entered(
@@ -31,7 +32,10 @@ void PurityChecker::Enter(const parser::FunctionSubprogram &func) {
       stmt.source, std::get<std::list<parser::PrefixSpec>>(stmt.statement.t));
 }
 
-void PurityChecker::Leave(const parser::FunctionSubprogram &func) { Left(); }
+void PurityChecker::Leave(const parser::FunctionSubprogram &) { Left(); }
+
+void PurityChecker::Enter(const parser::MainProgram &) { ++depth_; }
+void PurityChecker::Leave(const parser::MainProgram &) { --depth_; }
 
 bool PurityChecker::InPureSubprogram() const {
   return pureDepth_ >= 0 && depth_ >= pureDepth_;

diff  --git a/flang/lib/Semantics/check-purity.h b/flang/lib/Semantics/check-purity.h
index a6551162325f9..4e01bdc00e0bc 100644
--- a/flang/lib/Semantics/check-purity.h
+++ b/flang/lib/Semantics/check-purity.h
@@ -23,6 +23,8 @@ class PurityChecker : public virtual BaseChecker {
   void Enter(const parser::ExecutableConstruct &);
   void Enter(const parser::SubroutineSubprogram &);
   void Leave(const parser::SubroutineSubprogram &);
+  void Enter(const parser::MainProgram &);
+  void Leave(const parser::MainProgram &);
   void Enter(const parser::FunctionSubprogram &);
   void Leave(const parser::FunctionSubprogram &);
 

diff  --git a/flang/test/Semantics/bug150820.f90 b/flang/test/Semantics/bug150820.f90
new file mode 100644
index 0000000000000..5a369c47934ca
--- /dev/null
+++ b/flang/test/Semantics/bug150820.f90
@@ -0,0 +1,20 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1
+subroutine a
+ contains
+  subroutine b
+   contains
+    !ERROR: An internal subprogram may not contain an internal subprogram
+    subroutine c
+    end
+  end
+end
+
+program p
+ contains
+  subroutine b
+   contains
+    !ERROR: An internal subprogram may not contain an internal subprogram
+    subroutine c
+    end
+  end
+end

diff  --git a/flang/test/Semantics/misc-intrinsics.f90 b/flang/test/Semantics/misc-intrinsics.f90
index a7895f7b7f16f..517a8b247ad28 100644
--- a/flang/test/Semantics/misc-intrinsics.f90
+++ b/flang/test/Semantics/misc-intrinsics.f90
@@ -105,16 +105,19 @@ subroutine test(arg, assumedRank, poly)
       print *, lbound(assumedRank, dim=2)
       print *, ubound(assumedRank, dim=2)
     end select
-   contains
-    subroutine inner
-      !ERROR: A dim= argument is required for 'size' when the array is assumed-size
-      print *, size(arg)
-      print *, size(arg, dim=1) ! ok
-      !ERROR: A dim= argument is required for 'ubound' when the array is assumed-size
-      print *, ubound(arg)
-      print *, ubound(arg, dim=1) ! ok
-      !ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
-      print *, shape(arg)
-    end
-  end subroutine
+  end
+end
+subroutine test2(arg)
+  real, dimension(5, *) :: arg
+ contains
+  subroutine inner
+    !ERROR: A dim= argument is required for 'size' when the array is assumed-size
+    print *, size(arg)
+    print *, size(arg, dim=1) ! ok
+    !ERROR: A dim= argument is required for 'ubound' when the array is assumed-size
+    print *, ubound(arg)
+    print *, ubound(arg, dim=1) ! ok
+    !ERROR: The 'source=' argument to the intrinsic function 'shape' may not be assumed-size
+    print *, shape(arg)
+  end
 end

diff  --git a/flang/test/Semantics/symbol03.f90 b/flang/test/Semantics/symbol03.f90
index 62472495d9736..4651669020473 100644
--- a/flang/test/Semantics/symbol03.f90
+++ b/flang/test/Semantics/symbol03.f90
@@ -13,13 +13,6 @@ subroutine s
   !DEF: /MAIN/s/y (Implicit) ObjectEntity REAL(4)
   !DEF: /MAIN/s/x HostAssoc INTEGER(4)
   y = x
- contains
-  !DEF: /MAIN/s/s2 (Subroutine) Subprogram
-  subroutine s2
-   !DEF: /MAIN/s/s2/z (Implicit) ObjectEntity REAL(4)
-   !DEF: /MAIN/s/s2/x HostAssoc INTEGER(4)
-   z = x
-  end subroutine
  end subroutine
 end program