This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch,Fortran] PR39427/37829 - implement F2003's constructors
- From: Tobias Burnus <burnus at net-b dot de>
- To: fortran at gcc dot gnu dot org, gcc patches <gcc-patches at gcc dot gnu dot org>
- Date: Mon, 14 Nov 2011 10:45:54 +0100
- Subject: Re: [Patch,Fortran] PR39427/37829 - implement F2003's constructors
- References: <4EB6A7DD.10902@net-b.de>
I would like to *ping*.
Additionally, I attached an updated patch as the tree-walking patch is
now in. The updated patch is also available at
https://userpage.physik.fu-berlin.de/~tburnus/tmp/constructor.diff
On 11/06/2011 04:29 PM, Tobias Burnus wrote:
this patch fixes as collateral effect PR 37829 (alias PR 45190) where
C_PTR/C_FUNPTR occurred when use associating a module using them, if
one additionally uses iso_fc_binding directly.
The main part of this patch, however, is for PR 39427 (alias 45190):
Allowing generic functions to have the same name as a derived type,
which is a Fortran 2003 feature. In expressions, the generic functions
have a higher precedence then the structure constructor. Note that the
functions are not required to return the derived type.
This feature allows one to create something which looks similar to
constructors in other OOP languages, except that static constructor
functions do not exist.
This patch implements them by creating for each derived type two
symbols (symtrees): One for the derived type and one for the generic
function, which links to the derived type. To distinguish them, the
derived type starts with a capital letter in the symtree. In order to
facilitate the error-message handling, the symbol itself remains in
lower case.
The main challenges were to ensure that one gets the derived type when
needed and to store them properly in the module. The most time
consuming part was to find all the places one had to change that
issues with module reading could turn up much later; for instance at
resolution time of a scope which had read that module. In total, it
took 18 months between the first draft patch (cf. PR39427 comment 6,
12-14) and the final patch. Although, the patch looked almost working
by then, it took many, many, many hours to fix the issues. Also the
RFC patch, posted 6 days ago, had more issues than I had hoped for.
The attached patch had been build on x86-64-linux and successfully
regtested (gfortran and libgomp). (A full bootstrap of an almost-ready
version was done as well; I had to rebuild because I found some
left-over commented code blocks.)
Additionally, I tried the previous patches with several programs to
reduce the likelihood that it breaks real-world code. In particular,
the very latest version of the patch was used to compile FLEUR, Elk,
Octopus and the Polyhedron benchmark. Yesterday evening's version was
used to compile the Exciting code (which includes the sensitive FoX
Fortran XML library), CP2K, PSBLAS and FGSL. With a slightly older
version, I also successfully compiled Tonto, Quantum Espresso and Abinit.
OK for the trunk?
Tobias
PS: I have also included a patch for the website, i.e.
http://gcc.gnu.org/gcc-4.7/changes.html#fortran
PPS: As mentioned in the attachment, the patch includes the
tree-walking patch, which was posted before. It's a really an
independent bug, even if it only exposed with the constructor patch. I
can either commit it before or as part of this patch. See also
http://gcc.gnu.org/ml/fortran/2011-11/msg00026.html
[Remark: The delected section in resolve_symbol with gfc_find_symbol(..&ds)
was originally added in r133488 for PR fortran/33295]
gcc/fortran
2011-11-09 Tobias Burnus <burnus@net-b.de>
PR fortran/39427
PR fortran/37829
* decl.c (match_data_constant, match_data_constant, variable_decl,
gfc_match_decl_type_spec, access_attr_decl,
check_extended_derived_type, gfc_match_derived_decl,
gfc_match_derived_decl, gfc_match_derived_decl) Modified to deal
with DT constructors.
* gfortran.h (gfc_find_dt_in_generic,
gfc_convert_to_structure_constructor): New function prototypes.
* interface.c (check_interface0, check_interface1,
gfc_search_interface): Ignore DT constructors in generic list.
* match.h (gfc_match_structure_constructor): Update prototype.
* match.c (match_derived_type_spec): Ensure that one uses the DT
not the generic function.
* module.c (MOD_VERSION): Bump.
(dt_lower_string, dt_upper_string): New functions.
(find_use_name_n, find_use_operator, compare_true_names,
find_true_name, add_true_name, fix_mio_expr, load_needed,
read_module, write_dt_extensions, write_symbol): Changes to deal with
different symtree vs. sym names.
(create_derived_type): Create also generic procedure.
* parse.c (gfc_fixup_sibling_symbols): Don't regard DT and generic
function as the same.
* primary.c (gfc_convert_to_structure_constructor): New function.
(gfc_match_structure_constructor): Restructured; calls
gfc_convert_to_structure_constructor.
(build_actual_constructor, gfc_match_rvalue): Update for DT generic
functions.
* resolve.c (resolve_formal_arglist, resolve_structure_cons,
is_illegal_recursion, resolve_generic_f, resolve_variable,
resolve_fl_variable_derived, resolve_fl_derived0,
resolve_symbol): Handle DT and DT generic constructors.
* symbol.c (gfc_use_derived, gfc_undo_symbols,
gen_special_c_interop_ptr, gen_cptr_param,
generate_isocbinding_symbol, gfc_get_derived_super_type): Handle
derived-types, which are hidden in the generic type.
(gfc_find_dt_in_generic): New function
* trans-array.c (gfc_conv_array_initializer): Replace FL_PARAMETER
expr by actual value.
* trans-decl.c (gfc_get_module_backend_decl, gfc_trans_use_stmts):
Ensure that we use the DT and not the generic function.
* trans-types.c (gfc_get_derived_type): Ensure that we use the DT
and not the generic procedure.
gcc/testsuite/
2011-11-09 Tobias Burnus <burnus@net-b.de>
PR fortran/39427
PR fortran/37829
* gfortran.dg/constructor_1.f90: New.
* gfortran.dg/constructor_2.f90: New.
* gfortran.dg/constructor_3.f90: New.
* gfortran.dg/constructor_4.f90: New.
* gfortran.dg/constructor_5.f90: New.
* gfortran.dg/constructor_6.f90: New.
* gfortran.dg/use_only_5.f90: New.
* gfortran.dg/c_ptr_tests_17.f90: New.
* gfortran.dg/c_ptr_tests_18.f90: New.
* gfortran.dg/used_types_25.f90: New.
* gfortran.dg/used_types_26.f90: New
* gfortran.dg/type_decl_3.f90: New.
* gfortran.dg/function_types_3.f90: Update dg-error.
* gfortran.dg/result_1.f90: Ditto.
* gfortran.dg/structure_constructor_3.f03: Ditto.
* gfortran.dg/structure_constructor_4.f03: Ditto.
fortran/decl.c | 171 +++++++++--
fortran/gfortran.h | 4
fortran/interface.c | 26 +
fortran/match.c | 3
fortran/match.h | 2
fortran/module.c | 106 +++++-
fortran/parse.c | 6
fortran/primary.c | 339 ++++++++++++----------
fortran/resolve.c | 107 +++++-
fortran/symbol.c | 227 ++++++++++----
fortran/trans-array.c | 5
fortran/trans-decl.c | 25 +
fortran/trans-types.c | 4
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 | 2
testsuite/gfortran.dg/result_1.f90 | 7
testsuite/gfortran.dg/structure_constructor_3.f03 | 2
testsuite/gfortran.dg/structure_constructor_4.f03 | 2
testsuite/gfortran.dg/type_decl_3.f90 | 7
testsuite/gfortran.dg/use_only_5.f90 | 38 ++
testsuite/gfortran.dg/used_types_25.f90 | 17 +
testsuite/gfortran.dg/used_types_26.f90 | 22 +
29 files changed, 1345 insertions(+), 300 deletions(-)
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/use_only_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/use_only_5.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/use_only_5.f90 (Revision 0)
@@ -0,0 +1,38 @@
+! { dg-do compile }
+!
+! PR fortran/39427
+!
+! Test case was failing with the initial version of the
+! constructor patch.
+!
+! Based on the Fortran XML library FoX
+
+module m_common_attrs
+ implicit none
+ private
+
+ type dict_item
+ integer, allocatable :: i(:)
+ end type dict_item
+
+ type dictionary_t
+ private
+ type(dict_item), pointer :: d => null()
+ end type dictionary_t
+
+ public :: dictionary_t
+ public :: get_prefix_by_index
+
+contains
+ pure function get_prefix_by_index(dict) result(prefix)
+ type(dictionary_t), intent(in) :: dict
+ character(len=size(dict%d%i)) :: prefix
+ end function get_prefix_by_index
+end module m_common_attrs
+
+module m_common_namespaces
+ use m_common_attrs, only: dictionary_t
+ use m_common_attrs, only: get_prefix_by_index
+end module m_common_namespaces
+
+! { dg-final { cleanup-modules "m_common_attrs m_common_namespaces" } }
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 181240)
+++ 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 181240)
+++ 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" }
+type(f) function f() ! { dg-error "Type name 'f' at .1. conflicts with previously declared entity|The type for function 'f' at .1. is not accessible" }
f=110 ! { dg-error "Unclassifiable statement" }
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 ! { dg-error "the same name as derived type" }
+ integer :: x
+ end type t
+ interface t
+ module procedure f
+ end interface t
+contains
+ function f() ! { dg-error "the same name as derived type" }
+ type(t) :: f
+ end function
+end module
+
+module m2
+ interface t2
+ module procedure f2
+ end interface t2
+ type t2 ! { dg-error "the same name as derived type" }
+ integer :: x2
+ end type t2
+contains
+ function f2() ! { dg-error "the same name as derived type" }
+ 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 181240)
+++ gcc/testsuite/gfortran.dg/result_1.f90 (Arbeitskopie)
@@ -14,5 +14,10 @@ namelist /s/ a,b,c ! { dg-error "attribute conf
end function
function h() result(t)
-type t ! { dg-error "attribute conflicts" }
+type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" }
+end type t ! { dg-error "Expecting END FUNCTION statement" }
end function
+
+function i() result(t)
+type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" }
+end function
Index: gcc/testsuite/gfortran.dg/structure_constructor_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_4.f03 (Revision 181240)
+++ 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/testsuite/gfortran.dg/type_decl_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/type_decl_3.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/type_decl_3.f90 (Revision 0)
@@ -0,0 +1,7 @@
+! { dg-do compile }
+!
+! PR fortran/39427
+!
+ subroutine t(x) ! { dg-error "conflicts with previously declared entity" }
+ type(t) :: x ! { dg-error "conflicts with previously declared entity" }
+ end subroutine t
Index: gcc/testsuite/gfortran.dg/used_types_26.f90
===================================================================
--- gcc/testsuite/gfortran.dg/used_types_26.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/used_types_26.f90 (Revision 0)
@@ -0,0 +1,22 @@
+! { dg-do compile }
+!
+! Check for ambiguity.
+!
+! Added as part of the constructor work (PR fortran/39427).
+!
+ module m
+ type t
+ end type t
+ end module m
+
+ module m2
+ type t
+ end type t
+ end module m2
+
+ use m
+ use m2
+ type(t) :: x ! { dg-error "Type name 't' at .1. is ambiguous" }
+ end
+
+! { dg-final { cleanup-modules "m m2" } }
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (Revision 181240)
+++ gcc/fortran/interface.c (Arbeitskopie)
@@ -1262,8 +1262,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",
@@ -1276,11 +1277,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;
}
@@ -1336,8 +1344,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",
@@ -3019,6 +3029,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 181240)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -5027,6 +5027,11 @@ gfc_conv_array_initializer (tree type, gfc_expr *
tree index, range;
VEC(constructor_elt,gc) *v = NULL;
+ 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/symbol.c
===================================================================
--- gcc/fortran/symbol.c (Revision 181240)
+++ 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;
@@ -3773,15 +3781,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. */
@@ -3859,9 +3867,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__";
@@ -4338,20 +4346,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)
@@ -4443,64 +4463,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:
@@ -4550,21 +4618,20 @@ generate_isocbinding_symbol (const char *mod_name,
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.u.derived == NULL)
- {
+ if (tmp_sym->ts.u.derived == NULL)
+ {
/* Create the necessary derived type so we can continue
processing the file. */
- generate_isocbinding_symbol
+ generate_isocbinding_symbol
(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"));
+ ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
+ (const char *)(s == ISOCBINDING_FUNLOC
+ ? "c_funptr" : "c_ptr"));
tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR
- : ISOCBINDING_PTR);
- }
+ get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR
+ : ISOCBINDING_PTR);
+ }
/* The function result is itself (no result clause). */
tmp_sym->result = tmp_sym;
@@ -4712,6 +4779,9 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
gfc_symbol*
gfc_get_derived_super_type (gfc_symbol* derived)
{
+ if (derived && derived->attr.generic)
+ derived = gfc_find_dt_in_generic (derived);
+
if (!derived->attr.extension)
return NULL;
@@ -4719,6 +4789,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;
}
@@ -4814,3 +4887,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 181240)
+++ 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);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
@@ -1954,10 +1958,10 @@ 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 "
+ gfc_error ("The type of '%s' at %C has not been declared within the "
"interface", name);
m = MATCH_ERROR;
goto cleanup;
@@ -2501,10 +2505,11 @@ 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;
+ const char *dt_name;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
@@ -2668,41 +2673,94 @@ 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;
}
/* Search for the name but allow the components to be defined later. If
type = -1, this typespec has been seen in a function declaration but
the type could not be accessed at that point. */
+ dt_name = gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) name[0]),
+ (const char*)&name[1]);
sym = NULL;
- if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
+ dt_sym = NULL;
+ if (ts->kind != -1)
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
- return MATCH_ERROR;
+ gfc_get_ha_symbol (name, &sym);
+ if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
+ {
+ gfc_error ("Type name '%s' at %C is ambiguous", name);
+ return MATCH_ERROR;
+ }
+ if (sym->generic && !dt_sym)
+ dt_sym = gfc_find_dt_in_generic (sym);
}
else if (ts->kind == -1)
{
int iface = gfc_state_stack->previous->state != COMP_INTERFACE
|| gfc_current_ns->has_import_set;
- if (gfc_find_symbol (name, NULL, iface, &sym))
+ gfc_find_symbol (name, NULL, iface, &sym);
+ if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
+ if (sym && sym->generic && !dt_sym)
+ dt_sym = gfc_find_dt_in_generic (sym);
ts->kind = 0;
if (sym == NULL)
return MATCH_NO;
}
- if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
- return MATCH_ERROR;
+ if ((sym->attr.flavor != FL_UNKNOWN
+ && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
+ || sym->attr.subroutine)
+ {
+ gfc_error ("Type name '%s' at %C conflicts with previously declared "
+ "entity at %L, which has the same name", name,
+ &sym->declared_at);
+ return MATCH_ERROR;
+ }
gfc_set_sym_referenced (sym);
- ts->u.derived = sym;
+ 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;
+
+ if (!dt_sym)
+ {
+ gfc_interface *intr, *head;
+
+ /* Use upper case to save the actual derived-type symbol. */
+ gfc_get_symbol (dt_name, NULL, &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;
+ }
+
+ gfc_set_sym_referenced (dt_sym);
+
+ 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 +3111,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 +6544,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 +6574,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 +7251,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 +7355,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 +7406,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 +7459,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 181240)
+++ 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/module.c
===================================================================
--- gcc/fortran/module.c (Revision 181240)
+++ gcc/fortran/module.c (Arbeitskopie)
@@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
-#define MOD_VERSION "7"
+#define MOD_VERSION "8"
/* Structure that describes a position within a module file. */
@@ -429,6 +429,24 @@ resolve_fixups (fixup_t *f, void *gp)
}
+const char *
+dt_lower_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 gfc_get_string (name);
+}
+
+const char *
+dt_upper_string (const char *name)
+{
+ if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
+ return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
+ &name[1]);
+ return gfc_get_string (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 +717,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_lower_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 +747,13 @@ 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 dt_upper_string (u->local_name);
+ }
+
return (u->local_name[0] != '\0') ? u->local_name : name;
}
@@ -780,6 +811,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 +835,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 +849,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
@@ -847,6 +879,10 @@ add_true_name (gfc_symbol *sym)
t = XCNEW (true_name);
t->sym = sym;
+ if (sym->attr.flavor == FL_DERIVED)
+ t->name = dt_upper_string (sym->name);
+ else
+ t->name = sym->name;
gfc_insert_bbt (&true_name_root, t, compare_true_names);
}
@@ -858,13 +894,19 @@ add_true_name (gfc_symbol *sym)
static void
build_tnt (gfc_symtree *st)
{
+ const char *name;
if (st == NULL)
return;
build_tnt (st->left);
build_tnt (st->right);
- if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
+ if (st->n.sym->attr.flavor == FL_DERIVED)
+ name = dt_upper_string (st->n.sym->name);
+ else
+ name = st->n.sym->name;
+
+ if (find_true_name (name, st->n.sym->module) != NULL)
return;
add_true_name (st->n.sym);
@@ -2986,8 +3028,12 @@ fix_mio_expr (gfc_expr *e)
namespace to see if the required, non-contained symbol is available
yet. If so, the latter should be written. */
if (e->symtree->n.sym && check_unique_name (e->symtree->name))
- ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
- e->symtree->n.sym->name);
+ {
+ const char *name = e->symtree->n.sym->name;
+ if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
+ name = dt_upper_string (name);
+ ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ }
/* On the other hand, if the existing symbol is the module name or the
new symbol is a dummy argument, do not do the promotion. */
@@ -4205,6 +4251,7 @@ load_needed (pointer_info *p)
1, &ns->proc_name);
sym = gfc_new_symbol (p->u.rsym.true_name, ns);
+ sym->name = dt_lower_string (p->u.rsym.true_name);
sym->module = gfc_get_string (p->u.rsym.module);
strcpy (sym->binding_label, p->u.rsym.binding_label);
@@ -4497,6 +4544,7 @@ read_module (void)
{
info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
gfc_current_ns);
+ info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
@@ -4835,7 +4883,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 +4918,16 @@ 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 = dt_upper_string (sym->name);
+ 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)
{
@@ -5566,7 +5622,8 @@ create_derived_type (const char *name, const char
intmod_id module, int id)
{
gfc_symtree *tmp_symtree;
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym;
+ gfc_interface *intr, *head;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (tmp_symtree != NULL)
@@ -5579,18 +5636,35 @@ create_derived_type (const char *name, const char
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
-
sym->module = gfc_get_string (modname);
sym->from_intmod = module;
sym->intmod_sym_id = id;
- sym->attr.flavor = FL_DERIVED;
- sym->attr.private_comp = 1;
- sym->attr.zero_comp = 1;
- sym->attr.use_assoc = 1;
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.function = 1;
+ sym->attr.generic = 1;
+
+ gfc_get_sym_tree (dt_upper_string (sym->name),
+ gfc_current_ns, &tmp_symtree, false);
+ dt_sym = tmp_symtree->n.sym;
+ dt_sym->name = gfc_get_string (sym->name);
+ dt_sym->attr.flavor = FL_DERIVED;
+ dt_sym->attr.private_comp = 1;
+ dt_sym->attr.zero_comp = 1;
+ dt_sym->attr.use_assoc = 1;
+ dt_sym->module = gfc_get_string (modname);
+ dt_sym->from_intmod = module;
+ dt_sym->intmod_sym_id = id;
+
+ 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;
}
-
/* USE the ISO_FORTRAN_ENV intrinsic module. */
static void
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (Revision 181240)
+++ 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. */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 181240)
+++ 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);
@@ -967,13 +968,6 @@ resolve_structure_cons (gfc_expr *expr, int init)
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. */
@@ -992,6 +986,14 @@ resolve_structure_cons (gfc_expr *expr, int init)
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
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 +1403,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 +2326,7 @@ resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
+ gfc_interface *intr = NULL;
sym = expr->symtree->n.sym;
@@ -2335,6 +2339,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 +2356,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,
@@ -5053,6 +5071,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)
@@ -10152,6 +10173,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 "
@@ -11718,6 +11741,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)
@@ -11788,6 +11818,23 @@ resolve_fl_derived0 (gfc_symbol *sym)
static gfc_try
resolve_fl_derived (gfc_symbol *sym)
{
+ gfc_symbol *gen_dt = NULL;
+
+ if (!sym->attr.is_class)
+ gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
+ if (gen_dt && gen_dt->generic && gen_dt->generic->next
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
+ "function '%s' at %L being the same name as derived "
+ "type at %L", sym->name,
+ gen_dt->generic->sym == sym
+ ? gen_dt->generic->next->sym->name
+ : gen_dt->generic->sym->name,
+ gen_dt->generic->sym == sym
+ ? &gen_dt->generic->next->sym->declared_at
+ : &gen_dt->generic->sym->declared_at,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
+
if (sym->attr.is_class && sym->ts.u.derived == NULL)
{
/* Fix up incomplete CLASS symbols. */
@@ -12191,6 +12238,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
@@ -12260,7 +12321,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', "
@@ -12276,23 +12338,10 @@ resolve_symbol (gfc_symbol *sym)
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->attr.use_assoc
&& sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE)
- {
- gfc_symbol *ds;
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
+ return;
- if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
- return;
-
- gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
- if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
- {
- symtree = gfc_new_symtree (&sym->ns->sym_root,
- sym->ts.u.derived->name);
- symtree->n.sym = sym->ts.u.derived;
- sym->ts.u.derived->refs++;
- }
- }
-
/* Unless the derived-type declaration is use associated, Fortran 95
does not allow public entries of private derived types.
See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 181240)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -699,6 +699,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);
@@ -4035,8 +4047,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 181240)
+++ 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/match.h
===================================================================
--- gcc/fortran/match.h (Revision 181240)
+++ gcc/fortran/match.h (Arbeitskopie)
@@ -206,7 +206,7 @@ match gfc_match_bind_c (gfc_symbol *, bool);
match gfc_get_type_attr_spec (symbol_attribute *, char*);
/* primary.c. */
-match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **, bool);
+match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (Revision 181240)
+++ gcc/fortran/parse.c (Arbeitskopie)
@@ -3881,6 +3881,12 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_na
if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
goto fixup_contained;
+ if ((st->n.sym->attr.flavor == FL_DERIVED
+ && sym->attr.generic && sym->attr.function)
+ ||(sym->attr.flavor == FL_DERIVED
+ && st->n.sym->attr.generic && st->n.sym->attr.function))
+ goto fixup_contained;
+
old_sym = st->n.sym;
if (old_sym->ns == ns
&& !old_sym->attr.contained
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (Revision 181240)
+++ gcc/fortran/primary.c (Arbeitskopie)
@@ -2315,171 +2315,162 @@ build_actual_constructor (gfc_structure_ctor_compo
return SUCCESS;
}
-match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
- bool parent)
+
+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 */
- gfc_expr *e;
- locus where;
- match m;
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 && gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- where = gfc_current_locus;
-
- gfc_find_component (sym, NULL, false, true);
-
- /* Check that we're not about to construct an ABSTRACT type. */
if (!parent && sym->attr.abstract)
{
- gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
- return MATCH_ERROR;
+ gfc_error ("Can't construct ABSTRACT type '%s' at %L",
+ sym->name, &expr->where);
+ goto cleanup;
}
- /* Match the component list and store it in a list together with the
- corresponding component names. Check for empty argument list first. */
- if (gfc_match_char (')') != MATCH_YES)
+ comp = sym->components;
+ actual = parent ? *arglist : expr->value.function.actual;
+ for ( ; actual; )
{
- comp = sym->components;
- do
+ gfc_component *this_comp = NULL;
+
+ if (!comp_head)
+ comp_tail = comp_head = gfc_get_structure_ctor_component ();
+ else
{
- gfc_component *this_comp = NULL;
+ 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;
- if (comp == sym->components && sym->attr.extension
- && comp->ts.type == BT_DERIVED
- && comp->ts.u.derived->attr.zero_comp)
- /* Skip empty parents. */
- comp = comp->next;
-
- if (!comp_head)
- comp_tail = comp_head = gfc_get_structure_ctor_component ();
- else
+ 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)
{
- comp_tail->next = gfc_get_structure_ctor_component ();
- comp_tail = comp_tail->next;
+ 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 = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
- comp_tail->val = NULL;
- comp_tail->where = gfc_current_locus;
- /* Try matching a component name. */
- if (gfc_match_name (comp_tail->name) == MATCH_YES
- && gfc_match_char ('=') == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
- " constructor with named arguments at %C")
- == FAILURE)
- goto cleanup;
+ comp_tail->name = xstrdup (comp->name); /*CONST_CAST (char *, comp->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 %C!", last_name);
- else if (!parent)
- gfc_error ("Too many components in structure constructor at"
- " %C!");
- goto cleanup;
- }
+ /* 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! */
+ }
- gfc_current_locus = comp_tail->where;
- strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
- }
+ /* 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;
- /* 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! */
- }
+ comp_tail->val = actual->expr;
+ if (actual->expr != NULL)
+ comp_tail->where = actual->expr->where;
+ actual->expr = NULL;
- /* 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;
-
- /* Check if this component is already given a value. */
- for (comp_iter = comp_head; comp_iter != comp_tail;
- comp_iter = comp_iter->next)
+ /* 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))
{
- gcc_assert (comp_iter);
- if (!strcmp (comp_iter->name, comp_tail->name))
- {
- gfc_error ("Component '%s' is initialized twice in the"
- " structure constructor at %C!", comp_tail->name);
- goto cleanup;
- }
+ 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;
}
+ }
- /* Match the current initializer expression. */
- if (this_comp->attr.proc_pointer)
- gfc_matching_procptr_assignment = 1;
- m = gfc_match_expr (&comp_tail->val);
- gfc_matching_procptr_assignment = 0;
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- 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;
+ }
- /* F2008, R457/C725, for PURE C1283. */
- if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
- {
- gfc_error ("Coindexed expression to pointer component '%s' in "
- "structure constructor at %C!", comp_tail->name);
- 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;
-
- /* If not explicitly a parent constructor, gather up the components
- and build one. */
- if (comp && comp == sym->components
- && sym->attr.extension
- && (comp_tail->val->ts.type != BT_DERIVED
- ||
- comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
- {
- gfc_current_locus = where;
- gfc_free_expr (comp_tail->val);
+ actual->expr = comp_tail->val;
comp_tail->val = NULL;
- m = gfc_match_structure_constructor (comp->ts.u.derived,
- &comp_tail->val, true);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
- }
+ 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)
- comp = comp->next;
+ if (comp->ts.u.derived->attr.zero_comp)
+ {
+ comp = comp->next;
+ continue;
+ }
+ }
- if (parent && !comp)
- break;
- }
+ if (comp)
+ comp = comp->next;
+ if (parent && !comp)
+ break;
- while (gfc_match_char (',') == MATCH_YES);
-
- if (!parent && gfc_match_char (')') != MATCH_YES)
- goto syntax;
+ actual = actual->next;
}
if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
@@ -2488,9 +2479,8 @@ build_actual_constructor (gfc_structure_ctor_compo
/* 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)
+ if (comp_head && sym->attr.extension)
{
- gcc_assert (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 "
@@ -2499,18 +2489,33 @@ build_actual_constructor (gfc_structure_ctor_compo
}
goto cleanup;
}
+ else
+ gcc_assert (!comp_head);
- e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
- e->ts.u.derived = sym;
- e->value.constructor = ctor_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;
+ }
- *result = e;
- return MATCH_YES;
+ gfc_current_locus = old_locus;
+ if (parent)
+ *arglist = actual;
+ return SUCCESS;
-syntax:
- gfc_error ("Syntax error in structure constructor at %C");
+ cleanup:
+ gfc_current_locus = old_locus;
-cleanup:
for (comp_iter = comp_head; comp_iter; )
{
gfc_structure_ctor_component *next = comp_iter->next;
@@ -2518,10 +2523,48 @@ build_actual_constructor (gfc_structure_ctor_compo
comp_iter = next;
}
gfc_constructor_free (ctor_head);
- return MATCH_ERROR;
+
+ return FAILURE;
}
+match
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+{
+ match m;
+ gfc_expr *e;
+ gfc_symtree *symtree;
+
+ gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */
+
+ e = gfc_get_expr ();
+ e->symtree = symtree;
+ e->expr_type = EXPR_FUNCTION;
+
+ gcc_assert (sym->attr.flavor == FL_DERIVED
+ && symtree->n.sym->attr.flavor == FL_PROCEDURE);
+ e->value.function.esym = sym;
+ e->symtree->n.sym->attr.generic = 1;
+
+ m = gfc_match_actual_arglist (0, &e->value.function.actual);
+ if (m != MATCH_YES)
+ {
+ gfc_free_expr (e);
+ return m;
+ }
+
+ if (gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)
+ != SUCCESS)
+ {
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+
+ *result = e;
+ return MATCH_YES;
+}
+
+
/* If the symbol is an implicit do loop index and implicitly typed,
it should not be host associated. Provide a symtree from the
current namespace. */
@@ -2715,7 +2758,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 +3032,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;