This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patc, fortran] PR85603 - ICE with character array substring assignment
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Cc: Walter Spector <w6ws at earthlink dot net>
- Date: Thu, 18 Oct 2018 17:25:17 +0100
- Subject: Re: [Patc, fortran] PR85603 - ICE with character array substring assignment
- References: <CAGkQGi+iPx9zqfrv8_2kt7UEj7yeb8bAH7wePKFa6qT8XO0J8Q@mail.gmail.com>
It turned out that this patch did not quite complete the job (Thanks
Walt): The ICE has gone but reallocation on assignment is not
occurring because the correct string length for the rhs expression was
not being picked up. The fix for this took rather more detective work
than I anticipated but here it is.
Bootstraps and regtests on FC28/x86_64 - OK for trunk?
Cheers
Paul
2018-10-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/85603
* frontend-passes.c (get_len_call): New function to generate a
call to intrinsic LEN.
(create_var): Use this to make length expressions for variable
rhs string lengths.
Clean up some white space issues.
2018-10-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/85603
* gfortran.dg/deferred_character_23.f90 : Check reallocation is
occurring as it should..
On Sat, 22 Sep 2018 at 11:23, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
>
> Yet another 'obvious' deferred character fix. Committed to trunk as
> r264502. Will backport in about ten days time.
>
> Paul
>
> 2018-09-22 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/85603
> * trans-array.c (gfc_alloc_allocatable_for_assignment): Test
> the charlen backend_decl before using the VAR_P macro.
>
> 2018-09-22 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/85603
> * gfortran.dg/deferred_character_23.f90 : New test.
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
Index: gcc/fortran/frontend-passes.c
===================================================================
*** gcc/fortran/frontend-passes.c (revision 265262)
--- gcc/fortran/frontend-passes.c (working copy)
*************** realloc_string_callback (gfc_code **c, i
*** 280,286 ****
&& (expr2->expr_type != EXPR_OP
|| expr2->value.op.op != INTRINSIC_CONCAT))
return 0;
!
if (!gfc_check_dependency (expr1, expr2, true))
return 0;
--- 280,286 ----
&& (expr2->expr_type != EXPR_OP
|| expr2->value.op.op != INTRINSIC_CONCAT))
return 0;
!
if (!gfc_check_dependency (expr1, expr2, true))
return 0;
*************** insert_block ()
*** 704,709 ****
--- 704,744 ----
return ns;
}
+
+ /* Insert a call to the intrinsic len. Use a different name for
+ the symbol tree so we don't run into trouble when the user has
+ renamed len for some reason. */
+
+ static gfc_expr*
+ get_len_call (gfc_expr *str)
+ {
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist;
+
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = str;
+
+ fcn->value.function.actual = actual_arglist;
+ fcn->where = str->where;
+ fcn->ts.type = BT_INTEGER;
+ fcn->ts.kind = gfc_charlen_int_kind;
+
+ gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
+ fcn->symtree->n.sym->ts = fcn->ts;
+ fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ fcn->symtree->n.sym->attr.function = 1;
+ fcn->symtree->n.sym->attr.elemental = 1;
+ fcn->symtree->n.sym->attr.referenced = 1;
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ gfc_commit_symbol (fcn->symtree->n.sym);
+
+ return fcn;
+ }
+
+
/* Returns a new expression (a variable) to be used in place of the old one,
with an optional assignment statement before the current statement to set
the value of the variable. Creates a new BLOCK for the statement if that
*************** create_var (gfc_expr * e, const char *vn
*** 786,791 ****
--- 821,828 ----
length = constant_string_length (e);
if (length)
symbol->ts.u.cl->length = length;
+ else if (e->expr_type == EXPR_VARIABLE && e->ts.u.cl->length)
+ symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
else
{
symbol->attr.allocatable = 1;
*************** traverse_io_block (gfc_code *code, bool
*** 1226,1232 ****
{
/* Check for (a(i,i), i=1,3). */
int j;
!
for (j=0; j<i; j++)
if (iters[j] && iters[j]->var->symtree == start->symtree)
return false;
--- 1263,1269 ----
{
/* Check for (a(i,i), i=1,3). */
int j;
!
for (j=0; j<i; j++)
if (iters[j] && iters[j]->var->symtree == start->symtree)
return false;
*************** traverse_io_block (gfc_code *code, bool
*** 1286,1292 ****
|| var_in_expr (var, iters[j]->end)
|| var_in_expr (var, iters[j]->step)))
return false;
! }
}
}
--- 1323,1329 ----
|| var_in_expr (var, iters[j]->end)
|| var_in_expr (var, iters[j]->step)))
return false;
! }
}
}
*************** get_len_trim_call (gfc_expr *str, int ki
*** 2019,2024 ****
--- 2056,2062 ----
return fcn;
}
+
/* Optimize expressions for equality. */
static bool
*************** do_subscript (gfc_expr **e)
*** 2626,2632 ****
/* If we do not know about the stepsize, the loop may be zero trip.
Do not warn in this case. */
!
if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
else
--- 2664,2670 ----
/* If we do not know about the stepsize, the loop may be zero trip.
Do not warn in this case. */
!
if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
else
*************** do_subscript (gfc_expr **e)
*** 2640,2646 ****
else
have_do_start = false;
!
if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
{
have_do_end = true;
--- 2678,2684 ----
else
have_do_start = false;
!
if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
{
have_do_end = true;
*************** matmul_to_var_expr (gfc_expr **ep, int *
*** 2806,2812 ****
{
gfc_expr *e, *n;
bool *found = (bool *) data;
!
e = *ep;
if (e->expr_type != EXPR_FUNCTION
--- 2844,2850 ----
{
gfc_expr *e, *n;
bool *found = (bool *) data;
!
e = *ep;
if (e->expr_type != EXPR_FUNCTION
*************** matmul_to_var_expr (gfc_expr **ep, int *
*** 2819,2837 ****
return 0;
/* Check if this is already in the form c = matmul(a,b). */
!
if ((*current_code)->expr2 == e)
return 0;
n = create_var (e, "matmul");
!
/* If create_var is unable to create a variable (for example if
-fno-realloc-lhs is in force with a variable that does not have bounds
known at compile-time), just return. */
if (n == NULL)
return 0;
!
*ep = n;
*found = true;
return 0;
--- 2857,2875 ----
return 0;
/* Check if this is already in the form c = matmul(a,b). */
!
if ((*current_code)->expr2 == e)
return 0;
n = create_var (e, "matmul");
!
/* If create_var is unable to create a variable (for example if
-fno-realloc-lhs is in force with a variable that does not have bounds
known at compile-time), just return. */
if (n == NULL)
return 0;
!
*ep = n;
*found = true;
return 0;
*************** matmul_to_var_code (gfc_code **c, int *w
*** 2850,2856 ****
inserted_block = NULL;
changed_statement = NULL;
}
!
return 0;
}
--- 2888,2894 ----
inserted_block = NULL;
changed_statement = NULL;
}
!
return 0;
}
*************** matmul_temp_args (gfc_code **c, int *wal
*** 2870,2876 ****
bool a_tmp, b_tmp;
gfc_expr *matrix_a, *matrix_b;
bool conjg_a, conjg_b, transpose_a, transpose_b;
!
co = *c;
if (co->op != EXEC_ASSIGN)
--- 2908,2914 ----
bool a_tmp, b_tmp;
gfc_expr *matrix_a, *matrix_b;
bool conjg_a, conjg_b, transpose_a, transpose_b;
!
co = *c;
if (co->op != EXEC_ASSIGN)
*************** matmul_temp_args (gfc_code **c, int *wal
*** 2920,2926 ****
if (!a_tmp && !b_tmp)
return 0;
!
current_code = c;
inserted_block = NULL;
changed_statement = NULL;
--- 2958,2964 ----
if (!a_tmp && !b_tmp)
return 0;
!
current_code = c;
inserted_block = NULL;
changed_statement = NULL;
*************** scalarized_expr (gfc_expr *e_in, gfc_exp
*** 3648,3654 ****
/* For assumed size, we need to keep around the final
reference in order not to get an error on resolution
below, and we cannot use AR_FULL. */
!
if (ar->as->type == AS_ASSUMED_SIZE)
{
ar->type = AR_SECTION;
--- 3686,3692 ----
/* For assumed size, we need to keep around the final
reference in order not to get an error on resolution
below, and we cannot use AR_FULL. */
!
if (ar->as->type == AS_ASSUMED_SIZE)
{
ar->type = AR_SECTION;
*************** call_external_blas (gfc_code **c, int *w
*** 4604,4610 ****
default:
gcc_unreachable ();
}
! }
/* Handle the reallocation, if needed. */
--- 4642,4648 ----
default:
gcc_unreachable ();
}
! }
/* Handle the reallocation, if needed. */
*************** typedef struct {
*** 4756,4762 ****
int n[GFC_MAX_DIMENSIONS];
} ind_type;
! /* Callback function to determine if an expression is the
corresponding variable. */
static int
--- 4794,4800 ----
int n[GFC_MAX_DIMENSIONS];
} ind_type;
! /* Callback function to determine if an expression is the
corresponding variable. */
static int
*************** index_interchange (gfc_code **c, int *wa
*** 4842,4848 ****
gfc_forall_iterator *fa;
ind_type *ind;
int i, j;
!
if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
return 0;
--- 4880,4886 ----
gfc_forall_iterator *fa;
ind_type *ind;
int i, j;
!
if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
return 0;
*************** gfc_code_walker (gfc_code **c, walk_code
*** 5358,5364 ****
if (co->op == EXEC_SELECT)
select_level --;
!
in_omp_workshare = saved_in_omp_workshare;
in_where = saved_in_where;
}
--- 5396,5402 ----
if (co->op == EXEC_SELECT)
select_level --;
!
in_omp_workshare = saved_in_omp_workshare;
in_where = saved_in_where;
}
Index: gcc/testsuite/gfortran.dg/deferred_character_23.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_23.f90 (revision 265262)
--- gcc/testsuite/gfortran.dg/deferred_character_23.f90 (working copy)
*************** program strlen_bug
*** 15,22 ****
'somewhat longer' ]
maxlen = maxval (len_trim (strings))
if (maxlen .ne. 15) stop 1
! strings = strings(:)(:maxlen) ! Used to ICE
! if (any (strings .ne. ['short ','somewhat longer'])) stop 2
deallocate (strings) ! To check for memory leaks
end program
--- 15,30 ----
'somewhat longer' ]
maxlen = maxval (len_trim (strings))
if (maxlen .ne. 15) stop 1
!
! ! Used to cause an ICE and in the later version of the problem did not reallocate.
! strings = strings(:)(:maxlen)
! if (any (strings .ne. ['short ','somewhat longer' ])) stop 2
! if (len (strings) .ne. maxlen) stop 3
!
! ! Try something a bit more complicated.
! strings = strings(:)(2:maxlen - 5)
! if (any (strings .ne. ['hort ','omewhat l' ])) stop 4
! if (len (strings) .ne. maxlen - 6) stop 5
deallocate (strings) ! To check for memory leaks
end program