[flang] Better handling of ALLOCATED(pointer) error (#186622)

Some legacy compilers accept a reference to the intrinsic function
ALLOCATED with a pointer argument. (Pointers should be checked with
ASSOCIATED instead, of course.) Emit a good warning, but also interpret
the call to ALLOCATED with a pointer argument as if it had been
correctly spelled. Test that this only applies to the intrinsic
ALLOCATED, not a user-defined function.

flang/docs/Extensions.md

@@ -496,6 +496,9 @@ program p
   namelist /g/ k
 end program
 ```
+* When the argument to intrinsic `ALLOCATED(p)` is actually a pointer
+  rather than an allocatable, it is interpreted as `ASSOCIATED(p)` with a
+  stern warning.
 
 ### Extensions supported when enabled by options
 

flang/include/flang/Support/Fortran-features.h

@@ -58,7 +58,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     CudaWarpMatchFunction, DoConcurrentOffload, TransferBOZ, Coarray,
     PointerPassObject, MultipleIdenticalDATA,
     DefaultStructConstructorNullPointer, AssumedRankIoItem,
-    MultipleProgramUnitsOnSameLine)
+    MultipleProgramUnitsOnSameLine, AllocatedForAssociated)
 
 // Portability and suspicious usage warnings
 ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,

flang/lib/Evaluate/intrinsics.cpp

@@ -3802,6 +3802,21 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
       return HandleC_Devloc(arguments, context);
     } else if (call.name == "null") {
       return HandleNull(arguments, context);
+    } else if (call.name == "allocated") {
+      if (context.languageFeatures().IsEnabled(
+              common::LanguageFeature::AllocatedForAssociated) &&
+          arguments.size() == 1 && arguments[0].has_value()) {
+        auto &arg{*arguments[0]};
+        if (const Expr<SomeType> *expr{arg.UnwrapExpr()};
+            expr && IsObjectPointer(*expr)) {
+          context.Warn(common::LanguageFeature::AllocatedForAssociated,
+              arg.sourceLocation(),
+              "Argument of ALLOCATED() should be an allocatable, but is instead an object pointer"_warn_en_US);
+          // Treat ALLOCATED(ptr) as ASSOCIATED(ptr)
+          CallCharacteristics newCall{"associated"};
+          return Probe(newCall, arguments, context);
+        }
+      }
     }
   }
 

flang/lib/Support/Fortran-features.cpp

@@ -104,6 +104,7 @@ LanguageFeatureControl::LanguageFeatureControl() {
   warnLanguage_.set(LanguageFeature::ListDirectedSize);
   warnLanguage_.set(LanguageFeature::IgnoreIrrelevantAttributes);
   warnLanguage_.set(LanguageFeature::TransferBOZ);
+  warnLanguage_.set(LanguageFeature::AllocatedForAssociated);
   warnUsage_.set(UsageWarning::ShortArrayActual);
   warnUsage_.set(UsageWarning::FoldingException);
   warnUsage_.set(UsageWarning::FoldingAvoidsRuntimeCrash);

flang/test/Evaluate/bug2418.f90

@@ -0,0 +1,36 @@
+!RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+
+!CHECK-NOT: error:
+
+program main
+  integer, pointer :: p1(:) => NULL()
+  !CHECK: warning: Argument of ALLOCATED() should be an allocatable, but is instead an object pointer [-Wallocated-for-associated]
+  !CHECK:  PRINT *, associated(p1)
+  print *, allocated(p1)
+end
+
+subroutine s1
+  interface
+    logical function allocated(p)
+      class(*), pointer, intent(in) :: p(..)
+    end
+  end interface
+  real, pointer :: p2(:) => NULL()
+  !CHECK-NOT: error:
+  !CHECK-NOT: warning:
+  !CHECK: PRINT *, allocated(p2)
+  print *, allocated(p2)
+end
+
+subroutine s2
+  interface allocated
+    logical function specificallocated(p)
+      class(*), pointer, intent(in) :: p(..)
+    end
+  end interface
+  real, pointer :: p3(:) => NULL()
+  !CHECK-NOT: error:
+  !CHECK-NOT: warning:
+  !CHECK: PRINT *, specificallocated(p3)
+  print *, allocated(p3)
+end