[flang-commits] [PATCH] D140137: [flang] Catch bad usage of POINTER attribute

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: PeteSteinfeld.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
Herald added a reviewer: sscalpone.
Herald added a project: All.
klausler requested review of this revision.

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.


https://reviews.llvm.org/D140137

Files:
  flang/docs/Extensions.md
  flang/lib/Semantics/resolve-names.cpp
  flang/test/Semantics/pointer01.f90


Index: flang/test/Semantics/pointer01.f90
===================================================================
--- /dev/null
+++ 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
Index: flang/lib/Semantics/resolve-names.cpp
===================================================================
--- flang/lib/Semantics/resolve-names.cpp
+++ flang/lib/Semantics/resolve-names.cpp
@@ -3856,7 +3856,7 @@
   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 @@
     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));
   }
 }
Index: flang/docs/Extensions.md
===================================================================
--- flang/docs/Extensions.md
+++ flang/docs/Extensions.md
@@ -250,6 +250,8 @@
 * 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
 


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D140137.483259.patch
Type: text/x-patch
Size: 3111 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20221215/d7171bd9/attachment.bin>