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

re PR fortran/31608 (wrong types in character array/scalar binop)

Browse source 
2007-10-20  Paul Thomas  <pault@gcc.gnu.org>
	    FX Coudert <fxcoudert@gcc.gnu.org>

	PR fortran/31608
	* trans-array.c (gfc_conv_expr_descriptor): For all except
	indirect references, use gfc_trans_scalar_assign instead of
	gfc_add_modify_expr.
	* iresolve.c (check_charlen_present): Separate creation of cl
	if necessary and add code to treat an EXPR_ARRAY.
	(gfc_resolve_char_achar): New function.
	(gfc_resolve_achar, gfc_resolve_char): Call it.
	(gfc_resolve_transfer): If the MOLD expression does not have a
	character length expression, get it from a constant length.

2007-10-20  Paul Thomas  <pault@gcc.gnu.org>
	    FX Coudert <fxcoudert@gcc.gnu.org>

	PR fortran/31608
	* gfortran.dg/char_cast_1.f90: New test.


Co-Authored-By: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

From-SVN: r129505
This commit is contained in:
Paul Thomas 2007-10-20 09:27:09 +00:00
parent 0362597e22
commit 6f535271b7
5 changed files with 86 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View file

@ -1,3 +1,17 @@
2007-10-20 Paul Thomas <pault@gcc.gnu.org>
FX Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31608
* trans-array.c (gfc_conv_expr_descriptor): For all except
indirect references, use gfc_trans_scalar_assign instead of
gfc_add_modify_expr.
* iresolve.c (check_charlen_present): Separate creation of cl
if necessary and add code to treat an EXPR_ARRAY.
(gfc_resolve_char_achar): New function.
(gfc_resolve_achar, gfc_resolve_char): Call it.
(gfc_resolve_transfer): If the MOLD expression does not have a
character length expression, get it from a constant length.
2007-10-19 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/33544

36
gcc/fortran/iresolve.c
View file

@ -62,14 +62,24 @@ gfc_get_string (const char *format, ...)
static void
check_charlen_present (gfc_expr *source)
{
if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
if (source->ts.cl == NULL)
{
source->ts.cl = gfc_get_charlen ();
source->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = source->ts.cl;
}
if (source->expr_type == EXPR_CONSTANT)
{
source->ts.cl->length = gfc_int_expr (source->value.character.length);
source->rank = 0;
}
else if (source->expr_type == EXPR_ARRAY)
{
source->ts.cl->length =
gfc_int_expr (source->value.constructor->expr->value.character.length);
source->rank = 1;
}
}
/* Helper function for resolving the "mask" argument. */
@ -132,8 +142,9 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
}
void
gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
static void
gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
const char *name)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = (kind == NULL)
@ -143,12 +154,19 @@ gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
gfc_current_ns->cl_list = f->ts.cl;
f->ts.cl->length = gfc_int_expr (1);
f->value.function.name = gfc_get_string ("__achar_%d_%c%d", f->ts.kind,
f->value.function.name = gfc_get_string (name, f->ts.kind,
gfc_type_letter (x->ts.type),
x->ts.kind);
}
void
gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
{
gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
}
void
gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
{
@ -379,12 +397,7 @@ gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
void
gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = (kind == NULL)
? gfc_default_character_kind : mpz_get_si (kind->value.integer);
f->value.function.name
= gfc_get_string ("__char_%d_%c%d", f->ts.kind,
gfc_type_letter (a->ts.type), a->ts.kind);
gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
}
@ -2270,6 +2283,9 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
/* TODO: Make this do something meaningful. */
static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length)
mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
f->ts = mold->ts;
if (size == NULL && mold->rank == 0)

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

@ -4727,7 +4727,15 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_modify_expr (&block, lse.expr, rse.expr);
if (TREE_CODE (rse.expr) != INDIRECT_REF)
{
lse.string_length = rse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
expr->expr_type == EXPR_VARIABLE);
gfc_add_expr_to_block (&block, tmp);
}
else
gfc_add_modify_expr (&block, lse.expr, rse.expr);
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
2007-10-20 Paul Thomas <pault@gcc.gnu.org>
FX Coudert <fxcoudert@gcc.gnu.org>
PR fortran/31608
* gfortran.dg/char_cast_1.f90: New test.
2007-10-19 Steven G. Kargl <kargl@gcc.gnu.org>
* gfortran.dg/default_format_denormal_2.f90: xfail on FreeBSD.

31
gcc/testsuite/gfortran.dg/char_cast_1.f90 Normal file
View file

@ -0,0 +1,31 @@
! { dg-do compile }
! { dg-options "-O2 -fdump-tree-original" }
!
! Check the fix for PR31608 in all it's various manifestations:)
! Contributed by Richard Guenther <rguenth@gcc.gnu.org>
!
character(len=1) :: string = "z"
integer :: i(1) = (/100/)
print *, Up("abc")
print *, transfer(((transfer(string,"x",1))), "x",1)
print *, transfer(char(i), "x")
print *, Upper ("abcdefg")
contains
Character (len=20) Function Up (string)
Character(len=*) string
character(1) :: chr
Up = transfer(achar(iachar(transfer(string,chr,1))), "x")
return
end function Up
Character (len=20) Function Upper (string)
Character(len=*) string
Upper = &
transfer(merge(transfer(string,"x",len(string)), &
string, .true.), "x")
return
end function Upper
end
! The sign that all is well is that [S.5][1] appears twice.
! { dg-final { scan-tree-dump-times "\\\[S\.5\\\]\\\[1\\\]" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-tree-dump "original" } }