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

[via flang-commits]

llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-semantics

<details>
<summary>Changes</summary>

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.

---
Full diff: https://github.com/llvm/llvm-project/pull/67483.diff


3 Files Affected:

- (modified) flang/docs/Extensions.md (+15) 
- (modified) flang/lib/Semantics/resolve-names.cpp (+6-1) 
- (modified) flang/test/Semantics/resolve29.f90 (+23) 


``````````diff
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 68726cbd2ed932e..e3f62cf988f0602 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -610,6 +610,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 47ecaa1b82e53ed..0880ac6d1a79af6 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6400,6 +6400,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;
@@ -8067,7 +8072,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')

``````````

</details>


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