From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 27 May 2021 11:58:26 +0000 (+0200)
Subject: Fortran: Fix erroneous "pointer argument is not associated" runtime error
X-Git-Tag: releases/gcc-11.2.0~324
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=cb5c89afbe0ef59fa315cbfda31a55ea5d8ca297;p=thirdparty%2Fgcc.git

Fortran: Fix erroneous "pointer argument is not associated" runtime error

For CLASS arrays we need to use the CLASS data attributes to determine
which runtime check to generate.

gcc/fortran/ChangeLog:

	PR fortran/100602
	* trans-intrinsic.c (gfc_conv_intrinsic_size): Use CLASS data
	attributes for CLASS arrays for generation of runtime error.

gcc/testsuite/ChangeLog:

	PR fortran/100602
	* gfortran.dg/pointer_check_14.f90: New test.

(cherry picked from commit 71d7dc6cd09b603bcc58d5d1747a86eb498bb147)
---

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 5e53d1162fad..68090d4defcd 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8009,7 +8009,14 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
       tree temp;
       tree cond;
 
-      attr = sym ? sym->attr : gfc_expr_attr (e);
+      if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
+	{
+	  attr = CLASS_DATA (e->symtree->n.sym)->attr;
+	  attr.pointer = attr.class_pointer;
+	}
+      else
+	attr = gfc_expr_attr (e);
+
       if (attr.allocatable)
 	msg = xasprintf ("Allocatable argument '%s' is not allocated",
 			 e->symtree->n.sym->name);
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_14.f90 b/gcc/testsuite/gfortran.dg/pointer_check_14.f90
new file mode 100644
index 000000000000..8ef6b3611fa6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_14.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-options "-fcheck=pointer -fdump-tree-original" }
+! PR100602 - Erroneous "pointer argument is not associated" runtime error
+
+module m
+  type :: T
+  end type
+contains
+  subroutine f(this)
+    class(T), intent(in)  :: this(:)
+    class(T), allocatable :: ca(:)
+    class(T), pointer     :: cp(:)
+    if (size (this) == 0) return
+    write(*,*) size (this)
+    stop 1
+    write(*,*) size (ca) ! Check #1
+    write(*,*) size (cp) ! Check #2
+  end subroutine f
+end module
+
+program main
+  use m
+  call f([T::])
+end program
+
+! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 2 "original" } }
+! { dg-final { scan-tree-dump-times "Allocatable argument .*ca" 1 "original" } }
+! { dg-final { scan-tree-dump-times "Pointer argument .*cp" 1 "original" } }