+2012-01-02 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/51529
+ * trans-array.c (gfc_array_allocate): Null allocated memory of
+ newly allocted class arrays.
+
+ PR fortran/46262
+ PR fortran/46328
+ PR fortran/51052
+ * interface.c(build_compcall_for_operator): Add a type to the
+ expression.
+ * trans-expr.c (conv_base_obj_fcn_val): New function.
+ (gfc_conv_procedure_call): Use base_expr to detect non-variable
+ base objects and, ensuring that there is a temporary variable,
+ build up the typebound call using conv_base_obj_fcn_val.
+ (gfc_trans_class_assign): Pick out class procedure pointer
+ assignments and do the assignment with no further prcessing.
+ (gfc_trans_class_array_init_assign, gfc_trans_class_init_assign
+ gfc_trans_class_assign): Move to top of file.
+ * gfortran.h : Add 'base_expr' field to gfc_expr.
+ * resolve.c (get_declared_from_expr): Add 'types' argument to
+ switch checking of derived types on or off.
+ (resolve_typebound_generic_call): Set the new argument.
+ (resolve_typebound_function, resolve_typebound_subroutine):
+ Set 'types' argument for get_declared_from_expr appropriately.
+ Identify base expression, if not a variable, in the argument
+ list of class valued calls. Assign it to the 'base_expr' field
+ of the final expression. Strip away all references after the
+ last class reference.
+
2012-01-02 Tobias Burnus <burnus@net-b.de>
PR fortran/51682
dumpfile = file;
show_namespace (ns);
}
+
/* gfortran header file
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010, 2011
+ 2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
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;
/* Deal with interfaces.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010
+ 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
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;
+ }
}
/* Perform type resolution on the various structures.
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010, 2011
+ 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
/* Get the ultimate declared type from an expression. In addition,
return the last class/derived type reference and the copy of the
- reference list. */
+ reference list. If check_types is set true, derived types are
+ identified as well as class references. */
static gfc_symbol*
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
- gfc_expr *e)
+ gfc_expr *e, bool check_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)
+ if ((ref->u.c.component->ts.type == BT_CLASS
+ || (check_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);
+ derived = get_declared_from_expr (NULL, NULL, e, true);
st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
/* Resolve a typebound function, or 'method'. First separate all
the non-CLASS references by calling resolve_compcall directly. */
-static gfc_try
+gfc_try
resolve_typebound_function (gfc_expr* e)
{
gfc_symbol *declared;
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);
+ get_declared_from_expr (&class_ref, NULL, e, false);
+
+ /* Trim away the extraneous references that emerge from nested
+ use of interface.c (extend_expr). */
+ 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;
+ }
+
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);
+ 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);
+ 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)
/* Array translation routines
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011
+ 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
gfc_add_expr_to_block (&se->pre, tmp);
+ if (expr->ts.type == BT_CLASS && expr3)
+ {
+ tmp = build_int_cst (unsigned_char_type_node, 0);
+ /* For class objects we need to nullify the memory in case they have
+ allocatable components; the reason is that _copy, which is used for
+ initialization, first frees the destination. */
+ 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);
/* Expression translation
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011
+ 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
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 (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);
-}
+2012-01-02 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/46262
+ PR fortran/46328
+ PR fortran/51052
+ * gfortran.dg/typebound_operator_7.f03: New.
+ * gfortran.dg/typebound_operator_8.f03: New.
+
2012-01-02 Richard Sandiford <rdsandiford@googlemail.com>
PR target/51729
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { dg-do run }
+!
+! Solve a diffusion problem using an object-oriented approach
+!
+! Author: Arjen Markus (comp.lang.fortran)
+! This version: pault@gcc.gnu.org
+!
+! Note:
+! (i) This could be turned into a more sophisticated program
+! using the techniques described in the chapter on
+! mathematical abstractions.
+! (That would allow the selection of the time integration
+! method in a transparent way)
+!
+! (ii) The target procedures for process_p and source_p are
+! different to the typebound procedures for dynamic types
+! because the passed argument is not type(base_pde_object).
+!
+! (iii) Two solutions are calculated, one with the procedure
+! pointers and the other with typebound procedures. The sums
+! of the solutions are compared.
+
+! (iv) The source is a delta function in the middle of the
+! mesh, whilst the process is quartic in the local value,
+! when it is positive.
+!
+! base_pde_objects --
+! Module to define the basic objects
+!
+module base_pde_objects
+ implicit none
+ type, abstract :: base_pde_object
+! No data
+ procedure(process_p), pointer, pass :: process_p
+ procedure(source_p), pointer, pass :: source_p
+ contains
+ procedure(process), deferred :: process
+ procedure(source), deferred :: source
+ procedure :: initialise
+ procedure :: nabla2
+ procedure :: print
+ procedure(real_times_obj), pass(obj), deferred :: real_times_obj
+ procedure(obj_plus_obj), deferred :: obj_plus_obj
+ procedure(obj_assign_obj), deferred :: obj_assign_obj
+ generic :: operator(*) => real_times_obj
+ generic :: operator(+) => obj_plus_obj
+ generic :: assignment(=) => obj_assign_obj
+ end type
+ abstract interface
+ function process_p (obj)
+ import base_pde_object
+ class(base_pde_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: process_p
+ end function process_p
+ end interface
+ abstract interface
+ function source_p (obj, time)
+ import base_pde_object
+ class(base_pde_object), intent(in) :: obj
+ real, intent(in) :: time
+ class(base_pde_object), allocatable :: source_p
+ end function source_p
+ end interface
+ abstract interface
+ function process (obj)
+ import base_pde_object
+ class(base_pde_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: process
+ end function process
+ end interface
+ abstract interface
+ function source (obj, time)
+ import base_pde_object
+ class(base_pde_object), intent(in) :: obj
+ real, intent(in) :: time
+ class(base_pde_object), allocatable :: source
+ end function source
+ end interface
+ abstract interface
+ function real_times_obj (factor, obj) result(newobj)
+ import base_pde_object
+ real, intent(in) :: factor
+ class(base_pde_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: newobj
+ end function real_times_obj
+ end interface
+ abstract interface
+ function obj_plus_obj (obj1, obj2) result(newobj)
+ import base_pde_object
+ class(base_pde_object), intent(in) :: obj1
+ class(base_pde_object), intent(in) :: obj2
+ class(base_pde_object), allocatable :: newobj
+ end function obj_plus_obj
+ end interface
+ abstract interface
+ subroutine obj_assign_obj (obj1, obj2)
+ import base_pde_object
+ class(base_pde_object), intent(inout) :: obj1
+ class(base_pde_object), intent(in) :: obj2
+ end subroutine obj_assign_obj
+ end interface
+contains
+! print --
+! Print the concentration field
+ subroutine print (obj)
+ class(base_pde_object) :: obj
+ ! Dummy
+ end subroutine print
+! initialise --
+! Initialise the concentration field using a specific function
+ subroutine initialise (obj, funcxy)
+ class(base_pde_object) :: obj
+ interface
+ real function funcxy (coords)
+ real, dimension(:), intent(in) :: coords
+ end function funcxy
+ end interface
+ ! Dummy
+ end subroutine initialise
+! nabla2 --
+! Determine the divergence
+ function nabla2 (obj)
+ class(base_pde_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: nabla2
+ ! Dummy
+ end function nabla2
+end module base_pde_objects
+! cartesian_2d_objects --
+! PDE object on a 2D cartesian grid
+!
+module cartesian_2d_objects
+ use base_pde_objects
+ implicit none
+ type, extends(base_pde_object) :: cartesian_2d_object
+ real, dimension(:,:), allocatable :: c
+ real :: dx
+ real :: dy
+ contains
+ procedure :: process => process_cart2d
+ procedure :: source => source_cart2d
+ procedure :: initialise => initialise_cart2d
+ procedure :: nabla2 => nabla2_cart2d
+ procedure :: print => print_cart2d
+ procedure, pass(obj) :: real_times_obj => real_times_cart2d
+ procedure :: obj_plus_obj => obj_plus_cart2d
+ procedure :: obj_assign_obj => obj_assign_cart2d
+ end type cartesian_2d_object
+ interface grid_definition
+ module procedure grid_definition_cart2d
+ end interface
+contains
+ function process_cart2d (obj)
+ class(cartesian_2d_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: process_cart2d
+ allocate (process_cart2d,source = obj)
+ select type (process_cart2d)
+ type is (cartesian_2d_object)
+ process_cart2d%c = -sign (obj%c, 1.0)*obj%c** 4
+ class default
+ call abort
+ end select
+ end function process_cart2d
+ function process_cart2d_p (obj)
+ class(base_pde_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: process_cart2d_p
+ allocate (process_cart2d_p,source = obj)
+ select type (process_cart2d_p)
+ type is (cartesian_2d_object)
+ select type (obj)
+ type is (cartesian_2d_object)
+ process_cart2d_p%c = -sign (obj%c, 1.0)*obj%c** 4
+ end select
+ class default
+ call abort
+ end select
+ end function process_cart2d_p
+ function source_cart2d (obj, time)
+ class(cartesian_2d_object), intent(in) :: obj
+ real, intent(in) :: time
+ class(base_pde_object), allocatable :: source_cart2d
+ integer :: m, n
+ m = size (obj%c, 1)
+ n = size (obj%c, 2)
+ allocate (source_cart2d, source = obj)
+ select type (source_cart2d)
+ type is (cartesian_2d_object)
+ if (allocated (source_cart2d%c)) deallocate (source_cart2d%c)
+ allocate (source_cart2d%c(m, n))
+ source_cart2d%c = 0.0
+ if (time .lt. 5.0) source_cart2d%c(m/2, n/2) = 0.1
+ class default
+ call abort
+ end select
+ end function source_cart2d
+
+ function source_cart2d_p (obj, time)
+ class(base_pde_object), intent(in) :: obj
+ real, intent(in) :: time
+ class(base_pde_object), allocatable :: source_cart2d_p
+ integer :: m, n
+ select type (obj)
+ type is (cartesian_2d_object)
+ m = size (obj%c, 1)
+ n = size (obj%c, 2)
+ class default
+ call abort
+ end select
+ allocate (source_cart2d_p,source = obj)
+ select type (source_cart2d_p)
+ type is (cartesian_2d_object)
+ if (allocated (source_cart2d_p%c)) deallocate (source_cart2d_p%c)
+ allocate (source_cart2d_p%c(m,n))
+ source_cart2d_p%c = 0.0
+ if (time .lt. 5.0) source_cart2d_p%c(m/2, n/2) = 0.1
+ class default
+ call abort
+ end select
+ end function source_cart2d_p
+
+! grid_definition --
+! Initialises the grid
+!
+ subroutine grid_definition_cart2d (obj, sizes, dims)
+ class(base_pde_object), allocatable :: obj
+ real, dimension(:) :: sizes
+ integer, dimension(:) :: dims
+ allocate( cartesian_2d_object :: obj )
+ select type (obj)
+ type is (cartesian_2d_object)
+ allocate (obj%c(dims(1), dims(2)))
+ obj%c = 0.0
+ obj%dx = sizes(1)/dims(1)
+ obj%dy = sizes(2)/dims(2)
+ class default
+ call abort
+ end select
+ end subroutine grid_definition_cart2d
+! print_cart2d --
+! Print the concentration field to the screen
+!
+ subroutine print_cart2d (obj)
+ class(cartesian_2d_object) :: obj
+ character(len=20) :: format
+ write( format, '(a,i0,a)' ) '(', size(obj%c,1), 'f6.3)'
+ write( *, format ) obj%c
+ end subroutine print_cart2d
+! initialise_cart2d --
+! Initialise the concentration field using a specific function
+!
+ subroutine initialise_cart2d (obj, funcxy)
+ class(cartesian_2d_object) :: obj
+ interface
+ real function funcxy (coords)
+ real, dimension(:), intent(in) :: coords
+ end function funcxy
+ end interface
+ integer :: i, j
+ real, dimension(2) :: x
+ obj%c = 0.0
+ do j = 2,size (obj%c, 2)-1
+ x(2) = obj%dy * (j-1)
+ do i = 2,size (obj%c, 1)-1
+ x(1) = obj%dx * (i-1)
+ obj%c(i,j) = funcxy (x)
+ enddo
+ enddo
+ end subroutine initialise_cart2d
+! nabla2_cart2d
+! Determine the divergence
+ function nabla2_cart2d (obj)
+ class(cartesian_2d_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: nabla2_cart2d
+ integer :: m, n
+ real :: dx, dy
+ m = size (obj%c, 1)
+ n = size (obj%c, 2)
+ dx = obj%dx
+ dy = obj%dy
+ allocate (cartesian_2d_object :: nabla2_cart2d)
+ select type (nabla2_cart2d)
+ type is (cartesian_2d_object)
+ allocate (nabla2_cart2d%c(m,n))
+ nabla2_cart2d%c = 0.0
+ nabla2_cart2d%c(2:m-1,2:n-1) = &
+ -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(1:m-2,2:n-1) - obj%c(3:m,2:n-1)) / dx**2 &
+ -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(2:m-1,1:n-2) - obj%c(2:m-1,3:n)) / dy**2
+ class default
+ call abort
+ end select
+ end function nabla2_cart2d
+ function real_times_cart2d (factor, obj) result(newobj)
+ real, intent(in) :: factor
+ class(cartesian_2d_object), intent(in) :: obj
+ class(base_pde_object), allocatable :: newobj
+ integer :: m, n
+ m = size (obj%c, 1)
+ n = size (obj%c, 2)
+ allocate (cartesian_2d_object :: newobj)
+ select type (newobj)
+ type is (cartesian_2d_object)
+ allocate (newobj%c(m,n))
+ newobj%c = factor * obj%c
+ class default
+ call abort
+ end select
+ end function real_times_cart2d
+ function obj_plus_cart2d (obj1, obj2) result( newobj )
+ class(cartesian_2d_object), intent(in) :: obj1
+ class(base_pde_object), intent(in) :: obj2
+ class(base_pde_object), allocatable :: newobj
+ integer :: m, n
+ m = size (obj1%c, 1)
+ n = size (obj1%c, 2)
+ allocate (cartesian_2d_object :: newobj)
+ select type (newobj)
+ type is (cartesian_2d_object)
+ allocate (newobj%c(m,n))
+ select type (obj2)
+ type is (cartesian_2d_object)
+ newobj%c = obj1%c + obj2%c
+ class default
+ call abort
+ end select
+ class default
+ call abort
+ end select
+ end function obj_plus_cart2d
+ subroutine obj_assign_cart2d (obj1, obj2)
+ class(cartesian_2d_object), intent(inout) :: obj1
+ class(base_pde_object), intent(in) :: obj2
+ select type (obj2)
+ type is (cartesian_2d_object)
+ obj1%c = obj2%c
+ class default
+ call abort
+ end select
+ end subroutine obj_assign_cart2d
+end module cartesian_2d_objects
+! define_pde_objects --
+! Module to bring all the PDE object types together
+!
+module define_pde_objects
+ use base_pde_objects
+ use cartesian_2d_objects
+ implicit none
+ interface grid_definition
+ module procedure grid_definition_general
+ end interface
+contains
+ subroutine grid_definition_general (obj, type, sizes, dims)
+ class(base_pde_object), allocatable :: obj
+ character(len=*) :: type
+ real, dimension(:) :: sizes
+ integer, dimension(:) :: dims
+ select case (type)
+ case ("cartesian 2d")
+ call grid_definition (obj, sizes, dims)
+ case default
+ write(*,*) 'Unknown grid type: ', trim (type)
+ stop
+ end select
+ end subroutine grid_definition_general
+end module define_pde_objects
+! pde_specific --
+! Module holding the routines specific to the PDE that
+! we are solving
+!
+module pde_specific
+ implicit none
+contains
+ real function patch (coords)
+ real, dimension(:), intent(in) :: coords
+ if (sum ((coords-[50.0,50.0])**2) < 40.0) then
+ patch = 1.0
+ else
+ patch = 0.0
+ endif
+ end function patch
+end module pde_specific
+! test_pde_solver --
+! Small test program to demonstrate the usage
+!
+program test_pde_solver
+ use define_pde_objects
+ use pde_specific
+ implicit none
+ class(base_pde_object), allocatable :: solution, deriv
+ integer :: i
+ real :: time, dtime, diff, chksum(2)
+
+ call simulation1 ! Use proc pointers for source and process define_pde_objects
+ select type (solution)
+ type is (cartesian_2d_object)
+ deallocate (solution%c)
+ end select
+ select type (deriv)
+ type is (cartesian_2d_object)
+ deallocate (deriv%c)
+ end select
+ deallocate (solution, deriv)
+
+ call simulation2 ! Use typebound procedures for source and process
+ if (chksum(1) .ne. chksum(2)) call abort
+ if ((chksum(1) - 0.881868720)**2 > 1e-4) call abort
+contains
+ subroutine simulation1
+!
+! Create the grid
+!
+ call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16])
+ call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16, 16])
+!
+! Initialise the concentration field
+!
+ call solution%initialise (patch)
+!
+! Set the procedure pointers
+!
+ solution%source_p => source_cart2d_p
+ solution%process_p => process_cart2d_p
+!
+! Perform the integration - explicit method
+!
+ time = 0.0
+ dtime = 0.1
+ diff = 5.0e-3
+
+! Give the diffusion coefficient correct dimensions.
+ select type (solution)
+ type is (cartesian_2d_object)
+ diff = diff * solution%dx * solution%dy / dtime
+ end select
+
+! write(*,*) 'Time: ', time, diff
+! call solution%print
+ do i = 1,100
+ deriv = solution%nabla2 ()
+ solution = solution + diff * dtime * deriv + solution%source_p (time) + solution%process_p ()
+! if ( mod(i, 25) == 0 ) then
+! write(*,*)'Time: ', time
+! call solution%print
+! endif
+ time = time + dtime
+ enddo
+! write(*,*) 'End result 1: '
+! call solution%print
+ select type (solution)
+ type is (cartesian_2d_object)
+ chksum(1) = sum (solution%c)
+ end select
+ end subroutine
+ subroutine simulation2
+!
+! Create the grid
+!
+ call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16])
+ call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16, 16])
+!
+! Initialise the concentration field
+!
+ call solution%initialise (patch)
+!
+! Set the procedure pointers
+!
+ solution%source_p => source_cart2d_p
+ solution%process_p => process_cart2d_p
+!
+! Perform the integration - explicit method
+!
+ time = 0.0
+ dtime = 0.1
+ diff = 5.0e-3
+
+! Give the diffusion coefficient correct dimensions.
+ select type (solution)
+ type is (cartesian_2d_object)
+ diff = diff * solution%dx * solution%dy / dtime
+ end select
+
+! write(*,*) 'Time: ', time, diff
+! call solution%print
+ do i = 1,100
+ deriv = solution%nabla2 ()
+ solution = solution + diff * dtime * deriv + solution%source (time) + solution%process ()
+! if ( mod(i, 25) == 0 ) then
+! write(*,*)'Time: ', time
+! call solution%print
+! endif
+ time = time + dtime
+ enddo
+! write(*,*) 'End result 2: '
+! call solution%print
+ select type (solution)
+ type is (cartesian_2d_object)
+ chksum(2) = sum (solution%c)
+ end select
+ end subroutine
+end program test_pde_solver
+! { dg-final { cleanup-modules "pde_specific define_pde_objects cartesian_2d_objects base_pde_objects" } }
projects / gcc.git / commitdiff