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);
{
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)
- {
- /* 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 ();
+ if (code->expr2->ts.type != BT_CLASS)
+ {
+ /* 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 ();
+ }
/* 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");
}
--- /dev/null
+! { 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
OSDN Git Service
