Fortran: Enable inquiry references in data statements [PR98022].

2020-12-12  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/98022
	* data.c (gfc_assign_data_value): Handle inquiry references in
	the data statement object list.

gcc/testsuite/
	PR fortran/98022
	* gfortran.dg/data_inquiry_ref.f90: New test.

2 files changed, 94 insertions, 13 deletions

diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 5147515..3e52a57 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -20,14 +20,14 @@ along with GCC; see the file COPYING3.  If not see
 
 
 /* Notes for DATA statement implementation:
-									       
+
    We first assign initial value to each symbol by gfc_assign_data_value
    during resolving DATA statement. Refer to check_data_variable and
    traverse_data_list in resolve.c.
-									       
+
    The complexity exists in the handling of array section, implied do
    and array of struct appeared in DATA statement.
-									       
+
    We call gfc_conv_structure, gfc_con_array_array_initializer,
    etc., to convert the initial value. Refer to trans-expr.c and
    trans-array.c.  */
@@ -464,6 +464,54 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
 	    }
 	  break;
 
+	case REF_INQUIRY:
+
+	  /* 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.  */
+	  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);
+
+	  /* Rejection of LEN and KIND inquiry references is handled
+	     elsewhere. The error here is added as backup. The assertion
+	     of F2008 for RE and IM is also done elsewhere.  */
+	  switch (ref->u.i)
+	    {
+	    case INQUIRY_LEN:
+	    case INQUIRY_KIND:
+	      gfc_error ("LEN or KIND inquiry ref in DATA statement at %L",
+			 &lvalue->where);
+	      goto abort;
+	    case INQUIRY_RE:
+	      mpfr_set (mpc_realref (last_con->expr->value.complex),
+			expr->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,
+			GFC_RND_MODE);
+	      mpfr_set_ui (mpc_realref (last_con->expr->value.complex),
+			   0.0, GFC_RND_MODE);
+	      break;
+	    }
+
+	  gfc_free_expr (expr);
+	  mpz_clear (offset);
+	  return true;
+
 	default:
 	  gcc_unreachable ();
 	}
@@ -513,7 +561,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
 	  && gfc_has_default_initializer (lvalue->ts.u.derived))
 	{
 	  gfc_error ("Nonpointer object %qs with default initialization "
-		     "shall not appear in a DATA statement at %L", 
+		     "shall not appear in a DATA statement at %L",
 		     symbol->name, &lvalue->where);
 	  return false;
 	}
@@ -540,13 +588,13 @@ abort:
 
 /* Modify the index of array section and re-calculate the array offset.  */
 
-void 
+void
 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 		     mpz_t *offset_ret)
 {
   int i;
   mpz_t delta;
-  mpz_t tmp; 
+  mpz_t tmp;
   bool forwards;
   int cmp;
   gfc_expr *start, *end, *stride;
@@ -567,21 +615,21 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 	    forwards = true;
 	  else
 	    forwards = false;
-	  gfc_free_expr(stride);	
+	  gfc_free_expr(stride);
 	}
       else
 	{
 	  mpz_add_ui (section_index[i], section_index[i], 1);
 	  forwards = true;
 	}
-      
+
       if (ar->end[i])
         {
 	  end = gfc_copy_expr(ar->end[i]);
 	  if(!gfc_simplify_expr(end, 1))
 	    gfc_internal_error("Simplification error");
 	  cmp = mpz_cmp (section_index[i], end->value.integer);
-	  gfc_free_expr(end);	
+	  gfc_free_expr(end);
 	}
       else
 	cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
@@ -595,7 +643,7 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
 	      if(!gfc_simplify_expr(start, 1))
 	        gfc_internal_error("Simplification error");
 	      mpz_set (section_index[i], start->value.integer);
-	      gfc_free_expr(start); 
+	      gfc_free_expr(start);
 	    }
 	  else
 	    mpz_set (section_index[i], ar->as->lower[i]->value.integer);
@@ -613,7 +661,7 @@ gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
       mpz_mul (tmp, tmp, delta);
       mpz_add (*offset_ret, tmp, *offset_ret);
 
-      mpz_sub (tmp, ar->as->upper[i]->value.integer, 
+      mpz_sub (tmp, ar->as->upper[i]->value.integer,
 	       ar->as->lower[i]->value.integer);
       mpz_add_ui (tmp, tmp, 1);
       mpz_mul (delta, tmp, delta);
@@ -699,7 +747,7 @@ gfc_formalize_init_value (gfc_symbol *sym)
 
 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
    offset.  */
- 
+
 void
 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 {
@@ -741,7 +789,7 @@ gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
 	  gcc_unreachable ();
 	}
 
-      mpz_sub (tmp, ar->as->upper[i]->value.integer, 
+      mpz_sub (tmp, ar->as->upper[i]->value.integer,
 	       ar->as->lower[i]->value.integer);
       mpz_add_ui (tmp, tmp, 1);
       mpz_mul (delta, tmp, delta);
diff --git a/gcc/testsuite/gfortran.dg/data_inquiry_ref.f90 b/gcc/testsuite/gfortran.dg/data_inquiry_ref.f90
new file mode 100644
index 0000000..38c76ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_inquiry_ref.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! Test the fix for PR98022.
+!
+! Contributed by Arseny Solokha  <asolokha@gmx.com>
+!
+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
+  end function kn1
+
+! Check for derived types with complex components.
+  function kn2() result(hm2)
+    type t
+      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/
+    data (hm(md)%i, md=1,2)/1, 2/
+    hm2 = hm%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
+end