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
