From e2d299684b33efc10cb3eeb773cb1780af0b5719 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 2 Oct 2007 07:17:01 +0000 Subject: [PATCH] re PR fortran/31154 (IMPORT fails for " FUNCTION (...)" kind of procedures) 2007-10-02 Paul Thomas PR fortran/31154 PR fortran/31229 PR fortran/33334 * decl.c : Declare gfc_function_kind_locs and gfc_function_type_locus. (gfc_match_kind_spec): Add second argument kind_expr_only. Store locus before trying to match the expression. If the current state corresponds to a function declaration and there is no match to the expression, read to the parenthesis, return kind = -1, dump the expression and return. (gfc_match_type_spec): Renamed from match_type_spec and all references changed. If an interface or an external function, store the locus, set kind = -1 and return. Otherwise, if kind is already = -1, use gfc_find_symbol to try to find a use associated or imported type. match.h : Prototype for gfc_match_type_spec. * parse.c (match_deferred_characteristics): New function. (parse_spec): If in a function, statement is USE or IMPORT or DERIVED_DECL and the function kind=-1, call match_deferred_characteristics. If kind=-1 at the end of the specification expressions, this is an error. * parse.h : Declare external gfc_function_kind_locs and gfc_function_type_locus. 2007-10-02 Paul Thomas PR fortran/31154 PR fortran/31229 PR fortran/33334 * gfortran.dg/function_kinds_1.f90: New test. * gfortran.dg/function_kinds_2.f90: New test. * gfortran.dg/derived_function_interface_1.f90: Correct illegal use association into interfaces. From-SVN: r128948 --- gcc/fortran/ChangeLog | 26 +++++ gcc/fortran/decl.c | 95 +++++++++++++++---- gcc/fortran/match.h | 3 +- gcc/fortran/parse.c | 51 ++++++++++ gcc/fortran/parse.h | 2 + gcc/testsuite/ChangeLog | 10 ++ .../derived_function_interface_1.f90 | 13 ++- .../gfortran.dg/function_kinds_1.f90 | 54 +++++++++++ .../gfortran.dg/function_kinds_2.f90 | 21 ++++ gcc/testsuite/gfortran.dg/intent_out_2.f90 | 47 +++++++++ 10 files changed, 300 insertions(+), 22 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/function_kinds_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/function_kinds_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/intent_out_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3f18b8eb3a44..d6ae6dc7178a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,29 @@ +2007-10-02 Paul Thomas + + PR fortran/31154 + PR fortran/31229 + PR fortran/33334 + * decl.c : Declare gfc_function_kind_locs and + gfc_function_type_locus. + (gfc_match_kind_spec): Add second argument kind_expr_only. + Store locus before trying to match the expression. If the + current state corresponds to a function declaration and there + is no match to the expression, read to the parenthesis, return + kind = -1, dump the expression and return. + (gfc_match_type_spec): Renamed from match_type_spec and all + references changed. If an interface or an external function, + store the locus, set kind = -1 and return. Otherwise, if kind + is already = -1, use gfc_find_symbol to try to find a use + associated or imported type. + match.h : Prototype for gfc_match_type_spec. + * parse.c (match_deferred_characteristics): New function. + (parse_spec): If in a function, statement is USE or IMPORT + or DERIVED_DECL and the function kind=-1, call + match_deferred_characteristics. If kind=-1 at the end of the + specification expressions, this is an error. + * parse.h : Declare external gfc_function_kind_locs and + gfc_function_type_locus. + 2007-09-27 Kaveh R. Ghazi * module.c (mio_expr): Avoid -Wcast-qual warning. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 7fa8548fb563..e25389f94bea 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -78,6 +78,9 @@ static enumerator_history *max_enum = NULL; gfc_symbol *gfc_new_block; +locus gfc_function_kind_locus; +locus gfc_function_type_locus; + /********************* DATA statement subroutines *********************/ @@ -1762,17 +1765,21 @@ gfc_match_old_kind_spec (gfc_typespec *ts) string is found, then we know we have an error. */ match -gfc_match_kind_spec (gfc_typespec *ts) +gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) { - locus where; + locus where, loc; gfc_expr *e; match m, n; const char *msg; m = MATCH_NO; + n = MATCH_YES; e = NULL; - where = gfc_current_locus; + where = loc = gfc_current_locus; + + if (kind_expr_only) + goto kind_expr; if (gfc_match_char ('(') == MATCH_NO) return MATCH_NO; @@ -1781,11 +1788,42 @@ gfc_match_kind_spec (gfc_typespec *ts) if (gfc_match (" kind = ") == MATCH_YES) m = MATCH_ERROR; + loc = gfc_current_locus; + +kind_expr: n = gfc_match_init_expr (&e); - if (n == MATCH_NO) - gfc_error ("Expected initialization expression at %C"); + if (n != MATCH_YES) - return MATCH_ERROR; + { + if (gfc_current_state () == COMP_INTERFACE + || gfc_current_state () == COMP_NONE + || gfc_current_state () == COMP_CONTAINS) + { + /* Signal using kind = -1 that the expression might include + use associated or imported parameters and try again after + the specification expressions..... */ + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Missing right parenthesis at %C"); + m = MATCH_ERROR; + goto no_match; + } + + gfc_free_expr (e); + ts->kind = -1; + gfc_function_kind_locus = loc; + gfc_undo_symbols (); + return MATCH_YES; + } + else + { + /* ....or else, the match is real. */ + if (n == MATCH_NO) + gfc_error ("Expected initialization expression at %C"); + if (n != MATCH_YES) + return MATCH_ERROR; + } + } if (e->rank != 0) { @@ -1826,7 +1864,7 @@ gfc_match_kind_spec (gfc_typespec *ts) else if (gfc_match_char (')') != MATCH_YES) { gfc_error ("Missing right parenthesis at %C"); - m = MATCH_ERROR; + m = MATCH_ERROR; } else /* All tests passed. */ @@ -2033,13 +2071,14 @@ done: kind specification. Not doing so is needed for matching an IMPLICIT statement correctly. */ -static match -match_type_spec (gfc_typespec *ts, int implicit_flag) +match +gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) { char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; int c; + locus loc = gfc_current_locus; gfc_clear_ts (ts); @@ -2123,12 +2162,34 @@ match_type_spec (gfc_typespec *ts, int implicit_flag) if (m != MATCH_YES) return m; - /* Search for the name but allow the components to be defined later. */ - if (gfc_get_ha_symbol (name, &sym)) + if (gfc_current_state () == COMP_INTERFACE + || gfc_current_state () == COMP_NONE) + { + gfc_function_type_locus = loc; + ts->type = BT_UNKNOWN; + ts->kind = -1; + 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 legally be accessed at that point. */ + if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym)) { gfc_error ("Type name '%s' at %C is ambiguous", name); return MATCH_ERROR; } + else if (ts->kind == -1) + { + if (gfc_find_symbol (name, NULL, 0, &sym)) + { + gfc_error ("Type name '%s' at %C is ambiguous", name); + return MATCH_ERROR; + } + + if (sym == NULL) + return MATCH_NO; + } if (sym->attr.flavor != FL_DERIVED && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) @@ -2154,7 +2215,7 @@ get_kind: return MATCH_NO; } - m = gfc_match_kind_spec (ts); + m = gfc_match_kind_spec (ts, false); if (m == MATCH_NO && ts->type != BT_CHARACTER) m = gfc_match_old_kind_spec (ts); @@ -2301,7 +2362,7 @@ gfc_match_implicit (void) gfc_clear_new_implicit (); /* A basic type is mandatory here. */ - m = match_type_spec (&ts, 1); + m = gfc_match_type_spec (&ts, 1); if (m == MATCH_ERROR) goto error; if (m == MATCH_NO) @@ -2344,7 +2405,7 @@ gfc_match_implicit (void) m = match_char_spec (&ts); else { - m = gfc_match_kind_spec (&ts); + m = gfc_match_kind_spec (&ts, false); if (m == MATCH_NO) { m = gfc_match_old_kind_spec (&ts); @@ -3390,7 +3451,7 @@ gfc_match_data_decl (void) num_idents_on_line = 0; - m = match_type_spec (¤t_ts, 0); + m = gfc_match_type_spec (¤t_ts, 0); if (m != MATCH_YES) return m; @@ -3492,7 +3553,7 @@ match_prefix (gfc_typespec *ts) loop: if (!seen_type && ts != NULL - && match_type_spec (ts, 0) == MATCH_YES + && gfc_match_type_spec (ts, 0) == MATCH_YES && gfc_match_space () == MATCH_YES) { @@ -3798,7 +3859,7 @@ match_procedure_decl (void) /* Get the type spec. for the procedure interface. */ old_loc = gfc_current_locus; - m = match_type_spec (¤t_ts, 0); + m = gfc_match_type_spec (¤t_ts, 0); if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')')) goto got_ts; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 4841f33eacc2..f9d6aea7010a 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -127,8 +127,9 @@ match gfc_match_omp_end_single (void); match gfc_match_data (void); match gfc_match_null (gfc_expr **); -match gfc_match_kind_spec (gfc_typespec *); +match gfc_match_kind_spec (gfc_typespec *, bool); match gfc_match_old_kind_spec (gfc_typespec *); +match gfc_match_type_spec (gfc_typespec *, int); match gfc_match_end (gfc_statement *); match gfc_match_data_decl (void); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index a6672f46ca67..86e486c917e8 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1866,6 +1866,35 @@ done: } +/* Recover use associated or imported function characteristics. */ + +static try +match_deferred_characteristics (gfc_typespec * ts) +{ + locus loc; + match m; + + loc = gfc_current_locus; + + if (gfc_current_block ()->ts.type != BT_UNKNOWN) + { + /* Kind expression for an intrinsic type. */ + gfc_current_locus = gfc_function_kind_locus; + m = gfc_match_kind_spec (ts, true); + } + else + { + /* A derived type. */ + gfc_current_locus = gfc_function_type_locus; + m = gfc_match_type_spec (ts, 0); + } + + gfc_current_ns->proc_name->result->ts = *ts; + gfc_current_locus =loc; + return m; +} + + /* Parse a set of specification statements. Returns the statement that doesn't fit. */ @@ -1951,6 +1980,15 @@ loop: } accept_statement (st); + + /* Look out for function kind/type information that used + use associated or imported parameter. This is signalled + by kind = -1. */ + if (gfc_current_state () == COMP_FUNCTION + && (st == ST_USE || st == ST_IMPORT || st == ST_DERIVED_DECL) + && gfc_current_block ()->ts.kind == -1) + match_deferred_characteristics (&gfc_current_block ()->ts); + st = next_statement (); goto loop; @@ -1964,6 +2002,19 @@ loop: break; } + /* If we still have kind = -1 at the end of the specification block, + then there is an error. */ + if (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->ts.kind == -1) + { + if (gfc_current_block ()->ts.type != BT_UNKNOWN) + gfc_error ("Bad kind expression for function '%s' at %L", + gfc_current_block ()->name, &gfc_function_kind_locus); + else + gfc_error ("The type for function '%s' at %L is not accessible", + gfc_current_block ()->name, &gfc_function_type_locus); + } + return st; } diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 92806ba49a52..307d59a0ff8b 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -66,5 +66,7 @@ const char *gfc_ascii_statement (gfc_statement); match gfc_match_enum (void); match gfc_match_enumerator_def (void); void gfc_free_enum_history (void); +extern locus gfc_function_kind_locus; +extern locus gfc_function_type_locus; #endif /* GFC_PARSE_H */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 308826e51abe..1cc26f816a5e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,13 @@ +2007-10-02 Paul Thomas + + PR fortran/31154 + PR fortran/31229 + PR fortran/33334 + * gfortran.dg/function_kinds_1.f90: New test. + * gfortran.dg/function_kinds_2.f90: New test. + * gfortran.dg/derived_function_interface_1.f90: Correct illegal + use association into interfaces. + 2007-10-01 John David Anglin PR testsuite/31828 diff --git a/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90 b/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90 index 88acbb752bb8..a9e404182f64 100644 --- a/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90 +++ b/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90 @@ -6,24 +6,28 @@ ! ! Contributed by Francois-Xavier Coudert ! -type(foo) function ext_fun() +module kinds type foo integer :: i end type foo +end module + +type(foo) function ext_fun() + use kinds ext_fun%i = 1 end function ext_fun - type foo - integer :: i - end type foo + use kinds interface fun_interface type(foo) function fun() + use kinds end function fun end interface interface ext_fun_interface type(foo) function ext_fun() + use kinds end function ext_fun end interface @@ -38,3 +42,4 @@ contains end function fun ! { dg-error "Expecting END PROGRAM" } end ! { dg-warning "CONTAINS statement without FUNCTION or SUBROUTINE statement" } +! { dg-final { cleanup-modules "kinds" } } diff --git a/gcc/testsuite/gfortran.dg/function_kinds_1.f90 b/gcc/testsuite/gfortran.dg/function_kinds_1.f90 new file mode 100644 index 000000000000..f0140df0620c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_kinds_1.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! Tests the fix for PR31229, PR31154 and PR33334, in which +! the KIND and TYPE parameters in the function declarations +! would cause errors. +! +! Contributed by Brooks Moses +! and Tobias Burnus +! +module kinds + implicit none + integer, parameter :: dp = selected_real_kind(6) + type t + integer :: i + end type t + interface + real(dp) function y() + import + end function + end interface +end module kinds + +type(t) function func() ! The legal bit of PR33334 + use kinds + func%i = 5 +end function func + +real(dp) function another_dp_before_defined () + use kinds + another_dp_before_defined = real (kind (4.0_DP)) +end function + +module mymodule; +contains + REAL(2*DP) function declared_dp_before_defined() + use kinds, only: dp + real (dp) :: x + declared_dp_before_defined = 1.0_dp + x = 1.0_dp + declared_dp_before_defined = real (kind (x)) + end function +end module mymodule + + use kinds + use mymodule + type(t), external :: func + type(t) :: z + if (kind (y ()) .ne. 4) call abort () + if (kind (declared_dp_before_defined ()) .ne. 8) call abort () + if (int (declared_dp_before_defined ()) .ne. 4) call abort () + if (int (another_dp_before_defined ()) .ne. 4) call abort () + z = func() + if (z%i .ne. 5) call abort () +end +! { dg-final { cleanup-modules "kinds mymodule" } } diff --git a/gcc/testsuite/gfortran.dg/function_kinds_2.f90 b/gcc/testsuite/gfortran.dg/function_kinds_2.f90 new file mode 100644 index 000000000000..f14453df9b2e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_kinds_2.f90 @@ -0,0 +1,21 @@ +! Tests the fix for PR33334, in which the TYPE in the function +! declaration cannot be legally accessed. +! +! Contributed by Tobias Burnus +! +module types + implicit none + type t + integer :: i = 99 + end type t +end module + +module x + use types + interface + type(t) function bar() ! { dg-error "is not accessible" } + end function + end interface +end module +! { dg-final { cleanup-modules "types x" } } + diff --git a/gcc/testsuite/gfortran.dg/intent_out_2.f90 b/gcc/testsuite/gfortran.dg/intent_out_2.f90 new file mode 100644 index 000000000000..0fad1b8f3fea --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_2.f90 @@ -0,0 +1,47 @@ +! { dg-do -run } +! Tests the fix for PR33554, in which the default initialization +! of temp, in construct_temp, caused a segfault because it was +! being done before the array offset and lower bound were +! available. +! +! Contributed by Harald Anlauf +! +module gfcbug72 + implicit none + + type t_datum + character(len=8) :: mn = 'abcdefgh' + end type t_datum + + type t_temp + type(t_datum) :: p + end type t_temp + +contains + + subroutine setup () + integer :: i + type (t_temp), pointer :: temp(:) => NULL () + + do i=1,2 + allocate (temp (2)) + call construct_temp (temp) + if (any (temp % p% mn .ne. 'ijklmnop')) call abort () + deallocate (temp) + end do + end subroutine setup + !-- + subroutine construct_temp (temp) + type (t_temp), intent(out) :: temp (:) + if (any (temp % p% mn .ne. 'abcdefgh')) call abort () + temp(:)% p% mn = 'ijklmnop' + end subroutine construct_temp +end module gfcbug72 + +program test + use gfcbug72 + implicit none + call setup () +end program test +! { dg-final { cleanup-modules "gfcbug72" } } +