[flang-commits] [flang] 6f6af76 - [flang] Catch bad usage of POINTER attribute

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-12-16T09:04:54-08:00
New Revision: 6f6af76b843d1f5538e2ee112a0237ec3a899327

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

LOG: [flang] Catch bad usage of POINTER attribute

Most attributes apply to only object or only procedure entities,
and attempts to apply them to other kinds of symbol table entries
are caught in name resolution when ConvertToObjectEntity() or
ConvertToProcEntity() fails.  However, the POINTER attribute can
be applied to both, and name resolution can't perform that conversion
yet, and as a result we don't catch many kinds of silly errors.
Fix by ensuring that the symbol is of a type that could eventually
become an object or procedure entity if it is not one already.

Differential Revision: https://reviews.llvm.org/D140137

Added: 
    flang/test/Semantics/pointer01.f90

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

Removed: 
    


################################################################################
diff  --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index 69855bfb1c296..a032052d228ab 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -250,6 +250,8 @@ end
 * A type-bound procedure binding can be passed as an actual
   argument corresponding to a dummy procedure and can be used as
   the target of a procedure pointer assignment statement.
+* An explicit `INTERFACE` can declare the interface of a
+  procedure pointer even if it is not a dummy argument.
 
 ### Extensions supported when enabled by options
 

diff  --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index beca842745f54..8d5ce36a7f9ea 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -3856,7 +3856,7 @@ void SubprogramVisitor::CheckExtantProc(
   if (auto *prev{FindSymbol(name)}) {
     if (IsDummy(*prev)) {
     } else if (auto *entity{prev->detailsIf<EntityDetails>()};
-               IsPointer(*prev) && !entity->type()) {
+               IsPointer(*prev) && entity && !entity->type()) {
       // POINTER attribute set before interface
     } else if (inInterfaceBlock() && currScope() != prev->owner()) {
       // Procedures in an INTERFACE block do not resolve to symbols
@@ -4071,6 +4071,17 @@ void DeclarationVisitor::Post(const parser::PointerDecl &x) {
     symbol.ReplaceName(name.source);
     EndArraySpec();
   } else {
+    if (const auto *symbol{FindInScope(name)}) {
+      const auto *subp{symbol->detailsIf<SubprogramDetails>()};
+      if (!symbol->has<UseDetails>() && // error caught elsewhere
+          !symbol->has<ObjectEntityDetails>() &&
+          !symbol->has<ProcEntityDetails>() &&
+          !symbol->CanReplaceDetails(ObjectEntityDetails{}) &&
+          !symbol->CanReplaceDetails(ProcEntityDetails{}) &&
+          !(subp && subp->isInterface())) {
+        Say(name, "'%s' cannot have the POINTER attribute"_err_en_US);
+      }
+    }
     HandleAttributeStmt(Attr::POINTER, std::get<parser::Name>(x.t));
   }
 }

diff  --git a/flang/test/Semantics/pointer01.f90 b/flang/test/Semantics/pointer01.f90
new file mode 100644
index 0000000000000..b6a66b61fe25e
--- /dev/null
+++ b/flang/test/Semantics/pointer01.f90
@@ -0,0 +1,37 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  real mobj
+ contains
+  subroutine msubr
+  end subroutine
+end module
+program main
+  use m
+  !PORTABILITY: Name 'main' declared in a main program should not have the same name as the main program
+  pointer main
+  !ERROR: Cannot change POINTER attribute on use-associated 'mobj'
+  pointer mobj
+  !ERROR: Cannot change POINTER attribute on use-associated 'msubr'
+  pointer msubr
+  !ERROR: 'inner' cannot have the POINTER attribute
+  pointer inner
+  real obj
+  !ERROR: 'ip' may not have both the POINTER and PARAMETER attributes
+  integer, parameter :: ip = 123
+  pointer ip
+  type dt; end type
+  !ERROR: 'dt' cannot have the POINTER attribute
+  pointer dt
+  interface generic
+    subroutine extsub
+    end subroutine
+  end interface
+  !ERROR: 'generic' cannot have the POINTER attribute
+  pointer generic
+  namelist /nml/ obj
+  !ERROR: 'nml' cannot have the POINTER attribute
+  pointer nml
+ contains
+  subroutine inner
+  end subroutine
+end