From 0291fa2509cbd6816d720aebfacdebffe1c9dcad Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sun, 31 Jul 2011 12:25:07 +0200 Subject: [PATCH] re PR fortran/49112 ([OOP] Missing type-bound procedure, "duplicate save" warnings and internal compiler error) 2011-07-31 Janus Weil PR fortran/49112 * resolve.c (resolve_structure_cons): Don't do the full dt resolution, only call 'resolve_fl_derived0'. (resolve_typebound_procedures): Resolve typebound procedures of parent type. (resolve_fl_derived0): New function, which does a part of the work for 'resolve_fl_derived'. (resolve_fl_derived): Call 'resolve_fl_derived0' and do some additional things. 2011-07-31 Janus Weil PR fortran/49112 * gfortran.dg/abstract_type_6.f03: Modified. * gfortran.dg/typebound_proc_24.f03: New. From-SVN: r176971 --- gcc/fortran/ChangeLog | 12 +++ gcc/fortran/resolve.c | 75 ++++++++++++------- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/abstract_type_6.f03 | 2 +- .../gfortran.dg/typebound_proc_24.f03 | 32 ++++++++ 5 files changed, 101 insertions(+), 26 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_24.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6be5141023b..d2e2044eff0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2011-07-31 Janus Weil + + PR fortran/49112 + * resolve.c (resolve_structure_cons): Don't do the full dt resolution, + only call 'resolve_fl_derived0'. + (resolve_typebound_procedures): Resolve typebound procedures of + parent type. + (resolve_fl_derived0): New function, which does a part of the work + for 'resolve_fl_derived'. + (resolve_fl_derived): Call 'resolve_fl_derived0' and do some additional + things. + 2011-07-30 Thomas Koenig PR fortran/48876 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e9e7bf00fab..b4d66cc968b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -950,6 +950,9 @@ resolve_contained_functions (gfc_namespace *ns) } +static gfc_try resolve_fl_derived0 (gfc_symbol *sym); + + /* Resolve all of the elements of a structure constructor and make sure that the types are correct. The 'init' flag indicates that the given constructor is an initializer. */ @@ -965,7 +968,7 @@ resolve_structure_cons (gfc_expr *expr, int init) t = SUCCESS; if (expr->ts.type == BT_DERIVED) - resolve_symbol (expr->ts.u.derived); + 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 @@ -11361,9 +11364,14 @@ static gfc_try resolve_typebound_procedures (gfc_symbol* derived) { int op; + gfc_symbol* super_type; if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) return SUCCESS; + + super_type = gfc_get_derived_super_type (derived); + if (super_type) + resolve_typebound_procedures (super_type); resolve_bindings_derived = derived; resolve_bindings_result = SUCCESS; @@ -11475,28 +11483,17 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) } -/* Resolve the components of a derived type. */ +/* Resolve the components of a derived type. This does not have to wait until + resolution stage, but can be done as soon as the dt declaration has been + parsed. */ static gfc_try -resolve_fl_derived (gfc_symbol *sym) +resolve_fl_derived0 (gfc_symbol *sym) { gfc_symbol* super_type; gfc_component *c; super_type = gfc_get_derived_super_type (sym); - - if (sym->attr.is_class && sym->ts.u.derived == NULL) - { - /* Fix up incomplete CLASS symbols. */ - gfc_component *data = gfc_find_component (sym, "_data", true, true); - gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true); - if (vptr->ts.u.derived == NULL) - { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); - gcc_assert (vtab); - vptr->ts.u.derived = vtab->ts.u.derived; - } - } /* F2008, C432. */ if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) @@ -11508,7 +11505,7 @@ resolve_fl_derived (gfc_symbol *sym) } /* Ensure the extended type gets resolved before we do. */ - if (super_type && resolve_fl_derived (super_type) == FAILURE) + if (super_type && resolve_fl_derived0 (super_type) == FAILURE) return FAILURE; /* An ABSTRACT type must be extensible. */ @@ -11861,14 +11858,6 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - /* Resolve the type-bound procedures. */ - if (resolve_typebound_procedures (sym) == FAILURE) - return FAILURE; - - /* Resolve the finalizer procedures. */ - if (gfc_resolve_finalizers (sym) == FAILURE) - return FAILURE; - /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract @@ -11883,6 +11872,42 @@ resolve_fl_derived (gfc_symbol *sym) } +/* The following procedure does the full resolution of a derived type, + including resolution of all type-bound procedures (if present). In contrast + to 'resolve_fl_derived0' this can only be done after the module has been + parsed completely. */ + +static gfc_try +resolve_fl_derived (gfc_symbol *sym) +{ + if (sym->attr.is_class && sym->ts.u.derived == NULL) + { + /* Fix up incomplete CLASS symbols. */ + gfc_component *data = gfc_find_component (sym, "_data", true, true); + gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true); + if (vptr->ts.u.derived == NULL) + { + gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); + gcc_assert (vtab); + vptr->ts.u.derived = vtab->ts.u.derived; + } + } + + if (resolve_fl_derived0 (sym) == FAILURE) + return FAILURE; + + /* Resolve the type-bound procedures. */ + if (resolve_typebound_procedures (sym) == FAILURE) + return FAILURE; + + /* Resolve the finalizer procedures. */ + if (gfc_resolve_finalizers (sym) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + static gfc_try resolve_fl_namelist (gfc_symbol *sym) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c5a6f94fe27..4f9a1f850f4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2011-07-31 Janus Weil + + PR fortran/49112 + * gfortran.dg/abstract_type_6.f03: Modified. + * gfortran.dg/typebound_proc_24.f03: New. + 2011-07-30 Paolo Carlini PR testsuite/49917 diff --git a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 index 53116dfb360..de1cea36323 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 @@ -31,7 +31,7 @@ TYPE, EXTENDS(middle) :: bottom CONTAINS ! useful proc to satisfy deferred procedure in top. Because we've ! extended middle we wouldn't get told off if we forgot this. - PROCEDURE :: proc_a => bottom_a + PROCEDURE :: proc_a => bottom_a ! { dg-error "must be a module procedure" } ! calls middle%proc_b and then provides extra behaviour PROCEDURE :: proc_b => bottom_b ! calls top_c and then provides extra behaviour diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_24.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_24.f03 new file mode 100644 index 00000000000..f200e0efbbc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_24.f03 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 49112: [4.6/4.7 Regression] [OOP] Missing type-bound procedure, "duplicate save" warnings and internal compiler error +! +! Contributed by John + +module datetime_mod + + implicit none + + type :: DateTime + integer :: year, month, day + contains + procedure :: getFormattedString + end type + + type(DateTime) :: ISO_REFERENCE_DATE = DateTime(1875, 5, 20) + +contains + + character function getFormattedString(dt) + class(DateTime) :: dt + end function + + subroutine test + type(DateTime) :: dt + print *,dt%getFormattedString() + end subroutine + +end module + +! { dg-final { cleanup-modules "datetime_mod" } }