aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/check.c4
-rw-r--r--gcc/fortran/interface.c9
-rw-r--r--gcc/fortran/primary.c17
-rw-r--r--gcc/fortran/trans-array.c4
-rw-r--r--gcc/fortran/trans-decl.c3
-rw-r--r--gcc/fortran/trans-expr.c80
-rw-r--r--gcc/fortran/trans-types.c3
-rw-r--r--gcc/testsuite/gfortran.dg/assumed_rank_24.f90137
8 files changed, 209 insertions, 48 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f31ad68..677209e 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 2a71da7..24698be 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 56a78d6..d873264 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 e2f59e0..0c5cf4b 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6549,7 +6549,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 c758d26..87455f8 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)
suppress_warning (decl);
/* 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 1c24556..afca3a6 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 1c78a90..220976b 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/gfortran.dg/assumed_rank_24.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_24.f90
new file mode 100644
index 0000000..d91b5ec
--- /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
generated by cgit v1.1 at 2024-07-18 12:33:18 +0000