From ff2dfdef2f2e01c579dd280daa1d81fbeb4d7ac5 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 12 Dec 2020 14:01:08 +0000 Subject: [PATCH] Fortran: Enable inquiry references in data statements [PR98022]. 2020-12-12 Paul Thomas 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. --- gcc/fortran/data.c | 74 +++++++++++++++---- .../gfortran.dg/data_inquiry_ref.f90 | 33 +++++++++ 2 files changed, 94 insertions(+), 13 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/data_inquiry_ref.f90 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); 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 +! +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 -- 2.30.2