[gcc r9-9196] Fortran: Enable inquiry references in data statements [PR98022].
Paul Thomas
pault@gcc.gnu.org
Sat Jan 23 10:44:38 GMT 2021
https://gcc.gnu.org/g:87472f174299fba9b17fdbcc016818587919bd12
commit r9-9196-g87472f174299fba9b17fdbcc016818587919bd12
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Sat Dec 12 14:01:08 2020 +0000
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.
(cherry picked from commit ff2dfdef2f2e01c579dd280daa1d81fbeb4d7ac5)
Diff:
---
gcc/fortran/data.c | 74 +++++++++++++++++++++-----
gcc/testsuite/gfortran.dg/data_inquiry_ref.f90 | 33 ++++++++++++
2 files changed, 94 insertions(+), 13 deletions(-)
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index baafbbb94e2..b5dd9beed6a 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 ();
}
@@ -512,7 +560,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;
}
@@ -539,13 +587,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;
@@ -566,21 +614,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);
@@ -594,7 +642,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);
@@ -612,7 +660,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);
@@ -698,7 +746,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)
{
@@ -740,7 +788,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 00000000000..38c76abf590
--- /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
More information about the Gcc-cvs
mailing list