+2008-06-17 Daniel Kraft <d@domob.eu>
+
+ PR fortran/36112
+ * array.c (gfc_resolve_character_array_constructor): Check that all
+ elements with constant character length have the same one rather than
+ fixing it if no typespec is given, emit an error if they don't. Changed
+ return type to "try" and return FAILURE for the case above.
+ (gfc_resolve_array_constructor): Removed unneeded call to
+ gfc_resolve_character_array_constructor in this function.
+ * gfortran.h (gfc_resolve_character_array_constructor): Returns try.
+ * trans-array.c (get_array_ctor_strlen): Return length of first element
+ rather than last element.
+ * resolve.c (gfc_resolve_expr): Handle FAILURE return from
+ gfc_resolve_character_array_constructor.
+
2008-06-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34396
return t;
}
-/* Resolve character array constructor. If it is a constant character array and
- not specified character length, update character length to the maximum of
- its element constructors' length. For arrays with fixed length, pad the
- elements as necessary with needed_length. */
+/* Resolve character array constructor. If it has a specified constant character
+ length, pad/trunkate the elements here; if the length is not specified and
+ all elements are of compile-time known length, emit an error as this is
+ invalid. */
-void
+try
gfc_resolve_character_array_constructor (gfc_expr *expr)
{
gfc_constructor *p;
- int max_length;
- bool generated_length;
+ int found_length;
gcc_assert (expr->expr_type == EXPR_ARRAY);
gcc_assert (expr->ts.type == BT_CHARACTER);
- max_length = -1;
-
if (expr->ts.cl == NULL)
{
for (p = expr->value.constructor; p; p = p->next)
got_charlen:
- generated_length = false;
+ found_length = -1;
+
if (expr->ts.cl->length == NULL)
{
- /* Find the maximum length of the elements. Do nothing for variable
- array constructor, unless the character length is constant or
- there is a constant substring reference. */
+ /* Check that all constant string elements have the same length until
+ we reach the end or find a variable-length one. */
for (p = expr->value.constructor; p; p = p->next)
{
+ int current_length = -1;
gfc_ref *ref;
for (ref = p->expr->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING
break;
if (p->expr->expr_type == EXPR_CONSTANT)
- max_length = MAX (p->expr->value.character.length, max_length);
+ current_length = p->expr->value.character.length;
else if (ref)
{
long j;
j = mpz_get_ui (ref->u.ss.end->value.integer)
- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
- max_length = MAX ((int) j, max_length);
+ current_length = (int) j;
}
else if (p->expr->ts.cl && p->expr->ts.cl->length
&& p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
{
long j;
j = mpz_get_si (p->expr->ts.cl->length->value.integer);
- max_length = MAX ((int) j, max_length);
+ current_length = (int) j;
}
else
- return;
- }
+ return SUCCESS;
- if (max_length != -1)
- {
- /* Update the character length of the array constructor. */
- expr->ts.cl->length = gfc_int_expr (max_length);
- generated_length = true;
- /* Real update follows below. */
+ gcc_assert (current_length != -1);
+
+ if (found_length == -1)
+ found_length = current_length;
+ else if (found_length != current_length)
+ {
+ gfc_error ("Different CHARACTER lengths (%d/%d) in array"
+ " constructor at %L", found_length, current_length,
+ &p->expr->where);
+ return FAILURE;
+ }
+
+ gcc_assert (found_length == current_length);
}
+
+ gcc_assert (found_length != -1);
+
+ /* Update the character length of the array constructor. */
+ expr->ts.cl->length = gfc_int_expr (found_length);
}
else
{
/* If we've got a constant character length, pad according to this.
gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
max_length only if they pass. */
- gfc_extract_int (expr->ts.cl->length, &max_length);
+ gfc_extract_int (expr->ts.cl->length, &found_length);
+
+ /* Now pad/trunkate the elements accordingly to the specified character
+ length. This is ok inside this conditional, as in the case above
+ (without typespec) all elements are verified to have the same length
+ anyway. */
+ if (found_length != -1)
+ for (p = expr->value.constructor; p; p = p->next)
+ if (p->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_expr *cl = NULL;
+ int current_length = -1;
+
+ if (p->expr->ts.cl && p->expr->ts.cl->length)
+ {
+ cl = p->expr->ts.cl->length;
+ gfc_extract_int (cl, ¤t_length);
+ }
+
+ /* If gfc_extract_int above set current_length, we implicitly
+ know the type is BT_INTEGER and it's EXPR_CONSTANT. */
+
+ if (! cl
+ || (current_length != -1 && current_length < found_length))
+ gfc_set_constant_character_len (found_length, p->expr, true);
+ }
}
- /* Found a length to update to, do it for all element strings shorter than
- the target length. */
- if (max_length != -1)
- {
- for (p = expr->value.constructor; p; p = p->next)
- if (p->expr->expr_type == EXPR_CONSTANT)
- {
- gfc_expr *cl = NULL;
- int current_length = -1;
-
- if (p->expr->ts.cl && p->expr->ts.cl->length)
- {
- cl = p->expr->ts.cl->length;
- gfc_extract_int (cl, ¤t_length);
- }
-
- /* If gfc_extract_int above set current_length, we implicitly
- know the type is BT_INTEGER and it's EXPR_CONSTANT. */
-
- if (generated_length || ! cl
- || (current_length != -1 && current_length < max_length))
- gfc_set_constant_character_len (max_length, p->expr, true);
- }
- }
+ return SUCCESS;
}
t = resolve_array_list (expr->value.constructor);
if (t == SUCCESS)
t = gfc_check_constructor_type (expr);
- if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
- gfc_resolve_character_array_constructor (expr);
+
+ /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
+ the call to this function, so we don't need to call it here; if it was
+ called twice, an error message there would be duplicated. */
return t;
}
try gfc_expand_constructor (gfc_expr *);
int gfc_constant_ac (gfc_expr *);
int gfc_expanded_ac (gfc_expr *);
-void gfc_resolve_character_array_constructor (gfc_expr *);
+try gfc_resolve_character_array_constructor (gfc_expr *);
try gfc_resolve_array_constructor (gfc_expr *);
try gfc_check_constructor_type (gfc_expr *);
try gfc_check_iter_variable (gfc_expr *);
/* This provides the opportunity for the length of constructors with
character valued function elements to propagate the string length
to the expression. */
- if (e->ts.type == BT_CHARACTER)
- gfc_resolve_character_array_constructor (e);
+ if (t == SUCCESS && e->ts.type == BT_CHARACTER)
+ t = gfc_resolve_character_array_constructor (e);
break;
/* Figure out the string length of a character array constructor.
+ If len is NULL, don't calculate the length; this happens for recursive calls
+ when a sub-array-constructor is an element but not at the first position,
+ so when we're not interested in the length.
Returns TRUE if all elements are character constants. */
bool
if (c == NULL)
{
- *len = build_int_cstu (gfc_charlen_type_node, 0);
+ if (len)
+ *len = build_int_cstu (gfc_charlen_type_node, 0);
return is_const;
}
- for (; c; c = c->next)
+ /* Loop over all constructor elements to find out is_const, but in len we
+ want to store the length of the first, not the last, element. We can
+ of course exit the loop as soon as is_const is found to be false. */
+ for (; c && is_const; c = c->next)
{
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
- if (!(*len && INTEGER_CST_P (*len)))
+ if (len && !(*len && INTEGER_CST_P (*len)))
*len = build_int_cstu (gfc_charlen_type_node,
c->expr->value.character.length);
break;
case EXPR_VARIABLE:
is_const = false;
- get_array_ctor_var_strlen (c->expr, len);
+ if (len)
+ get_array_ctor_var_strlen (c->expr, len);
break;
default:
is_const = false;
- get_array_ctor_all_strlen (block, c->expr, len);
+ if (len)
+ get_array_ctor_all_strlen (block, c->expr, len);
break;
}
+
+ /* After the first iteration, we don't want the length modified. */
+ len = NULL;
}
return is_const;
+2008-06-17 Daniel Kraft <d@domob.eu>
+
+ PR fortran/36112
+ * gfortran.dg/bounds_check_array_ctor_1.f90: New test.
+ * gfortran.dg/bounds_check_array_ctor_2.f90: New test.
+ * gfortran.dg/bounds_check_array_ctor_3.f90: New test.
+ * gfortran.dg/bounds_check_array_ctor_4.f90: New test.
+ * gfortran.dg/bounds_check_array_ctor_5.f90: New test.
+ * gfortran.dg/bounds_check_array_ctor_6.f90: New test.
+ * gfortran.dg/bounds_check_array_ctor_7.f90: New test.
+ * gfortran.dg/bounds_check_array_ctor_8.f90: New test.
+ * gfortran.dg/arrayio_0.f90: Fixed invalid array constructor.
+ * gfortran.dg/char_cons_len.f90: Ditto.
+ * gfortran.dg/char_initializer_actual.f90: Ditto.
+ * gfortran.dg/pr15959.f90: Ditto.
+ * gfortran.dg/transfer_simplify_2.f90: Ditto.
+ * gfortran.dg/char_length_1.f90: Changed expected error messages.
+
2008-06-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/36366
character(len=48), dimension(2) :: iue
equivalence (iu, iue)
integer, dimension(4) :: v = (/2,1,4,3/)
- iu = (/"Vector","subscripts","not","allowed!"/)
+ iu = (/"Vector ","subscripts","not ","allowed! "/)
read (iu, '(a12/)') buff
read (iue(1), '(4a12)') buff
read (iu(4:1:-1), '(a12/)') buff
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "foo" }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+
+ call test ("this is long")
+contains
+ subroutine test(s)
+ character(len=*) :: s
+ character(len=128) :: arr(2)
+ arr = (/ s, "abc" /)
+ end subroutine test
+end
+! { dg-output "Different CHARACTER lengths \\(12/3\\) in array constructor" }
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "foo" }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+
+ call test ("this is long")
+contains
+ subroutine test(s)
+ character(len=*) :: s
+ character(len=128) :: arr(2)
+ arr = (/ "abc", s /)
+ end subroutine test
+end
+! { dg-output "Different CHARACTER lengths \\(3/12\\) in array constructor" }
--- /dev/null
+! { dg-do compile }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+! This should not need any -fbounds-check and is enabled all the time.
+
+ character(len=128) :: arr(2) = (/ "abc", "foobar" /) ! { dg-error "Different CHARACTER lengths" }
+ arr = (/ "abc", "foobar" /) ! { dg-error "Different CHARACTER lengths" }
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "foo" }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+
+ call test ("short", "this is long")
+contains
+ subroutine test(r, s)
+ character(len=*) :: r, s
+ character(len=128) :: arr(2)
+ arr = (/ r, s /)
+ end subroutine test
+end
+! { dg-output "Different CHARACTER lengths \\(5/12\\) in array constructor" }
--- /dev/null
+! { dg-do compile }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+! No need for -fbounds-check, enabled unconditionally.
+
+ character(len=5) :: s = "hello"
+ character(len=128) :: arr(3)
+ arr = (/ "abc", "foo", s /) ! { dg-error "Different CHARACTER lengths" }
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "foo" }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+
+ call test ("short", "also5")
+contains
+ subroutine test(r, s)
+ character(len=*) :: r, s
+ character(len=128) :: arr(3)
+ arr = (/ r, s, "this is too long" /)
+ end subroutine test
+end
+! { dg-output "Different CHARACTER lengths \\(5/16\\) in array constructor" }
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "foo" }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+
+ call test ("short")
+contains
+ subroutine test(s)
+ character(len=*) :: s
+ character(len=128) :: arr(3)
+ arr = (/ "this is long", "this one too", s /)
+ end subroutine test
+end
+! { dg-output "Different CHARACTER lengths \\(12/5\\) in array constructor" }
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "foo" }
+!
+! PR 36112
+! Check correct bounds-checking behaviour for character-array-constructors.
+
+ call test ("short")
+contains
+ subroutine test(s)
+ character(len=*) :: s
+ character(len=128) :: arr(3)
+ arr = (/ s, "this is long", "this one too" /)
+ end subroutine test
+end
+! { dg-output "Different CHARACTER lengths \\(5/12\\) in array constructor" }
! constructor, as an argument for LEN, would cause an ICE.
!
character(11) :: chr1, chr2
- i = len ((/chr1, chr2, "ggg"/))
+ i = len ((/chr1, chr2, "ggg "/))
j = len ((/"abcdefghijk", chr1, chr2/))
k = len ((/'hello ','goodbye'/))
l = foo ("yes siree, Bob")
program char_initialiser
character*5, dimension(3) :: x
character*5, dimension(:), pointer :: y
- x=(/"is Ja","ne Fo","nda"/)
+ x=(/"is Ja","ne Fo","nda "/)
call sfoo ("is Ja", x(1))
- call afoo ((/"is Ja","ne Fo","nda"/), x)
- y => pfoo ((/"is Ja","ne Fo","nda"/))
+ call afoo ((/"is Ja","ne Fo","nda "/), x)
+ y => pfoo ((/"is Ja","ne Fo","nda "/))
call afoo (y, x)
contains
subroutine sfoo(ch1, ch2)
! Contributed by Tobias Burnus <tobias.burnus@physik.fu-berlin.de>
!
program test
+ implicit none
character(10) :: a(3)
character(10) :: b(3)= &
- (/ 'Takata ', 'Tanaka', 'Hayashi' /) ! { dg-error "same length" }
+ (/ 'Takata ', 'Tanaka', 'Hayashi' /) ! { dg-error "Different CHARACTER" }
character(4) :: c = "abcde" ! { dg-warning "being truncated" }
- a = (/ 'Takata', 'Tanaka ', 'Hayashi' /) ! { dg-error "same length" }
+ a = (/ 'Takata', 'Tanaka ', 'Hayashi' /) ! { dg-error "Different CHARACTER" }
a = (/ 'Takata ', 'Tanaka ', 'Hayashi' /)
- b = "abc"
+ b = "abc" ! { dg-error "no IMPLICIT" }
c = "abcdefg" ! { dg-warning "will be truncated" }
end program test
! { dg-do run }
! Test initializer of character array. PR15959
-character (*), parameter :: a (1:2) = (/'ab', 'abc'/)
+character (*), parameter :: a (1:2) = (/'ab ', 'abc'/)
if (a(2) .ne. 'abc') call abort()
end
end subroutine integer8_to_complex4
subroutine character16_to_complex8
- character(16), parameter :: c1(2) = (/"abcdefghijklmnop","qrstuvwxyz1234567890"/)
+ character(16), parameter :: c1(2) = (/"abcdefghijklmnop","qrstuvwxyz123456"/)
character(16) :: c2(2) = c1
complex(8), parameter :: z1(2) = transfer (c1, (1.0_8,1.0_8), 2)
complex(8) :: z2(2)
projects / gcc.git / commitdiff