[flang] Do not die on typeless source expression in allocate.

While fixing 594, it appears the CHECK in allocate for non null
expression type pointer was too harsh as it could be a user error.
e.g: a boz used as source.

Original-commit: flang-compiler/f18@cbacdeaa0eb8077810db85d5b4469f797d524900
Reviewed-on: https://github.com/flang-compiler/f18/pull/607
Tree-same-pre-rewrite: false

diff --git a/flang/lib/semantics/check-allocate.cc b/flang/lib/semantics/check-allocate.cc
index 8ea2c33..47881dc 100644 (file)
--- a/flang/lib/semantics/check-allocate.cc
+++ b/flang/lib/semantics/check-allocate.cc
@@ -195,7 +195,8 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
     if (const auto *expr{GetExpr(DEREF(parserSourceExpr))}) {
       info.sourceExprType = expr->GetType();
       if (!info.sourceExprType.has_value()) {
-        CHECK(context.AnyFatalError());
+        context.Say(parserSourceExpr->source,
+            "Typeless item not allowed as SOURCE or MOLD in ALLOCATE"_err_en_US);
         return std::nullopt;
       }
       info.sourceExprRank = expr->Rank();

diff --git a/flang/test/semantics/allocate08.f90 b/flang/test/semantics/allocate08.f90
index 7bc6b28..6c9ebd9 100644 (file)
--- a/flang/test/semantics/allocate08.f90
+++ b/flang/test/semantics/allocate08.f90
@@ -86,3 +86,54 @@ subroutine C945_a(srca, srcb, srcc, src_complex, src_logical, &
   !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
   allocate(npca1, bp1, npbp1, mold=srcc)
 end subroutine
+
+module m
+  type :: t
+    real x(100)
+   contains
+    procedure :: f
+  end type
+ contains
+  function f(this) result (x)
+    class(t) :: this
+    class(t), allocatable :: x
+  end function
+  subroutine bar
+    type(t) :: o
+    type(t), allocatable :: p
+    real, allocatable :: rp
+    allocate(p, source=o%f())
+    !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
+    allocate(rp, source=o%f())
+  end subroutine
+end module
+
+! Related to C945, check typeless expression are caught
+
+subroutine sub
+end subroutine
+
+function func() result(x)
+  real :: x
+end function
+
+program test_typeless
+  class(*), allocatable :: x
+  procedure (sub), pointer :: subp => sub
+  procedure (func), pointer :: funcp => func
+
+  ! OK
+  allocate(x, mold=func())
+  allocate(x, source=funcp())
+
+  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
+  allocate(x, mold=x'1')
+  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
+  allocate(x, mold=sub)
+  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
+  allocate(x, source=subp)
+  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
+  allocate(x, mold=func)
+  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
+  allocate(x, source=funcp)
+end program