re PR fortran/43696 ([OOP] Bogus error: Passed-object dummy argument must not be POINTER)

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

	PR fortran/43696
	* resolve.c (resolve_fl_derived): Some fixes for class variables.
	* symbol.c (gfc_build_class_symbol): Add separate class container for
	class pointers.


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

	PR fortran/43696
	* gfortran.dg/class_17.f03: New.

From-SVN: r159056

5 files changed, 90 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e61c737..0641cbf 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2010-05-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43696
+	* resolve.c (resolve_fl_derived): Some fixes for class variables.
+	* symbol.c (gfc_build_class_symbol): Add separate class container for
+	class pointers.
+
 2010-05-03  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/43592
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 93c5b48..d92c69c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10794,7 +10794,7 @@ resolve_fl_derived (gfc_symbol *sym)
       
       /* If this type is an extension, see if this component has the same name
 	 as an inherited type-bound procedure.  */
-      if (super_type
+      if (super_type && !sym->attr.is_class
 	  && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
 	{
 	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
@@ -10841,7 +10841,7 @@ resolve_fl_derived (gfc_symbol *sym)
 	    }
 	}
 
-      if (c->ts.type == BT_DERIVED && c->attr.pointer
+      if (!sym->attr.is_class && c->ts.type == BT_DERIVED && c->attr.pointer
 	  && c->ts.u.derived->components == NULL
 	  && !c->ts.u.derived->attr.zero_comp)
 	{
@@ -10851,6 +10851,16 @@ resolve_fl_derived (gfc_symbol *sym)
 	  return FAILURE;
 	}
 
+      if (c->ts.type == BT_CLASS && c->ts.u.derived->components->attr.pointer
+	  && c->ts.u.derived->components->ts.u.derived->components == NULL
+	  && !c->ts.u.derived->components->ts.u.derived->attr.zero_comp)
+	{
+	  gfc_error ("The pointer component '%s' of '%s' at %L is a type "
+		     "that has not been declared", c->name, sym->name,
+		     &c->loc);
+	  return FAILURE;
+	}
+
       /* C437.  */
       if (c->ts.type == BT_CLASS
 	  && !(c->ts.u.derived->components->attr.pointer
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index b19714c..8403578 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4720,6 +4720,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
   else if ((*as) && (*as)->rank)
     sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
+  else if (attr->pointer)
+    sprintf (name, ".class.%s.p", ts->u.derived->name);
   else if (attr->allocatable)
     sprintf (name, ".class.%s.a", ts->u.derived->name);
   else
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 655afcd..f8273f0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-05-05  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43696
+	* gfortran.dg/class_17.f03: New.
+
 2010-05-04  Mike Stump  <mikestump@comcast.net>
 
 	PR objc/35165
diff --git a/gcc/testsuite/gfortran.dg/class_17.f03 b/gcc/testsuite/gfortran.dg/class_17.f03
new file mode 100644
index 0000000..b015c13
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_17.f03
@@ -0,0 +1,64 @@
+! { dg-do compile }
+!
+! PR 43696: [OOP] Bogus error: Passed-object dummy argument must not be POINTER
+!
+! Contributed by Hans-Werner Boschmann <boschmann@tp1.physik.uni-siegen.de>
+
+
+MODULE error_stack_module
+  implicit none
+
+  type,abstract::serializable_class
+   contains
+     procedure(ser_DTV_RF),deferred::read_formatted
+  end type serializable_class
+
+  abstract interface
+     subroutine ser_DTV_RF(dtv,unit,iotype,v_list,iostat,iomsg)
+       import serializable_class
+       CLASS(serializable_class),INTENT(INOUT) :: dtv
+       INTEGER, INTENT(IN) :: unit
+       CHARACTER (LEN=*), INTENT(IN) :: iotype
+       INTEGER, INTENT(IN) :: v_list(:)
+       INTEGER, INTENT(OUT) :: iostat
+       CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+     end subroutine ser_DTV_RF
+  end interface
+
+  type,extends(serializable_class)::error_type
+     class(error_type),pointer::next=>null()
+   contains
+     procedure::read_formatted=>error_read_formatted
+  end type error_type
+
+contains
+
+  recursive subroutine error_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg)
+    CLASS(error_type),INTENT(INOUT) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER (LEN=*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: v_list(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+    character(8),allocatable::type
+    character(8),allocatable::next
+    call basic_read_string(unit,type)
+    call basic_read_string(unit,next)
+    if(next=="NEXT")then
+       allocate(dtv%next)
+       call dtv%next%read_formatted(unit,iotype,v_list,iostat,iomsg)
+    end if
+  end subroutine error_read_formatted
+
+end MODULE error_stack_module
+
+
+module b_module
+  implicit none
+  type::b_type
+     class(not_yet_defined_type_type),pointer::b_component  ! { dg-error "is a type that has not been declared" }
+  end type b_type
+end module b_module
+ 
+
+! { dg-final { cleanup-modules "error_stack_module b_module" } }