+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
= 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;
}
}
+/* 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;
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;
}
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;
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;
}
/* 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;
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);
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;
}
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);
}
select_class_proc (se, expr->value.function.class_esym,
- tmp, &expr->where);
+ tmp, expr);
return;
}
+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
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
+
git://gcc.gnu.org / gcc.git / commitdiff