[Patch, fortran] PR fortran/100029 - ICE on storage_size with polymorphic argument, PR fortran/100040 - Wrong code with intent out assumed-rank allocatable

[Patch, fortran] PR fortran/100029 - ICE on storage_size with polymorphic argument, PR fortran/100040 - Wrong code with intent out assumed-rank allocatable

[José Rui Faustino de Sousa]

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

Hi All!

Proposed patch to:

PR100040 - Wrong code with intent out assumed-rank allocatable
PR100029 - ICE on subroutine call with allocatable polymorphic 
assumed-rank argument

Patch tested only on x86_64-pc-linux-gnu.

Made sure the code also recognized assumed-rank arrays as full arrays.

Changed the order of free and class to class conversion so that the free 
occurs first so that there are no problems with freeing an unexpected 
type of transformed class.

Thank you very much.

Best regards,
José Rui

Fortran: Fix ICE and wrong code emission [PR100029, PR100040]

gcc/fortran/ChangeLog:

	PR fortran/100040
	* trans-expr.c (gfc_conv_class_to_class): add code to have
	assumed-rank arrays recognized as full arrays and fix the type
	of the array assignment.

	PR fortran/100029
	* trans-expr.c (gfc_conv_procedure_call): change order of code
	blocks, such that the free occurs first.

gcc/testsuite/ChangeLog:

	PR fortran/100029
	* gfortran.dg/PR100029.f90: New test.

	PR fortran/100040
	* gfortran.dg/PR100040.f90: New test.


[-- Attachment #2: PR100040.patch --]
[-- Type: text/x-patch, Size: 4772 bytes --]

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2fa17b36c03..35b784ab782 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1099,8 +1099,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
     return;
 
   /* Test for FULL_ARRAY.  */
-  if (e->rank == 0 && gfc_expr_attr (e).codimension
-      && gfc_expr_attr (e).dimension)
+  if (e->rank == 0
+      && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
+	  || (class_ts.u.derived->components->as
+	      && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
     full_array = true;
   else
     gfc_is_class_array_ref (e, &full_array);
@@ -1148,8 +1150,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 	  && e->rank != class_ts.u.derived->components->as->rank)
 	{
 	  if (e->rank == 0)
-	    gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
-			    gfc_conv_descriptor_data_get (ctree));
+	    {
+	      tmp = gfc_class_data_get (parmse->expr);
+	      gfc_add_modify (&parmse->post, tmp,
+			      fold_convert (TREE_TYPE (tmp),
+					 gfc_conv_descriptor_data_get (ctree)));
+	    }
 	  else
 	    class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
 	}
@@ -6111,23 +6117,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    base_object = build_fold_indirect_ref_loc (input_location,
 							       parmse.expr);
 
-		  /* A class array element needs converting back to be a
-		     class object, if the formal argument is a class object.  */
-		  if (fsym && fsym->ts.type == BT_CLASS
-			&& e->ts.type == BT_CLASS
-			&& ((CLASS_DATA (fsym)->as
-			     && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
-			    || CLASS_DATA (e)->attr.dimension))
-		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
-				     fsym->attr.intent != INTENT_IN
-				     && (CLASS_DATA (fsym)->attr.class_pointer
-					 || CLASS_DATA (fsym)->attr.allocatable),
-				     fsym->attr.optional
-				     && e->expr_type == EXPR_VARIABLE
-				     && e->symtree->n.sym->attr.optional,
-				     CLASS_DATA (fsym)->attr.class_pointer
-				     || CLASS_DATA (fsym)->attr.allocatable);
-
 		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		     allocated on entry, it must be deallocated.  */
 		  if (fsym && fsym->attr.intent == INTENT_OUT
@@ -6186,6 +6175,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 		      gfc_add_expr_to_block (&se->pre, tmp);
 		    }
+		  /* A class array element needs converting back to be a
+		     class object, if the formal argument is a class object.  */
+		  if (fsym && fsym->ts.type == BT_CLASS
+			&& e->ts.type == BT_CLASS
+			&& ((CLASS_DATA (fsym)->as
+			     && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+			    || CLASS_DATA (e)->attr.dimension))
+		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+				     fsym->attr.intent != INTENT_IN
+				     && (CLASS_DATA (fsym)->attr.class_pointer
+					 || CLASS_DATA (fsym)->attr.allocatable),
+				     fsym->attr.optional
+				     && e->expr_type == EXPR_VARIABLE
+				     && e->symtree->n.sym->attr.optional,
+				     CLASS_DATA (fsym)->attr.class_pointer
+				     || CLASS_DATA (fsym)->attr.allocatable);
 
 		  if (fsym && (fsym->ts.type == BT_DERIVED
 			       || fsym->ts.type == BT_ASSUMED)
diff --git a/gcc/testsuite/gfortran.dg/PR100029.f90 b/gcc/testsuite/gfortran.dg/PR100029.f90
new file mode 100644
index 00000000000..1fef06fd2d3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100029.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+!
+! Test the fix for PR100029
+!
+
+program foo_p
+
+  implicit none
+
+  type :: foo_t
+  end type foo_t
+  
+  class(foo_t), allocatable :: pout
+
+  call foo_s(pout)
+  stop
+
+contains
+
+  subroutine foo_s(that)
+    class(foo_t), allocatable, intent(out) :: that(..)
+
+    return
+  end subroutine foo_s
+
+end program foo_p
diff --git a/gcc/testsuite/gfortran.dg/PR100040.f90 b/gcc/testsuite/gfortran.dg/PR100040.f90
new file mode 100644
index 00000000000..23128fa5328
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR100040.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! Test the fix for PR100040
+!
+
+program foo_p
+
+  implicit none
+
+  integer, parameter :: n = 11
+
+  type :: foo_t
+    integer :: i
+  end type foo_t
+  
+  type(foo_t), parameter :: a = foo_t(n)
+  
+  class(foo_t), allocatable :: pout
+
+  call foo_s(pout)
+  if(.not.allocated(pout)) stop 1
+  if(pout%i/=n) stop 2
+  stop
+
+contains
+
+  subroutine foo_s(that)
+    class(foo_t), allocatable, intent(out) :: that(..)
+
+    select rank(that)
+    rank(0)
+      that = a
+    rank default
+      stop 3
+    end select
+    return
+  end subroutine foo_s
+
+end program foo_p