Hello world,
when putting in a seemingly innocent simplification for PR 56342,
I caused a regression in PR 82823, in PACK. The root cause of
this one turned out to be PR 48890, in which structure
constructors containing characters were not handled correctly
if the lengths did not match.
The attached patch fixes that.
Regression-tested. OK for trunk?
Regards
Thomas
2018-02-19 Thomas Koenig <[email protected]>
PR fortran/48890
PR fortran/83823
* primary.c (gfc_convert_to_structure_constructor):
For a constant string constructor, make sure the length
is correct.
2018-02-19 Thomas Koenig <[email protected]>
PR fortran/48890
PR fortran/83823
* gfortran.dg/structure_constructor_14.f90: New test.
! { dg-do run }
! PR 48890, PR 83823
! Test fix for wrong length in parameters. Original test cases
! by mhp77 (a) gmx.at and Harald Anlauf.
program gfcbug145
implicit none
type t_obstyp
character(len=8) :: name
end type t_obstyp
type (t_obstyp) ,parameter :: obstyp(*)= &
[ t_obstyp ('SYNOP' ), &
t_obstyp ('DRIBU' ), &
t_obstyp ('TEMP' ), &
t_obstyp ('RADAR' ) ]
logical :: mask(size(obstyp)) = .true.
character(len=100) :: line
type (t_obstyp), parameter :: x = t_obstyp('asdf')
write(line,'(20(a8,:,"|"))') pack (obstyp% name, mask)
if (line /= 'SYNOP |DRIBU |TEMP |RADAR') call abort
write (line,'("|",A,"|")') x
if (line /= "|asdf |") call abort
end program gfcbug145
Index: primary.c
===================================================================
--- primary.c (Revision 257788)
+++ primary.c (Arbeitskopie)
@@ -2879,6 +2879,38 @@ gfc_convert_to_structure_constructor (gfc_expr *e,
if (!this_comp)
goto cleanup;
+ /* For a constant string constructor, make sure the length is correct;
+ truncate of fill with blanks if needed. */
+ if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable
+ && this_comp->ts.u.cl && this_comp->ts.u.cl->length
+ && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && actual->expr->expr_type == EXPR_CONSTANT)
+ {
+ ptrdiff_t c, e;
+ c = mpz_get_si (this_comp->ts.u.cl->length->value.integer);
+ e = actual->expr->value.character.length;
+
+ if (c != e)
+ {
+ ptrdiff_t i, to;
+ gfc_char_t *dest;
+ dest = gfc_get_wide_string (c + 1);
+
+ to = e < c ? e : c;
+ for (i = 0; i < to; i++)
+ dest[i] = actual->expr->value.character.string[i];
+
+ for (i = e; i < c; i++)
+ dest[i] = ' ';
+
+ dest[c] = '\0';
+ free (actual->expr->value.character.string);
+
+ actual->expr->value.character.length = c;
+ actual->expr->value.character.string = dest;
+ }
+ }
+
comp_tail->val = actual->expr;
if (actual->expr != NULL)
comp_tail->where = actual->expr->where;
