This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, fortran] PR34429 PR34431 and PR34471 - function type characteristics
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: fortran at gcc dot gnu dot org
- Cc: gcc-patches <gcc-patches at gcc dot gnu dot org>, Tobias Burnus <burnus at net-b dot de>
- Date: Tue, 15 Jan 2008 19:48:58 +0100
- Subject: Re: [Patch, fortran] PR34429 PR34431 and PR34471 - function type characteristics
- References: <339c37f20801141507w5b6b7f9blbe8493dcdc85c0c1@mail.gmail.com>
Dear All,
I have made some "adjustments" to the error handling in parse.c
(match_deferred_characteristics), a bit of tidying up and have added a
new test function_kinds_5.f90.
The overall functionality of the patch is not affected and it regtests
as before.
Given that Tobi's tests show greens across the board and the timing
relative to the release cycle, I propose to commit this patch tomorrow
night, just to ensure that it is properly exposed.. Comments, errors,
or whatever are more than welcome on that timescale.
Paul
2008-01-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34429
PR fortran/34431
PR fortran/34471
* decl.c : Remove gfc_function_kind_locus and
gfc_function_type_locus. Add gfc_matching_function.
(match_char_length): If matching a function and the length
does not match, return MATCH_YES and try again later.
(gfc_match_kind_spec): The same.
(match_char_kind): The same.
(gfc_match_type_spec): The same for numeric and derived types.
(match_prefix): Rename as gfc_match_prefix.
(gfc_match_function_decl): Except for function valued character
lengths, defer applying kind, type and charlen info until the
end of specification block.
(gfortran.h): Add ST_GET_FCN_CHARACTERISTICS.
parse.c (decode_specification_statement): New function.
(decode_statement): Call it when a function has kind = -1. Set
and reset gfc_matching function, as function statement is being
matched.
(match_deferred_characteristics): Simplify with a single call
to gfc_match_prefix. Do appropriate error handling. In any
case, make sure that kind = -1 is reset or corrected.
(parse_spec): Call above on seeing ST_GET_FCN_CHARACTERISTICS.
Throw an error if kind = -1 after last specification statement.
parse.h : Prototype for gfc_match_prefix.
misc.c (gfc_clear_ts): Do not clear kind if it = -1.
2008-01-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34429
* gfortran.dg/function_charlen_1.f90: New test.
PR fortran/34431
* gfortran.dg/function_types_1.f90: New test.
* gfortran.dg/function_types_2.f90: New test.
PR fortran/34471
* gfortran.dg/function_kinds_4.f90: New test.
* gfortran.dg/function_kinds_5.f90: New test.
* gfortran.dg/defined_operators_1.f90: Errors now at function
declarations.
* gfortran.dg/private_type_4.f90: The same.
* gfortran.dg/interface_15.f90: The same.
* gfortran.dg/elemental_args_check_2.f90: The same.
* gfortran.dg/auto_internal_assumed.f90: The same.
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 131492)
--- gcc/fortran/decl.c (working copy)
*************** static enumerator_history *max_enum = NU
*** 86,93 ****
gfc_symbol *gfc_new_block;
! locus gfc_function_kind_locus;
! locus gfc_function_type_locus;
/********************* DATA statement subroutines *********************/
--- 86,92 ----
gfc_symbol *gfc_new_block;
! bool gfc_matching_function;
/********************* DATA statement subroutines *********************/
*************** match_char_length (gfc_expr **expr)
*** 653,658 ****
--- 652,663 ----
goto syntax;
m = char_len_param_value (expr);
+ if (m != MATCH_YES && gfc_matching_function)
+ {
+ gfc_undo_symbols ();
+ m = MATCH_YES;
+ }
+
if (m == MATCH_ERROR)
return m;
if (m == MATCH_NO)
*************** kind_expr:
*** 1869,1881 ****
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");
--- 1874,1884 ----
if (n != MATCH_YES)
{
! if (gfc_matching_function)
! {
! /* The function kind 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");
*************** kind_expr:
*** 1884,1891 ****
}
gfc_free_expr (e);
- ts->kind = -1;
- gfc_function_kind_locus = loc;
gfc_undo_symbols ();
return MATCH_YES;
}
--- 1887,1892 ----
*************** kind_expr:
*** 1907,1912 ****
--- 1908,1914 ----
}
msg = gfc_extract_int (e, &ts->kind);
+
if (msg != NULL)
{
gfc_error (msg);
*************** match_char_kind (int * kind, int * is_is
*** 1977,1993 ****
n = gfc_match_init_expr (&e);
! if (n != MATCH_YES
! && (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. */
gfc_free_expr (e);
- *kind = -1;
- gfc_function_kind_locus = where;
gfc_undo_symbols ();
return MATCH_YES;
}
--- 1979,1990 ----
n = gfc_match_init_expr (&e);
! if (n != MATCH_YES && gfc_matching_function)
! {
! /* The expression might include use-associated or imported
! parameters and try again after the specification
! expressions. */
gfc_free_expr (e);
gfc_undo_symbols ();
return MATCH_YES;
}
*************** syntax:
*** 2154,2159 ****
--- 2151,2167 ----
return m;
done:
+ /* Except in the case of the length being a function, where symbol
+ association looks after itself, deal with character functions
+ after the specification statements. */
+ if (gfc_matching_function
+ && !(len && len->expr_type != EXPR_VARIABLE
+ && len->expr_type != EXPR_OP))
+ {
+ gfc_undo_symbols ();
+ return MATCH_YES;
+ }
+
if (m != MATCH_YES)
{
gfc_free_expr (len);
*************** gfc_match_type_spec (gfc_typespec *ts, i
*** 2209,2215 ****
gfc_symbol *sym;
match m;
int c;
- locus loc = gfc_current_locus;
gfc_clear_ts (ts);
--- 2217,2222 ----
*************** gfc_match_type_spec (gfc_typespec *ts, i
*** 2293,2310 ****
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);
--- 2300,2323 ----
if (m != MATCH_YES)
return m;
! ts->type = BT_DERIVED;
!
! /* Defer association of the derived type until the end of the
! specification block. However, if the derived type can be
! found, add it to the typespec. */
! if (gfc_matching_function)
! {
! ts->derived = NULL;
! if (gfc_current_state () != COMP_INTERFACE
! && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
! ts->derived = sym;
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 be accessed at that point. */
! sym = NULL;
if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
*************** gfc_match_type_spec (gfc_typespec *ts, i
*** 2312,2323 ****
}
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;
}
--- 2325,2339 ----
}
else if (ts->kind == -1)
{
! int iface = gfc_state_stack->previous->state != COMP_INTERFACE
! || gfc_current_ns->has_import_set;
! if (gfc_find_symbol (name, NULL, iface, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
+ ts->kind = 0;
if (sym == NULL)
return MATCH_NO;
}
*************** gfc_match_type_spec (gfc_typespec *ts, i
*** 2326,2333 ****
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
! ts->type = BT_DERIVED;
! ts->kind = 0;
ts->derived = sym;
return MATCH_YES;
--- 2342,2348 ----
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
! gfc_set_sym_referenced (sym);
ts->derived = sym;
return MATCH_YES;
*************** get_kind:
*** 2350,2355 ****
--- 2365,2376 ----
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
+ /* Defer association of the KIND expression of function results
+ until after USE and IMPORT statements. */
+ if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
+ || gfc_matching_function)
+ return MATCH_YES;
+
if (m == MATCH_NO)
m = MATCH_YES; /* No kind specifier found. */
*************** cleanup:
*** 3673,3680 ****
can be matched. Note that if nothing matches, MATCH_YES is
returned (the null string was matched). */
! static match
! match_prefix (gfc_typespec *ts)
{
bool seen_type;
--- 3694,3701 ----
can be matched. Note that if nothing matches, MATCH_YES is
returned (the null string was matched). */
! match
! gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
*************** loop:
*** 3720,3726 ****
}
! /* Copy attributes matched by match_prefix() to attributes on a symbol. */
static try
copy_prefix (symbol_attribute *dest, locus *where)
--- 3741,3747 ----
}
! /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
static try
copy_prefix (symbol_attribute *dest, locus *where)
*************** gfc_match_function_decl (void)
*** 4245,4251 ****
old_loc = gfc_current_locus;
! m = match_prefix (¤t_ts);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
--- 4266,4272 ----
old_loc = gfc_current_locus;
! m = gfc_match_prefix (¤t_ts);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
*************** gfc_match_function_decl (void)
*** 4329,4334 ****
--- 4350,4371 ----
goto cleanup;
}
+ /* Except in the case of a function valued character length,
+ delay matching the function characteristics until after the
+ specification block by signalling kind=-1. */
+ if (!(current_ts.type == BT_CHARACTER
+ && current_ts.cl
+ && current_ts.cl->length
+ && current_ts.cl->length->expr_type != EXPR_OP
+ && current_ts.cl->length->expr_type != EXPR_VARIABLE))
+ {
+ sym->declared_at = old_loc;
+ if (current_ts.type != BT_UNKNOWN)
+ current_ts.kind = -1;
+ else
+ current_ts.kind = 0;
+ }
+
if (result == NULL)
{
sym->ts = current_ts;
*************** gfc_match_subroutine (void)
*** 4635,4641 ****
&& gfc_current_state () != COMP_CONTAINS)
return MATCH_NO;
! m = match_prefix (NULL);
if (m != MATCH_YES)
return m;
--- 4672,4678 ----
&& gfc_current_state () != COMP_CONTAINS)
return MATCH_NO;
! m = gfc_match_prefix (NULL);
if (m != MATCH_YES)
return m;
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 131492)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef enum
*** 223,229 ****
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_PROCEDURE,
! ST_NONE
}
gfc_statement;
--- 223,229 ----
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_PROCEDURE,
! ST_GET_FCN_CHARACTERISTICS, ST_NONE
}
gfc_statement;
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 131492)
--- gcc/fortran/parse.c (working copy)
*************** match_word (const char *str, match (*sub
*** 85,90 ****
--- 85,228 ----
undo_new_statement (); \
} while (0);
+
+ /* This is a specialist version of decode_statement that is used
+ for the specification statements in a function, whose
+ characteristics are deferred into the specification statements.
+ eg.: INTEGER (king = mykind) foo ()
+ USE mymodule, ONLY mykind.....
+ The KIND parameter needs a return after USE or IMPORT, whereas
+ derived type declarations can occur anywhere, up the executable
+ block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
+ out of the correct kind of specification statements. */
+ static gfc_statement
+ decode_specification_statement (void)
+ {
+ gfc_statement st;
+ locus old_locus;
+ int c;
+
+ if (gfc_match_eos () == MATCH_YES)
+ return ST_NONE;
+
+ old_locus = gfc_current_locus;
+
+ match ("import", gfc_match_import, ST_IMPORT);
+ match ("use", gfc_match_use, ST_USE);
+
+ if (gfc_numeric_ts (&gfc_current_block ()->ts))
+ goto end_of_block;
+
+ match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
+ match (NULL, gfc_match_data_decl, ST_DATA_DECL);
+ match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
+
+ /* General statement matching: Instead of testing every possible
+ statement, we eliminate most possibilities by peeking at the
+ first character. */
+
+ c = gfc_peek_char ();
+
+ switch (c)
+ {
+ case 'a':
+ match ("abstract% interface", gfc_match_abstract_interface,
+ ST_INTERFACE);
+ break;
+
+ case 'b':
+ match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
+ break;
+
+ case 'c':
+ break;
+
+ case 'd':
+ match ("data", gfc_match_data, ST_DATA);
+ match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
+ break;
+
+ case 'e':
+ match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
+ match ("entry% ", gfc_match_entry, ST_ENTRY);
+ match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
+ match ("external", gfc_match_external, ST_ATTR_DECL);
+ break;
+
+ case 'f':
+ match ("format", gfc_match_format, ST_FORMAT);
+ break;
+
+ case 'g':
+ break;
+
+ case 'i':
+ match ("implicit", gfc_match_implicit, ST_IMPLICIT);
+ match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
+ match ("interface", gfc_match_interface, ST_INTERFACE);
+ match ("intent", gfc_match_intent, ST_ATTR_DECL);
+ match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
+ break;
+
+ case 'm':
+ break;
+
+ case 'n':
+ match ("namelist", gfc_match_namelist, ST_NAMELIST);
+ break;
+
+ case 'o':
+ match ("optional", gfc_match_optional, ST_ATTR_DECL);
+ break;
+
+ case 'p':
+ match ("parameter", gfc_match_parameter, ST_PARAMETER);
+ match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
+ if (gfc_match_private (&st) == MATCH_YES)
+ return st;
+ match ("procedure", gfc_match_procedure, ST_PROCEDURE);
+ if (gfc_match_public (&st) == MATCH_YES)
+ return st;
+ match ("protected", gfc_match_protected, ST_ATTR_DECL);
+ break;
+
+ case 'r':
+ break;
+
+ case 's':
+ match ("save", gfc_match_save, ST_ATTR_DECL);
+ break;
+
+ case 't':
+ match ("target", gfc_match_target, ST_ATTR_DECL);
+ match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
+ break;
+
+ case 'u':
+ break;
+
+ case 'v':
+ match ("value", gfc_match_value, ST_ATTR_DECL);
+ match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
+ break;
+
+ case 'w':
+ break;
+ }
+
+ /* This is not a specification statement. See if any of the matchers
+ has stored an error message of some sort. */
+
+ end_of_block:
+ gfc_clear_error ();
+ gfc_buffer_error (0);
+ gfc_current_locus = old_locus;
+
+ return ST_GET_FCN_CHARACTERISTICS;
+ }
+
+
+ /* This is the primary 'decode_statement'. */
static gfc_statement
decode_statement (void)
{
*************** decode_statement (void)
*** 100,108 ****
--- 238,252 ----
gfc_clear_error (); /* Clear any pending errors. */
gfc_clear_warning (); /* Clear any pending warnings. */
+ gfc_matching_function = false;
+
if (gfc_match_eos () == MATCH_YES)
return ST_NONE;
+ if (gfc_current_state () == COMP_FUNCTION
+ && gfc_current_block ()->result->ts.kind == -1)
+ return decode_specification_statement ();
+
old_locus = gfc_current_locus;
/* Try matching a data declaration or function declaration. The
*************** decode_statement (void)
*** 113,118 ****
--- 257,263 ----
|| gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_CONTAINS)
{
+ gfc_matching_function = true;
m = gfc_match_function_decl ();
if (m == MATCH_YES)
return ST_FUNCTION;
*************** decode_statement (void)
*** 122,127 ****
--- 267,274 ----
gfc_undo_symbols ();
gfc_current_locus = old_locus;
}
+ gfc_matching_function = false;
+
/* Match statements whose error messages are meant to be overwritten
by something better. */
*************** done:
*** 1870,1899 ****
}
! /* 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;
}
--- 2017,2064 ----
}
! /* Associate function characteristics by going back to the function
! declaration and rematching the prefix. */
! static match
match_deferred_characteristics (gfc_typespec * ts)
{
locus loc;
! match m = MATCH_ERROR;
! char name[GFC_MAX_SYMBOL_LEN + 1];
loc = gfc_current_locus;
! gfc_current_locus = gfc_current_block ()->declared_at;
!
! gfc_clear_error ();
! gfc_buffer_error (1);
! m = gfc_match_prefix (ts);
! gfc_buffer_error (0);
!
! if (ts->type == BT_DERIVED)
{
! ts->kind = 0;
!
! if (!ts->derived || !ts->derived->components)
! m = MATCH_ERROR;
}
!
! /* Only permit one go at the characteristic association. */
! if (ts->kind == -1)
! ts->kind = 0;
!
! /* Set the function locus correctly. If we have not found the
! function name, there is an error. */
! gfc_match ("function% %n", name);
! if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
{
! gfc_current_block ()->declared_at = gfc_current_locus;
! gfc_commit_symbols ();
}
+ else
+ gfc_error_check ();
gfc_current_locus =loc;
return m;
}
*************** static gfc_statement
*** 1906,1911 ****
--- 2071,2078 ----
parse_spec (gfc_statement st)
{
st_state ss;
+ bool bad_characteristic = false;
+ gfc_typespec *ts;
verify_st_order (&ss, ST_NONE);
if (st == ST_NONE)
*************** loop:
*** 1984,1998 ****
}
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;
--- 2151,2156 ----
*************** loop:
*** 2002,2022 ****
st = next_statement ();
goto loop;
default:
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;
--- 2160,2196 ----
st = next_statement ();
goto loop;
+ case ST_GET_FCN_CHARACTERISTICS:
+ /* This statement triggers the association of a function's result
+ characteristics. */
+ ts = &gfc_current_block ()->result->ts;
+ if (match_deferred_characteristics (ts) != MATCH_YES)
+ bad_characteristic = true;
+
+ st = next_statement ();
+ goto loop;
+
default:
break;
}
! /* If match_deferred_characteristics failed, then there is an error. */
! if (bad_characteristic)
{
! ts = &gfc_current_block ()->result->ts;
! if (ts->type != BT_DERIVED)
gfc_error ("Bad kind expression for function '%s' at %L",
! gfc_current_block ()->name,
! &gfc_current_block ()->declared_at);
else
gfc_error ("The type for function '%s' at %L is not accessible",
! gfc_current_block ()->name,
! &gfc_current_block ()->declared_at);
!
! gfc_current_block ()->ts.kind = 0;
! /* Keep the derived type; if it's bad, it will be discovered later. */
! if (!(ts->type = BT_DERIVED && ts->derived))
! ts->type = BT_UNKNOWN;
}
return st;
Index: gcc/fortran/parse.h
===================================================================
*** gcc/fortran/parse.h (revision 131492)
--- gcc/fortran/parse.h (working copy)
*************** const char *gfc_ascii_statement (gfc_sta
*** 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 */
--- 66,71 ----
match gfc_match_enum (void);
match gfc_match_enumerator_def (void);
void gfc_free_enum_history (void);
! extern bool gfc_matching_function;
! match gfc_match_prefix (gfc_typespec *);
#endif /* GFC_PARSE_H */
Index: gcc/fortran/misc.c
===================================================================
*** gcc/fortran/misc.c (revision 131492)
--- gcc/fortran/misc.c (working copy)
*************** void
*** 74,81 ****
gfc_clear_ts (gfc_typespec *ts)
{
ts->type = BT_UNKNOWN;
- ts->kind = 0;
ts->derived = NULL;
ts->cl = NULL;
/* flag that says if the type is C interoperable */
ts->is_c_interop = 0;
--- 74,82 ----
gfc_clear_ts (gfc_typespec *ts)
{
ts->type = BT_UNKNOWN;
ts->derived = NULL;
+ if (ts->kind != -1)
+ ts->kind = 0;
ts->cl = NULL;
/* flag that says if the type is C interoperable */
ts->is_c_interop = 0;
Index: gcc/testsuite/gfortran.dg/function_types_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/function_types_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/function_types_2.f90 (revision 0)
***************
*** 0 ****
--- 1,104 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR34431 in which function TYPEs that were
+ ! USE associated would cause an error.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ module m1
+ integer :: hh
+ type t
+ real :: r
+ end type t
+ end module m1
+
+ module m2
+ type t
+ integer :: k
+ end type t
+ end module m2
+
+ module m3
+ contains
+ type(t) function func()
+ use m2
+ func%k = 77
+ end function func
+ end module m3
+
+ type(t) function a()
+ use m1, only: hh
+ type t2
+ integer :: j
+ end type t2
+ type t
+ logical :: b
+ end type t
+
+ a%b = .true.
+ end function a
+
+ type(t) function b()
+ use m1, only: hh
+ use m2
+ use m3
+ b = func ()
+ b%k = 5
+ end function b
+
+ type(t) function c()
+ use m1, only: hh
+ type t2
+ integer :: j
+ end type t2
+ type t
+ logical :: b
+ end type t
+
+ c%b = .true.
+ end function c
+
+ program main
+ type t
+ integer :: m
+ end type t
+ contains
+ type(t) function a1()
+ use m1, only: hh
+ type t2
+ integer :: j
+ end type t2
+ type t
+ logical :: b
+ end type t
+
+ a1%b = .true.
+ end function a1
+
+ type(t) function b1()
+ use m1, only: hh
+ use m2, only: t
+ ! NAG f95 believes that the host-associated type(t)
+ ! should be used:
+ ! b1%m = 5
+ ! However, I (Tobias Burnus) believe that the use-associated one should
+ ! be used:
+ b1%k = 5
+ end function b1
+
+ type(t) function c1()
+ use m1, only: hh
+ type t2
+ integer :: j
+ end type t2
+ type t
+ logical :: b
+ end type t
+
+ c1%b = .true.
+ end function c1
+
+ type(t) function d1()
+ d1%m = 55
+ end function d1
+ end program main
+ ! { dg-final { cleanup-modules "m1 m2 m3" } }
Index: gcc/testsuite/gfortran.dg/defined_operators_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/defined_operators_1.f90 (revision 131492)
--- gcc/testsuite/gfortran.dg/defined_operators_1.f90 (working copy)
***************
*** 7,16 ****
!
module mymod
interface operator (.foo.)
! module procedure foo_0 ! { dg-error "must have at least one argument" }
! module procedure foo_1 ! { dg-error "must be INTENT" }
! module procedure foo_2 ! { dg-error "cannot be optional" }
! module procedure foo_3 ! { dg-error "must have, at most, two arguments" }
module procedure foo_1_OK ! { dg-error "Ambiguous interfaces" }
module procedure foo_2_OK
function foo_chr (chr) ! { dg-error "cannot be assumed character length" }
--- 7,16 ----
!
module mymod
interface operator (.foo.)
! module procedure foo_0
! module procedure foo_1
! module procedure foo_2
! module procedure foo_3
module procedure foo_1_OK ! { dg-error "Ambiguous interfaces" }
module procedure foo_2_OK
function foo_chr (chr) ! { dg-error "cannot be assumed character length" }
*************** module mymod
*** 22,32 ****
end subroutine bad_foo
end interface
contains
! function foo_0 ()
integer :: foo_1
foo_0 = 1
end function foo_0
! function foo_1 (a)
integer :: foo_1
integer :: a
foo_1 = 1
--- 22,32 ----
end subroutine bad_foo
end interface
contains
! function foo_0 () ! { dg-error "must have at least one argument" }
integer :: foo_1
foo_0 = 1
end function foo_0
! function foo_1 (a) ! { dg-error "must be INTENT" }
integer :: foo_1
integer :: a
foo_1 = 1
*************** contains
*** 36,42 ****
integer, intent (in) :: a
foo_1_OK = 1
end function foo_1_OK
! function foo_2 (a, b)
integer :: foo_2
integer, intent(in) :: a
integer, intent(in), optional :: b
--- 36,42 ----
integer, intent (in) :: a
foo_1_OK = 1
end function foo_1_OK
! function foo_2 (a, b) ! { dg-error "cannot be optional" }
integer :: foo_2
integer, intent(in) :: a
integer, intent(in), optional :: b
*************** contains
*** 48,54 ****
real, intent(in) :: b
foo_2_OK = 2.0 * a + b
end function foo_2_OK
! function foo_3 (a, b, c)
integer :: foo_3
integer, intent(in) :: a, b, c
foo_3 = a + 3 * b - c
--- 48,54 ----
real, intent(in) :: b
foo_2_OK = 2.0 * a + b
end function foo_2_OK
! function foo_3 (a, b, c) ! { dg-error "must have, at most, two arguments" }
integer :: foo_3
integer, intent(in) :: a, b, c
foo_3 = a + 3 * b - c
Index: gcc/testsuite/gfortran.dg/function_kinds_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/function_kinds_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/function_kinds_4.f90 (revision 0)
***************
*** 0 ****
--- 1,56 ----
+ ! { dg-do run }
+ ! Tests the fix for PR34471 in which function KINDs that were
+ ! USE associated would cause an error.
+ !
+ ! This only needs to be run once.
+ ! { dg-options "-O2" }
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ module m1
+ integer, parameter :: i1 = 1, i2 = 2
+ end module m1
+
+ module m2
+ integer, parameter :: i1 = 8
+ end module m2
+
+ integer(i1) function three()
+ use m1, only: i2
+ use m2 ! This provides the function kind
+ three = i1
+ if(three /= kind(three)) call abort()
+ end function three
+
+ ! At one stage during the development of the patch, this started failing
+ ! but was not tested in gfortran.dg. */
+ real (kind(0d0)) function foo ()
+ foo = real (kind (foo))
+ end function
+
+ program main
+ implicit none
+ interface
+ integer(8) function three()
+ end function three
+ end interface
+ integer, parameter :: i1 = 4
+ integer :: i
+ real (kind(0d0)) foo
+ i = one()
+ i = two()
+ if(three() /= 8) call abort()
+ if (int(foo()) /= 8) call abort ()
+ contains
+ integer(i1) function one() ! Host associated kind
+ if (kind(one) /= 4) call abort()
+ one = 1
+ end function one
+ integer(i1) function two() ! Use associated kind
+ use m1, only: i2
+ use m2
+ if (kind(two) /= 8) call abort()
+ two = 1
+ end function two
+ end program main
+ ! { dg-final { cleanup-modules "m1 m2" } }
Index: gcc/testsuite/gfortran.dg/function_kinds_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/function_kinds_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/function_kinds_5.f90 (revision 0)
***************
*** 0 ****
--- 1,10 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR34471 in which function KINDs that were
+ ! USE associated would cause an error. This checks a regression
+ ! caused by an intermediate version of the patch.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ real (bad_kind(0d0)) function foo () ! { dg-error "must be an intrinsic or" }
+ foo = real (kind (foo))
+ end function
Index: gcc/testsuite/gfortran.dg/function_charlen_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/function_charlen_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/function_charlen_1.f90 (revision 0)
***************
*** 0 ****
--- 1,23 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR34429 in which function charlens that were
+ ! USE associated would cause an error.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ module m
+ integer, parameter :: strlen = 5
+ end module m
+
+ character(strlen) function test()
+ use m
+ test = 'A'
+ end function test
+
+ interface
+ character(strlen) function test()
+ use m
+ end function test
+ end interface
+ print *, test()
+ end
+ ! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/private_type_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/private_type_4.f90 (revision 131492)
--- gcc/testsuite/gfortran.dg/private_type_4.f90 (working copy)
*************** module m1
*** 7,17 ****
end type t1
private :: t1
! public :: f1 ! { dg-error "cannot be of PRIVATE type" }
contains
! type(t1) function f1()
end function
end module
--- 7,17 ----
end type t1
private :: t1
! public :: f1
contains
! type(t1) function f1() ! { dg-error "cannot be of PRIVATE type" }
end function
end module
Index: gcc/testsuite/gfortran.dg/interface_15.f90
===================================================================
*** gcc/testsuite/gfortran.dg/interface_15.f90 (revision 131492)
--- gcc/testsuite/gfortran.dg/interface_15.f90 (working copy)
*************** MODULE M1
*** 8,19 ****
INTEGER :: I
END TYPE T1
INTERFACE I
! MODULE PROCEDURE F1 ! { dg-error "PUBLIC interface" }
END INTERFACE
PRIVATE ! :: T1,F1
PUBLIC :: I
CONTAINS
! INTEGER FUNCTION F1(D)
TYPE(T1) :: D
F1 = D%I
END FUNCTION
--- 8,19 ----
INTEGER :: I
END TYPE T1
INTERFACE I
! MODULE PROCEDURE F1
END INTERFACE
PRIVATE ! :: T1,F1
PUBLIC :: I
CONTAINS
! INTEGER FUNCTION F1(D) ! { dg-error "PUBLIC interface" }
TYPE(T1) :: D
F1 = D%I
END FUNCTION
Index: gcc/testsuite/gfortran.dg/elemental_args_check_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/elemental_args_check_2.f90 (revision 131492)
--- gcc/testsuite/gfortran.dg/elemental_args_check_2.f90 (working copy)
***************
*** 8,17 ****
MODULE M1
IMPLICIT NONE
CONTAINS
! PURE ELEMENTAL SUBROUTINE S1(I,F) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" }
INTEGER, INTENT(IN) :: I
INTERFACE
! PURE INTEGER FUNCTION F(I)
INTEGER, INTENT(IN) :: I
END FUNCTION F
END INTERFACE
--- 8,17 ----
MODULE M1
IMPLICIT NONE
CONTAINS
! PURE ELEMENTAL SUBROUTINE S1(I,F)
INTEGER, INTENT(IN) :: I
INTERFACE
! PURE INTEGER FUNCTION F(I) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" }
INTEGER, INTENT(IN) :: I
END FUNCTION F
END INTERFACE
Index: gcc/testsuite/gfortran.dg/function_types_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/function_types_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/function_types_1.f90 (revision 0)
***************
*** 0 ****
--- 1,12 ----
+ ! { dg-do compile }
+ ! Tests the fix for PR34431 in which function TYPEs that were
+ ! USE associated would cause an error.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ module bar
+ contains
+ type(non_exist) function func2() ! { dg-error "not accessible" }
+ end function func2
+ end module bar
+ ! { dg-final { cleanup-modules "bar" } }
Index: gcc/testsuite/gfortran.dg/auto_internal_assumed.f90
===================================================================
*** gcc/testsuite/gfortran.dg/auto_internal_assumed.f90 (revision 131492)
--- gcc/testsuite/gfortran.dg/auto_internal_assumed.f90 (working copy)
***************
*** 3,12 ****
! internal function.
!
character (6) :: c
! c = f1 () ! { dg-error "must not be assumed length" }
if (c .ne. 'abcdef') call abort
contains
! function f1 ()
character (*) :: f1
f1 = 'abcdef'
end function f1
--- 3,12 ----
! internal function.
!
character (6) :: c
! c = f1 ()
if (c .ne. 'abcdef') call abort
contains
! function f1 () ! { dg-error "must not be assumed length" }
character (*) :: f1
f1 = 'abcdef'
end function f1