This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[RFC, Patch, Fortran] F2003's OOP constructor support
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>, "Rouson, Damian" <rouson at sandia dot gov>
- Date: Mon, 31 Oct 2011 18:51:58 +0100
- Subject: [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;