re PR fortran/23843 (Access restrictions on derived types in modules too strict.)

fortran/
2005-09-22  Erik Edelmann  <erik.edelmann@iki.fi>

	PR fortran/23843
	* resolve.c (derived_inaccessible): New function.
	(resolve_transfer): Use it to check for private
	components.
testsuite/
2005-09-22  Erik Edelmann  <erik.edelmann@iki.fi>
	Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>

	PR fortran/23843
	* gfortran.dg/der_io_2.f90, gfortran.dg/der_io_3.f90: New test.

Co-Authored-By: Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de>

From-SVN: r104542

gcc/fortran/ChangeLog

+2005-09-22  Erik Edelmann  <erik.edelmann@iki.fi>
+
+	PR fortran/23843
+	* resolve.c (derived_inaccessible): New function.
+	(resolve_transfer): Use it to check for private
+	components.
+
 2005-09-22  Steven G. Kargl  <kargls@comcast.net>
 
 	PR fortran/23516

gcc/fortran/resolve.c

@@ -2518,6 +2518,29 @@ derived_pointer (gfc_symbol * sym)
 }
 
 
+/* Given a pointer to a symbol that is a derived type, see if it's
+   inaccessible, i.e. if it's defined in another module and the components are
+   PRIVATE.  The search is recursive if necessary.  Returns zero if no
+   inaccessible components are found, nonzero otherwise.  */
+
+static int
+derived_inaccessible (gfc_symbol *sym)
+{
+  gfc_component *c;
+
+  if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
+    return 1;
+
+  for (c = sym->components; c; c = c->next)
+    {
+        if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
+          return 1;
+    }
+
+  return 0;
+}
+
+
 /* Resolve the argument of a deallocate expression.  The expression must be
    a pointer or a full array.  */
 
@@ -3184,7 +3207,8 @@ resolve_select (gfc_code * code)
 
 /* Resolve a transfer statement. This is making sure that:
    -- a derived type being transferred has only non-pointer components
-   -- a derived type being transferred doesn't have private components
+   -- a derived type being transferred doesn't have private components, unless 
+      it's being transferred from the module where the type was defined
    -- we're not trying to transfer a whole assumed size array.  */
 
 static void
@@ -3219,7 +3243,7 @@ resolve_transfer (gfc_code * code)
 	  return;
 	}
 
-      if (ts->derived->component_access == ACCESS_PRIVATE)
+      if (derived_inaccessible (ts->derived))
 	{
 	  gfc_error ("Data transfer element at %L cannot have "
 		     "PRIVATE components",&code->loc);

gcc/testsuite/ChangeLog

+2005-09-22  Erik Edelmann  <erik.edelmann@iki.fi>
+	Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/23843
+	* gfortran.dg/der_io_2.f90, gfortran.dg/der_io_3.f90: New test.
+
 2005-09-22  Steven G. Kargl  <kargls@comcast.net>
 
 	PR fortran/23516

gcc/testsuite/gfortran.dg/der_io_2.f90

+! { dg-do compile }
+! PR 23843
+! IO of derived types with private components is allowed in the module itself,
+! but not elsewhere
+module gfortran2
+    type :: tp1
+        private
+        integer :: i
+    end type tp1
+
+    type :: tp1b
+        integer :: i
+    end type tp1b
+
+    type :: tp2
+        real :: a
+        type(tp1) :: t
+    end type tp2
+    
+contains
+    
+    subroutine test()
+        type(tp1) :: x
+        type(tp2) :: y
+
+        write (*, *) x
+        write (*, *) y
+    end subroutine test
+
+end module gfortran2
+
+program prog
+
+    use gfortran2
+
+    implicit none
+    type :: tp3
+        type(tp2) :: t
+    end type tp3
+    type :: tp3b
+        type(tp1b) :: t
+    end type tp3b
+
+    type(tp1) :: x
+    type(tp2) :: y
+    type(tp3) :: z
+    type(tp3b) :: zb
+
+    write (*, *) x   ! { dg-error "PRIVATE components" }
+    write (*, *) y   ! { dg-error "PRIVATE components" }
+    write (*, *) z   ! { dg-error "PRIVATE components" }
+    write (*, *) zb
+end program prog
+
+

gcc/testsuite/gfortran.dg/der_io_3.f90

+! PR23843
+! Make sure derived type I/O with PRIVATE components works where it's allowed
+module m1
+  type t1
+     integer i
+  end type t1
+end module m1
+
+module m2
+  use m1
+
+  type t2
+     private
+     type (t1) t
+  end type t2
+
+  type t3
+     private
+     integer i
+  end type t3
+
+contains
+  subroutine test
+    character*20 c
+    type(t2) :: a
+    type(t3) :: b
+
+    a % t % i = 31337
+    b % i = 255
+    
+    write(c,*) a
+    if (trim(adjustl(c)) /= "31337") call abort
+    write(c,*) b
+    if (trim(adjustl(c)) /= "255") call abort
+  end subroutine test
+end module m2
+
+use m2
+call test
+end