===================================================================
***************
e->value.compcall.base_object = base;
e->value.compcall.ignore_pass = 1;
e->value.compcall.assign = 0;
+ if (e->ts.type == BT_UNKNOWN
+ && target->function)
+ {
+ if (target->is_generic)
+ e->ts = target->u.generic->specific->u.specific->n.sym->ts;
+ else
+ e->ts = target->u.specific->n.sym->ts;
+ }
}
***************
gcc_assert (tb_base);
build_compcall_for_operator (e, actual, tb_base, tbo, gname);
-
result = gfc_resolve_expr (e);
if (result == FAILURE)
return MATCH_ERROR;
===================================================================
***************
gfc_add_expr_to_block (&se->pre, tmp);
+ if (expr->ts.type == BT_CLASS && expr3)
+ {
+ tmp = build_int_cst (unsigned_char_type_node, 0);
+ /* With class objects, it is best to play safe and null the
+ memory because we cannot know if dynamic types have allocatable
+ components or not. */
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, pointer, tmp, size);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
/* Update the array descriptors. */
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
===================================================================
***************
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
+
+ static tree
+ gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
+ {
+ gfc_actual_arglist *actual;
+ gfc_expr *ppc;
+ gfc_code *ppc_code;
+ tree res;
+
+ actual = gfc_get_actual_arglist ();
+ actual->expr = gfc_copy_expr (rhs);
+ actual->next = gfc_get_actual_arglist ();
+ actual->next->expr = gfc_copy_expr (lhs);
+ ppc = gfc_copy_expr (obj);
+ gfc_add_vptr_component (ppc);
+ gfc_add_component_ref (ppc, "_copy");
+ ppc_code = gfc_get_code ();
+ ppc_code->resolved_sym = ppc->symtree->n.sym;
+ /* Although '_copy' is set to be elemental in class.c, it is
+ not staying that way. Find out why, sometime.... */
+ ppc_code->resolved_sym->attr.elemental = 1;
+ ppc_code->ext.actual = actual;
+ ppc_code->expr1 = ppc;
+ ppc_code->op = EXEC_CALL;
+ /* Since '_copy' is elemental, the scalarizer will take care
+ of arrays in gfc_trans_call. */
+ res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
+ gfc_free_statements (ppc_code);
+ return res;
+ }
+
+ /* Special case for initializing a polymorphic dummy with INTENT(OUT).
+ A MEMCPY is needed to copy the full data from the default initializer
+ of the dynamic type. */
+
+ tree
+ gfc_trans_class_init_assign (gfc_code *code)
+ {
+ stmtblock_t block;
+ tree tmp;
+ gfc_se dst,src,memsz;
+ gfc_expr *lhs,*rhs,*sz;
+
+ gfc_start_block (&block);
+
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_data_component (lhs);
+
+ rhs = gfc_copy_expr (code->expr1);
+ gfc_add_vptr_component (rhs);
+
+ /* Make sure that the component backend_decls have been built, which
+ will not have happened if the derived types concerned have not
+ been referenced. */
+ gfc_get_derived_type (rhs->ts.u.derived);
+ gfc_add_def_init_component (rhs);
+
+ if (code->expr1->ts.type == BT_CLASS
+ && CLASS_DATA (code->expr1)->attr.dimension)
+ tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+ else
+ {
+ sz = gfc_copy_expr (code->expr1);
+ gfc_add_vptr_component (sz);
+ gfc_add_size_component (sz);
+
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_init_se (&memsz, NULL);
+ gfc_conv_expr (&dst, lhs);
+ gfc_conv_expr (&src, rhs);
+ gfc_conv_expr (&memsz, sz);
+ gfc_add_block_to_block (&block, &src.pre);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+ }
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+ }
+
+
+ /* Translate an assignment to a CLASS object
+ (pointer or ordinary assignment). */
+
+ tree
+ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
+ {
+ stmtblock_t block;
+ tree tmp;
+ gfc_expr *lhs;
+ gfc_expr *rhs;
+ gfc_ref *ref;
+
+ gfc_start_block (&block);
+
+ ref = expr1->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+
+ /* Class valued proc_pointer assignments do not need any further
+ preparation. */
+ if (ref && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
+ && op == EXEC_POINTER_ASSIGN)
+ goto assign;
+
+ if (expr2->ts.type != BT_CLASS)
+ {
+ /* Insert an additional assignment which sets the '_vptr' field. */
+ gfc_symbol *vtab = NULL;
+ gfc_symtree *st;
+
+ lhs = gfc_copy_expr (expr1);
+ gfc_add_vptr_component (lhs);
+
+ if (expr2->ts.type == BT_DERIVED)
+ vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
+ else if (expr2->expr_type == EXPR_NULL)
+ vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+ gcc_assert (vtab);
+
+ rhs = gfc_get_expr ();
+ rhs->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+ rhs->symtree = st;
+ rhs->ts = vtab->ts;
+
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+ }
+ else if (CLASS_DATA (expr2)->attr.dimension)
+ {
+ /* Insert an additional assignment which sets the '_vptr' field. */
+ lhs = gfc_copy_expr (expr1);
+ gfc_add_vptr_component (lhs);
+
+ rhs = gfc_copy_expr (expr2);
+ gfc_add_vptr_component (rhs);
+
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+ }
+
+ /* Do the actual CLASS assignment. */
+ if (expr2->ts.type == BT_CLASS
+ && !CLASS_DATA (expr2)->attr.dimension)
+ op = EXEC_ASSIGN;
+ else
+ gfc_add_data_component (expr1);
+
+ assign:
+
+ if (op == EXEC_ASSIGN)
+ tmp = gfc_trans_assignment (expr1, expr2, false, true);
+ else if (op == EXEC_POINTER_ASSIGN)
+ tmp = gfc_trans_pointer_assignment (expr1, expr2);
+ else
+ gcc_unreachable();
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+ }
+
+
/* End of prototype trans-class.c */
***************
}
+ /* Convert a typebound function reference from a class object. */
+ static void
+ conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
+ {
+ gfc_ref *ref;
+ tree var;
+
+ if (TREE_CODE (base_object) != VAR_DECL)
+ {
+ var = gfc_create_var (TREE_TYPE (base_object), NULL);
+ gfc_add_modify (&se->pre, var, base_object);
+ }
+ se->expr = gfc_class_vptr_get (base_object);
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+ ref = expr->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+ gcc_assert (ref && ref->type == REF_COMPONENT);
+ if (ref->u.c.sym->attr.extension)
+ conv_parent_component_references (se, ref);
+ gfc_conv_component_ref (se, ref);
+ se->expr = build_fold_addr_expr_loc (input_location, se->expr);
+ }
+
+
static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
***************
tree type;
tree var;
tree len;
+ tree base_object;
VEC(tree,gc) *stringargs;
tree result = NULL;
gfc_formal_arglist *formal;
***************
!= EXPR_CONSTANT);
}
+ base_object = NULL_TREE;
+
/* Evaluate the arguments. */
for (arg = args; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL)
***************
{
gfc_conv_expr_reference (&parmse, e);
+ /* Catch base objects that are not variables. */
+ if (e->ts.type == BT_CLASS
+ && e->expr_type != EXPR_VARIABLE
+ && expr && e == expr->base_expr)
+ 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
***************
arglist = retargs;
/* Generate the actual call. */
! conv_function_val (se, sym, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
arglist = retargs;
/* Generate the actual call. */
! if (base_object == NULL_TREE)
! conv_function_val (se, sym, expr);
! else
! conv_base_obj_fcn_val (se, base_object, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
***************
return;
}
-
gfc_conv_expr (se, expr);
/* Create a temporary var to hold the value. */
***************
{
return gfc_trans_assignment (code->expr1, code->expr2, false, true);
}
-
-
- static tree
- gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
- {
- gfc_actual_arglist *actual;
- gfc_expr *ppc;
- gfc_code *ppc_code;
- tree res;
-
- actual = gfc_get_actual_arglist ();
- actual->expr = gfc_copy_expr (rhs);
- actual->next = gfc_get_actual_arglist ();
- actual->next->expr = gfc_copy_expr (lhs);
- ppc = gfc_copy_expr (obj);
- gfc_add_vptr_component (ppc);
- gfc_add_component_ref (ppc, "_copy");
- ppc_code = gfc_get_code ();
- ppc_code->resolved_sym = ppc->symtree->n.sym;
- /* Although '_copy' is set to be elemental in class.c, it is
- not staying that way. Find out why, sometime.... */
- ppc_code->resolved_sym->attr.elemental = 1;
- ppc_code->ext.actual = actual;
- ppc_code->expr1 = ppc;
- ppc_code->op = EXEC_CALL;
- /* Since '_copy' is elemental, the scalarizer will take care
- of arrays in gfc_trans_call. */
- res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
- gfc_free_statements (ppc_code);
- return res;
- }
-
- /* Special case for initializing a polymorphic dummy with INTENT(OUT).
- A MEMCPY is needed to copy the full data from the default initializer
- of the dynamic type. */
-
- tree
- gfc_trans_class_init_assign (gfc_code *code)
- {
- stmtblock_t block;
- tree tmp;
- gfc_se dst,src,memsz;
- gfc_expr *lhs,*rhs,*sz;
-
- gfc_start_block (&block);
-
- lhs = gfc_copy_expr (code->expr1);
- gfc_add_data_component (lhs);
-
- rhs = gfc_copy_expr (code->expr1);
- gfc_add_vptr_component (rhs);
-
- /* Make sure that the component backend_decls have been built, which
- will not have happened if the derived types concerned have not
- been referenced. */
- gfc_get_derived_type (rhs->ts.u.derived);
- gfc_add_def_init_component (rhs);
-
- if (code->expr1->ts.type == BT_CLASS
- && CLASS_DATA (code->expr1)->attr.dimension)
- tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
- else
- {
- sz = gfc_copy_expr (code->expr1);
- gfc_add_vptr_component (sz);
- gfc_add_size_component (sz);
-
- gfc_init_se (&dst, NULL);
- gfc_init_se (&src, NULL);
- gfc_init_se (&memsz, NULL);
- gfc_conv_expr (&dst, lhs);
- gfc_conv_expr (&src, rhs);
- gfc_conv_expr (&memsz, sz);
- gfc_add_block_to_block (&block, &src.pre);
- tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
- }
- gfc_add_expr_to_block (&block, tmp);
-
- return gfc_finish_block (&block);
- }
-
-
- /* Translate an assignment to a CLASS object
- (pointer or ordinary assignment). */
-
- tree
- gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
- {
- stmtblock_t block;
- tree tmp;
- gfc_expr *lhs;
- gfc_expr *rhs;
-
- gfc_start_block (&block);
-
- if (expr2->ts.type != BT_CLASS)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- gfc_symbol *vtab = NULL;
- gfc_symtree *st;
-
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- if (expr2->ts.type == BT_DERIVED)
- vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
- else if (expr2->expr_type == EXPR_NULL)
- vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
- gcc_assert (vtab);
-
- rhs = gfc_get_expr ();
- rhs->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
- rhs->symtree = st;
- rhs->ts = vtab->ts;
-
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
- else if (CLASS_DATA (expr2)->attr.dimension)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- rhs = gfc_copy_expr (expr2);
- gfc_add_vptr_component (rhs);
-
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
-
- /* Do the actual CLASS assignment. */
- if (expr2->ts.type == BT_CLASS && !CLASS_DATA (expr2)->attr.dimension)
- op = EXEC_ASSIGN;
- else
- gfc_add_data_component (expr1);
-
- if (op == EXEC_ASSIGN)
- tmp = gfc_trans_assignment (expr1, expr2, false, true);
- else if (op == EXEC_POINTER_ASSIGN)
- tmp = gfc_trans_pointer_assignment (expr1, expr2);
- else
- gcc_unreachable();
-
- gfc_add_expr_to_block (&block, tmp);
-
- return gfc_finish_block (&block);
- }
===================================================================
***************
locus where;
+ /* Used to store the base expression in component calls, when the expression
+ is not a variable. */
+ gfc_expr *base_expr;
+
/* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
denotes a signalling not-a-number. */
unsigned int is_boz : 1, is_snan : 1;
===================================================================
***************
reference list. */
static gfc_symbol*
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
! gfc_expr *e)
{
gfc_symbol *declared;
gfc_ref *ref;
reference list. */
static gfc_symbol*
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
! gfc_expr *e, bool types)
{
gfc_symbol *declared;
gfc_ref *ref;
***************
if (ref->type != REF_COMPONENT)
continue;
! if (ref->u.c.component->ts.type == BT_CLASS
! || ref->u.c.component->ts.type == BT_DERIVED)
{
declared = ref->u.c.component->ts.u.derived;
if (class_ref)
if (ref->type != REF_COMPONENT)
continue;
! if ((ref->u.c.component->ts.type == BT_CLASS
! || (types && ref->u.c.component->ts.type == BT_DERIVED))
! && ref->u.c.component->attr.flavor != FL_PROCEDURE)
{
declared = ref->u.c.component->ts.u.derived;
if (class_ref)
***************
success:
/* Make sure that we have the right specific instance for the name. */
! derived = get_declared_from_expr (NULL, NULL, e);
st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
success:
/* Make sure that we have the right specific instance for the name. */
! derived = get_declared_from_expr (NULL, NULL, e, true);
st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
***************
overridable = !e->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
+ /* If the base_object is not a variable, the corresponding actual
+ argument expression must be stored in e->base_expression so
+ that the corresponding tree temporary can be used as the base
+ object in gfc_conv_procedure_call. */
+ if (expr->expr_type != EXPR_VARIABLE)
+ {
+ gfc_actual_arglist *args;
+
+ for (args= e->value.function.actual; args; args = args->next)
+ {
+ if (expr == args->expr)
+ expr = args->expr;
+ }
+ }
+
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
***************
name = name ? name : e->value.function.esym->name;
e->symtree = expr->symtree;
e->ref = gfc_copy_ref (expr->ref);
+
+ /* Trim away the extraneous references that emerge from nested
+ use of interface.c (extend_expr). */
+ get_declared_from_expr (&class_ref, NULL, e, false);
+ if (class_ref && class_ref->next)
+ {
+ gfc_free_ref_list (class_ref->next);
+ class_ref->next = NULL;
+ }
+ else if (e->ref && !class_ref)
+ {
+ gfc_free_ref_list (e->ref);
+ e->ref = NULL;
+ }
+
+ /* Now use the procedure in the vtable. */
gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
e->value.function.esym = NULL;
+ if (expr->expr_type != EXPR_VARIABLE)
+ e->base_expr = expr;
return SUCCESS;
}
***************
return FAILURE;
/* Get the CLASS declared type. */
! declared = get_declared_from_expr (&class_ref, &new_ref, e);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
return FAILURE;
/* Get the CLASS declared type. */
! declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
***************
overridable = !code->expr1->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
{
+ /* If the base_object is not a variable, the corresponding actual
+ argument expression must be stored in e->base_expression so
+ that the corresponding tree temporary can be used as the base
+ object in gfc_conv_procedure_call. */
+ if (expr->expr_type != EXPR_VARIABLE)
+ {
+ gfc_actual_arglist *args;
+
+ args= code->expr1->value.function.actual;
+ for (; args; args = args->next)
+ {
+ if (expr == args->expr)
+ expr = args->expr;
+ }
+ }
+
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
***************
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
code->expr1->ref = gfc_copy_ref (expr->ref);
+
+ /* Trim away the extraneous references that emerge from nested
+ use of interface.c (extend_expr). */
+ get_declared_from_expr (&class_ref, NULL, code->expr1, false);
+ if (class_ref && class_ref->next)
+ {
+ gfc_free_ref_list (class_ref->next);
+ class_ref->next = NULL;
+ }
+ else if (code->expr1->ref && !class_ref)
+ {
+ gfc_free_ref_list (code->expr1->ref);
+ code->expr1->ref = NULL;
+ }
+
+ /* Now use the procedure in the vtable. */
gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
+ if (expr->expr_type != EXPR_VARIABLE)
+ code->expr1->base_expr = expr;
return SUCCESS;
}
***************
return FAILURE;
/* Get the CLASS declared type. */
! get_declared_from_expr (&class_ref, &new_ref, code->expr1);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
return FAILURE;
/* Get the CLASS declared type. */
! get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
===================================================================
***************
+ ! { dg-do run }
+ ! PR46328 - complex expressions involving typebound operators of class objects.
+ !
+ module field_module
+ implicit none
+ type ,abstract :: field
+ contains
+ procedure(field_op_real) ,deferred :: multiply_real
+ procedure(field_plus_field) ,deferred :: plus
+ procedure(assign_field) ,deferred :: assn
+ generic :: operator(*) => multiply_real
+ generic :: operator(+) => plus
+ generic :: ASSIGNMENT(=) => assn
+ end type
+ abstract interface
+ function field_plus_field(lhs,rhs)
+ import :: field
+ class(field) ,intent(in) :: lhs
+ class(field) ,intent(in) :: rhs
+ class(field) ,allocatable :: field_plus_field
+ end function
+ end interface
+ abstract interface
+ function field_op_real(lhs,rhs)
+ import :: field
+ class(field) ,intent(in) :: lhs
+ real ,intent(in) :: rhs
+ class(field) ,allocatable :: field_op_real
+ end function
+ end interface
+ abstract interface
+ subroutine assign_field(lhs,rhs)
+ import :: field
+ class(field) ,intent(OUT) :: lhs
+ class(field) ,intent(IN) :: rhs
+ end subroutine
+ end interface
+ end module
+
+ module i_field_module
+ use field_module
+ implicit none
+ type, extends (field) :: i_field
+ integer :: i
+ contains
+ procedure :: multiply_real => i_multiply_real
+ procedure :: plus => i_plus_i
+ procedure :: assn => i_assn
+ end type
+ contains
+ function i_plus_i(lhs,rhs)
+ class(i_field) ,intent(in) :: lhs
+ class(field) ,intent(in) :: rhs
+ class(field) ,allocatable :: i_plus_i
+ integer :: m = 0
+ select type (lhs)
+ type is (i_field); m = lhs%i
+ end select
+ select type (rhs)
+ type is (i_field); m = rhs%i + m
+ end select
+ allocate (i_plus_i, source = i_field (m))
+ end function
+ function i_multiply_real(lhs,rhs)
+ class(i_field) ,intent(in) :: lhs
+ real ,intent(in) :: rhs
+ class(field) ,allocatable :: i_multiply_real
+ integer :: m = 0
+ select type (lhs)
+ type is (i_field); m = lhs%i * int (rhs)
+ end select
+ allocate (i_multiply_real, source = i_field (m))
+ end function
+ subroutine i_assn(lhs,rhs)
+ class(i_field) ,intent(OUT) :: lhs
+ class(field) ,intent(IN) :: rhs
+ select type (lhs)
+ type is (i_field)
+ select type (rhs)
+ type is (i_field)
+ lhs%i = rhs%i
+ end select
+ end select
+ end subroutine
+ end module
+
+ program main
+ use i_field_module
+ implicit none
+ class(i_field) ,allocatable :: u
+ allocate (u, source = i_field (99))
+
+ u = u*2.
+ u = (u*2.0*4.0) + u*4.0
+ u = u%multiply_real (2.0)*4.0
+ u = i_multiply_real (u, 2.0) * 4.0
+
+ select type (u)
+ type is (i_field); if (u%i .ne. 152064) call abort
+ end select
+ end program
+ ! { dg-final { cleanup-modules "field_module i_field_module" } }
+