[Fortran, Patch] Fix for PR60357 and possibly also for 55932, 57857 and others

[Fortran, Patch] Fix for PR60357 and possibly also for 55932, 57857 and others

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 1407 bytes --]

Hi all,

please find attached a fix for pr60357. This patch includes work published by
Janus Weil in the bug. I have made the extensions to support allocatable
scalar components in structure constructors. This patch also addresses
allocatable deferred length char arrays in structure constructors, which are
now supported. Furthermore is the artificial string-length component set
correctly now. I hope I have covered all paths.

Please note, that this patch does not fix allocatable deferred length char
array components in types that are defined and exported in/from a module. For
this bug Tobias Burnus wrote a patch, that will hopefully be published soon. 

During development I have found several related issues in the bugtracker
notably:

pr55932 - [F03] ICE for structure constructor with scalar allocatable component
pr57959 - [F03] ICE with structure constructor with scalar allocatable comp.
pr61275 - Invalid initialization expression for ALLOCATABLE component in
structure constructor at (1) 

I haven't check which ones are covered by the patch, too. I hope for support of
Dominique here, who is a valued resource for checking conflicts and suddenly
fixed bugs. :-) Would you do that for me Dominique?

All comments welcome.

Bootstraps and regtests ok on x86_64-linux-gnu.

Regards,
	Andre

-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

[-- Attachment #2: pr60357_1.clog --]
[-- Type: application/octet-stream, Size: 560 bytes --]

gcc/fortran/ChangeLog:

2015-01-16  Andre Vehreschild  <vehre@gmx.de>

	* primary.c (build_actual_constructor): Prevent warning.
	* trans-expr.c (alloc_scalar_allocatable_for_subcomponent_assignment):
		New function encapsulating treatment of allocatable components.
	(gfc_trans_subcomponent_assign): Needed to distinguish between regular
		assign and initilization.
	(gfc_trans_structure_assign): Same.
	(gfc_conv_structure): Same.

gcc/testsuite/ChangeLog:

2015-01-16  Andre Vehreschild  <vehre@gmx.de>

	* gfortran.dg/alloc_comp_assign_13.f08: New test.



[-- Attachment #3: pr60357_1.patch --]
[-- Type: text/x-patch, Size: 10613 bytes --]

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 7d4aa0c..6b1822d 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2370,11 +2370,13 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
 		return false;
 	      value = gfc_copy_expr (comp->initializer);
 	    }
-	  else if (comp->attr.allocatable)
+	  else if (comp->attr.allocatable
+		   || (comp->ts.type == BT_CLASS
+		       && CLASS_DATA (comp)->attr.allocatable))
 	    {
 	      if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
-		  "allocatable component '%s' given in the structure "
-		  "constructor at %C", comp->name))
+				   "allocatable component '%qs' given in the "
+				   "structure constructor at %C", comp->name))
 		return false;
 	    }
 	  else if (!comp->attr.deferred_parameter)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2ebf959..3dd3dfc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1202,7 +1202,7 @@ realloc_lhs_warning (bt type, bool array, locus *where)
 }
 
 
-static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
+static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init);
 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
 						 gfc_expr *);
 
@@ -6303,10 +6303,96 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
 }
 
 
+/* Allocate or reallocate scalar component, as necessary.  */
+
+static void
+alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
+						      tree comp,
+						      gfc_component *cm,
+						      gfc_expr *expr2,
+						      gfc_symbol *sym)
+{
+  tree tmp;
+  tree size;
+  tree size_in_bytes;
+  tree lhs_cl_size = NULL_TREE;
+
+  if (!comp)
+    return;
+
+  if (!expr2 || expr2->rank)
+    return;
+
+  realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
+
+  if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+    {
+      char name[GFC_MAX_SYMBOL_LEN+9];
+      gfc_component *strlen;
+      /* Use the rhs string length and the lhs element size.  */
+      gcc_assert (expr2->ts.type == BT_CHARACTER);
+      if (!expr2->ts.u.cl->backend_decl)
+	{
+	  gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
+	  gcc_assert (expr2->ts.u.cl->backend_decl);
+	}
+
+      size = expr2->ts.u.cl->backend_decl;
+
+      /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
+	 component.  */
+      sprintf (name, "_%s_length", cm->name);
+      strlen = gfc_find_component (sym, name, true, true);
+      lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
+				     gfc_charlen_type_node,
+				     TREE_OPERAND (comp, 0),
+				     strlen->backend_decl, NULL_TREE);
+
+      tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
+      tmp = TYPE_SIZE_UNIT (tmp);
+      size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
+				       TREE_TYPE (tmp), tmp,
+				       fold_convert (TREE_TYPE (tmp), size));
+    }
+  else
+    {
+      /* Otherwise use the length in bytes of the rhs.  */
+      size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
+      size_in_bytes = size;
+    }
+
+  size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+				   size_in_bytes, size_one_node);
+
+  if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_CALLOC),
+				 2, build_one_cst (size_type_node),
+				 size_in_bytes);
+      tmp = fold_convert (TREE_TYPE (comp), tmp);
+      gfc_add_modify (block, comp, tmp);
+    }
+  else
+    {
+      tmp = build_call_expr_loc (input_location,
+				 builtin_decl_explicit (BUILT_IN_MALLOC),
+				 1, size_in_bytes);
+      tmp = fold_convert (TREE_TYPE (comp), tmp);
+      gfc_add_modify (block, comp, tmp);
+    }
+
+  if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+    /* Update the lhs character length.  */
+    gfc_add_modify (block, lhs_cl_size, size);
+}
+
+
 /* Assign a single component of a derived type constructor.  */
 
 static tree
-gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
+gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
+			       gfc_symbol *sym, bool init)
 {
   gfc_se se;
   gfc_se lse;
@@ -6317,6 +6403,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 
   if (cm->attr.pointer || cm->attr.proc_pointer)
     {
+      /* Only care about pointers here, not about allocatables.  */
       gfc_init_se (&se, NULL);
       /* Pointer component.  */
       if ((cm->attr.dimension || cm->attr.codimension)
@@ -6354,7 +6441,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
     {
       /* NULL initialization for CLASS components.  */
       tmp = gfc_trans_structure_assign (dest,
-					gfc_class_initializer (&cm->ts, expr));
+					gfc_class_initializer (&cm->ts, expr),
+					false);
       gfc_add_expr_to_block (&block, tmp);
     }
   else if ((cm->attr.dimension || cm->attr.codimension)
@@ -6373,6 +6461,44 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
+  else if (init && (cm->attr.allocatable
+	   || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable)))
+    {
+      /* Take care about non-array allocatable components here.  The alloc_*
+	 routine below is motivated by the alloc_scalar_allocatable_for_
+	 assignment() routine, but with the realloc portions removed and
+	 different input.  */
+      alloc_scalar_allocatable_for_subcomponent_assignment (&block,
+							    dest,
+							    cm,
+							    expr,
+							    sym);
+      /* The remainder of these instructions follow the if (cm->attr.pointer)
+	 if (!cm->attr.dimension) part above.  */
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, expr);
+      gfc_add_block_to_block (&block, &se.pre);
+
+      if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
+	  && expr->symtree->n.sym->attr.dummy)
+	se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+      tmp = build_fold_indirect_ref_loc (input_location, dest);
+      /* For deferred strings insert a memcpy.  */
+      if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
+	{
+	  tree size;
+	  gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
+	  size = size_of_string_in_bytes (cm->ts.kind, se.string_length
+						? se.string_length
+						: expr->ts.u.cl->backend_decl);
+	  tmp = gfc_build_memcpy_call (tmp, se.expr, size);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      else
+	gfc_add_modify (&block, tmp,
+			fold_convert (TREE_TYPE (tmp), se.expr));
+      gfc_add_block_to_block (&block, &se.post);
+    }
   else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
     {
       if (expr->expr_type != EXPR_STRUCTURE)
@@ -6387,7 +6513,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
       else
 	{
 	  /* Nested constructors.  */
-	  tmp = gfc_trans_structure_assign (dest, expr);
+	  tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
@@ -6443,7 +6569,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 /* Assign a derived type constructor to a variable.  */
 
 static tree
-gfc_trans_structure_assign (tree dest, gfc_expr * expr)
+gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
 {
   gfc_constructor *c;
   gfc_component *cm;
@@ -6475,13 +6601,22 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
        c; c = gfc_constructor_next (c), cm = cm->next)
     {
       /* Skip absent members in default initializers.  */
-      if (!c->expr)
+      if (!c->expr && !cm->attr.allocatable)
 	continue;
 
       field = cm->backend_decl;
       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 			     dest, field, NULL_TREE);
-      tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
+      if (!c->expr)
+	{
+	  gfc_expr *e = gfc_get_null_expr (NULL);
+	  tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
+					       init);
+	  gfc_free_expr (e);
+	}
+      else
+        tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
+                                             expr->ts.u.derived, init);
       gfc_add_expr_to_block (&block, tmp);
     }
   return gfc_finish_block (&block);
@@ -6508,7 +6643,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
     {
       /* Create a temporary variable and fill it in.  */
       se->expr = gfc_create_var (type, expr->ts.u.derived->name);
-      tmp = gfc_trans_structure_assign (se->expr, expr);
+      /* The symtree in expr is NULL, if the code to generate is for
+	 initializing the static members only.  */
+      tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL);
       gfc_add_expr_to_block (&se->pre, tmp);
       return;
     }
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_13.f08 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_13.f08
new file mode 100644
index 0000000..fe69790
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_13.f08
@@ -0,0 +1,43 @@
+! { dg-do run }
+! Test for allocatable scalar components and deferred length char arrays.
+! Check that fix for pr60357 works.
+! Contributed by Antony Lewis <antony@cosmologist.info> and
+!                Andre Vehreschild <vehre@gmx.de>
+!
+program test_allocatable_components
+    Type A
+        integer :: X
+        integer, allocatable :: y
+        character(len=:), allocatable :: c
+    end type A
+    Type(A) :: Me
+    Type(A) :: Ea
+
+    Me= A(X= 1, Y= 2, C="correctly allocated")
+
+    if (Me%X /= 1) call abort()
+    if (.not. allocated(Me%y) .or. Me%y /= 2) call abort()
+    if (.not. allocated(Me%c)) call abort()
+    if (len(Me%c) /= 19) call abort()
+    if (Me%c /= "correctly allocated") call abort()
+
+    ! Now check explicitly allocated components.
+    Ea%X = 9
+    allocate(Ea%y)
+    Ea%y = 42
+    ! Implicit allocate on assign in the next line
+    Ea%c = "13 characters"
+
+    if (Ea%X /= 9) call abort()
+    if (.not. allocated(Ea%y) .or. Ea%y /= 42) call abort()
+    if (.not. allocated(Ea%c)) call abort()
+    if (len(Ea%c) /= 13) call abort()
+    if (Ea%c /= "13 characters") call abort()
+
+    deallocate(Ea%y)
+    deallocate(Ea%c)
+    if (allocated(Ea%y)) call abort()
+    if (allocated(Ea%c)) call abort()
+end program
+
+! vim:ts=4:sts=4:sw=4:

Re: [Fortran, Patch] Fix for PR60357 and possibly also for 55932, 57857 and others

[Paul Richard Thomas]

Committed with the patch for PR61275 as revision 219801. Also fixes
PR55932 for which a testcase has been added.

Will follow with a commit to 4.9 during the week.

Cheers

Paul

On 16 January 2015 at 12:30, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> please find attached a fix for pr60357. This patch includes work published by
> Janus Weil in the bug. I have made the extensions to support allocatable
> scalar components in structure constructors. This patch also addresses
> allocatable deferred length char arrays in structure constructors, which are
> now supported. Furthermore is the artificial string-length component set
> correctly now. I hope I have covered all paths.
>
> Please note, that this patch does not fix allocatable deferred length char
> array components in types that are defined and exported in/from a module. For
> this bug Tobias Burnus wrote a patch, that will hopefully be published soon.
>
> During development I have found several related issues in the bugtracker
> notably:
>
> pr55932 - [F03] ICE for structure constructor with scalar allocatable component
> pr57959 - [F03] ICE with structure constructor with scalar allocatable comp.
> pr61275 - Invalid initialization expression for ALLOCATABLE component in
> structure constructor at (1)
>
> I haven't check which ones are covered by the patch, too. I hope for support of
> Dominique here, who is a valued resource for checking conflicts and suddenly
> fixed bugs. :-) Would you do that for me Dominique?
>
> All comments welcome.
>
> Bootstraps and regtests ok on x86_64-linux-gnu.
>
> Regards,
>         Andre
>
> --
> Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
> Tel.: +49 241 9291018 * Email: vehre@gmx.de



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx