diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 18 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 127 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 24 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 | 96 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 | 185 |
6 files changed, 435 insertions, 23 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c0e217c3002..fd3a2bc6dd5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2009-10-16 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/41648 + PR fortran/41656 + * trans-expr.c (select_class_proc): Convert the expression for the + vindex, carried on the first member of the esym list. + * gfortran.h : Add the vindex field to the esym_list structure. + and eliminate the class_object field. + * resolve.c (check_class_members): Remove the setting of the + class_object field. + (vindex_expr): New function. + (get_class_from_expr): New function. + (resolve_class_compcall): Call the above to find the ultimate + class or derived component. If derived, do not generate the + esym list. Add and expression for the vindex to the esym list + by calling the above. + (resolve_class_typebound_call): The same. + 2009-10-15 Steven G. Kargl <kargl@gcc.gnu.org> PR fortran/41712 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9444fd10205..d0911b485ab 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5161,8 +5161,6 @@ check_class_members (gfc_symbol *derived) = 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; } @@ -5206,19 +5204,101 @@ resolve_class_esym (gfc_expr *e) } +/* Generate an expression for the vindex, given the reference to + the class of the final expression (class_ref), the base of the + full reference list (new_ref), the declared type and the class + object (st). */ +static gfc_expr* +vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref, + gfc_symbol *declared, gfc_symtree *st) +{ + gfc_expr *vindex; + gfc_ref *ref; + + /* Build an expression for the correct vindex; ie. that of the last + CLASS reference. */ + ref = gfc_get_ref(); + ref->type = REF_COMPONENT; + ref->u.c.component = declared->components->next; + ref->u.c.sym = declared; + ref->next = NULL; + if (class_ref) + { + class_ref->next = ref; + } + else + { + gfc_free_ref_list (new_ref); + new_ref = ref; + } + vindex = gfc_get_expr (); + vindex->expr_type = EXPR_VARIABLE; + vindex->symtree = st; + vindex->symtree->n.sym->refs++; + vindex->ts = ref->u.c.component->ts; + vindex->ref = new_ref; + + return vindex; +} + + +/* Get the ultimate declared type from an expression. In addition, + return the last class/derived type reference and the copy of the + 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; + + declared = NULL; + *class_ref = NULL; + *new_ref = gfc_copy_ref (e->ref); + for (ref = *new_ref; ref; ref = ref->next) + { + 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; + *class_ref = ref; + } + } + + if (declared == NULL) + declared = e->symtree->n.sym->ts.u.derived; + + return declared; +} + + /* Resolve a CLASS typebound function, or 'method'. */ static gfc_try resolve_class_compcall (gfc_expr* e) { - gfc_symbol *derived; + gfc_symbol *derived, *declared; + gfc_ref *new_ref; + gfc_ref *class_ref; + gfc_symtree *st; + + st = e->symtree; + class_object = st->n.sym; - class_object = e->symtree->n.sym; + /* Get the CLASS declared type. */ + declared = get_declared_from_expr (&class_ref, &new_ref, e); - /* Get the CLASS type. */ - derived = e->symtree->n.sym->ts.u.derived; + /* Weed out cases of the ultimate component being a derived type. */ + if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + { + gfc_free_ref_list (new_ref); + return resolve_compcall (e, true); + } /* Get the data component, which is of the declared type. */ - derived = derived->components->ts.u.derived; + derived = declared->components->ts.u.derived; /* Resolve the function call for each member of the class. */ class_try = SUCCESS; @@ -5238,6 +5318,12 @@ resolve_class_compcall (gfc_expr* e) resolve_class_esym (e); + /* More than one typebound procedure so transmit an expression for + the vindex as the selector. */ + if (e->value.function.class_esym != NULL) + e->value.function.class_esym->vindex + = vindex_expr (class_ref, new_ref, declared, st); + return class_try; } @@ -5245,15 +5331,26 @@ resolve_class_compcall (gfc_expr* e) static gfc_try resolve_class_typebound_call (gfc_code *code) { - gfc_symbol *derived; + gfc_symbol *derived, *declared; + gfc_ref *new_ref; + gfc_ref *class_ref; + gfc_symtree *st; + + st = code->expr1->symtree; + class_object = st->n.sym; - class_object = code->expr1->symtree->n.sym; + /* Get the CLASS declared type. */ + declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1); - /* Get the CLASS type. */ - derived = code->expr1->symtree->n.sym->ts.u.derived; + /* Weed out cases of the ultimate component being a derived type. */ + if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED) + { + gfc_free_ref_list (new_ref); + return resolve_typebound_call (code); + } /* Get the data component, which is of the declared type. */ - derived = derived->components->ts.u.derived; + derived = declared->components->ts.u.derived; class_try = SUCCESS; fcn_flag = false; @@ -5273,6 +5370,12 @@ resolve_class_typebound_call (gfc_code *code) resolve_class_esym (code->expr1); + /* More than one typebound procedure so transmit an expression for + the vindex as the selector. */ + if (code->expr1->value.function.class_esym != NULL) + code->expr1->value.function.class_esym->vindex + = vindex_expr (class_ref, new_ref, declared, st); + return class_try; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 65f13ad8a8d..331ca6a4ee4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1527,7 +1527,7 @@ 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 declared, gfc_expr *expr) { tree end_label; tree label; @@ -1535,16 +1535,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, tree vindex; stmtblock_t body; gfc_class_esym_list *next_elist, *tmp_elist; + gfc_se tmpse; - /* 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); + /* Convert the vindex expression. */ + gfc_init_se (&tmpse, NULL); + gfc_conv_expr (&tmpse, elist->vindex); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + vindex = gfc_evaluate_now (tmpse.expr, &se->pre); + gfc_add_block_to_block (&se->post, &tmpse.post); - /* Fix the function type to be that of the declared type. */ + /* Fix the function type to be that of the declared type method. */ declared = gfc_create_var (TREE_TYPE (declared), "method"); end_label = gfc_build_label_decl (NULL_TREE); @@ -1603,6 +1603,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, segfaults because it occurs too early and too often. */ free_elist: next_elist = elist->next; + if (elist->vindex) + gfc_free_expr (elist->vindex); gfc_free (elist); elist = NULL; } @@ -1612,7 +1614,7 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist, 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, + tmp = gfc_trans_runtime_error (true, &expr->where, "internal error: bad vindex in dynamic dispatch"); gfc_add_expr_to_block (&body, tmp); @@ -1649,7 +1651,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) } select_class_proc (se, expr->value.function.class_esym, - tmp, &expr->where); + tmp, expr); return; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7a851a34413..7e166317e4d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2009-10-16 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/41648 + * gfortran.dg/dynamic_dispatch_4.f03 : New test. + + PR fortran/41656 + * gfortran.dg/dynamic_dispatch_5.f03 : New test. + 2009-10-15 Michael Meissner <meissner@linux.vnet.ibm.com> PR target/23983 diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 new file mode 100644 index 00000000000..b72819acc4c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 @@ -0,0 +1,96 @@ +! { dg-do run } +! Tests the fix for PR41648 in which the reference a%a%getit () was wrongly +! identified as a recursive call to getit. +! +! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> +! +module foo_mod + type foo + integer :: i + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type foo + + private doit,getit +contains + subroutine doit(a) + class(foo) :: a + + a%i = 1 + end subroutine doit + function getit(a) result(res) + class(foo) :: a + integer :: res + + res = a%i + end function getit + +end module foo_mod + +module s_bar_mod + use foo_mod + type, extends(foo) :: s_bar + type(foo), allocatable :: a + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type s_bar + private doit,getit + +contains + subroutine doit(a) + class(s_bar) :: a + allocate (a%a) + call a%a%doit() + end subroutine doit + function getit(a) result(res) + class(s_bar) :: a + integer :: res + + res = a%a%getit () * 2 + end function getit +end module s_bar_mod + +module a_bar_mod + use foo_mod + type, extends(foo) :: a_bar + type(foo), allocatable :: a(:) + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type a_bar + private doit,getit + +contains + subroutine doit(a) + class(a_bar) :: a + allocate (a%a(1)) + call a%a(1)%doit () + end subroutine doit + function getit(a) result(res) + class(a_bar) :: a + integer :: res + + res = a%a(1)%getit () * 3 + end function getit +end module a_bar_mod + + use s_bar_mod + use a_bar_mod + type(foo), target :: b + type(s_bar), target :: c + type(a_bar), target :: d + class(foo), pointer :: a + a => b + call a%doit + if (a%getit () .ne. 1) call abort + a => c + call a%doit + if (a%getit () .ne. 2) call abort + a => d + call a%doit + if (a%getit () .ne. 3) call abort +end +! { dg-final { cleanup-modules "foo_mod s_bar_mod a_bar_mod" } } + diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 new file mode 100644 index 00000000000..8533508bcdc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 @@ -0,0 +1,185 @@ +! { dg-do compile } +! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile. +! +! Contributed by Salvatore Filippone <sfilippone@uniroma2.it> +! +module const_mod + integer, parameter :: longndig=12 + integer, parameter :: long_int_k_ = selected_int_kind(longndig) + integer, parameter :: dpk_ = kind(1.d0) + integer, parameter :: spk_ = kind(1.e0) +end module const_mod + +module base_mat_mod + use const_mod + type :: base_sparse_mat + integer, private :: m, n + integer, private :: state, duplicate + logical, private :: triangle, unitd, upper, sorted + contains + procedure, pass(a) :: get_nzeros + end type base_sparse_mat + private :: get_nzeros +contains + function get_nzeros(a) result(res) + implicit none + class(base_sparse_mat), intent(in) :: a + integer :: res + integer :: err_act + character(len=20) :: name='base_get_nzeros' + logical, parameter :: debug=.false. + res = -1 + end function get_nzeros +end module base_mat_mod + +module s_base_mat_mod + use base_mat_mod + type, extends(base_sparse_mat) :: s_base_sparse_mat + contains + procedure, pass(a) :: s_scals + procedure, pass(a) :: s_scal + generic, public :: scal => s_scals, s_scal + end type s_base_sparse_mat + private :: s_scals, s_scal + + type, extends(s_base_sparse_mat) :: s_coo_sparse_mat + + integer :: nnz + integer, allocatable :: ia(:), ja(:) + real(spk_), allocatable :: val(:) + contains + procedure, pass(a) :: get_nzeros => s_coo_get_nzeros + procedure, pass(a) :: s_scals => s_coo_scals + procedure, pass(a) :: s_scal => s_coo_scal + end type s_coo_sparse_mat + private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros +contains + subroutine s_scals(d,a,info) + implicit none + class(s_base_sparse_mat), intent(in) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scals' + logical, parameter :: debug=.false. + + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + end subroutine s_scals + + + subroutine s_scal(d,a,info) + implicit none + class(s_base_sparse_mat), intent(in) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scal' + logical, parameter :: debug=.false. + + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + end subroutine s_scal + + function s_coo_get_nzeros(a) result(res) + implicit none + class(s_coo_sparse_mat), intent(in) :: a + integer :: res + res = a%nnz + end function s_coo_get_nzeros + + + subroutine s_coo_scal(d,a,info) + use const_mod + implicit none + class(s_coo_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + info = 0 + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + end subroutine s_coo_scal + + subroutine s_coo_scals(d,a,info) + use const_mod + implicit none + class(s_coo_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + end subroutine s_coo_scals +end module s_base_mat_mod + +module s_mat_mod + use s_base_mat_mod + type :: s_sparse_mat + class(s_base_sparse_mat), pointer :: a + contains + procedure, pass(a) :: s_scals + procedure, pass(a) :: s_scal + generic, public :: scal => s_scals, s_scal + end type s_sparse_mat + interface scal + module procedure s_scals, s_scal + end interface +contains + subroutine s_scal(d,a,info) + use const_mod + implicit none + class(s_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + print *, "s_scal" + call a%a%scal(d,info) + return + end subroutine s_scal + + subroutine s_scals(d,a,info) + use const_mod + implicit none + class(s_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + print *, "s_scals" + call a%a%scal(d,info) + return + end subroutine s_scals +end module s_mat_mod + + use s_mat_mod + class (s_sparse_mat), pointer :: a + type (s_sparse_mat), target :: b + type (s_base_sparse_mat), target :: c + integer info + b%a => c + a => b + call a%scal (1.0_spk_, info) +end +! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } } + |
