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

[via flang-commits]

Author: Peter Klausler
Date: 2023-10-16T15:40:13-07:00
New Revision: 39f4ec5854a1ca34c70343c3ed1648a6be5b6b82

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

LOG: [flang] Catch a dangerous ambiguity in standard Fortran (#67483)

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.

Added: 
    

Modified: 
    flang/docs/Extensions.md
    flang/lib/Semantics/resolve-names.cpp
    flang/test/Semantics/resolve29.f90

Removed: 
    


################################################################################
diff  --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 480039911719c6d..373f18e1e22847b 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -613,6 +613,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 b4deac9cf5ccdeb..90c14806afbf82d 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -6429,6 +6429,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;
@@ -8096,7 +8101,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')