This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
| Other format: | [Raw text] | |
This I believe it it:
(i) Have added ST_DERIVED_DECL to the conditions where a check is made
to see if the derived type is available.
(ii) I have corrected the illegailities in derived_function_interface_1.f90.
With this, the patch bootstraps and regtests on x86_ia64/FC5 (no, I
did not miss anything this time!), CP2K compiles and runs, as does
tonto.
OK for trunk?
Paul
--
The knack of flying is learning how to throw yourself at the ground and miss.
--Hitchhikers Guide to the Galaxy
Attachment:
Change.Logs
Description: Binary data
Index: /svn/trunk/gcc/fortran/decl.c
===================================================================
*** /svn/trunk/gcc/fortran/decl.c (revision 128873)
--- /svn/trunk/gcc/fortran/decl.c (working copy)
*************** static enumerator_history *max_enum = NU
*** 78,83 ****
--- 78,86 ----
gfc_symbol *gfc_new_block;
+ locus gfc_function_kind_locus;
+ locus gfc_function_type_locus;
+
/********************* DATA statement subroutines *********************/
*************** gfc_match_old_kind_spec (gfc_typespec *t
*** 1762,1778 ****
string is found, then we know we have an error. */
match
! gfc_match_kind_spec (gfc_typespec *ts)
{
! locus where;
gfc_expr *e;
match m, n;
const char *msg;
m = MATCH_NO;
e = NULL;
! where = gfc_current_locus;
if (gfc_match_char ('(') == MATCH_NO)
return MATCH_NO;
--- 1765,1785 ----
string is found, then we know we have an error. */
match
! gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
{
! locus where, loc;
gfc_expr *e;
match m, n;
const char *msg;
m = MATCH_NO;
+ n = MATCH_YES;
e = NULL;
! where = loc = gfc_current_locus;
!
! if (kind_expr_only)
! goto kind_expr;
if (gfc_match_char ('(') == MATCH_NO)
return MATCH_NO;
*************** gfc_match_kind_spec (gfc_typespec *ts)
*** 1781,1791 ****
if (gfc_match (" kind = ") == MATCH_YES)
m = MATCH_ERROR;
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 (e->rank != 0)
{
--- 1788,1829 ----
if (gfc_match (" kind = ") == MATCH_YES)
m = MATCH_ERROR;
+ loc = gfc_current_locus;
+
+ kind_expr:
n = gfc_match_init_expr (&e);
!
if (n != MATCH_YES)
! {
! 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)
{
*************** gfc_match_kind_spec (gfc_typespec *ts)
*** 1826,1832 ****
else if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Missing right parenthesis at %C");
! m = MATCH_ERROR;
}
else
/* All tests passed. */
--- 1864,1870 ----
else if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Missing right parenthesis at %C");
! m = MATCH_ERROR;
}
else
/* All tests passed. */
*************** done:
*** 2033,2045 ****
kind specification. Not doing so is needed for matching an IMPLICIT
statement correctly. */
! static match
! match_type_spec (gfc_typespec *ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
int c;
gfc_clear_ts (ts);
--- 2071,2084 ----
kind specification. Not doing so is needed for matching an IMPLICIT
statement correctly. */
! 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);
*************** match_type_spec (gfc_typespec *ts, int i
*** 2123,2134 ****
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))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
--- 2162,2195 ----
if (m != MATCH_YES)
return m;
! 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)
*************** get_kind:
*** 2154,2160 ****
return MATCH_NO;
}
! m = gfc_match_kind_spec (ts);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
--- 2215,2221 ----
return MATCH_NO;
}
! m = gfc_match_kind_spec (ts, false);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
*************** gfc_match_implicit (void)
*** 2301,2307 ****
gfc_clear_new_implicit ();
/* A basic type is mandatory here. */
! m = match_type_spec (&ts, 1);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
--- 2362,2368 ----
gfc_clear_new_implicit ();
/* A basic type is mandatory here. */
! m = gfc_match_type_spec (&ts, 1);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
*************** gfc_match_implicit (void)
*** 2344,2350 ****
m = match_char_spec (&ts);
else
{
! m = gfc_match_kind_spec (&ts);
if (m == MATCH_NO)
{
m = gfc_match_old_kind_spec (&ts);
--- 2405,2411 ----
m = match_char_spec (&ts);
else
{
! m = gfc_match_kind_spec (&ts, false);
if (m == MATCH_NO)
{
m = gfc_match_old_kind_spec (&ts);
*************** gfc_match_data_decl (void)
*** 3390,3396 ****
num_idents_on_line = 0;
! m = match_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
--- 3451,3457 ----
num_idents_on_line = 0;
! m = gfc_match_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
*************** match_prefix (gfc_typespec *ts)
*** 3492,3498 ****
loop:
if (!seen_type && ts != NULL
! && match_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
{
--- 3553,3559 ----
loop:
if (!seen_type && ts != NULL
! && gfc_match_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
{
*************** match_procedure_decl (void)
*** 3798,3804 ****
/* Get the type spec. for the procedure interface. */
old_loc = gfc_current_locus;
! m = match_type_spec (¤t_ts, 0);
if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
goto got_ts;
--- 3859,3865 ----
/* Get the type spec. for the procedure interface. */
old_loc = gfc_current_locus;
! m = gfc_match_type_spec (¤t_ts, 0);
if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
goto got_ts;
Index: /svn/trunk/gcc/fortran/match.h
===================================================================
*** /svn/trunk/gcc/fortran/match.h (revision 128873)
--- /svn/trunk/gcc/fortran/match.h (working copy)
*************** match gfc_match_omp_end_single (void);
*** 127,134 ****
match gfc_match_data (void);
match gfc_match_null (gfc_expr **);
! match gfc_match_kind_spec (gfc_typespec *);
match gfc_match_old_kind_spec (gfc_typespec *);
match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
--- 127,135 ----
match gfc_match_data (void);
match gfc_match_null (gfc_expr **);
! 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);
Index: /svn/trunk/gcc/fortran/parse.c
===================================================================
*** /svn/trunk/gcc/fortran/parse.c (revision 128873)
--- /svn/trunk/gcc/fortran/parse.c (working copy)
*************** done:
*** 1866,1871 ****
--- 1866,1900 ----
}
+ /* 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. */
*************** loop:
*** 1951,1956 ****
--- 1980,1994 ----
}
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;
*************** loop:
*** 1964,1969 ****
--- 2002,2020 ----
break;
}
+ /* If we still have kind = -1 at the end of the specification block,
+ then ther 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;
}
Index: /svn/trunk/gcc/fortran/parse.h
===================================================================
*** /svn/trunk/gcc/fortran/parse.h (revision 128873)
--- /svn/trunk/gcc/fortran/parse.h (working copy)
*************** const char *gfc_ascii_statement (gfc_sta
*** 66,70 ****
--- 66,72 ----
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 */
Index: /svn/trunk/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90 (revision 128873)
--- /svn/trunk/gcc/testsuite/gfortran.dg/derived_function_interface_1.f90 (working copy)
***************
*** 6,29 ****
!
! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
!
! type(foo) function ext_fun()
type foo
integer :: i
end type foo
ext_fun%i = 1
end function ext_fun
! type foo
! integer :: i
! end type foo
interface fun_interface
type(foo) function fun()
end function fun
end interface
interface ext_fun_interface
type(foo) function ext_fun()
end function ext_fun
end interface
--- 6,33 ----
!
! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
!
! 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
! 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
*************** contains
*** 38,40 ****
--- 42,45 ----
end function fun ! { dg-error "Expecting END PROGRAM" }
end ! { dg-warning "CONTAINS statement without FUNCTION or SUBROUTINE statement" }
+ ! { dg-final { cleanup-modules "kinds" } }
Index: /svn/trunk/gcc/testsuite/gfortran.dg/function_kinds_1.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/function_kinds_1.f90 (revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/function_kinds_1.f90 (revision 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" } }
Index: /svn/trunk/gcc/testsuite/gfortran.dg/function_kinds_2.f90
===================================================================
*** /svn/trunk/gcc/testsuite/gfortran.dg/function_kinds_2.f90 (revision 0)
--- /svn/trunk/gcc/testsuite/gfortran.dg/function_kinds_2.f90 (revision 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" } }
+
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |