From e311e7c3ae9d2c65d64c920c0551e9dbca701af6 Mon Sep 17 00:00:00 2001 From: pbrook Date: Sat, 22 Jan 2005 15:24:09 +0000 Subject: [PATCH] 2005-01-22 Paul Brook * primary.c (gfc_match_rvalue): Only apply implicit type if variable does not have an explicit type. (gfc_match_variable): Resolve implicit derived types in all cases. Resolve contained function types from their own namespace, not the parent. * resolve.c (resolve_contained_fntype): Remove duplicate sym->result checking. Resolve from the contained namespace, not the parent. testsuite/ * gfortran.dg/implicit_2.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@94066 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 10 +++++++ gcc/fortran/primary.c | 30 ++++++++++++-------- gcc/fortran/resolve.c | 18 ++---------- gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gfortran.dg/implicit_2.f90 | 48 ++++++++++++++++++++++++++++++++ 5 files changed, 83 insertions(+), 27 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/implicit_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7ab798d21e6..fb4af7de454 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2005-01-22 Paul Brook + + * primary.c (gfc_match_rvalue): Only apply implicit type if variable + does not have an explicit type. + (gfc_match_variable): Resolve implicit derived types in all cases. + Resolve contained function types from their own namespace, not the + parent. + * resolve.c (resolve_contained_fntype): Remove duplicate sym->result + checking. Resolve from the contained namespace, not the parent. + 2005-01-22 Tobias Schl"uter PR fortran/19543 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index da2b7c82b1a..6496bcd3478 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2011,6 +2011,7 @@ gfc_match_rvalue (gfc_expr ** result) resolution phase. */ if (gfc_peek_char () == '%' + && sym->ts.type == BT_UNKNOWN && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED) gfc_set_default_type (sym, 0, sym->ns); @@ -2188,29 +2189,18 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag) case FL_UNKNOWN: if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) return MATCH_ERROR; - - /* Special case for derived type variables that get their types - via an IMPLICIT statement. This can't wait for the - resolution phase. */ - - if (gfc_peek_char () == '%' - && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED) - gfc_set_default_type (sym, 0, sym->ns); - break; case FL_PROCEDURE: /* Check for a nonrecursive function result */ if (sym->attr.function && (sym->result == sym || sym->attr.entry)) { - /* If a function result is a derived type, then the derived type may still have to be resolved. */ if (sym->ts.type == BT_DERIVED && gfc_use_derived (sym->ts.derived) == NULL) return MATCH_ERROR; - break; } @@ -2221,6 +2211,24 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag) return MATCH_ERROR; } + /* Special case for derived type variables that get their types + via an IMPLICIT statement. This can't wait for the + resolution phase. */ + + { + gfc_namespace * implicit_ns; + + if (gfc_current_ns->proc_name == sym) + implicit_ns = gfc_current_ns; + else + implicit_ns = sym->ns; + + if (gfc_peek_char () == '%' + && sym->ts.type == BT_UNKNOWN + && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED) + gfc_set_default_type (sym, 0, implicit_ns); + } + expr = gfc_get_expr (); expr->expr_type = EXPR_VARIABLE; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0e17c4be5e7..c3bf35057df 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -259,27 +259,13 @@ resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns) || sym->attr.flavor == FL_VARIABLE)) return; - /* Try to find out of what type the function is. If there was an - explicit RESULT clause, try to get the type from it. If the - function is never defined, set it to the implicit type. If - even that fails, give up. */ + /* Try to find out of what the return type is. */ if (sym->result != NULL) sym = sym->result; if (sym->ts.type == BT_UNKNOWN) { - /* Assume we can find an implicit type. */ - t = SUCCESS; - - if (sym->result == NULL) - t = gfc_set_default_type (sym, 0, ns); - else - { - if (sym->result->ts.type == BT_UNKNOWN) - t = gfc_set_default_type (sym->result, 0, NULL); - - sym->ts = sym->result->ts; - } + t = gfc_set_default_type (sym, 0, ns); if (t == FAILURE) gfc_error ("Contained function '%s' at %L has no IMPLICIT type", diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fb28b4b7903..6b16fc8542e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2005-01-22 Paul Brook + + * gfortran.dg/implicit_2.f90: New test. + 2005-01-22 Bud Davis PR fortran/19314 diff --git a/gcc/testsuite/gfortran.dg/implicit_2.f90 b/gcc/testsuite/gfortran.dg/implicit_2.f90 new file mode 100644 index 00000000000..c0582d703b6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/implicit_2.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } + +module implicit_2 + ! This should cause an error if function types are resolved from the + ! module namespace. + implicit none + type t + integer i + end type +contains +! This caused an ICE because we were trying to apply the implicit type +! after we had applied the explicit type. +subroutine test() + implicit type (t) (v) + type (t) v1, v2 + v1%i = 1 + call foo (v2%i) +end subroutine + +! A similar error because we failed to apply the implicit type to a function. +! This is a contained function to check we lookup the type in the function +! namespace, not it's parent. +function f() result (val) + implicit type (t) (v) + + val%i = 1 +end function + +! And again for a result variable. +function fun() + implicit type (t) (f) + + fun%i = 1 +end function + +! intrinsic types are resolved later than derived type, so check those as well. +function test2() + implicit integer (t) + test2 = 42 +end function +subroutine bar() + ! Check that implicit types are applied to names already known to be + ! variables. + implicit type(t) (v) + save v + v%i = 42 +end subroutine +end module -- 2.11.4.GIT