This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[RFC, Patch, Fortran] F2003's OOP constructor support


Dear all,

attached is a draft patch for Fortran 2003's constructors. By constructors, I mean a generic function which has the same name as a derived type and which can be used in place of a structure constructor.

If the generic function returns the derived type, it resembles the constructor functions of C++; however, the generic function might also just return an integer and have no relation/knowledge of the derived type. (Only) if no suitable generic function is available, the structure constructor is used.


The attached patch is nearly ready. Thus, I would like to have feedback on the implementation. Additionally, I would be happy if someone could test it as the patch could potentially break any Fortran code which uses derived types - and it might not handle all valid constructor code either. Especially with invalid code there can be issues.



The patch is not yet cleaned up; I also need to write a changelog. For the status and possibly updated versions of the patch, see also https://userpage.physik.fu-berlin.de/~tburnus/tmp/constructor.diff


While the patch should have no major regressions nor missing features, it is not yet regression free. Currently known issues (see link above for details):
- gfortran.dg/class_21.f03: ICE on valid code.
- gfortran.dg/coarray_lock_3.f90 and coarray_lock_4.f90: The dg-error message changed.
- fortran.dg/result_1.f90: Ditto.
- constructor_4.f90: (new test) Missing -std=f95 diagnostic
- [no test] Missing ambiguous check
- (Known, unrelated failures: realloc_on_assign_5.f03, select_type_12.f03, entry_4.f90)



Internal implementation:
* For derived types, a generic-function symbol is generated
* Additionally, a symbol is generated for FL_DERIVED with the same sym->name but where the symtree->name has the first letter of the name uppercased. This is included in the sym->generic list of previous symbol.
* At resolve time, if not suitable generic function could be found, a structure constructor is assumed.
* The main issue is to have FL_DERIVED available where needed and to ensure that with module loading always both symbols are loaded.
* I had to modify iso_c_binding a bit, which resulted in fixing PR 37829 and 45190.


Tobias

PS: I have tested the patch with some real-word codes, though not all with the latest patch version. I do not expect major issues, but I do expect that some programs will fail. Hopefully, most remaining issues can be found before 4.7.0 is released.
 fortran/class.c                                   |    4 
 fortran/data.c                                    |    1 
 fortran/decl.c                                    |  149 ++++++++++++--
 fortran/gfortran.h                                |    4 
 fortran/interface.c                               |   26 +-
 fortran/match.c                                   |    3 
 fortran/module.c                                  |   65 +++++-
 fortran/primary.c                                 |  221 +++++++++++++++++++++-
 fortran/resolve.c                                 |   88 +++++++-
 fortran/symbol.c                                  |  212 +++++++++++++++------
 fortran/trans-array.c                             |    6 
 fortran/trans-decl.c                              |   25 ++
 fortran/trans-types.c                             |   28 ++
 testsuite/gfortran.dg/c_ptr_tests_17.f90          |   88 ++++++++
 testsuite/gfortran.dg/c_ptr_tests_18.f90          |   35 +++
 testsuite/gfortran.dg/constructor_1.f90           |   42 ++++
 testsuite/gfortran.dg/constructor_2.f90           |   73 +++++++
 testsuite/gfortran.dg/constructor_3.f90           |   47 ++++
 testsuite/gfortran.dg/constructor_4.f90           |   33 +++
 testsuite/gfortran.dg/constructor_5.f90           |   34 +++
 testsuite/gfortran.dg/constructor_6.f90           |  171 +++++++++++++++++
 testsuite/gfortran.dg/function_types_3.f90        |    4 
 testsuite/gfortran.dg/result_1.f90                |    5 
 testsuite/gfortran.dg/structure_constructor_3.f03 |    2 
 testsuite/gfortran.dg/structure_constructor_4.f03 |    2 
 testsuite/gfortran.dg/used_types_25.f90           |   17 +
 26 files changed, 1262 insertions(+), 123 deletions(-)

See also: https://userpage.physik.fu-berlin.de/~tburnus/tmp/constructor.diff
          PRs 39427 (constructor), 37829/45190 (ISO_C_Binding)

Index: gcc/testsuite/gfortran.dg/constructor_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_1.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_1.f90	(Revision 0)
@@ -0,0 +1,42 @@
+! { dg-do compile }
+!
+! PR fortran/39427
+!
+! Check constructor functionality.
+!
+! Contributed by Damian Rouson.
+!
+module mycomplex_module
+   private
+   public :: mycomplex
+   type mycomplex
+!      private
+      real :: argument, modulus
+   end type
+   interface mycomplex
+      module procedure complex_to_mycomplex, two_reals_to_mycomplex
+   end interface
+!   :
+   contains
+      type(mycomplex) function complex_to_mycomplex(c)
+         complex, intent(in) :: c
+!         :
+      end function complex_to_mycomplex
+      type(mycomplex) function two_reals_to_mycomplex(x,y)
+         real, intent(in)           :: x
+         real, intent(in), optional :: y
+!         :
+       end function two_reals_to_mycomplex
+!       :
+    end module mycomplex_module
+!    :
+program myuse
+    use mycomplex_module
+    type(mycomplex) :: a, b, c
+!    :
+    a = mycomplex(argument=5.6, modulus=1.0)  ! The structure constructor
+    c = mycomplex(x=0.0, y=1.0)               ! A function reference
+    c = mycomplex(0.0, 1.0)               ! A function reference
+end program myuse
+
+! { dg-final { cleanup-modules "mycomplex_module" } }
Index: gcc/testsuite/gfortran.dg/constructor_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_3.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_3.f90	(Revision 0)
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! PR fortran/39427
+!
+! Check constructor functionality.
+!
+!
+module m
+  interface cons
+    procedure cons42
+  end interface cons
+contains
+  integer function cons42()
+    cons42 = 42
+  end function cons42
+end module m
+
+
+module m2
+  type cons
+    integer :: j = -1
+  end type cons
+  interface cons
+    procedure consT
+  end interface cons
+contains
+  type(cons) function consT(k)
+    integer :: k
+    consT%j = k**2
+  end function consT
+end module m2
+
+
+use m
+use m2, only: cons
+implicit none
+type(cons) :: x
+integer :: k
+x = cons(3)
+k = cons()
+if (x%j /= 9) call abort ()
+if (k /= 42) call abort ()
+!print *, x%j
+!print *, k
+end
+
+! { dg-final { cleanup-modules "m m2" } }
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90	(Revision 0)
@@ -0,0 +1,88 @@
+! { dg-do compile }
+!
+! PR fortran/37829
+!
+! Contributed by James Van Buskirk and Jerry DeLisle.
+!
+! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR.
+
+module m3
+   use ISO_C_BINDING
+   implicit none
+   private
+
+   public kill_C_PTR
+   interface
+      function kill_C_PTR() bind(C)
+         import
+         implicit none
+         type(C_PTR) kill_C_PTR
+      end function kill_C_PTR
+   end interface
+
+   public kill_C_FUNPTR
+   interface
+      function kill_C_FUNPTR() bind(C)
+         import
+         implicit none
+         type(C_FUNPTR) kill_C_FUNPTR
+      end function kill_C_FUNPTR
+   end interface
+end module m3
+
+module m1
+   use m3
+end module m1
+
+program X
+   use m1
+   use ISO_C_BINDING
+   implicit none
+   type(C_PTR) cp
+   type(C_FUNPTR) fp
+   integer(C_INT),target :: i
+   interface
+      function fun() bind(C)
+         use ISO_C_BINDING
+         implicit none
+         real(C_FLOAT) fun
+      end function fun
+   end interface
+
+   cp = C_NULL_PTR
+   cp = C_LOC(i)
+   fp = C_NULL_FUNPTR
+   fp = C_FUNLOC(fun)
+end program X
+
+function fun() bind(C)
+   use ISO_C_BINDING
+   implicit none
+   real(C_FLOAT) fun
+   fun = 1.0
+end function fun
+
+function kill_C_PTR() bind(C)
+   use ISO_C_BINDING
+   implicit none
+   type(C_PTR) kill_C_PTR
+   integer(C_INT), pointer :: p
+   allocate(p)
+   kill_C_PTR = C_LOC(p)
+end function kill_C_PTR
+
+function kill_C_FUNPTR() bind(C)
+   use ISO_C_BINDING
+   implicit none
+   type(C_FUNPTR) kill_C_FUNPTR
+   interface
+      function fun() bind(C)
+         use ISO_C_BINDING
+         implicit none
+         real(C_FLOAT) fun
+      end function fun
+   end interface
+   kill_C_FUNPTR = C_FUNLOC(fun)
+end function kill_C_FUNPTR
+
+! { dg-final { cleanup-modules "m3 m1" } }
Index: gcc/testsuite/gfortran.dg/constructor_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_5.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_5.f90	(Revision 0)
@@ -0,0 +1,34 @@
+! { dg-do compile }
+!
+! PR fortran/39427
+!
+! Check constructor functionality.
+!
+!
+module m
+  type t
+    integer :: x
+  end type t
+  interface t
+    module procedure f
+  end interface t
+contains
+  function f()
+    type(t) :: f
+  end function
+end module
+
+module m2
+  interface t2
+    module procedure f2
+  end interface t2
+  type t2
+    integer :: x2
+  end type t2
+contains
+  function f2()
+    type(t2) :: f2
+  end function
+end module
+
+! { dg-final { cleanup-modules "m m2" } }
Index: gcc/testsuite/gfortran.dg/structure_constructor_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_3.f03	(Revision 180704)
+++ gcc/testsuite/gfortran.dg/structure_constructor_3.f03	(Arbeitskopie)
@@ -13,6 +13,6 @@ PROGRAM test
 
   TYPE(basics_t) :: basics
 
-  basics = basics_t (i=42, 1.5) ! { dg-error "without name after" }
+  basics = basics_t (i=42, 1.5) ! { dg-error "Missing keyword name" }
 
 END PROGRAM test
Index: gcc/testsuite/gfortran.dg/used_types_25.f90
===================================================================
--- gcc/testsuite/gfortran.dg/used_types_25.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/used_types_25.f90	(Revision 0)
@@ -0,0 +1,17 @@
+! { dg-do compile }
+!
+! Created to check this ambiguity when
+! constructors were added. Cf. PR fortran/39427
+
+module m
+  type t
+  end type t
+end module m
+
+use m
+ type t ! { dg-error "Derived type definition of 't' at .1. has already been defined" }
+ end type t ! { dg-error "Expecting END PROGRAM statement" }
+end
+
+! { dg-final { cleanup-modules "m" } }
+
Index: gcc/testsuite/gfortran.dg/function_types_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/function_types_3.f90	(Revision 180704)
+++ gcc/testsuite/gfortran.dg/function_types_3.f90	(Arbeitskopie)
@@ -14,6 +14,6 @@ end
 
 ! PR 50403: SIGSEGV in gfc_use_derived
 
-type(f) function f()  ! { dg-error "conflicts with DERIVED attribute|is not accessible" }
-  f=110               ! { dg-error "Unclassifiable statement" }
+type(f) function f()  ! { dg-error "The derived type 'f' at .1. is of type 'f', which has not been defined" }
+  f=110               ! { dg-error "Derived type 'f' at .1. is being used before it is defined" }
 end
Index: gcc/testsuite/gfortran.dg/constructor_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_2.f90	(Revision 0)
@@ -0,0 +1,73 @@
+! { dg-do run }
+!
+! PR fortran/39427
+!
+module foo_module
+  interface foo
+    procedure constructor
+  end interface
+
+  type foo
+    integer :: bar
+  end type
+contains
+  type(foo) function constructor()
+    constructor%bar = 1
+  end function
+
+  subroutine test_foo()
+    type(foo) :: f
+    f = foo()
+    if (f%bar /= 1) call abort ()
+    f = foo(2)
+    if (f%bar /= 2) call abort ()
+  end subroutine test_foo
+end module foo_module
+
+
+! Same as foo_module but order
+! of INTERFACE and TYPE reversed
+module bar_module
+  type bar
+    integer :: bar
+  end type
+
+  interface bar
+    procedure constructor
+  end interface
+contains
+  type(bar) function constructor()
+    constructor%bar = 3
+  end function
+
+  subroutine test_bar()
+    type(bar) :: f
+    f = bar()
+    if (f%bar /= 3) call abort ()
+    f = bar(4)
+    if (f%bar /= 4) call abort ()
+  end subroutine test_bar
+end module bar_module
+
+program main
+  use foo_module
+  use bar_module
+  implicit none
+
+  type(foo) :: f
+  type(bar) :: b
+
+  call test_foo()
+  f = foo()
+  if (f%bar /= 1) call abort ()
+  f = foo(2)
+  if (f%bar /= 2) call abort ()
+
+  call test_bar()
+  b = bar()
+  if (b%bar /= 3) call abort ()
+  b = bar(4)
+  if (b%bar /= 4) call abort ()
+end program main
+
+! { dg-final { cleanup-tree-dump "foo_module bar_module" } }
Index: gcc/testsuite/gfortran.dg/constructor_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_4.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_4.f90	(Revision 0)
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/39427
+!
+! Check constructor functionality.
+!
+!
+module m
+  type t
+    integer :: x
+  end type t
+  interface t ! { dg-error "FIXME: Invalid F95" }
+    module procedure f
+  end interface t
+contains
+  function f()
+    type(t) :: f
+  end function
+end module
+
+module m2
+  interface t2
+    module procedure f2
+  end interface t2
+  type t2! { dg-error "FIXME: Invalid F95" }
+    integer :: x2
+  end type t2
+contains
+  function f2()
+    type(t2) :: f2
+  end function
+end module
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90	(Revision 0)
@@ -0,0 +1,35 @@
+! { dg-do compile }
+!
+! PR fortran/37829
+! PR fortran/45190
+!
+! Contributed by Mat Cross
+!
+! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR.
+
+MODULE NAG_J_TYPES
+  USE ISO_C_BINDING, ONLY : C_PTR
+  IMPLICIT NONE
+  TYPE                            :: NAG_IMAGE
+     INTEGER                      :: WIDTH, HEIGHT, PXFMT, NCHAN
+     TYPE (C_PTR)                 :: PIXELS
+  END TYPE NAG_IMAGE
+END MODULE NAG_J_TYPES
+program cfpointerstress
+  use nag_j_types
+  use iso_c_binding
+  implicit none
+  type(nag_image),pointer :: img
+  type(C_PTR)             :: ptr
+  real, pointer           :: r
+  allocate(r)
+  allocate(img)
+  r = 12
+  ptr = c_loc(img)
+  write(*,*) 'C_ASSOCIATED =', C_ASSOCIATED(ptr)
+  call c_f_pointer(ptr, img)
+  write(*,*) 'ASSOCIATED =', associated(img)
+  deallocate(r)
+end program cfpointerstress
+
+! { dg-final { cleanup-modules "nag_j_types" } }
Index: gcc/testsuite/gfortran.dg/constructor_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/constructor_6.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/constructor_6.f90	(Revision 0)
@@ -0,0 +1,171 @@
+! { dg-do run }
+!
+! PR fortran/39427
+!
+! Contributed by Norman S. Clerman (in PR fortran/45155)
+!
+! Constructor test case
+!
+!
+module test_cnt
+  integer, public, save :: my_test_cnt = 0
+end module test_cnt
+
+module Rational
+  use test_cnt
+  implicit none
+  private
+
+  type, public :: rational_t
+    integer :: n = 0, id = 1
+  contains
+    procedure, nopass :: Construct_rational_t
+    procedure :: Print_rational_t
+    procedure, private :: Rational_t_init
+    generic :: Rational_t => Construct_rational_t
+    generic :: print      => Print_rational_t
+  end type rational_t
+
+contains
+
+  function Construct_rational_t (message_) result (return_type)
+    character (*), intent (in) :: message_
+    type (rational_t) :: return_type
+
+!    print *, trim (message_)
+    if (my_test_cnt /= 1) call abort()
+    my_test_cnt = my_test_cnt + 1
+    call return_type % Rational_t_init
+
+  end function Construct_rational_t
+
+  subroutine Print_rational_t (this_)
+    class (rational_t), intent (in) :: this_
+
+!    print *, "n, id", this_% n, this_% id
+    if (my_test_cnt == 0) then
+      if (this_% n /= 0 .or. this_% id /= 1) call abort ()
+    else if (my_test_cnt == 2) then
+      if (this_% n /= 10 .or. this_% id /= 0) call abort ()
+    else
+      call abort ()
+    end if
+    my_test_cnt = my_test_cnt + 1
+  end subroutine Print_rational_t
+
+  subroutine Rational_t_init (this_)
+    class (rational_t), intent (in out) :: this_
+
+    this_% n = 10
+    this_% id = 0
+
+  end subroutine Rational_t_init
+
+end module Rational
+
+module Temp_node
+  use test_cnt
+  implicit none
+  private
+
+  real, parameter :: NOMINAL_TEMP = 20.0
+
+  type, public :: temp_node_t
+    real :: temperature = NOMINAL_TEMP
+    integer :: id = 1
+  contains
+    procedure :: Print_temp_node_t
+    procedure, private :: Temp_node_t_init
+    generic :: Print => Print_temp_node_t
+  end type temp_node_t
+
+  interface temp_node_t
+    module procedure Construct_temp_node_t
+  end interface
+
+contains
+
+  function Construct_temp_node_t (message_) result (return_type)
+    character (*), intent (in) :: message_
+    type (temp_node_t) :: return_type
+
+    !print *, trim (message_)
+    if (my_test_cnt /= 4) call abort()
+    my_test_cnt = my_test_cnt + 1
+    call return_type % Temp_node_t_init
+
+  end function Construct_temp_node_t
+
+  subroutine Print_temp_node_t (this_)
+    class (temp_node_t), intent (in) :: this_
+
+!    print *, "temp, id", this_% temperature, this_% id
+    if (my_test_cnt == 3) then
+      if (this_% temperature /= 20 .or. this_% id /= 1) call abort ()
+    else if (my_test_cnt == 5) then
+      if (this_% temperature /= 10 .or. this_% id /= 0) call abort ()
+    else
+      call abort ()
+    end if
+    my_test_cnt = my_test_cnt + 1
+  end subroutine Print_temp_node_t
+
+  subroutine Temp_node_t_init (this_)
+    class (temp_node_t), intent (in out) :: this_
+
+    this_% temperature = 10.0
+    this_% id = 0
+
+  end subroutine Temp_node_t_init
+
+end module Temp_node
+
+program Struct_over
+  use test_cnt
+  use Rational,  only : rational_t
+  use Temp_node, only : temp_node_t
+
+  implicit none
+
+  type (rational_t)  :: sample_rational_t
+  type (temp_node_t) :: sample_temp_node_t
+
+!  print *, "rational_t"
+!  print *, "----------"
+!  print *, ""
+!
+!  print *, "after declaration"
+  if (my_test_cnt /= 0) call abort()
+  call sample_rational_t % print
+
+  if (my_test_cnt /= 1) call abort()
+
+  sample_rational_t = sample_rational_t % rational_t ("using override")
+  if (my_test_cnt /= 2) call abort()
+!  print *, "after override"
+  !  call print (sample_rational_t)
+  !  call sample_rational_t % print ()
+  call sample_rational_t % print
+
+  if (my_test_cnt /= 3) call abort()
+
+!  print *, "sample_t"
+!  print *, "--------"
+!  print *, ""
+!
+!  print *, "after declaration"
+  call sample_temp_node_t % print
+
+  if (my_test_cnt /= 4) call abort()
+
+  sample_temp_node_t = temp_node_t ("using override")
+  if (my_test_cnt /= 5) call abort()
+!  print *, "after override"
+  !  call print (sample_rational_t)
+  !  call sample_rational_t % print ()
+  call sample_temp_node_t % print
+  if (my_test_cnt /= 6) call abort()
+
+end program Struct_over
+
+! { dg-final { cleanup-modules "test_cnt rational temp_node" } }
Index: gcc/testsuite/gfortran.dg/result_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/result_1.f90	(Revision 180704)
+++ gcc/testsuite/gfortran.dg/result_1.f90	(Arbeitskopie)
@@ -15,4 +15,9 @@ end function
 
 function h() result(t)
 type t    ! { dg-error "attribute conflicts" }
+end type t
 end function
+
+function i() result(t)
+type t    
+end function    ! { dg-error "Expecting END TYPE statement" }
Index: gcc/testsuite/gfortran.dg/structure_constructor_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_4.f03	(Revision 180704)
+++ gcc/testsuite/gfortran.dg/structure_constructor_4.f03	(Arbeitskopie)
@@ -14,6 +14,6 @@ PROGRAM test
   TYPE(basics_t) :: basics
 
   basics = basics_t (42, r=1.5, i=15) ! { dg-error "'i' is initialized twice" }
-  basics = basics_t (42, r=1., r=-2.) ! { dg-error "'r' is initialized twice" }
+  basics = basics_t (42, r=1., r=-2.) ! { dg-error "has already appeared in the current argument list" }
 
 END PROGRAM test
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 180703)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -1261,8 +1261,9 @@ check_interface0 (gfc_interface *p, const char *in
     {
       /* Make sure all symbols in the interface have been defined as
 	 functions or subroutines.  */
-      if ((!p->sym->attr.function && !p->sym->attr.subroutine)
-	  || !p->sym->attr.if_source)
+      if (((!p->sym->attr.function && !p->sym->attr.subroutine)
+	   || !p->sym->attr.if_source)
+	  && p->sym->attr.flavor != FL_DERIVED)
 	{
 	  if (p->sym->attr.external)
 	    gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
@@ -1275,11 +1276,18 @@ check_interface0 (gfc_interface *p, const char *in
 	}
 
       /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs.  */
-      if ((psave->sym->attr.function && !p->sym->attr.function)
+      if ((psave->sym->attr.function && !p->sym->attr.function
+	   && p->sym->attr.flavor != FL_DERIVED)
 	  || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
 	{
-	  gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
-		     " or all FUNCTIONs", interface_name, &p->sym->declared_at);
+	  if (p->sym->attr.flavor != FL_DERIVED)
+	    gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
+		       " or all FUNCTIONs", interface_name,
+		       &p->sym->declared_at);
+	  else
+	    gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
+		       "generic name is also the name of a derived type",
+		       interface_name, &p->sym->declared_at);
 	  return 1;
 	}
 
@@ -1335,8 +1343,10 @@ check_interface1 (gfc_interface *p, gfc_interface
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
-				    0, NULL, 0))
+	if (p->sym->attr.flavor != FL_DERIVED
+	    && q->sym->attr.flavor != FL_DERIVED
+	    && gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
+				       generic_flag, 0, NULL, 0))
 	  {
 	    if (referenced)
 	      gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
@@ -3018,6 +3028,8 @@ gfc_search_interface (gfc_interface *intr, int sub
 
   for (; intr; intr = intr->next)
     {
+      if (intr->sym->attr.flavor == FL_DERIVED)
+	continue;
       if (sub_flag && intr->sym->attr.function)
 	continue;
       if (!sub_flag && intr->sym->attr.subroutine)
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(Revision 180703)
+++ gcc/fortran/trans-array.c	(Arbeitskopie)
@@ -4674,6 +4674,12 @@ gfc_conv_array_initializer (tree type, gfc_expr *
   tree index, range;
   VEC(constructor_elt,gc) *v = NULL;
 
+  /*FIXME: WHY IS THIS NEEDED FOR gfortran.dg/array_constructor_32.f90 ? */
+  if (expr->expr_type == EXPR_VARIABLE
+      && expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+      && expr->symtree->n.sym->value)
+    expr = expr->symtree->n.sym->value;
+
   switch (expr->expr_type)
     {
     case EXPR_CONSTANT:
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(Revision 180703)
+++ gcc/fortran/class.c	(Arbeitskopie)
@@ -396,7 +396,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
-  
+
+  gcc_assert (!derived->attr.generic);
+ 
   /* Find the top-level namespace (MODULE or PROGRAM).  */
   for (ns = gfc_current_ns; ns; ns = ns->parent)
     if (!ns->parent)
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 180703)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -1949,6 +1949,9 @@ gfc_use_derived (gfc_symbol *sym)
   if (!sym)
     return NULL;
 
+  if (sym->attr.generic)
+    sym = gfc_find_dt_in_generic (sym);
+
   if (sym->components != NULL || sym->attr.zero_comp)
     return sym;               /* Already defined.  */
 
@@ -2880,7 +2883,12 @@ gfc_undo_symbols (void)
 		}
 	    }
 
-	  gfc_delete_symtree (&p->ns->sym_root, p->name);
+	  if (p->attr.flavor == FL_DERIVED)
+	    gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
+                        (char) TOUPPER ((unsigned char) p->name[0]),
+                        &p->name[1]));
+	  else
+	    gfc_delete_symtree (&p->ns->sym_root, p->name);
 
 	  gfc_release_symbol (p);
 	  continue;
@@ -3741,15 +3749,15 @@ gen_special_c_interop_ptr (int ptr_id, const char
          that has arg(s) of the missing type.  In this case, a
          regular version of the thing should have been put in the
          current ns.  */
+
       generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR 
                                    ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
                                    (const char *) (ptr_id == ISOCBINDING_NULL_PTR 
-				   ? "_gfortran_iso_c_binding_c_ptr"
-				   : "_gfortran_iso_c_binding_c_funptr"));
-
+				   ? "c_ptr"
+				   : "c_funptr"));
       tmp_sym->ts.u.derived =
-        get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
-                              ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
+	get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
+			      ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
     }
 
   /* Module name is some mangled version of iso_c_binding.  */
@@ -3827,9 +3835,9 @@ gen_cptr_param (gfc_formal_arglist **head,
   const char *c_ptr_type = NULL;
 
   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
-    c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
+    c_ptr_type = "c_funptr";
   else
-    c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
+    c_ptr_type = "c_ptr";
 
   if(c_ptr_name == NULL)
     c_ptr_in = "gfc_cptr__";
@@ -4306,20 +4314,32 @@ generate_isocbinding_symbol (const char *mod_name,
 					     : c_interop_kinds_table[s].name;
   gfc_symtree *tmp_symtree = NULL;
   gfc_symbol *tmp_sym = NULL;
-  gfc_dt_list **dt_list_ptr = NULL;
-  gfc_component *tmp_comp = NULL;
-  char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
   int index;
 
   if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
     return;
+
   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
 
-  /* Already exists in this scope so don't re-add it.
-     TODO: we should probably check that it's really the same symbol.  */
-  if (tmp_symtree != NULL)
-    return;
+  /* Already exists in this scope so don't re-add it. */
+  if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
+      && (!tmp_sym->attr.generic
+	  || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
+      && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
+    {
+      if (tmp_sym->attr.flavor == FL_DERIVED
+	  && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
+	{
+	  gfc_dt_list *dt_list;
+	  dt_list = gfc_get_dt_list ();
+	  dt_list->derived = tmp_sym;
+	  dt_list->next = gfc_derived_types;
+  	  gfc_derived_types = dt_list;
+        }
 
+      return;
+    }
+
   /* Create the sym tree in the current ns.  */
   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
   if (tmp_symtree)
@@ -4411,64 +4431,112 @@ generate_isocbinding_symbol (const char *mod_name,
 
       case ISOCBINDING_PTR:
       case ISOCBINDING_FUNPTR:
+	{
+	  gfc_interface *intr, *head;
+	  gfc_symbol *dt_sym;
+	  const char *hidden_name;
+	  gfc_dt_list **dt_list_ptr = NULL;
+	  gfc_component *tmp_comp = NULL;
+	  char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
 
-	/* Initialize an integer constant expression node.  */
-	tmp_sym->attr.flavor = FL_DERIVED;
-	tmp_sym->ts.is_c_interop = 1;
-	tmp_sym->attr.is_c_interop = 1;
-	tmp_sym->attr.is_iso_c = 1;
-	tmp_sym->ts.is_iso_c = 1;
-	tmp_sym->ts.type = BT_DERIVED;
+	  hidden_name = gfc_get_string ("%c%s",
+			    (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
+                            &tmp_sym->name[1]);
 
-	/* A derived type must have the bind attribute to be
-	   interoperable (J3/04-007, Section 15.2.3), even though
-	   the binding label is not used.  */
-	tmp_sym->attr.is_bind_c = 1;
+	  /* Generate real derived type.  */
+	  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+					  hidden_name);
 
-	tmp_sym->attr.referenced = 1;
+	  if (tmp_symtree != NULL)
+	    gcc_unreachable ();
+	  gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
+	  if (tmp_symtree)
+	    dt_sym = tmp_symtree->n.sym;
+	  else
+	    gcc_unreachable ();
 
-	tmp_sym->ts.u.derived = tmp_sym;
+	  /* Generate an artificial generic function.  */
+	  dt_sym->name = gfc_get_string (tmp_sym->name);
+	  head = tmp_sym->generic;
+	  intr = gfc_get_interface ();
+	  intr->sym = dt_sym;
+	  intr->where = gfc_current_locus;
+	  intr->next = head;
+	  tmp_sym->generic = intr;
 
-        /* Add the symbol created for the derived type to the current ns.  */
-        dt_list_ptr = &(gfc_derived_types);
-        while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
-          dt_list_ptr = &((*dt_list_ptr)->next);
+	  if (!tmp_sym->attr.generic
+	      && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
+		 == FAILURE)
+	    return;
 
-        /* There is already at least one derived type in the list, so append
-           the one we're currently building for c_ptr or c_funptr.  */
-        if (*dt_list_ptr != NULL)
-          dt_list_ptr = &((*dt_list_ptr)->next);
-        (*dt_list_ptr) = gfc_get_dt_list ();
-        (*dt_list_ptr)->derived = tmp_sym;
-        (*dt_list_ptr)->next = NULL;
+	  if (!tmp_sym->attr.function
+	      && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
+		 == FAILURE)
+	    return;
 
-        /* Set up the component of the derived type, which will be
-           an integer with kind equal to c_ptr_size.  Mangle the name of
-           the field for the c_address to prevent the curious user from
-           trying to access it from Fortran.  */
-        sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
-        gfc_add_component (tmp_sym, comp_name, &tmp_comp);
-        if (tmp_comp == NULL)
+	  /* Say what module this symbol belongs to.  */
+	  dt_sym->module = gfc_get_string (mod_name);
+	  dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
+	  dt_sym->intmod_sym_id = s;
+
+	  /* Initialize an integer constant expression node.  */
+	  dt_sym->attr.flavor = FL_DERIVED;
+	  dt_sym->ts.is_c_interop = 1;
+	  dt_sym->attr.is_c_interop = 1;
+	  dt_sym->attr.is_iso_c = 1;
+	  dt_sym->ts.is_iso_c = 1;
+	  dt_sym->ts.type = BT_DERIVED;
+
+	  /* A derived type must have the bind attribute to be
+	     interoperable (J3/04-007, Section 15.2.3), even though
+	     the binding label is not used.  */
+	  dt_sym->attr.is_bind_c = 1;
+
+	  dt_sym->attr.referenced = 1;
+	  dt_sym->ts.u.derived = dt_sym;
+
+	  /* Add the symbol created for the derived type to the current ns.  */
+	  dt_list_ptr = &(gfc_derived_types);
+	  while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
+	    dt_list_ptr = &((*dt_list_ptr)->next);
+
+	  /* There is already at least one derived type in the list, so append
+	     the one we're currently building for c_ptr or c_funptr.  */
+	  if (*dt_list_ptr != NULL)
+	    dt_list_ptr = &((*dt_list_ptr)->next);
+	  (*dt_list_ptr) = gfc_get_dt_list ();
+	  (*dt_list_ptr)->derived = dt_sym;
+	  (*dt_list_ptr)->next = NULL;
+
+	  /* Set up the component of the derived type, which will be
+	     an integer with kind equal to c_ptr_size.  Mangle the name of
+	     the field for the c_address to prevent the curious user from
+	     trying to access it from Fortran.  */
+	  sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
+	  gfc_add_component (dt_sym, comp_name, &tmp_comp);
+	  if (tmp_comp == NULL)
           gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
 			      "create component for c_address");
 
-        tmp_comp->ts.type = BT_INTEGER;
+	  tmp_comp->ts.type = BT_INTEGER;
 
-        /* Set this because the module will need to read/write this field.  */
-        tmp_comp->ts.f90_type = BT_INTEGER;
+	  /* Set this because the module will need to read/write this field.  */
+	  tmp_comp->ts.f90_type = BT_INTEGER;
 
-        /* The kinds for c_ptr and c_funptr are the same.  */
-        index = get_c_kind ("c_ptr", c_interop_kinds_table);
-        tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+	  /* The kinds for c_ptr and c_funptr are the same.  */
+	  index = get_c_kind ("c_ptr", c_interop_kinds_table);
+	  tmp_comp->ts.kind = c_interop_kinds_table[index].value;
 
-        tmp_comp->attr.pointer = 0;
-        tmp_comp->attr.dimension = 0;
+	  tmp_comp->attr.pointer = 0;
+	  tmp_comp->attr.dimension = 0;
 
-        /* Mark the component as C interoperable.  */
-        tmp_comp->ts.is_c_interop = 1;
+	  /* Mark the component as C interoperable.  */
+	  tmp_comp->ts.is_c_interop = 1;
 
-        /* Make it use associated (iso_c_binding module).  */
-        tmp_sym->attr.use_assoc = 1;
+	  /* Make it use associated (iso_c_binding module).  */
+	  dt_sym->attr.use_assoc = 1;
+	}
+
 	break;
 
       case ISOCBINDING_NULL_PTR:
@@ -4526,8 +4594,8 @@ generate_isocbinding_symbol (const char *mod_name,
 		      (mod_name, s == ISOCBINDING_FUNLOC
 				 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
 		       (const char *)(s == ISOCBINDING_FUNLOC
-                                ? "_gfortran_iso_c_binding_c_funptr"
-				: "_gfortran_iso_c_binding_c_ptr"));
+                                ? "c_funptr"
+				: "c_ptr"));
                     tmp_sym->ts.u.derived =
                       get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
                                             ? ISOCBINDING_FUNPTR
@@ -4680,6 +4748,11 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
 gfc_symbol*
 gfc_get_derived_super_type (gfc_symbol* derived)
 {
+/*   FIXME: SHould this be set? The value derived->attr.generic indeed occurs here!
+     for instance for gfortran.dg/coarray_lock_5.f90.  */
+  if (derived && derived->attr.generic)
+    derived = gfc_find_dt_in_generic (derived);
+
   if (!derived->attr.extension)
     return NULL;
 
@@ -4687,6 +4760,9 @@ gfc_get_derived_super_type (gfc_symbol* derived)
   gcc_assert (derived->components->ts.type == BT_DERIVED);
   gcc_assert (derived->components->ts.u.derived);
 
+  if (derived->components->ts.u.derived->attr.generic)
+    return gfc_find_dt_in_generic (derived->components->ts.u.derived);
+
   return derived->components->ts.u.derived;
 }
 
@@ -4782,3 +4858,19 @@ gfc_is_associate_pointer (gfc_symbol* sym)
 
   return true;
 }
+
+
+gfc_symbol *
+gfc_find_dt_in_generic (gfc_symbol *sym)
+{
+  gfc_interface *intr = NULL;
+
+  if (!sym || sym->attr.flavor == FL_DERIVED)
+    return sym;
+
+  if (sym->attr.generic)
+    for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
+      if (intr->sym->attr.flavor == FL_DERIVED)
+        break;
+  return intr ? intr->sym : NULL;
+}
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 180703)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -323,7 +323,7 @@ static match
 match_data_constant (gfc_expr **result)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
-  gfc_symbol *sym;
+  gfc_symbol *sym, *dt_sym = NULL;
   gfc_expr *expr;
   match m;
   locus old_loc;
@@ -366,15 +366,19 @@ match_data_constant (gfc_expr **result)
   if (gfc_find_symbol (name, NULL, 1, &sym))
     return MATCH_ERROR;
 
+  if (sym && sym->attr.generic)
+    dt_sym = gfc_find_dt_in_generic (sym);
+
   if (sym == NULL
-      || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
+      || (sym->attr.flavor != FL_PARAMETER
+	  && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
     {
       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
 		 name);
       return MATCH_ERROR;
     }
-  else if (sym->attr.flavor == FL_DERIVED)
-    return gfc_match_structure_constructor (sym, result, false);
+  else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
+    return gfc_match_structure_constructor (dt_sym, result, false);
 
   /* Check to see if the value is an initialization array expression.  */
   if (sym->value->expr_type == EXPR_ARRAY)
@@ -1954,7 +1958,7 @@ variable_decl (int elem)
       st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
       if (!(current_ts.u.derived->attr.imported
 		&& st != NULL
-		&& st->n.sym == current_ts.u.derived)
+		&& gfc_find_dt_in_generic (st->n.sym) == current_ts.u.derived)
 	    && !gfc_current_ns->has_import_set)
 	{
 	    gfc_error ("the type of '%s' at %C has not been declared within the "
@@ -2501,7 +2505,7 @@ match
 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
-  gfc_symbol *sym;
+  gfc_symbol *sym, *dt_sym;
   match m;
   char c;
   bool seen_deferred_kind, matched_type;
@@ -2668,7 +2672,10 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int im
       ts->u.derived = NULL;
       if (gfc_current_state () != COMP_INTERFACE
 	    && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
-	ts->u.derived = sym;
+	{
+	  sym = gfc_find_dt_in_generic (sym);
+	  ts->u.derived = sym;
+	}
       return MATCH_YES;
     }
 
@@ -2696,13 +2703,52 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int im
 	return MATCH_NO;
     }
 
-  if (sym->attr.flavor != FL_DERIVED
-      && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
-    return MATCH_ERROR;
 
   gfc_set_sym_referenced (sym);
-  ts->u.derived = sym;
+  if (sym->attr.flavor != FL_DERIVED)
+    {
+      if (!sym->attr.generic
+	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
+	return MATCH_ERROR;
 
+      if (!sym->attr.function
+	  && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+	return MATCH_ERROR;
+
+      dt_sym = gfc_find_dt_in_generic (sym);
+      if (dt_sym)
+	gfc_set_sym_referenced (dt_sym);
+   }
+  else
+    dt_sym = sym;
+
+  if (!dt_sym)
+    {
+      gfc_interface *intr, *head;
+
+      /* Use upper case to save the actual derived-type symbol.  */
+      gfc_get_symbol (gfc_get_string ("%c%s",
+		      (char) TOUPPER ((unsigned char) sym->name[0]),
+		      &sym->name[1]), NULL, &dt_sym);
+      gfc_set_sym_referenced (dt_sym);
+      dt_sym->name = gfc_get_string (sym->name);
+      head = sym->generic;
+      intr = gfc_get_interface ();
+      intr->sym = dt_sym;
+      intr->where = gfc_current_locus;
+      intr->next = head;
+      sym->generic = intr;
+      sym->attr.if_source = IFSRC_DECL;
+    }
+
+
+  if (dt_sym->attr.flavor != FL_DERIVED
+      && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
+			 == FAILURE)
+    return MATCH_ERROR;
+
+  ts->u.derived = dt_sym;
+
   return MATCH_YES;
 
 get_kind:
@@ -3053,6 +3099,17 @@ gfc_match_import (void)
 	  sym->refs++;
 	  sym->attr.imported = 1;
 
+	  if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
+	    {
+	      st = gfc_new_symtree (&gfc_current_ns->sym_root,
+			gfc_get_string ("%c%s",
+				(char) TOUPPER ((unsigned char) sym->name[0]),
+				&sym->name[1]));
+	      st->n.sym = sym;
+	      sym->refs++;
+	      sym->attr.imported = 1;
+	    }
+
 	  goto next_item;
 
 	case MATCH_NO:
@@ -6475,7 +6532,7 @@ access_attr_decl (gfc_statement st)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   interface_type type;
   gfc_user_op *uop;
-  gfc_symbol *sym;
+  gfc_symbol *sym, *dt_sym;
   gfc_intrinsic_op op;
   match m;
 
@@ -6505,6 +6562,13 @@ access_attr_decl (gfc_statement st)
 			      sym->name, NULL) == FAILURE)
 	    return MATCH_ERROR;
 
+	  if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
+	      && gfc_add_access (&dt_sym->attr,
+				 (st == ST_PUBLIC) ? ACCESS_PUBLIC
+						   : ACCESS_PRIVATE,
+				 sym->name, NULL) == FAILURE)
+	    return MATCH_ERROR;
+
 	  break;
 
 	case INTERFACE_INTRINSIC_OP:
@@ -7175,6 +7239,8 @@ check_extended_derived_type (char *name)
       return NULL;
     }
 
+  extended = gfc_find_dt_in_generic (extended);
+
   if (extended->attr.flavor != FL_DERIVED)
     {
       gfc_error ("'%s' in EXTENDS expression at %C is not a "
@@ -7277,11 +7343,12 @@ gfc_match_derived_decl (void)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   char parent[GFC_MAX_SYMBOL_LEN + 1];
   symbol_attribute attr;
-  gfc_symbol *sym;
+  gfc_symbol *sym, *gensym;
   gfc_symbol *extended;
   match m;
   match is_type_attr_spec = MATCH_NO;
   bool seen_attr = false;
+  gfc_interface *intr = NULL, *head;
 
   if (gfc_current_state () == COMP_DERIVED)
     return MATCH_NO;
@@ -7327,16 +7394,50 @@ gfc_match_derived_decl (void)
       return MATCH_ERROR;
     }
 
-  if (gfc_get_symbol (name, NULL, &sym))
+  if (gfc_get_symbol (name, NULL, &gensym))
     return MATCH_ERROR;
 
-  if (sym->ts.type != BT_UNKNOWN)
+  if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
     {
       gfc_error ("Derived type name '%s' at %C already has a basic type "
-		 "of %s", sym->name, gfc_typename (&sym->ts));
+		 "of %s", gensym->name, gfc_typename (&gensym->ts));
       return MATCH_ERROR;
     }
 
+  if (!gensym->attr.generic
+      && gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE)
+    return MATCH_ERROR;
+
+  if (!gensym->attr.function
+      && gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE)
+    return MATCH_ERROR;
+
+  sym = gfc_find_dt_in_generic (gensym);
+
+  if (sym && (sym->components != NULL || sym->attr.zero_comp))
+    {
+      gfc_error ("Derived type definition of '%s' at %C has already been "
+                 "defined", sym->name);
+      return MATCH_ERROR;
+    }
+
+  if (!sym)
+    {
+      /* Use upper case to save the actual derived-type symbol.  */
+      gfc_get_symbol (gfc_get_string ("%c%s",
+			(char) TOUPPER ((unsigned char) gensym->name[0]),
+			&gensym->name[1]), NULL, &sym);
+      sym->name = gfc_get_string (gensym->name);
+      head = gensym->generic;
+      intr = gfc_get_interface ();
+      intr->sym = sym;
+      intr->where = gfc_current_locus;
+      intr->sym->declared_at = gfc_current_locus;
+      intr->next = head;
+      gensym->generic = intr;
+      gensym->attr.if_source = IFSRC_DECL;
+    }
+
   /* The symbol may already have the derived attribute without the
      components.  The ways this can happen is via a function
      definition, an INTRINSIC statement or a subtype in another
@@ -7346,17 +7447,19 @@ gfc_match_derived_decl (void)
       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
     return MATCH_ERROR;
 
-  if (sym->components != NULL || sym->attr.zero_comp)
-    {
-      gfc_error ("Derived type definition of '%s' at %C has already been "
-		 "defined", sym->name);
-      return MATCH_ERROR;
-    }
-
   if (attr.access != ACCESS_UNKNOWN
       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
     return MATCH_ERROR;
+  else if (sym->attr.access == ACCESS_UNKNOWN
+	   && gensym->attr.access != ACCESS_UNKNOWN
+	   && gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL)
+	      == FAILURE)
+    return MATCH_ERROR;
 
+  if (sym->attr.access != ACCESS_UNKNOWN
+      && gensym->attr.access == ACCESS_UNKNOWN)
+    gensym->attr.access = sym->attr.access;
+
   /* See if the derived type was labeled as bind(c).  */
   if (attr.is_bind_c != 0)
     sym->attr.is_bind_c = attr.is_bind_c;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 180703)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -2630,6 +2630,7 @@ gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_n
 gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
 
 bool gfc_is_associate_pointer (gfc_symbol*);
+gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *);
 
 /* intrinsic.c -- true if working in an init-expr, false otherwise.  */
 extern bool gfc_init_expr_flag;
@@ -2874,6 +2875,9 @@ match gfc_match_rvalue (gfc_expr **);
 match gfc_match_varspec (gfc_expr*, int, bool, bool);
 int gfc_check_digit (char, int);
 bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
+gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *,
+					      gfc_expr **,
+					      gfc_actual_arglist **, bool);
 
 /* trans.c */
 void gfc_generate_code (gfc_namespace *);
Index: gcc/fortran/data.c
===================================================================
--- gcc/fortran/data.c	(Revision 180703)
+++ gcc/fortran/data.c	(Arbeitskopie)
@@ -424,6 +424,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr
 	      /* Setup the expression to hold the constructor.  */
 	      expr->expr_type = EXPR_STRUCTURE;
 	      expr->ts.type = BT_DERIVED;
+	      gcc_assert (ref->u.c.sym->attr.flavor == FL_DERIVED);
 	      expr->ts.u.derived = ref->u.c.sym;
 	    }
 	  else
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(Revision 180703)
+++ gcc/fortran/module.c	(Arbeitskopie)
@@ -429,6 +429,15 @@ resolve_fixups (fixup_t *f, void *gp)
 }
 
 
+const char *
+dt_low_string (const char *name)
+{
+  if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
+    return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
+			   &name[1]);
+  return name;
+}
+
 /* Call here during module reading when we know what pointer to
    associate with an integer.  Any fixups that exist are resolved at
    this time.  */
@@ -699,12 +708,18 @@ static const char *
 find_use_name_n (const char *name, int *inst, bool interface)
 {
   gfc_use_rename *u;
+  const char *low_name = NULL;
   int i;
 
+  /* For derived types.  */
+  if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
+    low_name = dt_low_string (name);
+
   i = 0;
   for (u = gfc_rename_list; u; u = u->next)
     {
-      if (strcmp (u->use_name, name) != 0
+      if ((!low_name && strcmp (u->use_name, name) != 0)
+	  || (low_name && strcmp (u->use_name, low_name) != 0)
 	  || (u->op == INTRINSIC_USER && !interface)
 	  || (u->op != INTRINSIC_USER &&  interface))
 	continue;
@@ -723,6 +738,15 @@ find_use_name_n (const char *name, int *inst, bool
 
   u->found = 1;
 
+  if (low_name)
+    {
+      if (u->local_name[0] == '\0')
+	return name;
+      return gfc_get_string ("%c%s",
+			     (char) TOUPPER ((unsigned char) u->local_name[0]),
+			     &u->local_name[1]);
+    }
+
   return (u->local_name[0] != '\0') ? u->local_name : name;
 }
 
@@ -780,6 +804,7 @@ find_use_operator (gfc_intrinsic_op op)
 typedef struct true_name
 {
   BBT_HEADER (true_name);
+  const char *name;
   gfc_symbol *sym;
 }
 true_name;
@@ -803,7 +828,7 @@ compare_true_names (void *_t1, void *_t2)
   if (c != 0)
     return c;
 
-  return strcmp (t1->sym->name, t2->sym->name);
+  return strcmp (t1->name, t2->name);
 }
 
 
@@ -817,7 +842,7 @@ find_true_name (const char *name, const char *modu
   gfc_symbol sym;
   int c;
 
-  sym.name = gfc_get_string (name);
+  t.name = gfc_get_string (name);
   if (module != NULL)
     sym.module = gfc_get_string (module);
   else
@@ -841,12 +866,13 @@ find_true_name (const char *name, const char *modu
 /* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
 
 static void
-add_true_name (gfc_symbol *sym)
+add_true_name (gfc_symbol *sym, const char *name)
 {
   true_name *t;
 
   t = XCNEW (true_name);
   t->sym = sym;
+  t->name = name;
 
   gfc_insert_bbt (&true_name_root, t, compare_true_names);
 }
@@ -864,10 +890,10 @@ build_tnt (gfc_symtree *st)
   build_tnt (st->left);
   build_tnt (st->right);
 
-  if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
+  if (find_true_name (st->name, st->n.sym->module) != NULL)
     return;
 
-  add_true_name (st->n.sym);
+  add_true_name (st->n.sym, st->name);
 }
 
 
@@ -4121,7 +4147,11 @@ load_derived_extensions (void)
 	  continue;
 	}
 
-      gcc_assert (derived->attr.flavor == FL_DERIVED);
+      if (derived->attr.generic) /* FIXME: DOES THIS MAKE SENSE AT ALL?
+	WITHOUT ASSERT FAILS, WITH a class.c assert fails for gfortran.dg/dynamic_dispatch_6.f03  */
+        derived = gfc_find_dt_in_generic (derived);
+
+      gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
       if (derived->f2k_derived == NULL)
 	derived->f2k_derived = gfc_get_namespace (NULL, 0);
 
@@ -4204,7 +4234,7 @@ load_needed (pointer_info *p)
 	gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
 				 1, &ns->proc_name);
 
-      sym = gfc_new_symbol (p->u.rsym.true_name, ns);
+      sym = gfc_new_symbol (dt_low_string (p->u.rsym.true_name), ns);
       sym->module = gfc_get_string (p->u.rsym.module);
       strcpy (sym->binding_label, p->u.rsym.binding_label);
 
@@ -4495,8 +4525,9 @@ read_module (void)
 	      /* Create a symbol node if it doesn't already exist.  */
 	      if (sym == NULL)
 		{
-		  info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
-						     gfc_current_ns);
+		  info->u.rsym.sym = gfc_new_symbol (
+					dt_low_string (info->u.rsym.true_name),
+					gfc_current_ns);
 		  sym = info->u.rsym.sym;
 		  sym->module = gfc_get_string (info->u.rsym.module);
 
@@ -4835,7 +4866,7 @@ write_dt_extensions (gfc_symtree *st)
     return;
 
   mio_lparen ();
-  mio_pool_string (&st->n.sym->name);
+  mio_pool_string (&st->name);
   if (st->n.sym->module != NULL)
     mio_pool_string (&st->n.sym->module);
   else
@@ -4870,8 +4901,18 @@ write_symbol (int n, gfc_symbol *sym)
     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
 
   mio_integer (&n);
-  mio_pool_string (&sym->name);
 
+  if (sym->attr.flavor == FL_DERIVED)
+    {
+      const char *name;
+      name = gfc_get_string ("%c%s",
+			     (char) TOUPPER ((unsigned char) sym->name[0]),
+			     &sym->name[1]);
+      mio_pool_string (&name);
+    }
+  else
+    mio_pool_string (&sym->name);
+
   mio_pool_string (&sym->module);
   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
     {
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(Revision 180703)
+++ gcc/fortran/trans-types.c	(Arbeitskopie)
@@ -2257,6 +2257,10 @@ gfc_get_derived_type (gfc_symbol * derived)
   gfc_dt_list *dt;
   gfc_namespace *ns;
 
+  if (derived && derived->attr.flavor == FL_PROCEDURE
+      && derived->attr.generic)
+    derived = gfc_find_dt_in_generic (derived);
+
   gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
 
   /* See if it's one of the iso_c_binding derived types.  */
@@ -2284,9 +2288,33 @@ gfc_get_derived_type (gfc_symbol * derived)
   if (gfc_option.flag_whole_file
 	&& derived->backend_decl == NULL
 	&& derived->attr.use_assoc
+/*<<<<<<< .mine
+	&& derived->module)
+    {
+      gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
+      if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+	{
+	  gfc_symbol *s;
+	  s = NULL;
+	  gfc_find_symbol (derived->name, gsym->ns, 0, &s);
+	  if (s->attr.generic)
+	    s = gfc_find_dt_in_generic (s);
+	  gcc_assert (s->attr.flavor == FL_DERIVED);
+
+	  if (s)
+	    {
+	      if (!s->backend_decl)
+		s->backend_decl = gfc_get_derived_type (s);
+	      gfc_copy_dt_decls_ifequal (s, derived, true);
+	      goto copy_derived_types;
+	    }
+	}
+    }
+=======*/
 	&& derived->module
 	&& gfc_get_module_backend_decl (derived))
     goto copy_derived_types;
+/*>>>>>>> .r170461*/
 
   /* If a whole file compilation, the derived types from an earlier
      namespace can be used as the canonical type.  */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 180703)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -454,7 +454,8 @@ resolve_formal_arglist (gfc_symbol *proc)
 static void
 find_arglists (gfc_symbol *sym)
 {
-  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
+  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
+      || sym->attr.flavor == FL_DERIVED)
     return;
 
   resolve_formal_arglist (sym);
@@ -963,17 +964,11 @@ resolve_structure_cons (gfc_expr *expr, int init)
 
   t = SUCCESS;
 
-  if (expr->ts.type == BT_DERIVED)
+  if (expr->ts.type == BT_DERIVED) /* && expr->ts.u.derived
+      && !expr->ts.u.derived->ts.is_iso_c)*/
     resolve_fl_derived0 (expr->ts.u.derived);
 
   cons = gfc_constructor_first (expr->value.constructor);
-  /* A constructor may have references if it is the result of substituting a
-     parameter variable.  In this case we just pull out the component we
-     want.  */
-  if (expr->ref)
-    comp = expr->ref->u.c.sym->components;
-  else
-    comp = expr->ts.u.derived->components;
 
   /* See if the user is trying to invoke a structure constructor for one of
      the iso_c_binding derived types.  */
@@ -990,8 +985,19 @@ resolve_structure_cons (gfc_expr *expr, int init)
   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
       && expr->ts.u.derived->ts.is_iso_c && cons
       && cons->expr && cons->expr->expr_type == EXPR_NULL)
+/* if (expr->ts.type == BT_DERIVED && cons
+      && cons->expr && cons->expr->expr_type == EXPR_NULL
+      && cons->expr->ts.is_iso_c)*/
     return SUCCESS;
 
+  /* A constructor may have references if it is the result of substituting a
+     parameter variable.  In this case we just pull out the component we
+     want.  */
+  if (expr->ref)
+    comp = expr->ref->u.c.sym->components;
+  else
+    comp = expr->ts.u.derived->components;
+
   for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
     {
       int rank;
@@ -1401,7 +1407,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespa
   gfc_symbol* context_proc;
   gfc_namespace* real_context;
 
-  if (sym->attr.flavor == FL_PROGRAM)
+  if (sym->attr.flavor == FL_PROGRAM
+      || sym->attr.flavor == FL_DERIVED)
     return false;
 
   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
@@ -2323,6 +2330,7 @@ resolve_generic_f (gfc_expr *expr)
 {
   gfc_symbol *sym;
   match m;
+  gfc_interface *intr = NULL;
 
   sym = expr->symtree->n.sym;
 
@@ -2335,6 +2343,11 @@ resolve_generic_f (gfc_expr *expr)
 	return FAILURE;
 
 generic:
+      if (!intr)
+	for (intr = sym->generic; intr; intr = intr->next)
+	  if (intr->sym->attr.flavor == FL_DERIVED)
+	    break;
+
       if (sym->ns->parent == NULL)
 	break;
       gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
@@ -2347,16 +2360,25 @@ generic:
 
   /* Last ditch attempt.  See if the reference is to an intrinsic
      that possesses a matching interface.  14.1.2.4  */
-  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
+  if (sym  && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
     {
-      gfc_error ("There is no specific function for the generic '%s' at %L",
-		 expr->symtree->n.sym->name, &expr->where);
+      gfc_error ("There is no specific function for the generic '%s' "
+		 "at %L", expr->symtree->n.sym->name, &expr->where);
       return FAILURE;
     }
 
+  if (intr)
+    {
+      if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
+						false) != SUCCESS)
+	return FAILURE;
+      return resolve_structure_cons (expr, 0);
+    }
+
   m = gfc_intrinsic_func_interface (expr, 0);
   if (m == MATCH_YES)
     return SUCCESS;
+
   if (m == MATCH_NO)
     gfc_error ("Generic function '%s' at %L is not consistent with a "
 	       "specific intrinsic interface", expr->symtree->n.sym->name,
@@ -5054,6 +5076,9 @@ resolve_variable (gfc_expr *e)
   if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
     return FAILURE;
 
+  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
+    sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+
   /* On the other hand, the parser may not have known this is an array;
      in this case, we have to add a FULL reference.  */
   if (sym->assoc && sym->attr.dimension && !e->ref)
@@ -10132,6 +10157,9 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
 {
   gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
 
+/*  if (sym->attr.generic)
+    sym = gfc_find_dt_in_generic (sym);*/
+
   /* Check to see if a derived type is blocked from being host
      associated by the presence of another class I symbol in the same
      namespace.  14.6.1.3 of the standard and the discussion on
@@ -10141,6 +10169,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
     {
       gfc_symbol *s;
       gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
+      if (s && s->attr.generic)
+	s = gfc_find_dt_in_generic (s);
       if (s && s->attr.flavor != FL_DERIVED)
 	{
 	  gfc_error ("The type '%s' cannot be host associated at %L "
@@ -11707,6 +11737,13 @@ resolve_fl_derived0 (gfc_symbol *sym)
 	    }
 	}
 
+      if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
+	c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
+      else if (c->ts.type == BT_CLASS && c->attr.class_ok
+	       && CLASS_DATA (c)->ts.u.derived->attr.generic)
+	CLASS_DATA (c)->ts.u.derived
+			= gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
+
       if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
 	  && c->attr.pointer && c->ts.u.derived->components == NULL
 	  && !c->ts.u.derived->attr.zero_comp)
@@ -12064,6 +12101,14 @@ resolve_symbol (gfc_symbol *sym)
 
   if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
     return;
+/*  if (sym->attr.generic && sym->attr.function)
+    {
+      gfc_symbol *dt_sym = gfc_find_dt_in_generic (sym);
+      if (dt_sym)
+        dt_sym->ts.type = BT_UNKNOWN;
+      if (dt_sym && resolve_fl_derived (dt_sym) == FAILURE)
+	return;
+    }*/
 
   /* Symbols that are module procedures with results (functions) have
      the types and array specification copied for type checking in
@@ -12180,6 +12225,20 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+      && sym->ts.u.derived->attr.generic)
+    {
+      sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
+      if (!sym->ts.u.derived)
+	{
+	  gfc_error ("The derived type '%s' at %L is of type '%s', "
+		     "which has not been defined", sym->name,
+		     &sym->declared_at, sym->ts.u.derived->name);
+	  sym->ts.type = BT_UNKNOWN;
+	  return;
+	}
+    }
+
   /* If the symbol is marked as bind(c), verify it's type and kind.  Do not
      do this for something that was implicitly typed because that is handled
      in gfc_set_default_type.  Handle dummy arguments and procedure
@@ -12249,7 +12308,8 @@ resolve_symbol (gfc_symbol *sym)
      the type is not declared in the scope of the implicit
      statement. Change the type to BT_UNKNOWN, both because it is so
      and to prevent an ICE.  */
-  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
+  if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
+      && sym->ts.u.derived->components == NULL
       && !sym->ts.u.derived->attr.zero_comp)
     {
       gfc_error ("The derived type '%s' at %L is of type '%s', "
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(Revision 180703)
+++ gcc/fortran/trans-decl.c	(Arbeitskopie)
@@ -695,6 +695,18 @@ gfc_get_module_backend_decl (gfc_symbol *sym)
 	}
       else if (sym->attr.flavor == FL_DERIVED)
 	{
+	  if (s && s->attr.flavor == FL_PROCEDURE)
+	    {
+	      gfc_interface *intr;
+	      gcc_assert (s->attr.generic);
+	      for (intr = s->generic; intr; intr = intr->next)
+		if (intr->sym->attr.flavor == FL_DERIVED)
+		  {
+		    s = intr->sym;
+		    break;
+		  }
+    	    }
+
 	  if (!s->backend_decl)
 	    s->backend_decl = gfc_get_derived_type (s);
 	  gfc_copy_dt_decls_ifequal (s, sym, true);
@@ -4031,8 +4043,19 @@ gfc_trans_use_stmts (gfc_namespace * ns)
 	      st = gfc_find_symtree (ns->sym_root,
 				     rent->local_name[0]
 				     ? rent->local_name : rent->use_name);
-	      gcc_assert (st);
 
+	      /* The following can happen if a derived type is renamed.  */
+	      if (!st)
+		{
+		  char *name;
+		  name = xstrdup (rent->local_name[0]
+				  ? rent->local_name : rent->use_name);
+		  name[0] = (char) TOUPPER ((unsigned char) name[0]);
+		  st = gfc_find_symtree (ns->sym_root, name);
+		  free (name);
+		  gcc_assert (st);
+		}
+
 	      /* Sometimes, generic interfaces wind up being over-ruled by a
 		 local symbol (see PR41062).  */
 	      if (!st->n.sym->attr.use_assoc)
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(Revision 180703)
+++ gcc/fortran/match.c	(Arbeitskopie)
@@ -1920,6 +1920,9 @@ match_derived_type_spec (gfc_typespec *ts)
 
   gfc_find_symbol (name, NULL, 1, &derived);
 
+  if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
+    derived = gfc_find_dt_in_generic (derived);
+
   if (derived && derived->attr.flavor == FL_DERIVED)
     {
       ts->type = BT_DERIVED;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 180703)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -2315,6 +2315,219 @@ build_actual_constructor (gfc_structure_ctor_compo
   return SUCCESS;
 }
 
+
+gfc_try
+gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
+				      gfc_actual_arglist **arglist,
+				      bool parent)
+{
+  gfc_actual_arglist *actual;
+  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
+  gfc_constructor_base ctor_head = NULL;
+  gfc_component *comp; /* Is set NULL when named component is first seen */
+  const char* last_name = NULL;
+  locus old_locus;
+  gfc_expr *expr;
+
+  expr = parent ? *cexpr : e;
+  old_locus = gfc_current_locus;
+  if (parent)
+    ; /* gfc_current_locus = *arglist->expr ? ->where;*/
+  else
+    gfc_current_locus = expr->where;
+
+  comp_tail = comp_head = NULL;
+
+  if (!parent && sym->attr.abstract)
+    {
+      gfc_error ("Can't construct ABSTRACT type '%s' at %L",
+		 sym->name, &expr->where);
+      goto cleanup;
+    }
+
+  comp = sym->components;
+  actual = parent ? *arglist : expr->value.function.actual;
+  for ( ; actual; )
+    {
+      gfc_component *this_comp = NULL;
+
+      if (!comp_head)
+	comp_tail = comp_head = gfc_get_structure_ctor_component ();
+      else
+	{
+	  comp_tail->next = gfc_get_structure_ctor_component ();
+	  comp_tail = comp_tail->next;
+       	}
+      if (actual->name)
+	{
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+			      " constructor with named arguments at %C")
+	      == FAILURE)
+	    goto cleanup;
+
+	  comp_tail->name = xstrdup (actual->name); /*CONST_CAST (char *, actual->name);*/
+	  last_name = comp_tail->name;
+	  comp = NULL;
+	}
+      else
+	{
+	  /* Components without name are not allowed after the first named
+	     component initializer!  */
+	  if (!comp)
+	    {
+	      if (last_name)
+		gfc_error ("Component initializer without name after component"
+			   " named %s at %L!", last_name,
+			   actual->expr ? &actual->expr->where
+					: &gfc_current_locus);
+	      else
+		gfc_error ("Too many components in structure constructor at "
+			   "%L!", actual->expr ? &actual->expr->where
+					       : &gfc_current_locus);
+	      goto cleanup;
+	    }
+
+	  comp_tail->name = xstrdup (comp->name); /*CONST_CAST (char *, comp->name);*/
+	}
+
+      /* Find the current component in the structure definition and check
+	     its access is not private.  */
+      if (comp)
+	this_comp = gfc_find_component (sym, comp->name, false, false);
+      else
+	{
+	  this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
+					  false, false);
+	  comp = NULL; /* Reset needed!  */
+	}
+
+      /* Here we can check if a component name is given which does not
+	 correspond to any component of the defined structure.  */
+      if (!this_comp)
+	goto cleanup;
+
+      comp_tail->val = actual->expr;
+      if (actual->expr != NULL)
+	comp_tail->where = actual->expr->where;
+      actual->expr = NULL;
+
+      /* Check if this component is already given a value.  */
+      for (comp_iter = comp_head; comp_iter != comp_tail; 
+	   comp_iter = comp_iter->next)
+	{
+	  gcc_assert (comp_iter);
+	  if (!strcmp (comp_iter->name, comp_tail->name))
+	    {
+	      gfc_error ("Component '%s' is initialized twice in the structure"
+			 " constructor at %L!", comp_tail->name,
+			 comp_tail->val ? &comp_tail->where
+					: &gfc_current_locus);
+	      goto cleanup;
+	    }
+	}
+
+      /* F2008, R457/C725, for PURE C1283.  */
+      if (this_comp->attr.pointer && comp_tail->val
+	  && gfc_is_coindexed (comp_tail->val))
+     	{
+       	  gfc_error ("Coindexed expression to pointer component '%s' in "
+		     "structure constructor at %L!", comp_tail->name,
+		     &comp_tail->where);
+	  goto cleanup;
+	}
+
+          /* If not explicitly a parent constructor, gather up the components
+             and build one.  */
+          if (comp && comp == sym->components
+                && sym->attr.extension
+		&& comp_tail->val
+                && (comp_tail->val->ts.type != BT_DERIVED
+                      ||
+                    comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
+            {
+              gfc_try m;
+	      gfc_actual_arglist *arg_null = NULL;
+
+	      actual->expr = comp_tail->val;
+	      comp_tail->val = NULL;
+
+              m = gfc_convert_to_structure_constructor (NULL,
+					comp->ts.u.derived, &comp_tail->val,
+					comp->ts.u.derived->attr.zero_comp
+					  ? &arg_null : &actual, true);
+              if (m == FAILURE)
+                goto cleanup;
+
+	      if (comp->ts.u.derived->attr.zero_comp)
+		{
+		  comp = comp->next;
+		  continue;
+		}
+            }
+
+      if (comp)
+	comp = comp->next;
+      if (parent && !comp)
+	break;
+
+      actual = actual->next;
+    }
+
+  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+    goto cleanup;
+
+  /* No component should be left, as this should have caused an error in the
+     loop constructing the component-list (name that does not correspond to any
+     component in the structure definition).  */
+  if (comp_head && sym->attr.extension)
+    {
+      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
+	{
+	  gfc_error ("component '%s' at %L has already been set by a "
+		     "parent derived type constructor", comp_iter->name,
+		     &comp_iter->where);
+	}
+      goto cleanup;
+    }
+  else
+    gcc_assert (!comp_head);
+
+  if (parent)
+    {
+      expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
+      expr->ts.u.derived = sym;
+      expr->value.constructor = ctor_head;
+      *cexpr = expr;
+    }
+  else
+    {
+      expr->ts.u.derived = sym;
+      expr->ts.kind = 0;
+      expr->ts.type = BT_DERIVED;
+      expr->value.constructor = ctor_head;
+      expr->expr_type = EXPR_STRUCTURE;
+    }
+
+  gfc_current_locus = old_locus; 
+  if (parent)
+    *arglist = actual;
+  return SUCCESS;
+
+  cleanup:
+  gfc_current_locus = old_locus; 
+
+  for (comp_iter = comp_head; comp_iter; )
+    {
+      gfc_structure_ctor_component *next = comp_iter->next;
+      gfc_free_structure_ctor_component (comp_iter);
+      comp_iter = next;
+    }
+/*  gfc_constructor_free (ctor_head);*/
+
+  return FAILURE;
+}
+
+
 match
 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
 				 bool parent)
@@ -2715,7 +2928,7 @@ gfc_match_rvalue (gfc_expr **result)
       if (sym == NULL)
 	m = MATCH_ERROR;
       else
-	m = gfc_match_structure_constructor (sym, &e, false);
+	goto generic_function;
       break;
 
     /* If we're here, then the name is known to be the name of a
@@ -2989,6 +3202,12 @@ gfc_match_rvalue (gfc_expr **result)
       e->symtree = symtree;
       e->expr_type = EXPR_FUNCTION;
 
+      if (sym->attr.flavor == FL_DERIVED)
+	{
+	  e->value.function.esym = sym;
+	  e->symtree->n.sym->attr.generic = 1;
+	}
+
       m = gfc_match_actual_arglist (0, &e->value.function.actual);
       break;
 

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]