re PR fortran/46662 ([OOP] gfortran accepts "CALL polymorphic%abstract_type%ppc()")

2010-11-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46662
	* resolve.c (update_ppc_arglist): Add check for abstract passed object.

2010-11-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46662
	* gfortran.dg/proc_ptr_comp_pass_7.f90: New.

From-SVN: r167225

4 files changed, 88 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 12a8afc..b7901ad 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2010-11-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46662
+	* resolve.c (update_ppc_arglist): Add check for abstract passed object.
+
 2010-11-28  Paul Thomas  <pault@gcc.gnu.org>
 
 	 PR fortran/35810
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 60a15d8..9d8ee23 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5383,12 +5383,21 @@ update_ppc_arglist (gfc_expr* e)
   if (!po)
     return FAILURE;
 
+  /* F08:R739.  */
   if (po->rank > 0)
     {
       gfc_error ("Passed-object at %L must be scalar", &e->where);
       return FAILURE;
     }
 
+  /* F08:C611.  */
+  if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
+    {
+      gfc_error ("Base object for procedure-pointer component call at %L is of"
+		 " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
+      return FAILURE;
+    }
+
   gcc_assert (tb->pass_arg_num > 0);
   e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
 						  tb->pass_arg_num,
@@ -5413,6 +5422,7 @@ check_typebound_baseobject (gfc_expr* e)
 
   gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
 
+  /* F08:C611.  */
   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"
@@ -5420,7 +5430,8 @@ check_typebound_baseobject (gfc_expr* e)
       goto cleanup;
     }
 
-  /* If the procedure called is NOPASS, the base object must be scalar.  */
+  /* F08:C1230. If the procedure called is NOPASS,
+     the base object must be scalar.  */
   if (e->value.compcall.tbp->nopass && base->rank > 0)
     {
       gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
@@ -5428,7 +5439,7 @@ check_typebound_baseobject (gfc_expr* e)
       goto cleanup;
     }
 
-  /* FIXME: Remove once PR 41177 (this problem) is fixed completely.  */
+  /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS).  */
   if (base->rank > 0)
     {
       gfc_error ("Non-scalar base object at %L currently not implemented",
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 18492e8..4a6ad47 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-11-28  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46662
+	* gfortran.dg/proc_ptr_comp_pass_7.f90: New.
+
 2010-11-28  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/aliasing2.adb (dg-final): Robustify pattern matching.
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_7.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_7.f90
new file mode 100644
index 0000000..a15018d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_7.f90
@@ -0,0 +1,65 @@
+! { dg-do compile }
+!
+! PR 46662: [OOP] gfortran accepts "CALL polymorphic%abstract_type%ppc()"
+!
+! Contributed by Wolfgang Kilian <kilian@hep.physik.uni-siegen.de>
+! cf. http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/a0857fa4a692d518
+
+module types
+  implicit none
+
+  type, abstract :: base_t
+     integer :: i = 0
+     procedure(base_write_i), pointer :: write_procptr
+   contains
+     procedure :: write_i => base_write_i
+  end type base_t
+
+  type, extends (base_t) :: t
+  end type t
+
+contains
+
+  subroutine base_write_i (obj)
+    class (base_t), intent(in) :: obj
+    print *, obj%i
+  end subroutine base_write_i
+
+end module types
+
+
+program main
+  use types
+  implicit none
+
+  type(t) :: obj
+
+  print *, "Direct printing"
+  obj%i = 1
+  print *, obj%i
+
+  print *, "Direct printing via parent"
+  obj%base_t%i = 2
+  print *, obj%base_t%i
+
+  print *, "Printing via TBP"
+  obj%i = 3
+  call obj%write_i
+
+  print *, "Printing via parent TBP"
+  obj%base_t%i = 4
+  call obj%base_t%write_i      ! { dg-error "is of ABSTRACT type" }
+
+  print *, "Printing via OBP"
+  obj%i = 5
+  obj%write_procptr => base_write_i
+  call obj%write_procptr
+
+  print *, "Printing via parent OBP"
+  obj%base_t%i = 6
+  obj%base_t%write_procptr => base_write_i
+  call obj%base_t%write_procptr               ! { dg-error "is of ABSTRACT type" }
+
+end program main
+
+! { dg-final { cleanup-modules "types" } }