From d94c13853accd0d733620f127edb7eb40e4b70b5 Mon Sep 17 00:00:00 2001 From: pault Date: Mon, 5 Oct 2009 18:19:55 +0000 Subject: [PATCH] 2009-10-05 Paul Thomas * trans-expr.c (select_class_proc): New function. (conv_function_val): Deal with class methods and call above. * symbol.c (gfc_type_compatible): Treat case where both ts1 and ts2 are BT_CLASS. gfortran.h : Add structure gfc_class_esym_list and include in the structure gfc_expr. * module.c (load_derived_extensions): New function. (read_module): Call above. (write_dt_extensions): New function. (write_derived_extensions): New function. (write_module): Use the above. * resolve.c (resolve_typebound_call): Add a function expression for class methods. This carries the chain of symbols for the dynamic dispatch in select_class_proc. (resolve_compcall): Add second, boolean argument to indicate if a function is being handled. (check_members): New function. (check_class_members): New function. (resolve_class_compcall): New function. (resolve_class_typebound_call): New function. (gfc_resolve_expr): Call above for component calls.. 2009-10-05 Paul Thomas * gfortran.dg/dynamic_dispatch_1.f90: New test. * gfortran.dg/dynamic_dispatch_2.f90: New test. * gfortran.dg/dynamic_dispatch_3.f90: New test. * gfortran.dg/module_md5_1.f90: Update md5 sum. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152463 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 24 +++ gcc/fortran/gfortran.h | 12 ++ gcc/fortran/module.c | 104 +++++++++- gcc/fortran/resolve.c | 232 ++++++++++++++++++++++- gcc/fortran/symbol.c | 5 +- gcc/fortran/trans-expr.c | 124 ++++++++++++ gcc/testsuite/ChangeLog | 7 + gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03 | 84 ++++++++ gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03 | 105 ++++++++++ gcc/testsuite/gfortran.dg/dynamic_dispatch_3.f03 | 91 +++++++++ gcc/testsuite/gfortran.dg/module_md5_1.f90 | 2 +- 11 files changed, 778 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03 create mode 100644 gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03 create mode 100644 gcc/testsuite/gfortran.dg/dynamic_dispatch_3.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a844ed655d5..24891ab3835 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2009-10-05 Paul Thomas + + * trans-expr.c (select_class_proc): New function. + (conv_function_val): Deal with class methods and call above. + * symbol.c (gfc_type_compatible): Treat case where both ts1 and + ts2 are BT_CLASS. + gfortran.h : Add structure gfc_class_esym_list and include in + the structure gfc_expr. + * module.c (load_derived_extensions): New function. + (read_module): Call above. + (write_dt_extensions): New function. + (write_derived_extensions): New function. + (write_module): Use the above. + * resolve.c (resolve_typebound_call): Add a function expression + for class methods. This carries the chain of symbols for the + dynamic dispatch in select_class_proc. + (resolve_compcall): Add second, boolean argument to indicate if + a function is being handled. + (check_members): New function. + (check_class_members): New function. + (resolve_class_compcall): New function. + (resolve_class_typebound_call): New function. + (gfc_resolve_expr): Call above for component calls.. + 2009-10-05 Daniel Kraft PR fortran/41403 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b40f01ba4bf..72f01264630 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1594,6 +1594,17 @@ typedef struct gfc_intrinsic_sym gfc_intrinsic_sym; +typedef struct gfc_class_esym_list +{ + gfc_symbol *derived; + gfc_symbol *esym; + gfc_symbol *class_object; + struct gfc_class_esym_list *next; +} +gfc_class_esym_list; + +#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list) + /* Expression nodes. The expression node types deserve explanations, since the last couple can be easily misconstrued: @@ -1705,6 +1716,7 @@ typedef struct gfc_expr const char *name; /* Points to the ultimate name of the function */ gfc_intrinsic_sym *isym; gfc_symbol *esym; + gfc_class_esym_list *class_esym; } function; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 1769eada5fe..2112d3e82b1 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3972,6 +3972,61 @@ load_equiv (void) } +/* This function loads the sym_root of f2k_derived with the extensions to + the derived type. */ +static void +load_derived_extensions (void) +{ + int symbol, nuse, j; + gfc_symbol *derived; + gfc_symbol *dt; + gfc_symtree *st; + pointer_info *info; + char name[GFC_MAX_SYMBOL_LEN + 1]; + char module[GFC_MAX_SYMBOL_LEN + 1]; + const char *p; + + mio_lparen (); + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + mio_integer (&symbol); + info = get_integer (symbol); + derived = info->u.rsym.sym; + + gcc_assert (derived->attr.flavor == FL_DERIVED); + if (derived->f2k_derived == NULL) + derived->f2k_derived = gfc_get_namespace (NULL, 0); + + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + mio_internal_string (name); + mio_internal_string (module); + + /* Only use one use name to find the symbol. */ + nuse = number_use_names (name, false); + j = 1; + p = find_use_name_n (name, &j, false); + st = gfc_find_symtree (gfc_current_ns->sym_root, p); + dt = st->n.sym; + st = gfc_find_symtree (derived->f2k_derived->sym_root, name); + if (st == NULL) + { + /* Only use the real name in f2k_derived to ensure a single + symtree. */ + st = gfc_new_symtree (&derived->f2k_derived->sym_root, name); + st->n.sym = dt; + st->n.sym->refs++; + } + mio_rparen (); + } + mio_rparen (); + } + mio_rparen (); +} + + /* Recursive function to traverse the pointer_info tree and load a needed symbol. We return nonzero if we load a symbol and stop the traversal, because the act of loading can alter the tree. */ @@ -4113,7 +4168,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info) static void read_module (void) { - module_locus operator_interfaces, user_operators; + module_locus operator_interfaces, user_operators, extensions; const char *p; char name[GFC_MAX_SYMBOL_LEN + 1]; int i; @@ -4130,10 +4185,13 @@ read_module (void) skip_list (); skip_list (); - /* Skip commons and equivalences for now. */ + /* Skip commons, equivalences and derived type extensions for now. */ skip_list (); skip_list (); + get_module_locus (&extensions); + skip_list (); + mio_lparen (); /* Create the fixup nodes for all the symbols. */ @@ -4386,6 +4444,11 @@ read_module (void) gfc_check_interfaces (gfc_current_ns); + /* Now we should be in a position to fill f2k_derived with derived type + extensions, since everything has been loaded. */ + set_module_locus (&extensions); + load_derived_extensions (); + /* Clean up symbol nodes that were never loaded, create references to hidden symbols. */ @@ -4594,6 +4657,36 @@ write_equiv (void) } +/* Write derived type extensions to the module. */ + +static void +write_dt_extensions (gfc_symtree *st) +{ + mio_lparen (); + mio_pool_string (&st->n.sym->name); + if (st->n.sym->module != NULL) + mio_pool_string (&st->n.sym->module); + else + mio_internal_string (module_name); + mio_rparen (); +} + +static void +write_derived_extensions (gfc_symtree *st) +{ + if (!((st->n.sym->attr.flavor == FL_DERIVED) + && (st->n.sym->f2k_derived != NULL) + && (st->n.sym->f2k_derived->sym_root != NULL))) + return; + + mio_lparen (); + mio_symbol_ref (&(st->n.sym)); + gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root, + write_dt_extensions); + mio_rparen (); +} + + /* Write a symbol to the module. */ static void @@ -4820,6 +4913,13 @@ write_module (void) write_char ('\n'); write_char ('\n'); + mio_lparen (); + gfc_traverse_symtree (gfc_current_ns->sym_root, + write_derived_extensions); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + /* Write symbol information. First we traverse all symbols in the primary namespace, writing those that need to be written. Sometimes writing one symbol will cause another to need to be diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index bb803b3475c..2f0972b04eb 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4997,28 +4997,42 @@ resolve_typebound_call (gfc_code* c) c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); + gfc_free_expr (c->expr1); - c->expr1 = NULL; + c->expr1 = gfc_get_expr (); + c->expr1->expr_type = EXPR_FUNCTION; + c->expr1->symtree = target; + c->expr1->where = c->loc; return resolve_call (c); } -/* Resolve a component-call expression. */ - +/* Resolve a component-call expression. This originally was intended + only to see functions. However, it is convenient to use it in + resolving subroutine class methods, since we do not have to add a + gfc_code each time. */ static gfc_try -resolve_compcall (gfc_expr* e) +resolve_compcall (gfc_expr* e, bool fcn) { gfc_actual_arglist* newactual; gfc_symtree* target; /* Check that's really a FUNCTION. */ - if (!e->value.compcall.tbp->function) + if (fcn && !e->value.compcall.tbp->function) { gfc_error ("'%s' at %L should be a FUNCTION", e->value.compcall.name, &e->where); return FAILURE; } + else if (!fcn && !e->value.compcall.tbp->subroutine) + { + /* To resolve class member calls, we borrow this bit + of code to select the specific procedures. */ + gfc_error ("'%s' at %L should be a SUBROUTINE", + e->value.compcall.name, &e->where); + return FAILURE; + } /* These must not be assign-calls! */ gcc_assert (!e->value.compcall.assign); @@ -5043,12 +5057,207 @@ resolve_compcall (gfc_expr* e) e->value.function.actual = newactual; e->value.function.name = e->value.compcall.name; e->value.function.esym = target->n.sym; + e->value.function.class_esym = NULL; e->value.function.isym = NULL; e->symtree = target; e->ts = target->n.sym->ts; e->expr_type = EXPR_FUNCTION; - return gfc_resolve_expr (e); + /* Resolution is not necessary if this is a class subroutine; this + function only has to identify the specific proc. Resolution of + the call will be done next in resolve_typebound_call. */ + return fcn ? gfc_resolve_expr (e) : SUCCESS; +} + + +/* Resolve a typebound call for the members in a class. This group of + functions implements dynamic dispatch in the provisional version + of f03 OOP. As soon as vtables are in place and contain pointers + to methods, this will no longer be necessary. */ +static gfc_expr *list_e; +static void check_class_members (gfc_symbol *); +static gfc_try class_try; +static bool fcn_flag; +static gfc_symbol *class_object; + + +static void +check_members (gfc_symbol *derived) +{ + if (derived->attr.flavor == FL_DERIVED) + check_class_members (derived); +} + + +static void +check_class_members (gfc_symbol *derived) +{ + gfc_symbol* tbp_sym; + gfc_expr *e; + gfc_symtree *tbp; + gfc_class_esym_list *etmp; + + e = gfc_copy_expr (list_e); + + tbp = gfc_find_typebound_proc (derived, &class_try, + e->value.compcall.name, + false, &e->where); + + if (tbp == NULL) + { + gfc_error ("no typebound available procedure named '%s' at %L", + e->value.compcall.name, &e->where); + return; + } + + if (tbp->n.tb->is_generic) + { + tbp_sym = NULL; + + /* If we have to match a passed class member, force the actual + expression to have the correct type. */ + if (!tbp->n.tb->nopass) + { + if (e->value.compcall.base_object == NULL) + e->value.compcall.base_object = + extract_compcall_passed_object (e); + + e->value.compcall.base_object->ts.type = BT_DERIVED; + e->value.compcall.base_object->ts.u.derived = derived; + } + } + else + tbp_sym = tbp->n.tb->u.specific->n.sym; + + e->value.compcall.tbp = tbp->n.tb; + e->value.compcall.name = tbp->name; + + /* Do the renaming, PASSing, generic => specific and other + good things for each class member. */ + class_try = (resolve_compcall (e, fcn_flag) == SUCCESS) + ? class_try : FAILURE; + + /* Now transfer the found symbol to the esym list. */ + if (class_try == SUCCESS) + { + etmp = list_e->value.function.class_esym; + list_e->value.function.class_esym + = gfc_get_class_esym_list(); + list_e->value.function.class_esym->next = etmp; + list_e->value.function.class_esym->derived = derived; + list_e->value.function.class_esym->class_object + = class_object; + list_e->value.function.class_esym->esym + = e->value.function.esym; + } + + gfc_free_expr (e); + + /* Burrow down into grandchildren types. */ + if (derived->f2k_derived) + gfc_traverse_ns (derived->f2k_derived, check_members); +} + + +/* Eliminate esym_lists where all the members point to the + typebound procedure of the declared type; ie. one where + type selection has no effect.. */ +static void +resolve_class_esym (gfc_expr *e) +{ + gfc_class_esym_list *p, *q; + bool empty = true; + + gcc_assert (e && e->expr_type == EXPR_FUNCTION); + + p = e->value.function.class_esym; + if (p == NULL) + return; + + for (; p; p = p->next) + empty = empty && (e->value.function.esym == p->esym); + + if (empty) + { + p = e->value.function.class_esym; + for (; p; p = q) + { + q = p->next; + gfc_free (p); + } + e->value.function.class_esym = NULL; + } +} + + +/* Resolve a CLASS typebound function, or 'method'. */ +static gfc_try +resolve_class_compcall (gfc_expr* e) +{ + gfc_symbol *derived; + + class_object = e->symtree->n.sym; + + /* Get the CLASS type. */ + derived = e->symtree->n.sym->ts.u.derived; + + /* Get the data component, which is of the declared type. */ + derived = derived->components->ts.u.derived; + + /* Resolve the function call for each member of the class. */ + class_try = SUCCESS; + fcn_flag = true; + list_e = gfc_copy_expr (e); + check_class_members (derived); + + class_try = (resolve_compcall (e, true) == SUCCESS) + ? class_try : FAILURE; + + /* Transfer the class list to the original expression. Note that + the class_esym list is cleaned up in trans-expr.c, as the calls + are translated. */ + e->value.function.class_esym = list_e->value.function.class_esym; + list_e->value.function.class_esym = NULL; + gfc_free_expr (list_e); + + resolve_class_esym (e); + + return class_try; +} + +/* Resolve a CLASS typebound subroutine, or 'method'. */ +static gfc_try +resolve_class_typebound_call (gfc_code *code) +{ + gfc_symbol *derived; + + class_object = code->expr1->symtree->n.sym; + + /* Get the CLASS type. */ + derived = code->expr1->symtree->n.sym->ts.u.derived; + + /* Get the data component, which is of the declared type. */ + derived = derived->components->ts.u.derived; + + class_try = SUCCESS; + fcn_flag = false; + list_e = gfc_copy_expr (code->expr1); + check_class_members (derived); + + class_try = (resolve_typebound_call (code) == SUCCESS) + ? class_try : FAILURE; + + /* Transfer the class list to the original expression. Note that + the class_esym list is cleaned up in trans-expr.c, as the calls + are translated. */ + code->expr1->value.function.class_esym + = list_e->value.function.class_esym; + list_e->value.function.class_esym = NULL; + gfc_free_expr (list_e); + + resolve_class_esym (code->expr1); + + return class_try; } @@ -5162,7 +5371,10 @@ gfc_resolve_expr (gfc_expr *e) break; case EXPR_COMPCALL: - t = resolve_compcall (e); + if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) + t = resolve_class_compcall (e); + else + t = resolve_compcall (e, true); break; case EXPR_SUBSTRING: @@ -7517,7 +7729,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_COMPCALL: compcall: - resolve_typebound_call (code); + if (code->expr1->symtree + && code->expr1->symtree->n.sym->ts.type == BT_CLASS) + resolve_class_typebound_call (code); + else + resolve_typebound_call (code); break; case EXEC_CALL_PPC: diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 39285b16fea..8cd18db0a8f 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4579,9 +4579,12 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS) && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS)) { - if (ts1->type == BT_CLASS) + if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED) return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, ts2->u.derived); + else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS) + return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived, + ts2->u.derived->components->ts.u.derived); else if (ts2->type != BT_CLASS) return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); else diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index eb741f8231f..77953c8e15f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1523,11 +1523,135 @@ get_proc_ptr_comp (gfc_expr *e) } +/* Select a class typebound procedure at runtime. */ +static void +select_class_proc (gfc_se *se, gfc_class_esym_list *elist, + tree declared, locus *where) +{ + tree end_label; + tree label; + tree tmp; + tree vindex; + stmtblock_t body; + gfc_class_esym_list *next_elist, *tmp_elist; + + /* Calculate the switch expression: class_object.vindex. */ + gcc_assert (elist->class_object->ts.type == BT_CLASS); + tmp = elist->class_object->ts.u.derived->components->next->backend_decl; + vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp), + elist->class_object->backend_decl, + tmp, NULL_TREE); + vindex = gfc_evaluate_now (vindex, &se->pre); + + /* Fix the function type to be that of the declared type. */ + declared = gfc_create_var (TREE_TYPE (declared), "method"); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + /* Go through the list of extensions. */ + for (; elist; elist = next_elist) + { + /* This case has already been added. */ + if (elist->derived == NULL) + goto free_elist; + + /* Run through the chain picking up all the cases that call the + same procedure. */ + tmp_elist = elist; + for (; elist; elist = elist->next) + { + tree cval; + + if (elist->esym != tmp_elist->esym) + continue; + + cval = build_int_cst (TREE_TYPE (vindex), + elist->derived->vindex); + /* Build a label for the vindex value. */ + label = gfc_build_label_decl (NULL_TREE); + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + cval, NULL_TREE, label); + gfc_add_expr_to_block (&body, tmp); + + /* Null the reference the derived type so that this case is + not used again. */ + elist->derived = NULL; + } + + elist = tmp_elist; + + /* Get a pointer to the procedure, */ + tmp = gfc_get_symbol_decl (elist->esym); + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + { + gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + } + + /* Assign the pointer to the appropriate procedure. */ + gfc_add_modify (&body, declared, + fold_convert (TREE_TYPE (declared), tmp)); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + + /* Free the elists as we go; freeing them in gfc_free_expr causes + segfaults because it occurs too early and too often. */ + free_elist: + next_elist = elist->next; + gfc_free (elist); + elist = NULL; + } + + /* Default is an error. */ + label = gfc_build_label_decl (NULL_TREE); + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + NULL_TREE, NULL_TREE, label); + gfc_add_expr_to_block (&body, tmp); + tmp = gfc_trans_runtime_error (true, where, + "internal error: bad vindex in dynamic dispatch"); + gfc_add_expr_to_block (&body, tmp); + + /* Write the switch expression. */ + tmp = gfc_finish_block (&body); + tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE); + gfc_add_expr_to_block (&se->pre, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = declared; + return; +} + + static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; + if (expr && expr->symtree + && expr->value.function.class_esym) + { + if (!sym->backend_decl) + sym->backend_decl = gfc_get_extern_function_decl (sym); + + tmp = sym->backend_decl; + + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + { + gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + } + + select_class_proc (se, expr->value.function.class_esym, + tmp, &expr->where); + return; + } + if (gfc_is_proc_ptr_comp (expr, NULL)) tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1b21ec7b2f4..bf1b53217ea 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2009-10-05 Paul Thomas + + * gfortran.dg/dynamic_dispatch_1.f90: New test. + * gfortran.dg/dynamic_dispatch_2.f90: New test. + * gfortran.dg/dynamic_dispatch_3.f90: New test. + * gfortran.dg/module_md5_1.f90: Update md5 sum. + 2009-10-05 Sriraman Tallam * gcc.dg/plugin/selfassign.c (plugin_init): Change plugin_pass to diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03 new file mode 100644 index 00000000000..4854b0ff08d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03 @@ -0,0 +1,84 @@ +! { dg-do run } +! Tests dynamic dispatch of class functions. +! +! Contributed by Paul Thomas +! +module m + type :: t1 + integer :: i = 42 + procedure(make_real), pointer :: ptr + contains + procedure, pass :: real => make_real + procedure, pass :: make_integer + procedure, pass :: prod => i_m_j + generic, public :: extract => real, make_integer + generic, public :: base_extract => real, make_integer + end type t1 + + type, extends(t1) :: t2 + integer :: j = 99 + contains + procedure, pass :: real => make_real2 + procedure, pass :: make_integer_2 + procedure, pass :: prod => i_m_j_2 + generic, public :: extract => real, make_integer_2 + end type t2 +contains + real function make_real (arg) + class(t1), intent(in) :: arg + make_real = real (arg%i) + end function make_real + + real function make_real2 (arg) + class(t2), intent(in) :: arg + make_real2 = real (arg%j) + end function make_real2 + + integer function make_integer (arg, arg2) + class(t1), intent(in) :: arg + integer :: arg2 + make_integer = arg%i * arg2 + end function make_integer + + integer function make_integer_2 (arg, arg2) + class(t2), intent(in) :: arg + integer :: arg2 + make_integer_2 = arg%j * arg2 + end function make_integer_2 + + integer function i_m_j (arg) + class(t1), intent(in) :: arg + i_m_j = arg%i + end function i_m_j + + integer function i_m_j_2 (arg) + class(t2), intent(in) :: arg + i_m_j_2 = arg%j + end function i_m_j_2 +end module m + + use m + type, extends(t1) :: l1 + character(16) :: chr + end type l1 + class(t1), pointer :: a !=> NULL() + type(t1), target :: b + type(t2), target :: c + type(l1), target :: d + a => b ! declared type + if (a%real() .ne. real (42)) call abort + if (a%prod() .ne. 42) call abort + if (a%extract (2) .ne. 84) call abort + if (a%base_extract (2) .ne. 84) call abort + a => c ! extension in module + if (a%real() .ne. real (99)) call abort + if (a%prod() .ne. 99) call abort + if (a%extract (3) .ne. 297) call abort + if (a%base_extract (3) .ne. 126) call abort + a => d ! extension in main + if (a%real() .ne. real (42)) call abort + if (a%prod() .ne. 42) call abort + if (a%extract (4) .ne. 168) call abort + if (a%base_extract (4) .ne. 168) call abort +end +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03 new file mode 100644 index 00000000000..989a2e0d3f0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03 @@ -0,0 +1,105 @@ +! { dg-do run } +! Tests dynamic dispatch of class subroutines. +! +! Contributed by Paul Thomas +! +module m + type :: t1 + integer :: i = 42 + procedure(make_real), pointer :: ptr + contains + procedure, pass :: real => make_real + procedure, pass :: make_integer + procedure, pass :: prod => i_m_j + generic, public :: extract => real, make_integer + generic, public :: base_extract => real, make_integer + end type t1 + + type, extends(t1) :: t2 + integer :: j = 99 + contains + procedure, pass :: real => make_real2 + procedure, pass :: make_integer_2 + procedure, pass :: prod => i_m_j_2 + generic, public :: extract => real, make_integer_2 + end type t2 +contains + subroutine make_real (arg, arg2) + class(t1), intent(in) :: arg + real :: arg2 + arg2 = real (arg%i) + end subroutine make_real + + subroutine make_real2 (arg, arg2) + class(t2), intent(in) :: arg + real :: arg2 + arg2 = real (arg%j) + end subroutine make_real2 + + subroutine make_integer (arg, arg2, arg3) + class(t1), intent(in) :: arg + integer :: arg2, arg3 + arg3 = arg%i * arg2 + end subroutine make_integer + + subroutine make_integer_2 (arg, arg2, arg3) + class(t2), intent(in) :: arg + integer :: arg2, arg3 + arg3 = arg%j * arg2 + end subroutine make_integer_2 + + subroutine i_m_j (arg, arg2) + class(t1), intent(in) :: arg + integer :: arg2 + arg2 = arg%i + end subroutine i_m_j + + subroutine i_m_j_2 (arg, arg2) + class(t2), intent(in) :: arg + integer :: arg2 + arg2 = arg%j + end subroutine i_m_j_2 +end module m + + use m + type, extends(t1) :: l1 + character(16) :: chr + end type l1 + class(t1), pointer :: a !=> NULL() + type(t1), target :: b + type(t2), target :: c + type(l1), target :: d + real :: r + integer :: i + + a => b ! declared type + call a%real(r) + if (r .ne. real (42)) call abort + call a%prod(i) + if (i .ne. 42) call abort + call a%extract (2, i) + if (i .ne. 84) call abort + call a%base_extract (2, i) + if (i .ne. 84) call abort + + a => c ! extension in module + call a%real(r) + if (r .ne. real (99)) call abort + call a%prod(i) + if (i .ne. 99) call abort + call a%extract (3, i) + if (i .ne. 297) call abort + call a%base_extract (3, i) + if (i .ne. 126) call abort + + a => d ! extension in main + call a%real(r) + if (r .ne. real (42)) call abort + call a%prod(i) + if (i .ne. 42) call abort + call a%extract (4, i) + if (i .ne. 168) call abort + call a%extract (4, i) + if (i .ne. 168) call abort +end +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_3.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_3.f03 new file mode 100644 index 00000000000..aa8713ef4d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_3.f03 @@ -0,0 +1,91 @@ +! { dg-do run } +! Tests dynamic dispatch of class functions, spread over +! different modules. Apart from the location of the derived +! type declarations, this test is the same as +! dynamic_dispatch_1.f03 +! +! Contributed by Paul Thomas +! +module m1 + type :: t1 + integer :: i = 42 + procedure(make_real), pointer :: ptr + contains + procedure, pass :: real => make_real + procedure, pass :: make_integer + procedure, pass :: prod => i_m_j + generic, public :: extract => real, make_integer + generic, public :: base_extract => real, make_integer + end type t1 +contains + real function make_real (arg) + class(t1), intent(in) :: arg + make_real = real (arg%i) + end function make_real + + integer function make_integer (arg, arg2) + class(t1), intent(in) :: arg + integer :: arg2 + make_integer = arg%i * arg2 + end function make_integer + + integer function i_m_j (arg) + class(t1), intent(in) :: arg + i_m_j = arg%i + end function i_m_j +end module m1 + +module m2 + use m1 + type, extends(t1) :: t2 + integer :: j = 99 + contains + procedure, pass :: real => make_real2 + procedure, pass :: make_integer_2 + procedure, pass :: prod => i_m_j_2 + generic, public :: extract => real, make_integer_2 + end type t2 +contains + real function make_real2 (arg) + class(t2), intent(in) :: arg + make_real2 = real (arg%j) + end function make_real2 + + integer function make_integer_2 (arg, arg2) + class(t2), intent(in) :: arg + integer :: arg2 + make_integer_2 = arg%j * arg2 + end function make_integer_2 + + integer function i_m_j_2 (arg) + class(t2), intent(in) :: arg + i_m_j_2 = arg%j + end function i_m_j_2 +end module m2 + + use m1 + use m2 + type, extends(t1) :: l1 + character(16) :: chr + end type l1 + class(t1), pointer :: a !=> NULL() + type(t1), target :: b + type(t2), target :: c + type(l1), target :: d + a => b ! declared type in module m1 + if (a%real() .ne. real (42)) call abort + if (a%prod() .ne. 42) call abort + if (a%extract (2) .ne. 84) call abort + if (a%base_extract (2) .ne. 84) call abort + a => c ! extension in module m2 + if (a%real() .ne. real (99)) call abort + if (a%prod() .ne. 99) call abort + if (a%extract (3) .ne. 297) call abort + if (a%base_extract (3) .ne. 126) call abort + a => d ! extension in main + if (a%real() .ne. real (42)) call abort + if (a%prod() .ne. 42) call abort + if (a%extract (4) .ne. 168) call abort + if (a%base_extract (4) .ne. 168) call abort +end +! { dg-final { cleanup-modules "m1, m2" } } diff --git a/gcc/testsuite/gfortran.dg/module_md5_1.f90 b/gcc/testsuite/gfortran.dg/module_md5_1.f90 index 7aeeb800f10..88002c204bf 100644 --- a/gcc/testsuite/gfortran.dg/module_md5_1.f90 +++ b/gcc/testsuite/gfortran.dg/module_md5_1.f90 @@ -10,5 +10,5 @@ program test use foo print *, pi end program test -! { dg-final { scan-module "foo" "MD5:dc2fd1358dcaddc25e3c89dae859ef32" } } +! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } } ! { dg-final { cleanup-modules "foo" } } -- 2.11.4.GIT