re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument)
fortran/ PR fortran/50981 * gfortran.h (gfc_is_class_container_ref): New prototype. * class.c (gfc_is_class_container_ref): New function. * trans-expr.c (gfc_conv_procedure_call): Add a "_data" component reference to polymorphic actual arguments. testsuite/ PR fortran/50981 * gfortran.dg/elemental_optional_args_5.f03: Add subcomponent actual argument checks. From-SVN: r184904
This commit is contained in:
parent
f0050a4b2a
commit
5bf5fa563a
|
@ -1,3 +1,11 @@
|
|||
2012-03-04 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/50981
|
||||
* gfortran.h (gfc_is_class_container_ref): New prototype.
|
||||
* class.c (gfc_is_class_container_ref): New function.
|
||||
* trans-expr.c (gfc_conv_procedure_call): Add a "_data" component
|
||||
reference to polymorphic actual arguments.
|
||||
|
||||
2012-03-04 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/50981
|
||||
|
|
|
@ -361,6 +361,39 @@ gfc_is_class_scalar_expr (gfc_expr *e)
|
|||
}
|
||||
|
||||
|
||||
/* Tells whether the expression E is a reference to a (scalar) class container.
|
||||
Scalar because array class containers usually have an array reference after
|
||||
them, and gfc_fix_class_refs will add the missing "_data" component reference
|
||||
in that case. */
|
||||
|
||||
bool
|
||||
gfc_is_class_container_ref (gfc_expr *e)
|
||||
{
|
||||
gfc_ref *ref;
|
||||
bool result;
|
||||
|
||||
if (e->expr_type != EXPR_VARIABLE)
|
||||
return e->ts.type == BT_CLASS;
|
||||
|
||||
if (e->symtree->n.sym->ts.type == BT_CLASS)
|
||||
result = true;
|
||||
else
|
||||
result = false;
|
||||
|
||||
for (ref = e->ref; ref; ref = ref->next)
|
||||
{
|
||||
if (ref->type != REF_COMPONENT)
|
||||
result = false;
|
||||
else if (ref->u.c.component->ts.type == BT_CLASS)
|
||||
result = true;
|
||||
else
|
||||
result = false;
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/* Build a NULL initializer for CLASS pointers,
|
||||
initializing the _data component to NULL and
|
||||
the _vptr component to the declared type. */
|
||||
|
|
|
@ -2930,6 +2930,7 @@ void gfc_add_class_array_ref (gfc_expr *);
|
|||
#define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
|
||||
bool gfc_is_class_array_ref (gfc_expr *, bool *);
|
||||
bool gfc_is_class_scalar_expr (gfc_expr *);
|
||||
bool gfc_is_class_container_ref (gfc_expr *e);
|
||||
gfc_expr *gfc_class_null_initializer (gfc_typespec *);
|
||||
unsigned int gfc_hash_value (gfc_symbol *);
|
||||
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
|
||||
|
|
|
@ -3542,6 +3542,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|
|||
else
|
||||
gfc_conv_expr_reference (&parmse, e);
|
||||
|
||||
if (fsym && fsym->ts.type == BT_DERIVED
|
||||
&& gfc_is_class_container_ref (e))
|
||||
parmse.expr = gfc_class_data_get (parmse.expr);
|
||||
|
||||
/* If we are passing an absent array as optional dummy to an
|
||||
elemental procedure, make sure that we pass NULL when the data
|
||||
pointer is NULL. We need this extra conditional because of
|
||||
|
|
|
@ -1,3 +1,9 @@
|
|||
2012-03-04 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/50981
|
||||
* gfortran.dg/elemental_optional_args_5.f03: Add subcomponent actual
|
||||
argument checks.
|
||||
|
||||
2012-03-04 H.J. Lu <hongjiu.lu@intel.com>
|
||||
|
||||
PR target/52146
|
||||
|
|
|
@ -115,6 +115,111 @@ call sub_t (v, tp, .false.)
|
|||
if (s /= 3) call abort()
|
||||
if (any (v /= [9, 33])) call abort()
|
||||
|
||||
call sub_t (s, ca, .false.)
|
||||
call sub_t (v, ca, .false.)
|
||||
!print *, s, v
|
||||
if (s /= 3) call abort()
|
||||
if (any (v /= [9, 33])) call abort()
|
||||
|
||||
call sub_t (s, cp, .false.)
|
||||
call sub_t (v, cp, .false.)
|
||||
!print *, s, v
|
||||
if (s /= 3) call abort()
|
||||
if (any (v /= [9, 33])) call abort()
|
||||
|
||||
! SCALAR COMPONENTS: alloc/assoc
|
||||
|
||||
allocate (ta, tp, ca, cp)
|
||||
ta%a = 4
|
||||
tp%a = 5
|
||||
ca%a = 6
|
||||
cp%a = 7
|
||||
|
||||
call sub_t (s, ta, .true.)
|
||||
call sub_t (v, ta, .true.)
|
||||
!print *, s, v
|
||||
if (s /= 4*2) call abort()
|
||||
if (any (v /= [4*2, 4*2])) call abort()
|
||||
|
||||
call sub_t (s, tp, .true.)
|
||||
call sub_t (v, tp, .true.)
|
||||
!print *, s, v
|
||||
if (s /= 5*2) call abort()
|
||||
if (any (v /= [5*2, 5*2])) call abort()
|
||||
|
||||
call sub_t (s, ca, .true.)
|
||||
call sub_t (v, ca, .true.)
|
||||
!print *, s, v
|
||||
if (s /= 6*2) call abort()
|
||||
if (any (v /= [6*2, 6*2])) call abort()
|
||||
|
||||
call sub_t (s, cp, .true.)
|
||||
call sub_t (v, cp, .true.)
|
||||
!print *, s, v
|
||||
if (s /= 7*2) call abort()
|
||||
if (any (v /= [7*2, 7*2])) call abort()
|
||||
|
||||
! ARRAY COMPONENTS: Non alloc/assoc
|
||||
|
||||
v = [9, 33]
|
||||
|
||||
call sub_t (v, taa, .false.)
|
||||
!print *, v
|
||||
if (any (v /= [9, 33])) call abort()
|
||||
|
||||
call sub_t (v, tpa, .false.)
|
||||
!print *, v
|
||||
if (any (v /= [9, 33])) call abort()
|
||||
|
||||
call sub_t (v, caa, .false.)
|
||||
!print *, v
|
||||
if (any (v /= [9, 33])) call abort()
|
||||
|
||||
call sub_t (v, cpa, .false.)
|
||||
!print *, v
|
||||
if (any (v /= [9, 33])) call abort()
|
||||
|
||||
deallocate(ta, tp, ca, cp)
|
||||
|
||||
|
||||
! ARRAY COMPONENTS: alloc/assoc
|
||||
|
||||
allocate (taa(2), tpa(2))
|
||||
taa(1:2)%a = [44, 444]
|
||||
tpa(1:2)%a = [55, 555]
|
||||
allocate (caa(2), source=[t(66), t(666)])
|
||||
allocate (cpa(2), source=[t(77), t(777)])
|
||||
|
||||
select type (caa)
|
||||
type is (t)
|
||||
if (any (caa(:)%a /= [66, 666])) call abort()
|
||||
end select
|
||||
|
||||
select type (cpa)
|
||||
type is (t)
|
||||
if (any (cpa(:)%a /= [77, 777])) call abort()
|
||||
end select
|
||||
|
||||
call sub_t (v, taa, .true.)
|
||||
!print *, v
|
||||
if (any (v /= [44*2, 444*2])) call abort()
|
||||
|
||||
call sub_t (v, tpa, .true.)
|
||||
!print *, v
|
||||
if (any (v /= [55*2, 555*2])) call abort()
|
||||
|
||||
|
||||
call sub_t (v, caa, .true.)
|
||||
!print *, v
|
||||
if (any (v /= [66*2, 666*2])) call abort()
|
||||
|
||||
call sub_t (v, cpa, .true.)
|
||||
!print *, v
|
||||
if (any (v /= [77*2, 777*2])) call abort()
|
||||
|
||||
deallocate (taa, tpa, caa, cpa)
|
||||
|
||||
|
||||
contains
|
||||
|
||||
elemental subroutine sub1 (x, y, alloc)
|
||||
|
|
Loading…
Reference in New Issue