diff mbox

[Fortran] PR54618 fix some INTENT(OUT) issues for CLASS

Message ID 505A3D78.8060703@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Sept. 19, 2012, 9:47 p.m. UTC 
This patch fixes a couple of issues, I run into when working on FINAL 
subroutines.


a) PR54618:

(i) For a nonallocatable CLASS(...),INTENT(OUT), gfortran is setting the 
the _def_init; however, for OPTIONAL this has to be guarded by an 
is-present check.

(ii) For CLASS(...),ALLOCATABLE, INTENT(OUT), gfortran didn't deallocate 
the dummy argument - nor did it reset the var->_vtab to the declared type.

Note: (ii) for polymorphic arrays has still to be implemented, 
currently, only scalars are handled. There are also some other issues 
related to OPTIONAL with polymorphic arrays. (See PR.)

b) When working on FINAL, I also run into the problem that 
attr.alloc_comp is set, when there is a pointer component, which only in 
turn has allocatable components. That lead to an ICE (segfault) with my 
FINAL patch.

c) I also include three coverity patches:
(i) resolve.c: "nl->sym" is many times dereferenced (before and after 
that check), thus it cannot be NULL.
(ii) simplify.c: There is an "if (extremum == NULL) ... continue;", 
hence, one always loops at least once before one reaches that line; but 
then "last" gets set. Thus, the code is unreachable.
(iii) trans-array.c: Here, class_expr is NULL_TREE if the condition is 
false, but TREE_TYPE(NULL_TREE) won't work. Hence, an assert is better.

I intent to do two commits: One for (a) and one for the rest.

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias

Comments

Janus Weil Sept. 22, 2012, 10:23 p.m. UTC | #1 
Hi Tobias,

> This patch fixes a couple of issues, I run into when working on FINAL
> subroutines.
>
>
> a) PR54618:
>
> (i) For a nonallocatable CLASS(...),INTENT(OUT), gfortran is setting the the
> _def_init; however, for OPTIONAL this has to be guarded by an is-present
> check.
>
> (ii) For CLASS(...),ALLOCATABLE, INTENT(OUT), gfortran didn't deallocate the
> dummy argument - nor did it reset the var->_vtab to the declared type.
>
> Note: (ii) for polymorphic arrays has still to be implemented, currently,
> only scalars are handled. There are also some other issues related to
> OPTIONAL with polymorphic arrays. (See PR.)
>
> b) When working on FINAL, I also run into the problem that attr.alloc_comp
> is set, when there is a pointer component, which only in turn has
> allocatable components. That lead to an ICE (segfault) with my FINAL patch.
>
> c) I also include three coverity patches:
> (i) resolve.c: "nl->sym" is many times dereferenced (before and after that
> check), thus it cannot be NULL.
> (ii) simplify.c: There is an "if (extremum == NULL) ... continue;", hence,
> one always loops at least once before one reaches that line; but then "last"
> gets set. Thus, the code is unreachable.
> (iii) trans-array.c: Here, class_expr is NULL_TREE if the condition is
> false, but TREE_TYPE(NULL_TREE) won't work. Hence, an assert is better.
>
> I intent to do two commits: One for (a) and one for the rest.
>
> Build and regtested on x86-64-linux.
> OK for the trunk?

yes, looks good to me. Thanks for the patch!

Cheers,
Janus
diff mbox

Patch

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

	* parse.c (parse_derived): Don't set attr.alloc_comp
	for pointer components with allocatable subcomps.
	* 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 vtab by gfc_conv_expr_present.
	(gfc_conv_procedure_call): Fix INTENT(OUT) handling
	for allocatable BT_CLASS.

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

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

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 5c5d381..f31e309 100644
--- a/gcc/fortran/parse.c
+++ b/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;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f67c07f..0a20540 100644
--- a/gcc/fortran/resolve.c
+++ b/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)
 	{
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 1c9dff2..2f96e90 100644
--- a/gcc/fortran/simplify.c
+++ b/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);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c350c3b..3e684ee 100644
--- a/gcc/fortran/trans-array.c
+++ b/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.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 98634c3..177d286 100644
--- a/gcc/fortran/trans-expr.c
+++ b/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)
--- /dev/null	2012-09-19 07:37:13.203764737 +0200
+++ gcc/gcc/testsuite/gfortran.dg/class_array_14.f90	2012-09-19 23:19:19.000000000 +0200
@@ -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