Fortran: fix string length for array constructors with type-spec [PR85547]

	PR fortran/85547

gcc/fortran/ChangeLog:

	* decl.cc (gfc_match_volatile): Fix frontend memleak.
	(gfc_match_asynchronous): Likewise.
	* dump-parse-tree.cc (show_expr): Show type-spec for character
	array constructor when given.
	* simplify.cc (gfc_simplify_len): Simplify LEN() when type-spec
	is provided for character array constructor.
	* trans-intrinsic.cc (gfc_conv_intrinsic_len): Likewise.

gcc/testsuite/ChangeLog:

	* gfortran.dg/string_length_5.f90: New test.

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index e646d6b8f9a15451266e60983a4ba0a2603014c0..2908007d75c66bf44fda2d1b658b03669a730a78 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -10405,7 +10405,7 @@ gfc_match_volatile (void)
       switch (m)
        {
        case MATCH_YES:
-         name = XCNEWVAR (char, strlen (sym->name) + 1);
+         name = XALLOCAVAR (char, strlen (sym->name) + 1);
          strcpy (name, sym->name);
          if (!check_function_name (name))
            return MATCH_ERROR;
@@ -10469,7 +10469,7 @@ gfc_match_asynchronous (void)
       switch (m)
        {
        case MATCH_YES:
-         name = XCNEWVAR (char, strlen (sym->name) + 1);
+         name = XALLOCAVAR (char, strlen (sym->name) + 1);
          strcpy (name, sym->name);
          if (!check_function_name (name))
            return MATCH_ERROR;

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index b51414c13e29e5091a3ef03e63608da88c4de198..028c946d2d99e197977190068b25098ac7d09237 100644 (file)
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -545,6 +545,14 @@ show_expr (gfc_expr *p)
 
     case EXPR_ARRAY:
       fputs ("(/ ", dumpfile);
+      if (p->ts.type == BT_CHARACTER
+         && p->ts.u.cl
+         && p->ts.u.cl->length_from_typespec
+         && p->ts.u.cl->length)
+       {
+         show_typespec (&p->ts);
+         fputs (" :: ", dumpfile);
+       }
       show_constructor (p->value.constructor);
       fputs (" /)", dumpfile);
 

diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index a3af457b5dead936eec1c4743b36839b85415102..c6291d7ea1d47f90d87dea5d1a9f9fadafdb9001 100644 (file)
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -5083,6 +5083,21 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
            }
        }
     }
+  else if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_CHARACTER
+          && e->ts.u.cl
+          && e->ts.u.cl->length_from_typespec
+          && e->ts.u.cl->length
+          && e->ts.u.cl->length->ts.type == BT_INTEGER)
+    {
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
+      ts.type = BT_INTEGER;
+      ts.kind = k;
+      result = gfc_copy_expr (e->ts.u.cl->length);
+      gfc_convert_type_warn (result, &ts, 2, 0);
+      return result;
+    }
+
   return NULL;
 }
 

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index ec98f967200477481991a4534b42e66c918891ac..39ed230e874deb61788ee2603d369c0b4478db1f 100644 (file)
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -7647,6 +7647,14 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
       break;
 
     case EXPR_ARRAY:
+      /* If there is an explicit type-spec, use it.  */
+      if (arg->ts.u.cl->length && arg->ts.u.cl->length_from_typespec)
+       {
+         gfc_conv_string_length (arg->ts.u.cl, arg, &se->pre);
+         len = arg->ts.u.cl->backend_decl;
+         break;
+       }
+
       /* Obtain the string length from the function used by
          trans-array.cc(gfc_trans_array_constructor).  */
       len = NULL_TREE;

diff --git a/gcc/testsuite/gfortran.dg/string_length_5.f90 b/gcc/testsuite/gfortran.dg/string_length_5.f90
new file mode 100644 (file)
index 0000000..12ae5a1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/string_length_5.f90
@@ -0,0 +1,88 @@
+! { dg-do run }
+! PR fortran/85547 - string length for array constructors with type-spec
+!
+! Reported by Walter Spector
+
+program p
+  implicit none
+  integer, parameter :: k = 16
+  integer            :: m = k
+  integer, volatile  :: n = k
+  character(10)      :: path  = 'xyz/'
+  character(8)       :: path2 = 'abc/'
+  character(*), parameter :: s = 'ijk/'
+  if (k /= len ( [ character(k) :: path ]        )) stop 1
+  if (k /= len ( [ character(m) :: path ]        )) stop 2
+  if (k /= len ( [ character(n) :: path ]        )) stop 3
+  if (k /= len ( [ character(k) :: path ] ,kind=2)) stop 4
+  if (k /= len ( [ character(m) :: path ] ,kind=2)) stop 5
+  if (k /= len ( [ character(n) :: path ] ,kind=2)) stop 6
+
+  if (k /= len ( [ character(k) ::      ]        )) stop 7
+  if (k /= len ( [ character(m) ::      ]        )) stop 8
+  if (k /= len ( [ character(n) ::      ]        )) stop 9
+  if (k /= len ( [ character(k) ::      ] ,kind=2)) stop 10
+  if (k /= len ( [ character(m) ::      ] ,kind=2)) stop 11
+  if (k /= len ( [ character(n) ::      ] ,kind=2)) stop 12
+  if (k /= len ( [ character(2*n/2) ::  ]        )) stop 13
+  if (k /= len ( [ character(2*n/2) ::  ] ,kind=2)) stop 14
+  if (k /= len ( [ character((m+n)/2) ::] ,kind=2)) stop 15
+  if (k /= len ( [ character((m+n)/2) ::] ,kind=2)) stop 16
+  if (k /= len ([[ character(k) ::      ]],kind=2)) stop 17
+  if (k /= len ([[ character(m) ::      ]],kind=2)) stop 18
+  if (k /= len ([[ character(n) ::      ]],kind=2)) stop 19
+  if (k /= len ([[ character((m+n)/2) ::]],kind=2)) stop 20
+
+  if (k /= len ( [ character(k)       :: path,path2 ] ,kind=2)) stop 21
+  if (k /= len ( [ character(m)       :: path,path2 ] ,kind=2)) stop 22
+  if (k /= len ( [ character(n)       :: path,path2 ] ,kind=2)) stop 23
+  if (k /= len ( [ character((m+n)/2) :: path,path2 ] ,kind=2)) stop 24
+  if (k /= len ([[ character(k)       :: path,path2 ]],kind=2)) stop 25
+  if (k /= len ([[ character(m)       :: path,path2 ]],kind=2)) stop 26
+  if (k /= len ([[ character(n)       :: path,path2 ]],kind=2)) stop 27
+  if (k /= len ([[ character((m+n)/2) :: path,path2 ]],kind=2)) stop 28
+
+  call sub ()
+contains
+  subroutine sub ()
+!   call print_string (31, [ character(k)       :: ] )
+!   call print_string (32, [ character(m)       :: ] )
+!   call print_string (33, [ character(n)       :: ] )
+!   call print_string (34, [ character((m+n)/2) :: ] )
+!   call print_string (35, [ character(k)       :: path ] )
+!   call print_string (36, [ character(m)       :: path ] )
+!   call print_string (37, [ character(n)       :: path ] )
+!   call print_string (38, [ character((m+n)/2) :: path ] )
+!   call print_string (39, [ character(k)       :: path,path2 ] )
+!   call print_string (40, [ character(m)       :: path,path2 ] )
+!   call print_string (41, [ character(n)       :: path,path2 ] )
+!   call print_string (42, [ character((m+n)/2) :: path,path2 ] )
+!
+!   call print_string (51,[[ character(k)       :: ]])
+!   call print_string (52,[[ character(m)       :: ]])
+!   call print_string (53,[[ character(n)       :: ]])
+!   call print_string (54,[[ character((m+n)/2) :: ]])
+!   call print_string (55,[[ character(k)       :: path ]])
+!   call print_string (56,[[ character(m)       :: path ]])
+!   call print_string (57,[[ character(n)       :: path ]])
+!   call print_string (58,[[ character((m+n)/2) :: path ]])
+!   call print_string (59,[[ character(k)       :: path,path2 ]])
+!   call print_string (60,[[ character(m)       :: path,path2 ]])
+!   call print_string (61,[[ character(n)       :: path,path2 ]])
+!   call print_string (62,[[ character((m+n)/2) :: path,path2 ]])
+
+!   call print_string (70, [ character(k)       ::     ] )
+    call print_string (71, [ character(k)       :: s   ] )
+    call print_string (72, [ character(k)       :: s,s ] )
+
+  end subroutine sub
+
+  subroutine print_string (i, s)
+    integer,      intent(in) :: i
+    character(*), intent(in) :: s(:)
+    if (len(s) /= k) then
+       print *, i, len(s), len(s)==k, size (s), s(:)
+       stop i
+    end if
+  end subroutine
+end program