From 65167982efa4dbb96698d026e6d7e17acb513f0a Mon Sep 17 00:00:00 2001
From: Tobias Burnus <tobias@codesourcery.com>
Date: Wed, 30 Sep 2020 15:01:13 +0200
Subject: Fortran: add contiguous check for ptr assignment, fix non-contig
 check (PR97242)

gcc/fortran/ChangeLog:

	PR fortran/97242
	* expr.c (gfc_is_not_contiguous): Fix check.
	(gfc_check_pointer_assign): Use it.

gcc/testsuite/ChangeLog:

	PR fortran/97242
	* gfortran.dg/contiguous_11.f90: New test.
	* gfortran.dg/contiguous_4.f90: Update.
	* gfortran.dg/contiguous_7.f90: Update.
---
 gcc/fortran/expr.c | 26 +++++++++++++++++++-------
 1 file changed, 19 insertions(+), 7 deletions(-)

(limited to 'gcc/fortran')

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 68784a2..b87ae3d 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4366,10 +4366,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
      contiguous.  */
 
   if (lhs_attr.contiguous
-      && lhs_attr.dimension > 0
-      && !gfc_is_simply_contiguous (rvalue, false, true))
-    gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
-		 "non-contiguous target at %L", &rvalue->where);
+      && lhs_attr.dimension > 0)
+    {
+      if (gfc_is_not_contiguous (rvalue))
+	{
+	  gfc_error ("Assignment to contiguous pointer from "
+		     "non-contiguous target at %L", &rvalue->where);
+	  return false;
+	}
+      if (!gfc_is_simply_contiguous (rvalue, false, true))
+	gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
+				 "non-contiguous target at %L", &rvalue->where);
+    }
 
   /* Warn if it is the LHS pointer may lives longer than the RHS target.  */
   if (warn_target_lifetime
@@ -5935,7 +5943,7 @@ gfc_is_not_contiguous (gfc_expr *array)
     {
       /* Array-ref shall be last ref.  */
 
-      if (ar)
+      if (ar && ar->type != AR_ELEMENT)
 	return true;
 
       if (ref->type == REF_ARRAY)
@@ -5955,10 +5963,11 @@ gfc_is_not_contiguous (gfc_expr *array)
 
       if (gfc_ref_dimen_size (ar, i, &ref_size, NULL))
 	{
-	  if (gfc_dep_difference (ar->as->lower[i], ar->as->upper[i], &arr_size))
+	  if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size))
 	    {
 	      /* a(2:4,2:) is known to be non-contiguous, but
 		 a(2:4,i:i) can be contiguous.  */
+	      mpz_add_ui (arr_size, arr_size, 1L);
 	      if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0)
 		{
 		  mpz_clear (arr_size);
@@ -5979,7 +5988,10 @@ gfc_is_not_contiguous (gfc_expr *array)
 	      && ar->dimen_type[i] == DIMEN_RANGE
 	      && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT
 	      && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)
-	    return true;
+	    {
+	      mpz_clear (ref_size);
+	      return true;
+	    }
 
 	  mpz_clear (ref_size);
 	}
-- 
cgit v1.1