[gcc r9-9197] Fortran: Correction to recent patch in light of comments [PR98022].

[gcc r9-9197] Fortran: Correction to recent patch in light of comments [PR98022].

[Paul Thomas]

https://gcc.gnu.org/g:5c84d9e37d6a647bc2bbc83ac28250a4902a86ea

commit r9-9197-g5c84d9e37d6a647bc2bbc83ac28250a4902a86ea
Author: Paul Thomas <pault@gcc.gnu.org>
Date:   Sat Dec 26 16:44:24 2020 +0000

    Fortran: Correction to recent patch in light of comments [PR98022].
    
    2020-12-26  Paul Thomas  <pault@gcc.gnu.org>
    
    gcc/fortran
            PR fortran/98022
            * data.c (gfc_assign_data_value): Throw an error for inquiry
            references. Follow with corrected code that would provide the
            expected result and provides clean error recovery.
    
    gcc/testsuite/
            PR fortran/98022
            * gfortran.dg/data_inquiry_ref.f90: Change to dg-compile and
            add errors for inquiry references.
    
    (cherry picked from commit c7256c8260afa313e019fd531574ad33ec49b9f6)

Diff:
---
 gcc/fortran/data.c                             | 63 ++++++++++++++++++--------
 gcc/testsuite/gfortran.dg/data_inquiry_ref.f90 | 30 +++++++-----
 2 files changed, 61 insertions(+), 32 deletions(-)

diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index b5dd9beed6a..0ca41c3dad8 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -221,11 +221,14 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
   gfc_ref *ref;
   gfc_expr *init;
   gfc_expr *expr = NULL;
+  gfc_expr *rexpr;
   gfc_constructor *con;
   gfc_constructor *last_con;
   gfc_symbol *symbol;
   gfc_typespec *last_ts;
   mpz_t offset;
+  const char *msg = "F18(R841): data-implied-do object at %L is neither an "
+		    "array-element nor a scalar-structure-component";
 
   symbol = lvalue->symtree->n.sym;
   init = symbol->value;
@@ -466,21 +469,38 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
 
 	case REF_INQUIRY:
 
+	  /* After some discussion on clf it was determined that the following
+	     violates F18(R841). If the error is removed, the expected result
+	     is obtained. Leaving the code in place ensures a clean error
+	     recovery.  */
+	  gfc_error (msg, &lvalue->where);
+
 	  /* This breaks with the other reference types in that the output
 	     constructor has to be of type COMPLEX, whereas the lvalue is
 	     of type REAL.  The rvalue is copied to the real or imaginary
-	     part as appropriate.  */
+	     part as appropriate.  In addition, for all except scalar
+	     complex variables, a complex expression has to provided, where
+	     the constructor does not have it, and the expression modified
+	     with a new value for the real or imaginary part.  */
 	  gcc_assert (ref->next == NULL && last_ts->type == BT_COMPLEX);
-	  expr = gfc_copy_expr (rvalue);
-	  if (!gfc_compare_types (&lvalue->ts, &expr->ts))
-	    gfc_convert_type (expr, &lvalue->ts, 0);
-
-	  if (last_con->expr)
-	    gfc_free_expr (last_con->expr);
-
-	  last_con->expr = gfc_get_constant_expr (BT_COMPLEX,
-						  last_ts->kind,
-						  &lvalue->where);
+	  rexpr = gfc_copy_expr (rvalue);
+	  if (!gfc_compare_types (&lvalue->ts, &rexpr->ts))
+	    gfc_convert_type (rexpr, &lvalue->ts, 0);
+
+	  /* This is the scalar, complex case, where an initializer exists.  */
+	  if (init && ref == lvalue->ref)
+	    expr = symbol->value;
+	  /* Then all cases, where a complex expression does not exist.  */
+	  else if (!last_con || !last_con->expr)
+	    {
+	      expr = gfc_get_constant_expr (BT_COMPLEX, lvalue->ts.kind,
+					    &lvalue->where);
+	      if (last_con)
+		last_con->expr = expr;
+	    }
+	  else
+	    /* Finally, and existing constructor expression to be modified.  */
+	    expr = last_con->expr;
 
 	  /* Rejection of LEN and KIND inquiry references is handled
 	     elsewhere. The error here is added as backup. The assertion
@@ -493,22 +513,25 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
 			 &lvalue->where);
 	      goto abort;
 	    case INQUIRY_RE:
-	      mpfr_set (mpc_realref (last_con->expr->value.complex),
-			expr->value.real,
+	      mpfr_set (mpc_realref (expr->value.complex),
+			rexpr->value.real,
 			GFC_RND_MODE);
-	      mpfr_set_ui (mpc_imagref (last_con->expr->value.complex),
-			   0.0, GFC_RND_MODE);
 	      break;
 	    case INQUIRY_IM:
-	      mpfr_set (mpc_imagref (last_con->expr->value.complex),
-			expr->value.real,
+	      mpfr_set (mpc_imagref (expr->value.complex),
+			rexpr->value.real,
 			GFC_RND_MODE);
-	      mpfr_set_ui (mpc_realref (last_con->expr->value.complex),
-			   0.0, GFC_RND_MODE);
 	      break;
 	    }
 
-	  gfc_free_expr (expr);
+	  /* Only the scalar, complex expression needs to be saved as the
+	     symbol value since the last constructor expression is already
+	     provided as the initializer in the code after the reference
+	     cases.  */
+	  if (ref == lvalue->ref)
+	    symbol->value = expr;
+
+	  gfc_free_expr (rexpr);
 	  mpz_clear (offset);
 	  return true;
 
diff --git a/gcc/testsuite/gfortran.dg/data_inquiry_ref.f90 b/gcc/testsuite/gfortran.dg/data_inquiry_ref.f90
index 38c76abf590..de320f178ed 100644
--- a/gcc/testsuite/gfortran.dg/data_inquiry_ref.f90
+++ b/gcc/testsuite/gfortran.dg/data_inquiry_ref.f90
@@ -1,6 +1,8 @@
-! { dg-do run }
+! { dg-do compile }
 !
-! Test the fix for PR98022.
+! Test the fix for PR98022. Code is in place to deliver the expected result.
+! However, it was determined that the data statements below violate F18(R841)
+! and so an error results.
 !
 ! Contributed by Arseny Solokha  <asolokha@gmx.com>
 !
@@ -8,9 +10,11 @@ module ur
 contains
 ! The reporter's test.
   function kn1() result(hm2)
-    complex :: hm(1:2), hm2(1:2)
-    data (hm(md)%re, md=1,2)/1.0, 2.0/
-    hm2 = hm
+    complex :: hm(1:2), hm2(1:3), scalar
+    data (hm(md)%re, md=1,2)/1.0, 2.0/, scalar%re/42.0/     ! { dg-error "neither an array-element" }
+    data (hm(md)%im, md=1,2)/0.0, 0.0/, scalar%im/-42.0/    ! { dg-error "neither an array-element" }
+    hm2(1:2) = hm
+    hm2(3) = scalar
   end function kn1
 
 ! Check for derived types with complex components.
@@ -19,15 +23,17 @@ contains
       complex :: c
       integer :: i
     end type
-    type (t) :: hm(1:2)
-    complex :: hm2(1:2)
-    data (hm(md)%c%im, md=1,2)/1.0, 2.0/
+    type (t) :: hm(1:2), scalar
+    complex :: hm2(1:3)
+    data (hm(md)%c%re, md=1,2)/0.0, 0.0/, scalar%c%re/42.0/  ! { dg-error "neither an array-element" }
+    data (hm(md)%c%im, md=1,2)/1.0, 2.0/, scalar%c%im/-42.0/ ! { dg-error "neither an array-element" }
     data (hm(md)%i, md=1,2)/1, 2/
-    hm2 = hm%c
+    hm2(1:2) = hm%c
+    hm2(3) = scalar%c
   end function kn2
 end module ur
 
-  use ur
-  if (any (kn1() .ne. [(1.0,0.0),(2.0,0.0)])) stop 1
-  if (any (kn2() .ne. [(0.0,1.0),(0.0,2.0)])) stop 2
+!  use ur
+!  if (any (kn1() .ne. [(1.0,0.0),(2.0,0.0),(42.0,-42.0)])) stop 1
+!  if (any (kn2() .ne. [(0.0,1.0),(0.0,2.0),(42.0,-42.0)])) stop 2
 end