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

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

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