PR fortran/35846
* trans.h (gfc_conv_string_length): New argument `expr'.
* trans-expr.c (flatten_array_ctors_without_strlen): New method.
(gfc_conv_string_length): New argument `expr' that is used in a new
special case handling if cl->length is NULL.
(gfc_conv_subref_array_arg): Pass expr to gfc_conv_string_length.
* trans-array.c (gfc_conv_expr_descriptor): Ditto.
(gfc_trans_auto_array_allocation): Pass NULL as new expr.
(gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto.
(gfc_trans_deferred_array): Ditto.
(gfc_trans_array_constructor): Save and restore old values of globals
used for bounds checking.
* trans-decl.c (gfc_trans_dummy_character): Ditto.
(gfc_trans_auto_character_variable): Ditto.
2008-09-21 Daniel Kraft <d@domob.eu>
PR fortran/35846
* gfortran.dg/nested_array_constructor_1.f90: New test.
* gfortran.dg/nested_array_constructor_2.f90: New test.
* gfortran.dg/nested_array_constructor_3.f90: New test.
* gfortran.dg/nested_array_constructor_4.f90: New test.
* gfortran.dg/nested_array_constructor_5.f90: New test.
* gfortran.dg/nested_array_constructor_6.f90: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@140529
138bc75d-0d04-0410-961f-
82ee72b054a4
2008-09-21 Daniel Kraft <d@domob.eu>
+ PR fortran/35846
+ * trans.h (gfc_conv_string_length): New argument `expr'.
+ * trans-expr.c (flatten_array_ctors_without_strlen): New method.
+ (gfc_conv_string_length): New argument `expr' that is used in a new
+ special case handling if cl->length is NULL.
+ (gfc_conv_subref_array_arg): Pass expr to gfc_conv_string_length.
+ * trans-array.c (gfc_conv_expr_descriptor): Ditto.
+ (gfc_trans_auto_array_allocation): Pass NULL as new expr.
+ (gfc_trans_g77_array), (gfc_trans_dummy_array_bias): Ditto.
+ (gfc_trans_deferred_array): Ditto.
+ (gfc_trans_array_constructor): Save and restore old values of globals
+ used for bounds checking.
+ * trans-decl.c (gfc_trans_dummy_character): Ditto.
+ (gfc_trans_auto_character_variable): Ditto.
+
+2008-09-21 Daniel Kraft <d@domob.eu>
+
* decl.c (match_procedure_in_type): Changed misleading error message
for not yet implemented PROCEDURE(interface) syntax.
tree type;
tree loopfrom;
bool dynamic;
+ bool old_first_len, old_typespec_chararray_ctor;
+ tree old_first_len_val;
+
+ /* Save the old values for nested checking. */
+ old_first_len = first_len;
+ old_first_len_val = first_len_val;
+ old_typespec_chararray_ctor = typespec_chararray_ctor;
/* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
typespec was given for the array constructor. */
if (size && compare_tree_int (size, nelem) == 0)
{
gfc_trans_constant_array_constructor (loop, ss, type);
- return;
+ goto finish;
}
}
}
gcc_unreachable ();
}
#endif
+
+finish:
+ /* Restore old values of globals. */
+ first_len = old_first_len;
+ first_len_val = old_first_len_val;
+ typespec_chararray_ctor = old_typespec_chararray_ctor;
}
if (sym->ts.type == BT_CHARACTER
&& onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
gfc_trans_vla_type_sizes (sym, &block);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
/* Evaluate the bounds of the array. */
gfc_trans_array_bounds (type, sym, &offset, &block);
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
break;
}
-
gfc_init_loopinfo (&loop);
/* Associate the SS with the loop. */
loop.temp_ss->next = gfc_ss_terminator;
if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, &se->pre);
+ gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, &fnblock);
+ gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
gfc_trans_vla_type_sizes (sym, &fnblock);
}
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_conv_string_length (cl, &body);
+ gfc_conv_string_length (cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_conv_string_length (sym->ts.cl, &body);
+ gfc_conv_string_length (sym->ts.cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
return length;
}
-
+
+/* For each character array constructor subexpression without a ts.cl->length,
+ replace it by its first element (if there aren't any elements, the length
+ should already be set to zero). */
+
+static void
+flatten_array_ctors_without_strlen (gfc_expr* e)
+{
+ gfc_actual_arglist* arg;
+ gfc_constructor* c;
+
+ if (!e)
+ return;
+
+ switch (e->expr_type)
+ {
+
+ case EXPR_OP:
+ flatten_array_ctors_without_strlen (e->value.op.op1);
+ flatten_array_ctors_without_strlen (e->value.op.op2);
+ break;
+
+ case EXPR_COMPCALL:
+ /* TODO: Implement as with EXPR_FUNCTION when needed. */
+ gcc_unreachable ();
+
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ flatten_array_ctors_without_strlen (arg->expr);
+ break;
+
+ case EXPR_ARRAY:
+
+ /* We've found what we're looking for. */
+ if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+ {
+ gfc_expr* new_expr;
+ gcc_assert (e->value.constructor);
+
+ new_expr = e->value.constructor->expr;
+ e->value.constructor->expr = NULL;
+
+ flatten_array_ctors_without_strlen (new_expr);
+ gfc_replace_expr (e, new_expr);
+ break;
+ }
+
+ /* Otherwise, fall through to handle constructor elements. */
+ case EXPR_STRUCTURE:
+ for (c = e->value.constructor; c; c = c->next)
+ flatten_array_ctors_without_strlen (c->expr);
+ break;
+
+ default:
+ break;
+
+ }
+}
+
/* Generate code to initialize a string length variable. Returns the
- value. */
+ value. For array constructors, cl->length might be NULL and in this case,
+ the first element of the constructor is needed. expr is the original
+ expression so we can access it but can be NULL if this is not needed. */
void
-gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
+gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
{
gfc_se se;
gfc_init_se (&se, NULL);
+
+ /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
+ "flatten" array constructors by taking their first element; all elements
+ should be the same length or a cl->length should be present. */
+ if (!cl->length)
+ {
+ gfc_expr* expr_flat;
+ gcc_assert (expr);
+
+ expr_flat = gfc_copy_expr (expr);
+ flatten_array_ctors_without_strlen (expr_flat);
+ gfc_resolve_expr (expr_flat);
+
+ gfc_conv_expr (&se, expr_flat);
+ gfc_add_block_to_block (pblock, &se.pre);
+ cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
+
+ gfc_free_expr (expr_flat);
+ return;
+ }
+
+ /* Convert cl->length. */
+
+ gcc_assert (cl->length);
+
gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
build_int_cst (gfc_charlen_type_node, 0));
/* Build an ss for the temporary. */
if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, &parmse->pre);
+ gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
base_type = gfc_typenode_for_spec (&expr->ts);
if (GFC_ARRAY_TYPE_P (base_type)
/* Get the string length variable belonging to an expression. */
tree gfc_get_expr_charlen (gfc_expr *);
/* Initialize a string length variable. */
-void gfc_conv_string_length (gfc_charlen *, stmtblock_t *);
+void gfc_conv_string_length (gfc_charlen *, gfc_expr *, stmtblock_t *);
/* Ensure type sizes can be gimplified. */
void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
2008-09-21 Daniel Kraft <d@domob.eu>
+ PR fortran/35846
+ * gfortran.dg/nested_array_constructor_1.f90: New test.
+ * gfortran.dg/nested_array_constructor_2.f90: New test.
+ * gfortran.dg/nested_array_constructor_3.f90: New test.
+ * gfortran.dg/nested_array_constructor_4.f90: New test.
+ * gfortran.dg/nested_array_constructor_5.f90: New test.
+ * gfortran.dg/nested_array_constructor_6.f90: New test.
+
+2008-09-21 Daniel Kraft <d@domob.eu>
+
* gfortran.dg/typebound_proc_4.f03: Changed expected error for not
yet implemented PROCEDURE(interface).
--- /dev/null
+! { dg-do compile }
+! This test is run with result-checking and -fbounds-check as
+! nested_array_constructor_2.f90
+
+! PR fortran/35846
+! This used to ICE because the charlength of the trim-expression was
+! NULL.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+character(len=2) :: c(3)
+
+c = 'a'
+c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /)
+
+print *, c
+
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+
+! PR fortran/35846
+! This used to ICE because the charlength of the trim-expression was
+! NULL.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+character(len=2) :: c(3)
+
+c = 'a'
+c = (/ (/ trim(c(1)), 'a' /)//'c', 'cd' /)
+
+print *, c
+
+if (c(1) /= 'ac' .or. c(2) /= 'ac' .or. c(3) /= 'cd') then
+ call abort ()
+end if
+
+end
--- /dev/null
+! { dg-do run }
+
+! PR fortran/35846
+! Alternate test that also produced an ICE because of a missing length.
+
+PROGRAM test
+ IMPLICIT NONE
+ CHARACTER(LEN=2) :: x
+
+ x = 'a'
+ CALL sub ( (/ TRIM(x), 'a' /) // 'c')
+END PROGRAM
+
+SUBROUTINE sub(str)
+ IMPLICIT NONE
+ CHARACTER(LEN=*) :: str(2)
+ WRITE (*,*) str
+
+ IF (str(1) /= 'ac' .OR. str(2) /= 'ac') THEN
+ CALL abort ()
+ END IF
+END SUBROUTINE sub
--- /dev/null
+! { dg-do run }
+
+! PR fortran/35846
+! Alternate test that also produced an ICE because of a missing length.
+
+PROGRAM test
+ IMPLICIT NONE
+ CHARACTER(LEN=2) :: x
+ INTEGER :: length
+
+ x = 'a'
+ length = LEN ( (/ TRIM(x), 'a' /) // 'c')
+
+ IF (length /= 2) THEN
+ CALL abort ()
+ END IF
+END PROGRAM
--- /dev/null
+! { dg-do compile }
+
+! PR fortran/35846
+! This used to ICE because the charlength of the trim-expression was
+! NULL, but it is switched around to test for the right operand of // being
+! not a constant, too.
+
+implicit none
+character(len=2) :: c(2)
+
+c = 'a'
+c = (/ (/ trim(c(1)), 'a' /) // (/ trim(c(1)), 'a' /) /)
+
+print *, c
+
+end
--- /dev/null
+! { dg-do compile }
+
+! PR fortran/35846
+! Nested three levels deep.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+character(len=3) :: c(3)
+c = 'a'
+c = (/ (/ 'A'//(/ trim(c(1)), 'a' /)/)//'c', 'dcd' /)
+print *, c(1)
+print *, c(2)
+print *, c(3)
+end
OSDN Git Service
