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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159056 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e61c737..0641cbf 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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" } }