diff options
-rw-r--r-- | gcc/fortran/ChangeLog | 8 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 49 | ||||
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 2 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/select_type_4.f90 | 174 |
5 files changed, 215 insertions, 22 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 04aac0c..9318bae 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,13 @@ 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 SAME_TYPE_AS and EXTENDS_TYPE_OF. * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 445753e..bb803b3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) - { - /* 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"); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index b00ceba..1e7b35f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1a98272..671f37a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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. diff --git a/gcc/testsuite/gfortran.dg/select_type_4.f90 b/gcc/testsuite/gfortran.dg/select_type_4.f90 new file mode 100644 index 0000000..7e12d93 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_4.f90 @@ -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 |