[flang-commits] [flang] [flang] Catch a dangerous ambiguity in standard Fortran (PR #67483)

[Peter Klausler via flang-commits]

https://github.com/klausler updated https://github.com/llvm/llvm-project/pull/67483

>From 2e333828f8a086f56150bf5066902cb71f49a921 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 26 Sep 2023 12:53:52 -0700
Subject: [PATCH] [flang] Catch a dangerous ambiguity in standard Fortran

Fortran allows forward references to type names, which can
lead to ambiguity when coupled with host association, as in:

  module m
    type ambiguous; integer n; end type
   contains
    subroutine s
      type(ambiguous), pointer :: variable
      type t
        type(ambiguous), pointer :: component
      end type
      type ambiguous; real x; end type
    end
  end

Some other compilers resolve to a host association, some resolve
to a forward reference.  This compiler will now emit an error.
---
 flang/docs/Extensions.md              | 15 +++++++++++++++
 flang/lib/Semantics/resolve-names.cpp |  7 ++++++-
 flang/test/Semantics/resolve29.f90    | 23 +++++++++++++++++++++++
 3 files changed, 44 insertions(+), 1 deletion(-)

diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index bacb2dd7996b930..28ad1842d9b8382 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -611,6 +611,21 @@ end module
   associated objects and do not elicit errors about improper redeclarations
   of implicitly typed entities.
 
+* Standard Fortran allows forward references to derived types, which
+  can lead to ambiguity when combined with host association.
+  Some Fortran compilers resolve the type name to the host type,
+  others to the forward-referenced local type; this compiler diagnoses
+  an error.
+```
+module m
+  type ambiguous; integer n; end type
+ contains
+  subroutine s
+    type(ambiguous), pointer :: ptr
+    type ambiguous; real a; end type
+  end
+end
+```
 
 ## De Facto Standard Features
 
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 40f5ab9eb6e27ca..16fa1a505543e0c 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6425,6 +6425,11 @@ std::optional<DerivedTypeSpec> DeclarationVisitor::ResolveDerivedType(
       Say(name, "Derived type '%s' not found"_err_en_US);
       return std::nullopt;
     }
+  } else if (&DEREF(symbol).owner() != &outer &&
+      !ultimate->has<GenericDetails>()) {
+    // Prevent a later declaration in this scope of a host-associated
+    // type name.
+    outer.add_importName(name.source);
   }
   if (CheckUseError(name)) {
     return std::nullopt;
@@ -8092,7 +8097,7 @@ void ResolveNamesVisitor::CheckImport(
     const Symbol &ultimate{symbol->GetUltimate()};
     if (&ultimate.owner() == &currScope()) {
       Say(location, "'%s' from host is not accessible"_err_en_US, name)
-          .Attach(symbol->name(), "'%s' is hidden by this entity"_en_US,
+          .Attach(symbol->name(), "'%s' is hidden by this entity"_because_en_US,
               symbol->name());
     }
   }
diff --git a/flang/test/Semantics/resolve29.f90 b/flang/test/Semantics/resolve29.f90
index ea4642c1b3ddc78..3e6a8a0ba697638 100644
--- a/flang/test/Semantics/resolve29.f90
+++ b/flang/test/Semantics/resolve29.f90
@@ -9,6 +9,7 @@ subroutine s1(x)
       !ERROR: 't1' from host is not accessible
       import :: t1
       type(t1) :: x
+      !BECAUSE: 't1' is hidden by this entity
       integer :: t1
     end subroutine
     subroutine s2()
@@ -24,6 +25,7 @@ subroutine s4(x, y)
       import, all
       type(t1) :: x
       type(t3) :: y
+      !BECAUSE: 't3' is hidden by this entity
       integer :: t3
     end subroutine
   end interface
@@ -41,6 +43,27 @@ subroutine s7()
     !ERROR: 's5' is an external procedure without the EXTERNAL attribute in a scope with IMPLICIT NONE(EXTERNAL)
     call s5()
   end
+  subroutine s8()
+    !This case is a dangerous ambiguity allowed by the standard.
+    !ERROR: 't1' from host is not accessible
+    type(t1), pointer :: p
+    !BECAUSE: 't1' is hidden by this entity
+    type t1
+      integer n(2)
+    end type
+  end
+  subroutine s9()
+    !This case is a dangerous ambiguity allowed by the standard.
+    type t2
+      !ERROR: 't1' from host is not accessible
+      type(t1), pointer :: p
+    end type
+    !BECAUSE: 't1' is hidden by this entity
+    type t1
+      integer n(2)
+    end type
+    type(t2) x
+  end
 end module
 module m2
   integer, parameter :: ck = kind('a')