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.

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

Reply via email to