procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

resolve.c (check_typebound_baseobject): Don't check for abstract types for CLASS.

Browse source 
fortran/
2009-09-30  Janus Weil  <janus@gcc.gnu.org>

        * resolve.c (check_typebound_baseobject): Don't check for
        abstract types for CLASS.
        (resolve_class_assign): Adapt for RHS being a CLASS.
        * trans-intrinsic.c (gfc_conv_associated): Add component ref
        if expr is a CLASS.

testsuite/
2009-09-30  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/select_type_4.f90: New test.

From-SVN: r152346
This commit is contained in:
Tobias Burnus 2009-09-30 22:45:07 +02:00
parent cf2b3c22a2
commit e56817dbc6
5 changed files with 213 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View file

@ -1,3 +1,11 @@
2009-09-30 Janus Weil <janus@gcc.gnu.org>
* resolve.c (check_typebound_baseobject): Don't check for
abstract types for CLASS.
(resolve_class_assign): Adapt for RHS being a CLASS.
* trans-intrinsic.c (gfc_conv_associated): Add component ref
if expr is a CLASS.
2009-09-30 Janus Weil <janus@gcc.gnu.org>
* check.c (gfc_check_same_type_as): New function for checking

45
gcc/fortran/resolve.c
View file

@ -4851,7 +4851,8 @@ check_typebound_baseobject (gfc_expr* e)
return FAILURE;
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
if (base->ts.u.derived->attr.abstract)
if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for type-bound procedure call at %L is of"
" ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
@ -7298,30 +7299,34 @@ resolve_class_assign (gfc_code *code)
{
gfc_code *assign_code = gfc_get_code ();
/* Insert an additional assignment which sets the vindex. */
assign_code->next = code->next;
code->next = assign_code;
assign_code->op = EXEC_ASSIGN;
assign_code->expr1 = gfc_copy_expr (code->expr1);
gfc_add_component_ref (assign_code->expr1, "$vindex");
if (code->expr2->ts.type == BT_DERIVED)
/* vindex is constant, determined at compile time. */
assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
else if (code->expr2->ts.type == BT_CLASS)
if (code->expr2->ts.type != BT_CLASS)
{
/* vindex must be determined at run time. */
assign_code->expr2 = gfc_copy_expr (code->expr2);
gfc_add_component_ref (assign_code->expr2, "$vindex");
/* Insert an additional assignment which sets the vindex. */
assign_code->next = code->next;
code->next = assign_code;
assign_code->op = EXEC_ASSIGN;
assign_code->expr1 = gfc_copy_expr (code->expr1);
gfc_add_component_ref (assign_code->expr1, "$vindex");
if (code->expr2->ts.type == BT_DERIVED)
/* vindex is constant, determined at compile time. */
assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
else if (code->expr2->ts.type == BT_CLASS)
{
/* vindex must be determined at run time. */
assign_code->expr2 = gfc_copy_expr (code->expr2);
gfc_add_component_ref (assign_code->expr2, "$vindex");
}
else if (code->expr2->expr_type == EXPR_NULL)
assign_code->expr2 = gfc_int_expr (0);
else
gcc_unreachable ();
}
else if (code->expr2->expr_type == EXPR_NULL)
assign_code->expr2 = gfc_int_expr (0);
else
gcc_unreachable ();
/* Modify the actual pointer assignment. */
gfc_add_component_ref (code->expr1, "$data");
if (code->expr2->ts.type == BT_CLASS)
gfc_add_component_ref (code->expr2, "$data");
code->op = EXEC_ASSIGN;
else
gfc_add_component_ref (code->expr1, "$data");
}

2
gcc/fortran/trans-intrinsic.c
View file

@ -4608,6 +4608,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
gfc_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL);
arg1 = expr->value.function.actual;
if (arg1->expr->ts.type == BT_CLASS)
gfc_add_component_ref (arg1->expr, "$data");
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);

4
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,7 @@
2009-09-30 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/select_type_4.f90: New test.
2009-09-30 Janus Weil <janus@gcc.gnu.org>
* gfortran.dg/same_type_as_1.f03: New test.

174
gcc/testsuite/gfortran.dg/select_type_4.f90 Normal file
View file

@ -0,0 +1,174 @@
! { dg-do run }
!
! Contributed by by Richard Maine
! http://coding.derkeiler.com/Archive/Fortran/comp.lang.fortran/2006-10/msg00104.html
!
module poly_list
!-- Polymorphic lists using type extension.
implicit none
type, public :: node_type
private
class(node_type), pointer :: next => null()
end type node_type
type, public :: list_type
private
class(node_type), pointer :: head => null(), tail => null()
end type list_type
contains
subroutine append_node (list, new_node)
!-- Append a node to a list.
!-- Caller is responsible for allocating the node.
!---------- interface.
type(list_type), intent(inout) :: list
class(node_type), target :: new_node
!---------- executable code.
if (.not.associated(list%head)) list%head => new_node
if (associated(list%tail)) list%tail%next => new_node
list%tail => new_node
return
end subroutine append_node
function first_node (list)
!-- Get the first node of a list.
!---------- interface.
type(list_type), intent(in) :: list
class(node_type), pointer :: first_node
!---------- executable code.
first_node => list%head
return
end function first_node
function next_node (node)
!-- Step to the next node of a list.
!---------- interface.
class(node_type), target :: node
class(node_type), pointer :: next_node
!---------- executable code.
next_node => node%next
return
end function next_node
subroutine destroy_list (list)
!-- Delete (and deallocate) all the nodes of a list.
!---------- interface.
type(list_type), intent(inout) :: list
!---------- local.
class(node_type), pointer :: node, next
!---------- executable code.
node => list%head
do while (associated(node))
next => node%next
deallocate(node)
node => next
end do
nullify(list%head, list%tail)
return
end subroutine destroy_list
end module poly_list
program main
use poly_list
implicit none
integer :: cnt
type, extends(node_type) :: real_node_type
real :: x
end type real_node_type
type, extends(node_type) :: integer_node_type
integer :: i
end type integer_node_type
type, extends(node_type) :: character_node_type
character(1) :: c
end type character_node_type
type(list_type) :: list
class(node_type), pointer :: node
type(integer_node_type), pointer :: integer_node
type(real_node_type), pointer :: real_node
type(character_node_type), pointer :: character_node
!---------- executable code.
!----- Build the list.
allocate(real_node)
real_node%x = 1.23
call append_node(list, real_node)
allocate(integer_node)
integer_node%i = 42
call append_node(list, integer_node)
allocate(node)
call append_node(list, node)
allocate(character_node)
character_node%c = "z"
call append_node(list, character_node)
allocate(real_node)
real_node%x = 4.56
call append_node(list, real_node)
!----- Retrieve from it.
node => first_node(list)
cnt = 0
do while (associated(node))
cnt = cnt + 1
select type (node)
type is (real_node_type)
write (*,*) node%x
if (.not.( (cnt == 1 .and. node%x == 1.23) &
.or. (cnt == 5 .and. node%x == 4.56))) then
call abort()
end if
type is (integer_node_type)
write (*,*) node%i
if (cnt /= 2 .or. node%i /= 42) call abort()
type is (node_type)
write (*,*) "Node with no data."
if (cnt /= 3) call abort()
class default
Write (*,*) "Some other node type."
if (cnt /= 4) call abort()
end select
node => next_node(node)
end do
if (cnt /= 5) call abort()
call destroy_list(list)
stop
end program main