------- Comment #28 from pault at gcc dot gnu dot org 2007-10-10 15:44 -------
The patch below fixes the lot. It was not necessary in the end to touch
trans-intrinsic.c. Once the appropriate, offending bit of trans-array.c was
fixed, all the casting occurred correctly. The fixes to iresolve.c deal with
the various ICEing testcases in the comments below and are partially based on
FX's input.
This now compiles an runs correctly.
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
and the code in achar, which Richard flagged up has become:
char char.6;
char.6 = (*(char[0:][1:1] *) atmp.3.data)[S.5][1]{lb: 1 sz: 1};
(*(char[0:][1:1] *) atmp.4.data)[S.5][1]{lb: 1 sz: 1} = char.6;
The patch even regtests but I will check tonto and cp2k before submitting.
Cheers
Paul
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (révision 129121)
--- gcc/fortran/trans-array.c (copie de travail)
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4711,4717 ****
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);
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);
--- 4711,4725 ----
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_block_to_block (&block, &lse.pre);
! 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);
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c (révision 129121)
--- gcc/fortran/iresolve.c (copie de travail)
*************** gfc_get_string (const char *format, ...)
*** 62,75 ****
static void
check_charlen_present (gfc_expr *source)
{
! if (source->expr_type == EXPR_CONSTANT && 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;
source->ts.cl->length = gfc_int_expr (source->value.character.length);
source->rank = 0;
}
}
/* Helper function for resolving the "mask" argument. */
--- 62,85 ----
static void
check_charlen_present (gfc_expr *source)
{
! 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. */
*************** gfc_resolve_access (gfc_expr *f, gfc_exp
*** 132,139 ****
}
! void
! gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
{
f->ts.type = BT_CHARACTER;
f->ts.kind = (kind == NULL)
--- 142,150 ----
}
! 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)
*************** gfc_resolve_achar (gfc_expr *f, gfc_expr
*** 143,155 ****
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,
gfc_type_letter (x->ts.type),
x->ts.kind);
}
void
gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
{
f->ts = x->ts;
--- 154,173 ----
gfc_current_ns->cl_list = f->ts.cl;
f->ts.cl->length = gfc_int_expr (1);
! 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)
{
f->ts = x->ts;
*************** gfc_resolve_ceiling (gfc_expr *f, gfc_ex
*** 379,390 ****
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);
}
--- 397,403 ----
void
gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
! gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
}
*************** gfc_resolve_transfer (gfc_expr *f, gfc_e
*** 2269,2274 ****
--- 2282,2290 ----
{
/* 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;
--
pault at gcc dot gnu dot org changed:
What |Removed |Added
----------------------------------------------------------------------------
AssignedTo|unassigned at gcc dot gnu |pault at gcc dot gnu dot org
|dot org |
Status|NEW |ASSIGNED
Last reconfirmed|2007-10-05 17:41:43 |2007-10-10 15:45:00
date| |
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=31608
