Submitted rediffed patch: http://gcc.gnu.org/ml/fortran/2011-11/msg00061.html Note: This is a rediff as the tree-walking patch has been committed. http://gcc.gnu.org/ml/fortran/2011-11/msg00026.html Original submittal: http://gcc.gnu.org/ml/fortran/2011-11/msg00061.html Fortran 2003 Constructor Patch for GNU Fortran Fortran 2003 allows that a generic function has the same name as a derived type, which can be used to create something similar to a constructor of other object-oriented programming languages. For an example, see "constructor_1.f90" below. This patch will be submitted for inclusion in GCC 4.7. Due to its invasive nature, I expect regressions (diagnostic, internal compiler errors, rejecting valid code - but not wrong-code regressions). Hopefully, there won't be too many regressions - but testing your favourite code and reporting bugs will surely help. Last update: 2011-11-09 / Tobias Burnus Previous version: https://userpage.physik.fu-berlin.de/~tburnus/tmp/constructor_old19.diff Changes: 2011-11-09 * Rediff as the tree-walking patch has been committed. 2011-11-06 * Cleanup of the patch, writing ChangeLog. 2011-11-05 * After many days and hours of debugging: No test-suite regressions but diagnostics still work * Slightly improved wrong-code diagnostic 2011-11-02/2011-11-03 * Some more diagnostic (ambiguity check) 2011-11-02 * Added diagnostic check and thus fixed constructor_4.f90. * Fixed lock_type generation - fixing lock_type_{3,5}.f90. * Modified result_1.f90: Worse wording of the error message, but otherwise OK. 2011-11-02 * Fixed module loading issue with FoX * That was the last rejects valid/ICE on valid issue. Now the only known issues are related to diagnostics. 2011-11-01 * Fixed class_21.f03. Submitted patch at http://gcc.gnu.org/ml/fortran/2011-11/msg00026.html see also http://gcc.gnu.org/ml/fortran/2011-11/msg00000.html 2011-10-31/2011-11-01 * Debugged class_21.f03 and found the cause (but not yet the solution) * Created reduced test case for FoX failure 2011-10-31 * Fixed issues with ISO_C_Binding * Fixed regressions in iso_c_binding_only.f03 and pr32801.f03 * Fixes the Octopus issue * Collaterally, fix PR fortran/37829 comment 16 * Breaks - again - FoX. 2011-10-31 * Modified .mod handling to be finally correct, clean up patch in module.c * Fixed nested_modules_3.f90 and Abinit. 2011-10-27 * Included test case from PR 45155 * Fixed previous regressions (5) and (2), CP2K and FoX 2011-10-27 * Fixed issue attr.access in decl.c (PUBLIC/PRIVATE issue) * Solves one Octopus failure (now fails later with different error) * Solves former regressions (2), (11), (12) * Solves the issue with the test case from PR 45115 * Tested newer version of Elk (works) and CP2K (fails) 2011-10-26 * Reduced Octopus failure 2011-10-19 * Some fixes to resolving variables of type BT_DERIVED. 2011-10-17 * Some debugging, cf. (7) * Fixed one double-declaration issue [decl.c, used_types_25.f90] 2011-10-13 * Fixed one issue affecting FoX (and thus the Exciting code) FoX still does not work due to another bug [cf. (7)/(8)] 2011-10-12 * Fixes for coarray_lock_3.f90 and coarray_lock_5.f90 Issue fixed, but test case fails because of changed error msg * derived_constructor_comps_4.f90: Successfully fixed Tracking bug: http://gcc.gnu.org/bugzilla/show_bug.cgi?id=39427 gfortran OOP status: http://gcc.gnu.org/wiki/OOP REGRESSIONS TESTS: * libgomp's check: No failures! * gcc's check-gfortran: Only known old failures: (1) gfortran.dg/realloc_on_assign_5.f03 PR fortran/47674 (never worked: fails with non-'\0'-setting malloc) (2) gfortran.dg/select_type_12.f03 PR middle-end/50640 (P1 regression) (3) gfortran.fortran-torture/execute/entry_4.f90 PR middle-end/50628 (P1 regression) * FLEUR (flapw.de): Compiles. * ELK (Elk.sf.net): Compiles (Elk 1.0.0). * Octopus (tddft.org): Compiles. * Polyhedron Benchmark 2005 (www.polyhedron.com): Compiles. Tested with yesterday's patch: * Exciting Code (http://exciting-code.org/, contains FoX Fortran XML lib): Compiles. * CP2K (http://www.cp2k.org/). Compiles. * PSBLAS (http://www.ce.uniroma2.it/psblas/psblas-3.0-alpha3.tgz): Compiles. * FGSL (http://www.lrz.de/services/software/mathematik/gsl/fortran/): Compiles (+ test cases) test/poly.f90 fails due to a test bug (cf. invalid PR target/50721) Last tested 2011-11-02: * ELK (Elk.sf.net): Compiles Elk 1.3.31. Older version tested: * Abinit (http://www.abinit.org/, 6.8.2): Works. * Polyhedron Benchmark 2011 (www.polyhedron.com): NEEDS TO BE TESTED * Tonto 3.1: No failures. http://sourceforge.net/projects/tonto-chem/files/latest/download * Quantum Expresso 4.3.2: No failures. http://qe-forge.org/frs/?group_id=10 CHANGELOG [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 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 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;