From d146db54ca2dbdc7bafb17bc732f310584d97d0f Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier@nvidia.com>
Date: Wed, 22 May 2019 08:00:19 -0700
Subject: [PATCH] [flang] Fix: catch subroutine symbols in ALLOCATE

Original-commit: flang-compiler/f18@99d4b3dcd6a34c571979ca520b10033ee9a0b973
Reviewed-on: https://github.com/flang-compiler/f18/pull/467
---
 flang/lib/semantics/check-allocate.cc | 15 ++++++++---
 flang/test/semantics/allocate01.f90   | 49 +++++++++++++++++++++++++++++++++++
 2 files changed, 60 insertions(+), 4 deletions(-)

diff --git a/flang/lib/semantics/check-allocate.cc b/flang/lib/semantics/check-allocate.cc
index 5f1db3f..fee7799 100644
--- a/flang/lib/semantics/check-allocate.cc
+++ b/flang/lib/semantics/check-allocate.cc
@@ -342,8 +342,7 @@ static std::optional<std::int64_t> GetTypeParameterInt64Value(
       paramValue{derivedType.FindParameter(parameterSymbol.name())}) {
     return evaluate::ToInt64(paramValue->GetExplicit());
   } else {
-    // Type parameter with default value and omitted in DerivedTypeSpec
-    return evaluate::ToInt64(parameterSymbol.get<TypeParamDetails>().init());
+    return std::nullopt;
   }
 }
 
@@ -401,15 +400,23 @@ static bool HaveCompatibleKindParameters(
 }
 
 bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
-  if (type_ == nullptr) {
+  if (name_.symbol == nullptr) {
+    CHECK(context.AnyFatalError());
     return false;
   }
-  GatherAllocationBasicInfo();
   if (!IsVariableName(*name_.symbol)) {  // C932 pre-requisite
     context.Say(name_.source,
         "Name in ALLOCATE statement must be a variable name"_err_en_US);
     return false;
   }
+  if (type_ == nullptr) {
+    // This is done after variable check because a user could have put
+    // a subroutine name in allocate for instance which is a symbol with
+    // no type.
+    CHECK(context.AnyFatalError());
+    return false;
+  }
+  GatherAllocationBasicInfo();
   if (!IsAllocatableOrPointer(*name_.symbol)) {  // C932
     context.Say(name_.source,
         "Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
diff --git a/flang/test/semantics/allocate01.f90 b/flang/test/semantics/allocate01.f90
index 94906e1..0c6e54b 100644
--- a/flang/test/semantics/allocate01.f90
+++ b/flang/test/semantics/allocate01.f90
@@ -14,8 +14,30 @@
 
 ! Check for semantic errors in ALLOCATE statements
 
+module m
+! Creating symbols that allocate should not accept
+  type :: a_type
+    real, allocatable :: x
+    contains
+      procedure, pass :: foo => mfoo
+      procedure, pass :: bar => mbar
+  end type
+
+contains
+  function mfoo(x)
+    class(a_type) :: foo, x
+    allocatable :: x
+    foo = x
+  end function
+  subroutine mbar(x)
+    class(a_type), allocatable :: x
+    allocate(x)
+  end subroutine
+end module
+
 subroutine C932(ed1, ed5, ed7, edc9, edc10, okad1, okpd1, okacd5)
 ! Each allocate-object shall be a data pointer or an allocatable variable.
+  use :: m, only: a_type
   type TestType1
     integer, allocatable :: ok(:)
     integer :: nok(:)
@@ -24,14 +46,24 @@ subroutine C932(ed1, ed5, ed7, edc9, edc10, okad1, okpd1, okacd5)
     integer, pointer :: ok
     integer :: nok
   end type
+  interface
+    function foo(x)
+      real(4) :: foo, x
+    end function
+    subroutine bar()
+    end subroutine
+  end interface
   real ed1(:), e2
   real, save :: e3[*]
   real , target :: e4, ed5(:)
   real , parameter :: e6 = 5.
+  procedure(foo), pointer :: proc_ptr1 => NULL()
+  procedure(bar), pointer :: proc_ptr2
   type(TestType1) ed7
   type(TestType2) e8
   type(TestType1) edc9[*]
   type(TestType2) edc10[*]
+  class(a_type), allocatable :: a_var
 
   real, allocatable :: oka1(:, :), okad1(:, :), oka2
   real, pointer :: okp1(:, :), okpd1(:, :), okp2
@@ -39,6 +71,21 @@ subroutine C932(ed1, ed5, ed7, edc9, edc10, okad1, okpd1, okacd5)
   real, allocatable, save :: oka3, okac4[:,:]
   real, allocatable :: okacd5(:, :)[:]
 
+  !ERROR: Name in ALLOCATE statement must be a variable name
+  allocate(foo)
+  !ERROR: Name in ALLOCATE statement must be a variable name
+  allocate(bar)
+  !ERROR: Name in ALLOCATE statement must be a variable name
+  allocate(C932)
+  !ERROR: Name in ALLOCATE statement must be a variable name
+  allocate(proc_ptr1)
+  !ERROR: Name in ALLOCATE statement must be a variable name
+  allocate(proc_ptr2)
+  !ERROR: Name in ALLOCATE statement must be a variable name
+  allocate(a_var%foo)
+  !ERROR: Name in ALLOCATE statement must be a variable name
+  allocate(a_var%bar)
+
   !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
   allocate(ed1)
   !ERROR: Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute
@@ -65,6 +112,8 @@ subroutine C932(ed1, ed5, ed7, edc9, edc10, okad1, okpd1, okacd5)
   allocate(edc10)
 
   ! No errors expected below:
+  allocate(a_var)
+  allocate(a_var%x)
   allocate(oka1(5, 7), okad1(4, 8), oka2)
   allocate(okp1(5, 7), okpd1(4, 8), okp2)
   allocate(okp1(5, 7), okpd1(4, 8), okp2)
-- 
2.7.4