OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/31154 (IMPORT fails for "<imported symbol> FUNCTION (...)" kind of procedures)

Browse Source 
2007-10-02  Paul Thomas  <pault@gcc.gnu.org>

	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  <pault@gcc.gnu.org>

	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
This commit is contained in:
Paul Thomas 2007-10-02 07:17:01 +00:00
parent c052733d54
commit e2d299684b
10 changed files with 300 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View File

@ -1,3 +1,29 @@
2007-10-02 Paul Thomas <pault@gcc.gnu.org>
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 <ghazi@caip.rutgers.edu>
* module.c (mio_expr): Avoid -Wcast-qual warning.

95
gcc/fortran/decl.c
View File

@ -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 (&current_ts, 0);
m = gfc_match_type_spec (&current_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 (&current_ts, 0);
m = gfc_match_type_spec (&current_ts, 0);
if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
goto got_ts;

3
gcc/fortran/match.h
View File

@ -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);

51
gcc/fortran/parse.c
View File

@ -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;
}

2
gcc/fortran/parse.h
View File

@ -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 */

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2007-10-02 Paul Thomas <pault@gcc.gnu.org>
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 <dave.anglin@nrc-cnrc.gc.ca>
PR testsuite/31828

13
gcc/testsuite/gfortran.dg/derived_function_interface_1.f90
View File

@ -6,24 +6,28 @@
!
! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
!
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" } }

54
gcc/testsuite/gfortran.dg/function_kinds_1.f90 Normal file
View File

@ -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 <brooks@gcc.gnu.org>
! and Tobias Burnus <burnus@gcc.gnu.org>
!
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" } }

21
gcc/testsuite/gfortran.dg/function_kinds_2.f90 Normal file
View File

@ -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 <burnus@gcc.gnu.org>
!
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" } }

47
gcc/testsuite/gfortran.dg/intent_out_2.f90 Normal file
View File

@ -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 <anlauf@gmx.de>
!
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" } }