mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-23 00:41:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/41648 ([OOP] Type-bound procedures refused)

Browse Source 
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-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.

From-SVN: r152890
This commit is contained in:
Paul Thomas 2009-10-16 06:07:09 +00:00
parent 8e200755cf
commit 28188747cb
6 changed files with 435 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View File

@ -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

127
gcc/fortran/resolve.c
View File

@ -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;
class_object = e->symtree->n.sym;
st = e->symtree;
class_object = st->n.sym;
/* Get the CLASS type. */
derived = e->symtree->n.sym->ts.u.derived;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
/* Weed out cases of the ultimate component being a derived type. */
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
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;
class_object = code->expr1->symtree->n.sym;
st = code->expr1->symtree;
class_object = st->n.sym;
/* Get the CLASS type. */
derived = code->expr1->symtree->n.sym->ts.u.derived;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
/* Weed out cases of the ultimate component being a derived type. */
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
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;
}

24
gcc/fortran/trans-expr.c
View File

@ -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;
}

8
gcc/testsuite/ChangeLog
View File

@ -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

96
gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03 Normal file
View File

@ -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" } }

185
gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 Normal file
View File

@ -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" } }