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
+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.
gfc_symbol *gfc_new_block;
+locus gfc_function_kind_locus;
+locus gfc_function_type_locus;
+
/********************* DATA statement subroutines *********************/
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;
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)
{
else if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Missing right parenthesis at %C");
- m = MATCH_ERROR;
+ m = MATCH_ERROR;
}
else
/* All tests passed. */
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);
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)
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);
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)
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);
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;
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)
{
/* 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;
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);
}
+/* 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. */
}
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;
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;
}
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 */
+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
!
! 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
end function fun ! { dg-error "Expecting END PROGRAM" }
end ! { dg-warning "CONTAINS statement without FUNCTION or SUBROUTINE statement" }
+! { dg-final { cleanup-modules "kinds" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! 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" } }
+
--- /dev/null
+! { dg-do -run }\r
+! 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>
+!\r
+module gfcbug72\r
+ implicit none\r
+\r
+ type t_datum\r
+ character(len=8) :: mn = 'abcdefgh'\r
+ end type t_datum\r
+\r
+ type t_temp\r
+ type(t_datum) :: p\r
+ end type t_temp\r
+\r
+contains\r
+\r
+ subroutine setup ()\r
+ integer :: i\r
+ type (t_temp), pointer :: temp(:) => NULL ()\r
+\r
+ do i=1,2\r
+ allocate (temp (2))\r
+ call construct_temp (temp)\r
+ if (any (temp % p% mn .ne. 'ijklmnop')) call abort ()\r
+ deallocate (temp)\r
+ end do\r
+ end subroutine setup\r
+ !--\r
+ subroutine construct_temp (temp)\r
+ type (t_temp), intent(out) :: temp (:)\r
+ if (any (temp % p% mn .ne. 'abcdefgh')) call abort ()\r
+ temp(:)% p% mn = 'ijklmnop'\r
+ end subroutine construct_temp\r
+end module gfcbug72\r
+\r
+program test\r
+ use gfcbug72\r
+ implicit none\r
+ call setup ()\r
+end program test\r
+! { dg-final { cleanup-modules "gfcbug72" } }
+\r
projects / platform / upstream / gcc.git / commitdiff