FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/39865 (ICE in gfc_conv_scalarized_array_ref)

Browse source 
PR fortran/39865
	* io.c (resolve_tag_format): CHARACTER array in FMT= argument
	isn't an extension.  Reject non-CHARACTER array element of
	assumed shape or pointer or assumed size array.
	* trans-array.c (array_parameter_size): New function.
	(gfc_conv_array_parameter): Add size argument.  Call
	array_parameter_size if it is non-NULL.
	* trans-array.h (gfc_conv_array_parameter): Adjust prototype.
	* trans-expr.c (gfc_conv_function_call, gfc_trans_arrayfunc_assign):
	Adjust callers.
	* trans-intrinsic.c (gfc_conv_intrinsic_loc): Likewise.
	* trans-io.c (gfc_convert_array_to_string): Rewritten.

	* gfortran.dg/pr39865.f90: New test.
	* gfortran.dg/hollerith.f90: Don't expect errors for CHARACTER
	arrays in FMT=.
	* gfortran.dg/hollerith_f95.f90: Likewise.
	* gfortran.dg/hollerith6.f90: New test.
	* gfortran.dg/hollerith7.f90: New test.

From-SVN: r147507
This commit is contained in:
Jakub Jelinek 2009-05-14 02:00:27 +02:00 • committed by Jakub Jelinek
parent 00b0c19b4b
commit 7e2791428f
13 changed files with 311 additions and 80 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View file

@ -1,3 +1,18 @@
2009-05-14 Jakub Jelinek <jakub@redhat.com>
PR fortran/39865
* io.c (resolve_tag_format): CHARACTER array in FMT= argument
isn't an extension. Reject non-CHARACTER array element of
assumed shape or pointer or assumed size array.
* trans-array.c (array_parameter_size): New function.
(gfc_conv_array_parameter): Add size argument. Call
array_parameter_size if it is non-NULL.
* trans-array.h (gfc_conv_array_parameter): Adjust prototype.
* trans-expr.c (gfc_conv_function_call, gfc_trans_arrayfunc_assign):
Adjust callers.
* trans-intrinsic.c (gfc_conv_intrinsic_loc): Likewise.
* trans-io.c (gfc_convert_array_to_string): Rewritten.
2009-05-13 Steven G. Kargl <kargl@gcc.gnu.org>
* gfortran.h (gfc_code): Rename struct member expr to expr1.

43
gcc/fortran/io.c
View file

@ -1,5 +1,5 @@
/* Deal with I/O statements & related stuff.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -1234,8 +1234,11 @@ resolve_tag_format (const gfc_expr *e)
/* If e's rank is zero and e is not an element of an array, it should be
of integer or character type. The integer variable should be
ASSIGNED. */
if (e->symtree == NULL || e->symtree->n.sym->as == NULL
|| e->symtree->n.sym->as->rank == 0)
if (e->rank == 0
&& (e->expr_type != EXPR_VARIABLE
|| e->symtree == NULL
|| e->symtree->n.sym->as == NULL
|| e->symtree->n.sym->as->rank == 0))
{
if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
{
@ -1266,20 +1269,34 @@ resolve_tag_format (const gfc_expr *e)
return SUCCESS;
}
/* If rank is nonzero, we allow the type to be character under GFC_STD_GNU
and other type under GFC_STD_LEGACY. It may be assigned an Hollerith
constant. */
if (e->ts.type == BT_CHARACTER)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
"in FORMAT tag at %L", &e->where) == FAILURE)
return FAILURE;
}
else
/* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
It may be assigned an Hollerith constant. */
if (e->ts.type != BT_CHARACTER)
{
if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
"in FORMAT tag at %L", &e->where) == FAILURE)
return FAILURE;
if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
{
gfc_error ("Non-character assumed shape array element in FORMAT"
" tag at %L", &e->where);
return FAILURE;
}
if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
{
gfc_error ("Non-character assumed size array element in FORMAT"
" tag at %L", &e->where);
return FAILURE;
}
if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
{
gfc_error ("Non-character pointer array element in FORMAT tag at %L",
&e->where);
return FAILURE;
}
}
return SUCCESS;

44
gcc/fortran/trans-array.c
View file

@ -5339,13 +5339,41 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
gfc_cleanup_loop (&loop);
}
/* Helper function for gfc_conv_array_parameter if array size needs to be
computed. */
static void
array_parameter_size (tree desc, gfc_expr *expr, tree *size)
{
tree elem;
if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
*size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
else if (expr->rank > 1)
*size = build_call_expr (gfor_fndecl_size0, 1,
gfc_build_addr_expr (NULL, desc));
else
{
tree ubound = gfc_conv_descriptor_ubound (desc, gfc_index_zero_node);
tree lbound = gfc_conv_descriptor_lbound (desc, gfc_index_zero_node);
*size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
*size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
gfc_index_one_node);
*size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
gfc_index_zero_node);
}
elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
*size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
fold_convert (gfc_array_index_type, elem));
}
/* Convert an array for passing as an actual parameter. */
/* TODO: Optimize passing g77 arrays. */
void
gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
const gfc_symbol *fsym, const char *proc_name)
const gfc_symbol *fsym, const char *proc_name,
tree *size)
{
tree ptr;
tree desc;
@ -5394,6 +5422,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
se->expr = tmp;
else
se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
if (size)
array_parameter_size (tmp, expr, size);
return;
}
if (sym->attr.allocatable)
@ -5401,10 +5431,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
if (sym->attr.dummy || sym->attr.result)
{
gfc_conv_expr_descriptor (se, expr, ss);
se->expr = gfc_conv_array_data (se->expr);
tmp = se->expr;
}
else
se->expr = gfc_conv_array_data (tmp);
if (size)
array_parameter_size (tmp, expr, size);
se->expr = gfc_conv_array_data (tmp);
return;
}
}
@ -5413,6 +5444,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
{
/* Result of the enclosing function. */
gfc_conv_expr_descriptor (se, expr, ss);
if (size)
array_parameter_size (se->expr, expr, size);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
@ -5426,6 +5459,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
/* Every other type of array. */
se->want_pointer = 1;
gfc_conv_expr_descriptor (se, expr, ss);
if (size)
array_parameter_size (build_fold_indirect_ref (se->expr),
expr, size);
}
/* Deallocate the allocatable components of structures that are

2
gcc/fortran/trans-array.h
View file

@ -106,7 +106,7 @@ void gfc_conv_tmp_ref (gfc_se *);
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
/* Convert an array for passing as an actual function parameter. */
void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int,
const gfc_symbol *, const char *);
const gfc_symbol *, const char *, tree *);
/* Evaluate and transpose a matrix expression. */
void gfc_conv_array_transpose (gfc_se *, gfc_expr *);

7
gcc/fortran/trans-expr.c
View file

@ -2424,7 +2424,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
f = f || !sym->attr.always_explicit;
argss = gfc_walk_expr (arg->expr);
gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
gfc_conv_array_parameter (se, arg->expr, argss, f,
NULL, NULL, NULL);
}
/* TODO -- the following two lines shouldn't be necessary, but
@ -2676,7 +2677,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name);
sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
@ -4352,7 +4353,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_start_block (&se.pre);
se.want_pointer = 1;
gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);

2
gcc/fortran/trans-intrinsic.c
View file

@ -4394,7 +4394,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (se, arg_expr);
else
gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL);
gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
/* Create a temporary variable for loc return value. Without this,

84
gcc/fortran/trans-io.c
View file

@ -567,65 +567,57 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
/* Given an array expr, find its address and length to get a string. If the
array is full, the string's address is the address of array's first element
and the length is the size of the whole array. If it is an element, the
and the length is the size of the whole array. If it is an element, the
string's address is the element's address and the length is the rest size of
the array.
*/
the array. */
static void
gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
{
tree tmp;
tree array;
tree type;
tree size;
int rank;
gfc_symbol *sym;
sym = e->symtree->n.sym;
rank = sym->as->rank - 1;
if (e->rank == 0)
{
tree type, array, tmp;
gfc_symbol *sym;
int rank;
if (e->ref->u.ar.type == AR_FULL)
{
se->expr = gfc_get_symbol_decl (sym);
se->expr = gfc_conv_array_data (se->expr);
}
else
{
/* If it is an element, we need its address and size of the rest. */
gcc_assert (e->expr_type == EXPR_VARIABLE);
gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
sym = e->symtree->n.sym;
rank = sym->as->rank - 1;
gfc_conv_expr (se, e);
}
array = sym->backend_decl;
type = TREE_TYPE (array);
array = sym->backend_decl;
type = TREE_TYPE (array);
if (GFC_ARRAY_TYPE_P (type))
size = GFC_TYPE_ARRAY_SIZE (type);
else
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
size = gfc_conv_array_stride (array, rank);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_conv_array_ubound (array, rank),
gfc_conv_array_lbound (array, rank));
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
gfc_index_one_node);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
}
if (GFC_ARRAY_TYPE_P (type))
size = GFC_TYPE_ARRAY_SIZE (type);
else
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
size = gfc_conv_array_stride (array, rank);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_conv_array_ubound (array, rank),
gfc_conv_array_lbound (array, rank));
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
gfc_index_one_node);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
}
gcc_assert (size);
gcc_assert (size);
/* If it is an element, we need the its address and size of the rest. */
if (e->ref->u.ar.type == AR_ELEMENT)
{
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
TREE_OPERAND (se->expr, 1));
TREE_OPERAND (se->expr, 1));
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
fold_convert (gfc_array_index_type, tmp));
se->string_length = fold_convert (gfc_charlen_type_node, size);
return;
}
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
fold_convert (gfc_array_index_type, tmp));
gfc_conv_array_parameter (se, e, gfc_walk_expr (e), 1, NULL, NULL, &size);
se->string_length = fold_convert (gfc_charlen_type_node, size);
}
@ -654,7 +646,9 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
var, p->field_len, NULL_TREE);
/* Integer variable assigned a format label. */
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
if (e->ts.type == BT_INTEGER
&& e->rank == 0
&& e->symtree->n.sym->attr.assign == 1)
{
char * msg;
tree cond;
@ -680,7 +674,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
if (e->ts.type == BT_CHARACTER && e->rank == 0)
gfc_conv_expr (&se, e);
/* Array assigned Hollerith constant or character array. */
else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
gfc_convert_array_to_string (&se, e);
else
gcc_unreachable ();

10
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,13 @@
2009-05-14 Jakub Jelinek <jakub@redhat.com>
PR fortran/39865
* gfortran.dg/pr39865.f90: New test.
* gfortran.dg/hollerith.f90: Don't expect errors for CHARACTER
arrays in FMT=.
* gfortran.dg/hollerith_f95.f90: Likewise.
* gfortran.dg/hollerith6.f90: New test.
* gfortran.dg/hollerith7.f90: New test.
2009-05-14 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
PR cpp/36674

6
gcc/testsuite/gfortran.dg/hollerith.f90
View file

@ -99,10 +99,4 @@ end subroutine
! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 39 }
! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 43 }
! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 45 }
! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 47 }
! { dg-warning "Hollerith constant" "" { target *-*-* } 51 }

35
gcc/testsuite/gfortran.dg/hollerith6.f90 Normal file
View file

@ -0,0 +1,35 @@
! PR fortran/39865
! { dg-do run }
subroutine foo (a)
integer(kind=4) :: a(1, 3)
character(len=40) :: t
write (t, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
if (t .ne. ' 1 2 3 4 5 6 7 8') call abort
end subroutine foo
interface
subroutine foo (a)
integer(kind=4) :: a(1, 3)
end subroutine foo
end interface
integer(kind=4) :: b(1,3)
character(len=40) :: t
b(1,1) = 4HXXXX
b(1,2) = 4H (8I
b(1,3) = 2H4)
write (t, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
if (t .ne. ' 1 2 3 4 5 6 7 8') call abort
call foo (b)
end
! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 7 }
! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 20 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 17 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 17 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 18 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 18 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 19 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 19 }

52
gcc/testsuite/gfortran.dg/hollerith7.f90 Normal file
View file

@ -0,0 +1,52 @@
! PR fortran/39865
! { dg-do compile }
subroutine foo (a)
integer(kind=4), target :: a(1:, 1:)
integer(kind=4), pointer :: b(:, :)
b => a
write (*, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
write (*, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8
end subroutine foo
subroutine bar (a, b)
character :: b(2,*)
integer :: a(*)
write (*, fmt=b) 1, 2, 3
write (*, fmt=a) 1, 2, 3
write (*, fmt=a(2)) 1, 2, 3
end subroutine
interface
subroutine foo (a)
integer(kind=4), target :: a(:, :)
end subroutine foo
end interface
integer(kind=4) :: a(2, 3)
a = 4HXXXX
a(2,2) = 4H (8I
a(1,3) = 2H4)
a(2,3) = 1H
call foo (a(2:2,:))
end
! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 8 }
! { dg-error "Non-character assumed shape array element in FORMAT tag" "element" { target *-*-* } 8 }
! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 9 }
! { dg-error "Non-character pointer array element in FORMAT tag" "element" { target *-*-* } 9 }
! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 14 }
! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 15 }
! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 16 }
! { dg-error "Non-character assumed size array element in FORMAT tag" "element" { target *-*-* } 16 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 24 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 24 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 25 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 25 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 26 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 26 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 27 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 27 }

7
gcc/testsuite/gfortran.dg/hollerith_f95.f90
View file

@ -91,10 +91,3 @@ end subroutine
! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 38 }
! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 40 }
! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 44 }
! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 46 }
! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 48 }

84
gcc/testsuite/gfortran.dg/pr39865.f90 Normal file
View file

@ -0,0 +1,84 @@
! PR fortran/39865
! { dg-do run }
subroutine f1 (a)
character(len=1) :: a(7:)
character(len=12) :: b
character(len=1) :: c(2:10)
write (b, a) 'Hell', 'o wo', 'rld!'
if (b .ne. 'Hello world!') call abort
write (b, a(:)) 'hell', 'o Wo', 'rld!'
if (b .ne. 'hello World!') call abort
write (b, a(8:)) 'Hell', 'o wo', 'rld!'
if (b .ne. 'Hello world!') call abort
c(2) = ' '
c(3) = '('
c(4) = '3'
c(5) = 'A'
c(6) = '4'
c(7) = ')'
write (b, c) 'hell', 'o Wo', 'rld!'
if (b .ne. 'hello World!') call abort
write (b, c(:)) 'Hell', 'o wo', 'rld!'
if (b .ne. 'Hello world!') call abort
write (b, c(3:)) 'hell', 'o Wo', 'rld!'
if (b .ne. 'hello World!') call abort
end subroutine f1
subroutine f2 (a)
character(len=1) :: a(10:,20:)
character(len=12) :: b
write (b, a) 'Hell', 'o wo', 'rld!'
if (b .ne. 'Hello world!') call abort
write (b, a) 'hell', 'o Wo', 'rld!'
if (b .ne. 'hello World!') call abort
end subroutine f2
function f3 ()
character(len=1) :: f3(5)
f3(1) = '('
f3(2) = '3'
f3(3) = 'A'
f3(4) = '4'
f3(5) = ')'
end function f3
interface
subroutine f1 (a)
character(len=1) :: a(:)
end
end interface
interface
subroutine f2 (a)
character(len=1) :: a(:,:)
end
end interface
interface
function f3 ()
character(len=1) :: f3(5)
end
end interface
integer :: i, j
character(len=1) :: e (6, 7:9), f (3,2), g (10)
character(len=12) :: b
e = 'X'
e(2,8) = ' '
e(3,8) = '('
e(4,8) = '3'
e(2,9) = 'A'
e(3,9) = '4'
e(4,9) = ')'
f = e(2:4,8:9)
g = 'X'
g(2) = ' '
g(3) = '('
g(4) = '3'
g(5) = 'A'
g(6) = '4'
g(7) = ')'
call f1 (g(2:7))
call f2 (f)
call f2 (e(2:4,8:9))
write (b, f3 ()) 'Hell', 'o wo', 'rld!'
if (b .ne. 'Hello world!') call abort
end