Re: [Patch, fortran] PR51976 - [F2003] Support deferred-length character components of derived types (allocatable string length)

[Tobias Burnus <burnus at net-b dot de>]

Dear Paul, dear all,

On February 24, 2013 Paul Richard Thomas wrote:
> The attached patch represents progress to date.  It fixes the original
> problem in this PR and allows John Reid's version of
> iso_varying_string/vocabulary_word_count.f90 to compile and run
> correctly.  It even bootstraps and regtests!

Attached is a re-diffed patch; I have additionally fixed some indenting 
issues.

Additionally, I have tested the patch - and it fails with 
deferred-length *array* character components. See attached test case. 
Also, the following line of the included test case leaks memory:
    allocate (array(2), source = [t("abcedefg","hi"), t("jkl","mnop")])

I think at least the array bug should be fixed prior committal. (Fixing 
the memory leak and some of the below-mentioned issues would be nice, 
too.) Otherwise, I think the patch looks fine. For completeness, I have 
some naming remarks, which I would also like to considered: 
http://thread.gmane.org/gmane.comp.gcc.fortran/40393/focus=281580

Tobias

> However, it doe not fix:
> PR51976 comment #6 and PR51550 - allocate with typespec ICEs
> PR51976 comment #6 FORALL assignment is messed up and ICEs..
> PR47545 the compiler complains about the lack of an initializer for
> the hidden character length field.
> PR45170 will need going through from one end to the other - there is a
> lot of "stuff" here!
>
> Of these, I consider the fix of the PR47545 problem to be a must and
> the allocate with typespec desirable.
type t
  character(len=:), pointer :: p(:)
  character(len=:), allocatable :: a(:)
end type t
type(T) :: x

character(len=5), target :: y(2)
y = ["abc","def"]

x%p => y
x%a = y

print '(">",a,"<")', x%p ! Doesn't print anything
print '(">",a,"<")', x%a ! Doesn't print anything

print '(">",a,"<")', x%p(1) ! Doesn't print anything
print '(">",a,"<")', x%p(2) ! Doesn't print anything
print '(">",a,"<")', x%a(1) ! Prints "def  " (expected: "abc  ")
print '(">",a,"<")', x%a(2) ! Prints "def  " (okay)
end

2013-03-19  Paul Thomas  <pault <at> gcc.gnu.org>

	PR fortran/51976
	* gfortran.h : Add deferred_parameter attribute.
	* primary.c (build_actual_constructor): It is not an error if
	a missing component has the deferred_parameter attribute;
	equally, if one is given a value, it is an error.
	* resolve.c (resolve_fl_derived0): Remove error for deferred
	character length components.  Add the hidden string length
	field to the structure. Give it the deferred_parameter
	attribute.
	* trans-array.c (duplicate_allocatable): Add a strlen field
	which is used as the element size if it is non-null.
	(gfc_duplicate_allocatable, gfc_copy_allocatable_data): Pass a
	NULL to the new argument in duplicate_allocatable.
	(structure_alloc_comps): Set the hidden string length as
	appropriate. Use it in calls to duplicate_allocatable.
	(gfc_alloc_allocatable_for_assignment): When a deferred length
	backend declaration is variable, use that; otherwise use the
	string length from the expression evaluation.
	* trans-expr.c (gfc_conv_component_ref): If this is a deferred
	character length component, the string length should have the
	value of the hidden string length field.
	(gfc_trans_subcomponent_assign): Set the hidden string length
	field for deferred character length components.  Allocate the
	necessary memory for the string.
	(alloc_scalar_allocatable_for_assignment): Same change as in
	gfc_alloc_allocatable_for_assignment above.
	* trans-stmt.c (gfc_trans_allocate): Likewise.
	* trans-types.c (gfc_get_derived_type): Set the tree type for
	a deferred character length component.
	* trans.c (gfc_deferred_strlen): New function.
	* trans.h : Prototype for the new function.

2013-03-19  Paul Thomas  <pault <at> gcc.gnu.org>

	PR fortran/51976
	* gfortran.dg/deferred_type_component_1.f90 : New test.

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 76d2797..6956d33 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -811,6 +811,9 @@ typedef struct
   /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES).  */
   unsigned ext_attr:EXT_ATTR_NUM;
 
+  /* Is a parameter associated with a deferred type component.  */
+  unsigned deferred_parameter:1;
+
   /* The namespace where the attribute has been set.  */
   struct gfc_namespace *volatile_ns, *asynchronous_ns;
 }
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index d149224..34a55b5 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2349,7 +2349,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
 	}
 
       /* If it was not found, try the default initializer if there's any;
-	 otherwise, it's an error.  */
+	 otherwise, it's an error unless this is a deferred parameter.  */
       if (!comp_iter)
 	{
 	  if (comp->initializer)
@@ -2360,7 +2360,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
 		return FAILURE;
 	      value = gfc_copy_expr (comp->initializer);
 	    }
-	  else
+	  else if (!comp->attr.deferred_parameter)
 	    {
 	      gfc_error ("No initializer for component '%s' given in the"
 			 " structure constructor at %C!", comp->name);
@@ -2443,7 +2443,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
 	{
 	  /* Components without name are not allowed after the first named
 	     component initializer!  */
-	  if (!comp)
+	  if (!comp || comp->attr.deferred_parameter)
 	    {
 	      if (last_name)
 		gfc_error ("Component initializer without name after component"
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e9b6fb9..f70a749 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -12539,14 +12539,6 @@ resolve_fl_derived0 (gfc_symbol *sym)
       if (c->attr.artificial)
 	continue;
 
-      /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170.  */
-      if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
-	{
-	  gfc_error ("Deferred-length character component '%s' at %L is not "
-		     "yet supported", c->name, &c->loc);
-	  return FAILURE;
-	}
-
       /* F2008, C442.  */
       if ((!sym->attr.is_class || c != sym->components)
 	  && c->attr.codimension
@@ -12798,6 +12790,25 @@ resolve_fl_derived0 (gfc_symbol *sym)
 	  return FAILURE;
 	}
 
+      /* Add the hidden deferred length field.  */
+      if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function
+	  && !sym->attr.is_class)
+	{
+	  char name[GFC_MAX_SYMBOL_LEN+1];
+	  gfc_component *strlen;
+	  sprintf (name, "_%s", c->name);
+	  strlen = gfc_find_component (sym, name, true, true);
+	  if (strlen == NULL)
+	    {
+	      if (gfc_add_component (sym, name, &strlen) == FAILURE)
+		return FAILURE;
+	      strlen->ts.type = BT_INTEGER;
+	      strlen->ts.kind = gfc_charlen_int_kind;
+	      strlen->attr.access = ACCESS_PRIVATE;
+	      strlen->attr.deferred_parameter = 1;
+	    }
+	}
+
       if (c->ts.type == BT_DERIVED
 	  && sym->component_access != ACCESS_PRIVATE
 	  && gfc_check_symbol_access (sym)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 75fed2f..7a2d5de 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7308,7 +7308,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank)
 
 static tree
 duplicate_allocatable (tree dest, tree src, tree type, int rank,
-		       bool no_malloc)
+		       bool no_malloc, tree strlen)
 {
   tree tmp;
   tree size;
@@ -7329,7 +7329,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
       null_data = gfc_finish_block (&block);
 
       gfc_init_block (&block);
-      size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+      if (strlen != NULL_TREE)
+	size = strlen;
+      else
+	size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+
       if (!no_malloc)
 	{
 	  tmp = gfc_call_malloc (&block, type, size);
@@ -7349,8 +7353,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
 
       gfc_init_block (&block);
       nelems = get_full_array_size (&block, src, rank);
-      tmp = fold_convert (gfc_array_index_type,
-			  TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      if (strlen != NULL_TREE)
+	tmp = fold_convert (gfc_array_index_type, strlen);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			      nelems, tmp);
       if (!no_malloc)
@@ -7391,7 +7398,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
 tree
 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
 {
-  return duplicate_allocatable (dest, src, type, rank, false);
+  return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE);
 }
 
 
@@ -7400,7 +7407,7 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
 tree
 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
 {
-  return duplicate_allocatable (dest, src, type, rank, true);
+  return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE);
 }
 
 
@@ -7637,6 +7644,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				     void_type_node, comp,
 				     build_int_cst (TREE_TYPE (comp), 0));
 	      gfc_add_expr_to_block (&fnblock, tmp);
+	      if (gfc_deferred_strlen (c, &comp))
+		{
+		  comp = fold_build3_loc (input_location, COMPONENT_REF,
+					  TREE_TYPE (comp),
+					  decl, comp, NULL_TREE);
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 TREE_TYPE (comp), comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
 	    }
 	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
@@ -7730,8 +7747,25 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      continue;
 	    }
 
-	  if (c->attr.allocatable && !c->attr.proc_pointer
-	      && !cmp_has_alloc_comps)
+	  if (gfc_deferred_strlen (c, &tmp))
+	    {
+	      tree len;
+	      len = tmp;
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     decl, len, NULL_TREE);
+	      len = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     dest, len, NULL_TREE);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     TREE_TYPE (len), len, tmp);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
+					   false, len);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else if (c->attr.allocatable && !c->attr.proc_pointer
+		   && !cmp_has_alloc_comps)
 	    {
 	      rank = c->as ? c->as->rank : 0;
 	      tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank);
@@ -8183,10 +8217,24 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   /* Get the new lhs size in bytes.  */
   if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
     {
-      tmp = expr2->ts.u.cl->backend_decl;
-      gcc_assert (expr1->ts.u.cl->backend_decl);
-      tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
-      gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+      if (expr2->ts.deferred)
+	{
+	  if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL)
+	    tmp = expr2->ts.u.cl->backend_decl;
+	  else
+	    tmp = rss->info->string_length;
+	}
+      else
+	{
+	  tmp = expr2->ts.u.cl->backend_decl;
+	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+	}
+
+      if (expr1->ts.u.cl->backend_decl
+	  && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
+	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+      else
+	gfc_add_modify (&fblock, lss->info->string_length, tmp);
     }
   else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
     {
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2c3ff1f..c73741d 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1589,6 +1589,14 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       se->string_length = tmp;
     }
 
+  if (gfc_deferred_strlen (c, &field))
+    {
+      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+			     TREE_TYPE (field),
+			     decl, field, NULL_TREE);
+      se->string_length = tmp;
+    }
+
   if (((c->attr.pointer || c->attr.allocatable)
        && (!c->attr.dimension && !c->attr.codimension)
        && c->ts.type != BT_CHARACTER)
@@ -6031,9 +6039,40 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
-  else
+  else if (gfc_deferred_strlen (cm, &tmp))
+    {
+      tree strlen;
+      strlen = tmp;
+      gcc_assert (strlen);
+      strlen = fold_build3_loc (input_location, COMPONENT_REF,
+				TREE_TYPE (strlen),
+				TREE_OPERAND (dest, 0),
+				strlen, NULL_TREE);
+
+      if (expr->expr_type == EXPR_NULL)
+	{
+	  tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
+	  gfc_add_modify (&block, dest, tmp);
+	  tmp = build_int_cst (TREE_TYPE (strlen), 0);
+	  gfc_add_modify (&block, strlen, tmp);
+	}
+      else
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr);
+	  tmp = build_call_expr_loc (input_location,
+				     builtin_decl_explicit (BUILT_IN_MALLOC),
+				     1, se.string_length);
+	  gfc_add_modify (&block, dest,
+			  fold_convert (TREE_TYPE (dest), tmp));
+	  gfc_add_modify (&block, strlen, se.string_length);
+	  tmp = gfc_build_memcpy_call (dest, se.expr, se.string_length);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
+  else if (!cm->attr.deferred_parameter)
     {
-      /* Scalar component.  */
+      /* Scalar component (excluding deferred parameters).  */
       gfc_init_se (&se, NULL);
       gfc_init_se (&lse, NULL);
 
@@ -7629,7 +7668,10 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
 
       /* Update the lhs character length.  */
       size = string_length;
-      gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+      if (TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
+	gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+      else
+	gfc_add_modify (block, lse.string_length, size);
     }
 }
 
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 430b10e..aad0139 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5009,6 +5009,11 @@ gfc_trans_allocate (gfc_code * code)
 	      if (tmp && TREE_CODE (tmp) == VAR_DECL)
 		gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
 				memsz));
+	      else if (al->expr->ts.type == BT_CHARACTER
+		       && al->expr->ts.deferred && se.string_length)
+		gfc_add_modify (&se.pre, se.string_length,
+				fold_convert (TREE_TYPE (se.string_length),
+				memsz));
 
 	      /* Convert to size in bytes, using the character KIND.  */
 	      if (unlimited_char)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index cdac0da..cda26ab 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2479,12 +2479,15 @@ gfc_get_derived_type (gfc_symbol * derived)
         field_type = c->ts.u.derived->backend_decl;
       else
 	{
-	  if (c->ts.type == BT_CHARACTER)
+	  if (c->ts.type == BT_CHARACTER && !c->ts.deferred)
 	    {
 	      /* Evaluate the string length.  */
 	      gfc_conv_const_charlen (c->ts.u.cl);
 	      gcc_assert (c->ts.u.cl->backend_decl);
 	    }
+	  else if (c->ts.type == BT_CHARACTER)
+	    c->ts.u.cl->backend_decl
+			= build_int_cst (gfc_charlen_type_node, 0);
 
 	  field_type = gfc_typenode_for_spec (&c->ts);
 	}
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index d7bdf26..986213a 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1843,3 +1843,21 @@ gfc_likely (tree cond)
   cond = fold_convert (boolean_type_node, cond);
   return cond;
 }
+
+
+/* Get the string length for a deferred character length component.  */
+
+bool
+gfc_deferred_strlen (gfc_component *c, tree *decl)
+{
+  char name[GFC_MAX_SYMBOL_LEN+1];
+  gfc_component *strlen;
+  if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
+    return false;
+  sprintf (name, "_%s", c->name);
+  for (strlen = c; strlen; strlen = strlen->next)
+    if (strcmp (strlen->name, name) == 0)
+      break;
+  *decl = strlen ? strlen->backend_decl : NULL_TREE;
+  return strlen != NULL;
+}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 03adfdd..95c1864 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -578,6 +578,9 @@ bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
 tree gfc_likely (tree);
 tree gfc_unlikely (tree);
 
+/* Return the string length of a deferred character length component.  */
+bool gfc_deferred_strlen (gfc_component *, tree *);
+
 /* Generate a runtime error call.  */
 tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
 
diff --git a/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90 b/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90
new file mode 100644
index 0000000..17d1ac0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_type_component_1.f90
@@ -0,0 +1,54 @@
+! { dg-do run }
+! Test fix for PR51976 - introduce deferred character length components
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+  type t
+    character(len=:), allocatable :: str_comp
+    character(len=:), allocatable :: str_comp1
+  end type t
+  type(t) :: x
+  type(t), allocatable, dimension(:) :: array
+
+! Check scalars
+  allocate (x%str_comp, source = "abc")
+  call check (x%str_comp, "abc")
+  deallocate (x%str_comp)
+  allocate (x%str_comp, source = "abcdefghijklmnop")
+  call check (x%str_comp, "abcdefghijklmnop")
+  x%str_comp = "xyz"
+  call check (x%str_comp, "xyz")
+  x%str_comp = "abcdefghijklmnop"
+  x%str_comp1 = "lmnopqrst"
+  call foo (x%str_comp1, "lmnopqrst")
+  call bar (x, "abcdefghijklmnop", "lmnopqrst")
+
+! Check arrays and structure constructors
+  allocate (array(2), source = [t("abcedefg","hi"), t("jkl","mnop")])
+  call check (array(1)%str_comp, "abcedefg")
+  call check (array(1)%str_comp1, "hi")
+  call check (array(2)%str_comp, "jkl")
+  call check (array(2)%str_comp1, "mnop")
+  deallocate (array)
+  allocate (array(3), source = [x, x, x])
+  array(2)%str_comp = "blooey"
+  call bar (array(1), "abcdefghijklmnop", "lmnopqrst")
+  call bar (array(2), "blooey", "lmnopqrst")
+  call bar (array(3), "abcdefghijklmnop", "lmnopqrst")
+contains
+  subroutine foo (chr1, chr2)
+    character (*) :: chr1, chr2
+    call check (chr1, chr2)
+  end subroutine
+  subroutine bar (a, chr1, chr2)
+    character (*) :: chr1, chr2
+    type(t) :: a
+    call check (a%str_comp, chr1)
+    call check (a%str_comp1, chr2)
+  end subroutine
+  subroutine check (chr1, chr2)
+    character (*) :: chr1, chr2
+    if (len(chr1) .ne. len (chr2)) call abort
+    if (chr1 .ne. chr2) call abort
+  end subroutine
+end