public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/omp/gcc-11] Fortran: Various CLASS + assumed-rank fixed [PR102541]
@ 2021-10-12 8:06 Tobias Burnus
0 siblings, 0 replies; only message in thread
From: Tobias Burnus @ 2021-10-12 8:06 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:595deb6b894431dbc3a03d83ece10f0640964ff8
commit 595deb6b894431dbc3a03d83ece10f0640964ff8
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Tue Oct 12 09:58:45 2021 +0200
Fortran: Various CLASS + assumed-rank fixed [PR102541]
Starting point was PR102541, were a previous patch caused an invalid
e->ref access for class. When testing, it turned out that for
CLASS to CLASS the code was never executed - additionally, issues
appeared for optional and a bogus error for -fcheck=all. In particular:
There were a bunch of issues related to optional CLASS, can have the
'attr.dummy' set in CLASS_DATA (sym) - but sometimes also in 'sym'!?!
Additionally, gfc_variable_attr could return pointer = 1 for nonpointers
when the expr is no longer "var" but "var%_data".
PR fortran/102541
gcc/fortran/ChangeLog:
* check.c (gfc_check_present): Handle optional CLASS.
* interface.c (gfc_compare_actual_formal): Likewise.
* trans-array.c (gfc_trans_g77_array): Likewise.
* trans-decl.c (gfc_build_dummy_array_decl): Likewise.
* trans-types.c (gfc_sym_type): Likewise.
* primary.c (gfc_variable_attr): Fixes for dummy and
pointer when 'class%_data' is passed.
* trans-expr.c (set_dtype_for_unallocated, gfc_conv_procedure_call):
For assumed-rank dummy, fix setting rank for dealloc/notassoc actual
and setting ubound to -1 for assumed-size actuals.
gcc/testsuite/ChangeLog:
* gfortran.dg/assumed_rank_24.f90: New test.
(cherry picked from commit eb92cd57a1ebe7cd7589bdbec34d9ae337752ead)
Diff:
---
gcc/fortran/ChangeLog.omp | 17 ++++
gcc/fortran/check.c | 4 +-
gcc/fortran/interface.c | 9 +-
gcc/fortran/primary.c | 17 +++-
gcc/fortran/trans-array.c | 4 +-
gcc/fortran/trans-decl.c | 3 +-
gcc/fortran/trans-expr.c | 80 ++++++++-------
gcc/fortran/trans-types.c | 3 +-
gcc/testsuite/ChangeLog.omp | 8 ++
gcc/testsuite/gfortran.dg/assumed_rank_24.f90 | 137 ++++++++++++++++++++++++++
10 files changed, 234 insertions(+), 48 deletions(-)
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 9bcd68edf90..207a8f6bdc1 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,20 @@
+2021-10-12 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2021-10-12 Tobias Burnus <tobias@codesourcery.com>
+
+ PR fortran/102541
+ * check.c (gfc_check_present): Handle optional CLASS.
+ * interface.c (gfc_compare_actual_formal): Likewise.
+ * trans-array.c (gfc_trans_g77_array): Likewise.
+ * trans-decl.c (gfc_build_dummy_array_decl): Likewise.
+ * trans-types.c (gfc_sym_type): Likewise.
+ * primary.c (gfc_variable_attr): Fixes for dummy and
+ pointer when 'class%_data' is passed.
+ * trans-expr.c (set_dtype_for_unallocated, gfc_conv_procedure_call):
+ For assumed-rank dummy, fix setting rank for dealloc/notassoc actual
+ and setting ubound to -1 for assumed-size actuals.
+
2021-10-08 Sandra Loosemore <sandra@codesourcery.com>
Backport from master:
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f31ad68053b..677209ee95e 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -4530,7 +4530,9 @@ gfc_check_present (gfc_expr *a)
return false;
}
- if (!sym->attr.optional)
+ /* For CLASS, the optional attribute might be set at either location. */
+ if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional)
+ && !sym->attr.optional)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be of "
"an OPTIONAL dummy variable",
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 2a71da75c72..24698be8364 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3624,8 +3624,13 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
"at %L", where);
return false;
}
- if (!f->sym->attr.optional
- || (in_statement_function && f->sym->attr.optional))
+ /* For CLASS, the optional attribute might be set at either location. */
+ if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional)
+ && !f->sym->attr.optional)
+ || (in_statement_function
+ && (f->sym->attr.optional
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.optional))))
{
if (where)
gfc_error ("Missing actual argument for argument %qs at %L",
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index a6df885c80c..11e2a555e0a 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2627,7 +2627,7 @@ check_substring:
symbol_attribute
gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
- int dimension, codimension, pointer, allocatable, target;
+ int dimension, codimension, pointer, allocatable, target, optional;
symbol_attribute attr;
gfc_ref *ref;
gfc_symbol *sym;
@@ -2640,12 +2640,14 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
sym = expr->symtree->n.sym;
attr = sym->attr;
+ optional = attr.optional;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
{
dimension = CLASS_DATA (sym)->attr.dimension;
codimension = CLASS_DATA (sym)->attr.codimension;
pointer = CLASS_DATA (sym)->attr.class_pointer;
allocatable = CLASS_DATA (sym)->attr.allocatable;
+ optional |= CLASS_DATA (sym)->attr.optional;
}
else
{
@@ -2667,6 +2669,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
if (ref->type == REF_INQUIRY)
{
has_inquiry_part = true;
+ optional = false;
break;
}
@@ -2684,12 +2687,13 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
case AR_SECTION:
allocatable = pointer = 0;
dimension = 1;
+ optional = false;
break;
case AR_ELEMENT:
/* Handle coarrays. */
if (ref->u.ar.dimen > 0)
- allocatable = pointer = 0;
+ allocatable = pointer = optional = false;
break;
case AR_UNKNOWN:
@@ -2702,6 +2706,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
break;
case REF_COMPONENT:
+ optional = false;
comp = ref->u.c.component;
attr = comp->attr;
if (ts != NULL && !has_inquiry_part)
@@ -2723,7 +2728,10 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
else
{
codimension = comp->attr.codimension;
- pointer = comp->attr.pointer;
+ if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0)
+ pointer = comp->attr.class_pointer;
+ else
+ pointer = comp->attr.pointer;
allocatable = comp->attr.allocatable;
}
if (pointer || attr.proc_pointer)
@@ -2733,7 +2741,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
case REF_INQUIRY:
case REF_SUBSTRING:
- allocatable = pointer = 0;
+ allocatable = pointer = optional = false;
break;
}
@@ -2743,6 +2751,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
attr.allocatable = allocatable;
attr.target = target;
attr.save = sym->attr.save;
+ attr.optional = optional;
return attr;
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 1480dce722e..c9d2b4a1902 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6554,7 +6554,9 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Add the initialization code to the start of the function. */
- if (sym->attr.optional || sym->attr.not_always_present)
+ if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+ || sym->attr.optional
+ || sym->attr.not_always_present)
{
tree nullify;
if (TREE_CODE (parm) != PARM_DECL)
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 93e2c46e473..e65a525bf6c 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1303,7 +1303,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
DECL_EXTERNAL (decl) = 0;
/* Avoid uninitialized warnings for optional dummy arguments. */
- if (sym->attr.optional)
+ if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+ || sym->attr.optional)
TREE_NO_WARNING (decl) = 1;
/* We should never get deferred shape arrays here. We used to because of
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e4a3d7ff36c..cf1d8a47453 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5454,7 +5454,8 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
if (POINTER_TYPE_P (TREE_TYPE (desc)))
desc = build_fold_indirect_ref_loc (input_location, desc);
-
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
+ desc = gfc_class_data_get (desc);
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
return;
@@ -6533,43 +6534,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
sym->name, NULL);
- /* Special case for assumed-rank arrays. */
- if (!sym->attr.is_bind_c && e && fsym && fsym->as
- && fsym->as->type == AS_ASSUMED_RANK
- && e->rank != -1)
- {
- if ((gfc_expr_attr (e).pointer
- || gfc_expr_attr (e).allocatable)
- && ((fsym->ts.type == BT_CLASS
- && (CLASS_DATA (fsym)->attr.class_pointer
- || CLASS_DATA (fsym)->attr.allocatable))
- || (fsym->ts.type != BT_CLASS
- && (fsym->attr.pointer || fsym->attr.allocatable))))
- {
- /* Unallocated allocatable arrays and unassociated pointer
- arrays need their dtype setting if they are argument
- associated with assumed rank dummies. However, if the
- dummy is nonallocate/nonpointer, the user may not
- pass those. Hence, it can be skipped. */
- set_dtype_for_unallocated (&parmse, e);
- }
- else if (e->expr_type == EXPR_VARIABLE
- && e->ref
- && e->ref->u.ar.type == AR_FULL
- && e->symtree->n.sym->attr.dummy
- && e->symtree->n.sym->as
- && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
- {
- tree minus_one;
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
- minus_one = build_int_cst (gfc_array_index_type, -1);
- gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
- gfc_rank_cst[e->rank - 1],
- minus_one);
- }
- }
-
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
@@ -6621,6 +6585,46 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
}
+ /* Special case for an assumed-rank dummy argument. */
+ if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
+ && (fsym->ts.type == BT_CLASS
+ ? (CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
+ {
+ if (fsym->ts.type == BT_CLASS
+ ? (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable)
+ : (fsym->attr.pointer || fsym->attr.allocatable))
+ {
+ /* Unallocated allocatable arrays and unassociated pointer
+ arrays need their dtype setting if they are argument
+ associated with assumed rank dummies to set the rank. */
+ set_dtype_for_unallocated (&parmse, e);
+ }
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy
+ && (e->ts.type == BT_CLASS
+ ? (e->ref && e->ref->next
+ && e->ref->next->type == REF_ARRAY
+ && e->ref->next->u.ar.type == AR_FULL
+ && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
+ : (e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.type == AR_FULL
+ && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
+ {
+ /* Assumed-size actual to assumed-rank dummy requires
+ dim[rank-1].ubound = -1. */
+ tree minus_one;
+ tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ if (fsym->ts.type == BT_CLASS)
+ tmp = gfc_class_data_get (tmp);
+ minus_one = build_int_cst (gfc_array_index_type, -1);
+ gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+ gfc_rank_cst[e->rank - 1],
+ minus_one);
+ }
+ }
/* The case with fsym->attr.optional is that of a user subroutine
with an interface indicating an optional argument. When we call
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 5c5841a9f22..63a241ad9c1 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2342,7 +2342,8 @@ gfc_sym_type (gfc_symbol * sym)
{
/* We must use pointer types for potentially absent variables. The
optimizers assume a reference type argument is never NULL. */
- if (sym->attr.optional
+ if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
+ || sym->attr.optional
|| (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
type = build_pointer_type (type);
else
diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index c4ecd4f1c27..3797ca2628c 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,11 @@
+2021-10-12 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2021-10-12 Tobias Burnus <tobias@codesourcery.com>
+
+ PR fortran/102541
+ * gfortran.dg/assumed_rank_24.f90: New test.
+
2021-10-12 Tobias Burnus <tobias@codesourcery.com>
* gfortran.dg/gomp/defaultmap-2.f90: Replace unsupported
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_24.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90
new file mode 100644
index 00000000000..d91b5ecdc46
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90
@@ -0,0 +1,137 @@
+! { dg-do run }
+! { dg-additional-options "-fcheck=all" }
+module m
+ implicit none (external, type)
+contains
+ subroutine cl(x)
+ class(*) :: x(..)
+ if (rank(x) /= 1) stop 1
+ if (ubound(x, dim=1) /= -1) stop 2
+ select rank (x)
+ rank (1)
+ select type (x)
+ type is (integer)
+ ! ok
+ class default
+ stop 3
+ end select
+ end select
+ end subroutine
+ subroutine tp(x)
+ type(*) :: x(..)
+ if (rank(x) /= 1) stop 4
+ if (ubound(x, dim=1) /= -1) stop 5
+ end subroutine
+
+ subroutine foo (ccc, ddd, sss, ttt)
+ integer :: sss(*), ttt(*)
+ class(*) :: ccc(*), ddd(*)
+ call cl(sss)
+ call tp(ttt)
+ call cl(ccc)
+ call tp(ddd)
+ end
+
+ subroutine foo2 (ccc, ddd, sss, ttt, ispresent)
+ integer :: sss(*), ttt(*)
+ class(*) :: ccc(*), ddd(*)
+ optional :: ccc, ddd, sss, ttt
+ logical, value :: ispresent
+ if (present(ccc) .neqv. ispresent) stop 6
+ if (present(ccc)) then
+ call cl(sss)
+ call tp(ttt)
+ call cl(ccc)
+ call tp(ddd)
+ end if
+ end
+end
+
+module m2
+ implicit none (external, type)
+contains
+ subroutine cl2(x)
+ class(*), allocatable :: x(..)
+ if (rank(x) /= 1) stop 7
+ if (.not. allocated (x)) &
+ return
+ if (lbound(x, dim=1) /= -2) stop 8
+ if (ubound(x, dim=1) /= -1) stop 9
+ if (size (x, dim=1) /= 2) stop 10
+ select rank (x)
+ rank (1)
+ select type (x)
+ type is (integer)
+ ! ok
+ class default
+ stop 11
+ end select
+ end select
+ end subroutine
+
+ subroutine tp2(x)
+ class(*), pointer :: x(..)
+ if (rank(x) /= 1) stop 12
+ if (.not. associated (x)) &
+ return
+ if (lbound(x, dim=1) /= -2) stop 13
+ if (ubound(x, dim=1) /= -1) stop 14
+ if (size (x, dim=1) /= 2) stop 15
+ select rank (x)
+ rank (1)
+ select type (x)
+ type is (integer)
+ ! ok
+ class default
+ stop 16
+ end select
+ end select
+ end subroutine
+
+ subroutine foo3 (ccc, ddd, sss, ttt)
+ class(*), allocatable :: sss(:)
+ class(*), pointer :: ttt(:)
+ class(*), allocatable :: ccc(:)
+ class(*), pointer :: ddd(:)
+ call cl2(sss)
+ call tp2(ttt)
+ call cl2(ccc)
+ call tp2(ddd)
+ end
+
+ subroutine foo4 (ccc, ddd, sss, ttt, ispresent)
+ class(*), allocatable, optional :: sss(:)
+ class(*), pointer, optional :: ttt(:)
+ class(*), allocatable, optional :: ccc(:)
+ class(*), pointer, optional :: ddd(:)
+ logical, value :: ispresent
+ if (present(ccc) .neqv. ispresent) stop 17
+ if (present(ccc)) then
+ call cl2(sss)
+ call tp2(ttt)
+ call cl2(ccc)
+ call tp2(ddd)
+ end if
+ end
+end
+
+use m
+use m2
+implicit none (external, type)
+integer :: a(1),b(1),c(1),d(1)
+class(*),allocatable :: aa(:),cc(:)
+class(*),pointer :: bb(:),dd(:)
+call foo (a,b,c,d)
+call foo2 (a,b,c,d, .true.)
+call foo2 (ispresent=.false.)
+
+nullify(bb,dd)
+call foo3 (aa,bb,cc,dd)
+call foo4 (aa,bb,cc,dd, .true.)
+call foo4 (ispresent=.false.)
+allocate(integer :: aa(-2:-1), bb(-2:-1), cc(-2:-1), dd(-2:-1))
+call foo3 (aa,bb,cc,dd)
+call foo4 (aa,bb,cc,dd, .true.)
+call foo4 (ispresent=.false.)
+deallocate(aa,bb,cc,dd)
+end
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-10-12 8:06 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-10-12 8:06 [gcc/devel/omp/gcc-11] Fortran: Various CLASS + assumed-rank fixed [PR102541] Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).