Fortran: Enable inquiry references in data statements [PR98022].
This patch speaks for itself.
Regtests on FC31/x86_64 - OK for master?
Paul
2020-12-12 Paul Thomas <pa...@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.
! { dg-do run }
!
! Test the fix for PR98022.
!
! Contributed by Arseny Solokha <asolo...@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
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 5147515659b..3e52a5717b5 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);
