diff options
| author | José Rui Faustino de Sousa <jrfsousa@gmail.com> | 2022-09-25 22:48:55 +0200 |
|---|---|---|
| committer | Harald Anlauf <anlauf@gmx.de> | 2022-10-08 20:48:12 +0200 |
| commit | a880f9a44ecad385d4273f96f76c5c900d716941 (patch) | |
| tree | 5ebf9d8c014d41319bd8329511344e8b7c63e3b5 /gcc/fortran | |
| parent | db6d642edd24313581c9f92abb6c79cad0b49559 (diff) | |
| download | gcc-a880f9a44ecad385d4273f96f76c5c900d716941.zip gcc-a880f9a44ecad385d4273f96f76c5c900d716941.tar.gz gcc-a880f9a44ecad385d4273f96f76c5c900d716941.tar.bz2 | |
Fortran: Fix ICE and wrong code for assumed-rank arrays [PR100029, PR100040]
gcc/fortran/ChangeLog:
PR fortran/100040
PR fortran/100029
* 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.
(gfc_conv_procedure_call): Change order of code blocks such that
the free of ALLOCATABLE dummy arguments with INTENT(OUT) occurs
first.
gcc/testsuite/ChangeLog:
PR fortran/100029
* gfortran.dg/PR100029.f90: New test.
PR fortran/100040
* gfortran.dg/PR100040.f90: New test.
(cherry picked from commit 5299155bb80e90df822e1eebc9f9a0c8e4505a46)
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 48 |
1 files changed, 27 insertions, 21 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 82341f6..49089eb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1084,8 +1084,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); @@ -1133,8 +1135,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); } @@ -6096,23 +6102,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 @@ -6172,6 +6161,23 @@ 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) && e->ts.type == BT_CLASS |