re PR fortran/48890 ([F95] Wrong length of a character component of named constant...

2018-02-20  Thomas Koenig  <tkoenig@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-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/48890
	PR fortran/83823
	* gfortran.dg/structure_constructor_14.f90: New test.

From-SVN: r257856

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e3818ab6a9271c8b1b10a8cb7661f18fde2f25f9..d6d66c5e3f3cef850e41dbb4e53382db57380159 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2018-02-20  Thomas Koenig  <tkoenig@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  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/83344

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 9e6a8fe0d8019a92906605ab9ed5341345ddc52a..d889ed10ac38d7092737009ffb171286f698cac7 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2879,6 +2879,38 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
       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 = gfc_mpz_get_hwi (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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index de9cd420e9e4f04486ea87100a34e73392595017..6351dd56db771bfa05d96d17ca07809fb1452342 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2018-02-20  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/48890
+       PR fortran/83823
+       * gfortran.dg/structure_constructor_14.f90: New test.
+
 2018-02-20  Jeff Law  <law@redhat.com>
 
         PR middle-end/82123

diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_14.f90 b/gcc/testsuite/gfortran.dg/structure_constructor_14.f90
new file mode 100644 (file)
index 0000000..b889206
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/structure_constructor_14.f90
@@ -0,0 +1,24 @@
+! { 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') STOP 1
+  write (line,'("|",A,"|")') x
+  if (line /= "|asdf    |") STOP 1
+end program gfcbug145