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 <tkoe...@gcc.gnu.org> 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 <tkoe...@gcc.gnu.org> 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;