re PR fortran/54599 (Issues found in gfortran by the Coverity Scan)

2012-09-23  Tobias Burnus  <burnus@net-b.de>

        * parse.c (parse_derived): Don't set attr.alloc_comp
        for pointer components with allocatable subcomps.

        PR fortran/54599
        * resolve.c (resolve_fl_namelist): Remove superfluous
        NULL check.
        * simplify.c (simplify_min_max): Remove unreachable code.
        * trans-array.c (gfc_trans_create_temp_array): Change
        a condition into an assert.

        PR fortran/54618
        * trans-expr.c (gfc_trans_class_init_assign): Guard
        re-setting of the _data by gfc_conv_expr_present.
        (gfc_conv_procedure_call): Fix INTENT(OUT) handling
        for allocatable BT_CLASS.

2012-09-23  Tobias Burnus  <burnus@net-b.de>

        PR fortran/54618
        * gfortran.dg/class_array_14.f90: New.

From-SVN: r191649

gcc/fortran/ChangeLog

@@ -1,3 +1,21 @@
+2012-09-23  Tobias Burnus  <burnus@net-b.de>
+
+	* parse.c (parse_derived): Don't set attr.alloc_comp
+	for pointer components with allocatable subcomps.
+
+	PR fortran/54599
+	* resolve.c (resolve_fl_namelist): Remove superfluous
+	NULL check.
+	* simplify.c (simplify_min_max): Remove unreachable code.
+	* trans-array.c (gfc_trans_create_temp_array): Change
+	a condition into an assert.
+
+	PR fortran/54618
+	* trans-expr.c (gfc_trans_class_init_assign): Guard
+	re-setting of the _data by gfc_conv_expr_present.
+	(gfc_conv_procedure_call): Fix INTENT(OUT) handling
+	for allocatable BT_CLASS.
+
 2012-09-22  Thomas König  <tkoenig@gcc.gnu.org>
 
 	PR fortran/54599

gcc/fortran/parse.c

@@ -2195,7 +2195,8 @@ endType:
       if (c->attr.allocatable
 	  || (c->ts.type == BT_CLASS && c->attr.class_ok
 	      && CLASS_DATA (c)->attr.allocatable)
-	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
+	  || (c->ts.type == BT_DERIVED && !c->attr.pointer
+	      && c->ts.u.derived->attr.alloc_comp))
 	{
 	  allocatable = true;
 	  sym->attr.alloc_comp = 1;

gcc/fortran/resolve.c

@@ -12478,7 +12478,7 @@ resolve_fl_namelist (gfc_symbol *sym)
 	  continue;
 
       nlsym = NULL;
-      if (nl->sym && nl->sym->name)
+      if (nl->sym->name)
 	gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
       if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
 	{

gcc/fortran/simplify.c

@@ -4106,10 +4106,7 @@ simplify_min_max (gfc_expr *expr, int sign)
       min_max_choose (arg->expr, extremum->expr, sign);
 
       /* Delete the extra constant argument.  */
-      if (last == NULL)
-	expr->value.function.actual = arg->next;
-      else
-	last->next = arg->next;
+      last->next = arg->next;
 
       arg->next = NULL;
       gfc_free_actual_arglist (arg);

gcc/fortran/trans-array.c

@@ -1022,8 +1022,8 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
      dynamic type.  Generate an eltype and then the class expression.  */
   if (eltype == NULL_TREE && initial)
     {
-      if (POINTER_TYPE_P (TREE_TYPE (initial)))
-	class_expr = build_fold_indirect_ref_loc (input_location, initial);
+      gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
+      class_expr = build_fold_indirect_ref_loc (input_location, initial);
       eltype = TREE_TYPE (class_expr);
       eltype = gfc_get_element_type (eltype);
       /* Obtain the structure (class) expression.  */

gcc/fortran/trans-expr.c

@@ -621,6 +621,16 @@ gfc_trans_class_init_assign (gfc_code *code)
       gfc_add_block_to_block (&block, &src.pre);
       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
     }
+
+  if (code->expr1->symtree->n.sym->attr.optional
+      || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
+    {
+      tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
+      tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			present, tmp,
+			build_empty_stmt (input_location));
+    }
+
   gfc_add_expr_to_block (&block, tmp);
   
   return gfc_finish_block (&block);
@@ -3905,22 +3915,42 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
 		     allocated on entry, it must be deallocated.  */
-		  if (fsym && fsym->attr.allocatable
-		      && fsym->attr.intent == INTENT_OUT)
+		  if (fsym && fsym->attr.intent == INTENT_OUT
+		      && (fsym->attr.allocatable
+			  || (fsym->ts.type == BT_CLASS
+			      && CLASS_DATA (e)->attr.allocatable)))
 		    {
 		      stmtblock_t block;
+		      tree ptr;
 
 		      gfc_init_block  (&block);
-		      tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
+		      ptr = parmse.expr;
+		      if (e->ts.type == BT_CLASS)
+			ptr = gfc_class_data_get (ptr);	
+
+		      tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
 							NULL_TREE, NULL_TREE,
 							NULL_TREE, true, NULL,
 							false);
 		      gfc_add_expr_to_block (&block, tmp);
 		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-					     void_type_node, parmse.expr,
+					     void_type_node, ptr,
 					     null_pointer_node);
 		      gfc_add_expr_to_block (&block, tmp);
 
+		      if (fsym->ts.type == BT_CLASS)
+			{
+			  gfc_symbol *vtab;
+			  gcc_assert (fsym->ts.u.derived == e->ts.u.derived);
+			  vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
+			  tmp = gfc_get_symbol_decl (vtab);
+			  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+			  ptr = gfc_class_vptr_get (parmse.expr);
+			  gfc_add_modify (&block, ptr,
+					  fold_convert (TREE_TYPE (ptr), tmp));
+			  gfc_add_expr_to_block (&block, tmp);
+			}
+
 		      if (fsym->attr.optional
 			  && e->expr_type == EXPR_VARIABLE
 			  && e->symtree->n.sym->attr.optional)

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2012-09-2323  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54618
+	* gfortran.dg/class_array_14.f90: New.
+
 2012-09-22  Kai Tietz  <ktietz@redhat.com>
 
 	* gcc.dg/tree-ssa/scev-3.c: Add llp64 to xfail.

gcc/testsuite/gfortran.dg/class_array_14.f90

@@ -0,0 +1,53 @@
+! { dg-do run }
+!
+! PR fortran/54618
+!
+! Check whether default initialization works with INTENT(OUT)
+! and ALLOCATABLE and no segfault occurs with OPTIONAL.
+!
+
+subroutine test1()
+  type typ1
+    integer :: i = 6
+  end type typ1
+
+  type(typ1) :: x
+
+  x%i = 77
+  call f(x)
+  if (x%i /= 6) call abort ()
+  call f()
+contains
+  subroutine f(y1)
+    class(typ1), intent(out), optional :: y1
+  end subroutine f
+end subroutine test1
+
+subroutine test2()
+  type mytype
+  end type mytype
+  type, extends(mytype):: mytype2
+  end type mytype2
+
+  class(mytype), allocatable :: x,y
+  allocate (mytype2 :: x)
+  call g(x)
+  if (allocated (x) .or. .not. same_type_as (x,y)) call abort()
+
+  allocate (mytype2 :: x)
+  call h(x)
+  if (allocated (x) .or. .not. same_type_as (x,y)) call abort()
+
+  call h()
+contains
+  subroutine g(y2)
+    class(mytype), intent(out), allocatable :: y2
+  end subroutine g
+  subroutine h(y3)
+    class(mytype), optional, intent(out), allocatable :: y3
+  end subroutine h
+end subroutine test2
+
+call test1()
+call test2()
+end