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.

diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 5147515659bb11552cb4db0267d85fe26d22be1d..3e52a5717b5017c45f5cec239630fdb14cdf43e0 100644 (file)
--- 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 (file)
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