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)
+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:
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",
"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",
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;
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
{
if (ref->type == REF_INQUIRY)
{
has_inquiry_part = true;
+ optional = false;
break;
}
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:
break;
case REF_COMPONENT:
+ optional = false;
comp = ref->u.c.component;
attr = comp->attr;
if (ts != NULL && !has_inquiry_part)
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)
case REF_INQUIRY:
case REF_SUBSTRING:
- allocatable = pointer = 0;
+ allocatable = pointer = optional = false;
break;
}
attr.allocatable = allocatable;
attr.target = target;
attr.save = sym->attr.save;
+ attr.optional = optional;
return attr;
}
/* 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)
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
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;
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
}
}
}
+ /* 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
{
/* 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
+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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
