Commit 1c8bcdf7 by Paul Thomas

re PR fortran/34429 (Fails: character(len=use_associated_const) function foo())

2008-01-17  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 (gfc_statement): 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.

2008-01-17  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.

From-SVN: r131592
parent e7ce29e7
2008-01-17 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 (gfc_statement): 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.
2008-01-16 Tobias Burnus <burnus@net-b.de>
PR fortran/34796
......
......@@ -86,8 +86,7 @@ static enumerator_history *max_enum = NULL;
gfc_symbol *gfc_new_block;
locus gfc_function_kind_locus;
locus gfc_function_type_locus;
bool gfc_matching_function;
/********************* DATA statement subroutines *********************/
......@@ -653,6 +652,12 @@ match_char_length (gfc_expr **expr)
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)
......@@ -1869,13 +1874,11 @@ kind_expr:
if (n != MATCH_YES)
{
if (gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_NONE
|| gfc_current_state () == COMP_CONTAINS)
if (gfc_matching_function)
{
/* Signal using kind = -1 that the expression might include
use associated or imported parameters and try again after
the specification expressions..... */
/* 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");
......@@ -1884,8 +1887,6 @@ kind_expr:
}
gfc_free_expr (e);
ts->kind = -1;
gfc_function_kind_locus = loc;
gfc_undo_symbols ();
return MATCH_YES;
}
......@@ -1907,6 +1908,7 @@ kind_expr:
}
msg = gfc_extract_int (e, &ts->kind);
if (msg != NULL)
{
gfc_error (msg);
......@@ -1977,17 +1979,12 @@ match_char_kind (int * kind, int * is_iso_c)
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))
if (n != MATCH_YES && gfc_matching_function)
{
/* Signal using kind = -1 that the expression might include
use-associated or imported parameters and try again after
the specification expressions. */
/* 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;
}
......@@ -2154,6 +2151,17 @@ syntax:
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);
......@@ -2209,9 +2217,16 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
gfc_symbol *sym;
match m;
int c;
locus loc = gfc_current_locus;
bool seen_deferred_kind;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
&& (gfc_current_block ()->result->ts.kind == -1)
&& (ts->kind == -1);
gfc_clear_ts (ts);
if (seen_deferred_kind)
ts->kind = -1;
/* Clear the current binding label, in case one is given. */
curr_binding_label[0] = '\0';
......@@ -2293,18 +2308,24 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
if (m != MATCH_YES)
return m;
if (gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_NONE)
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)
{
gfc_function_type_locus = loc;
ts->type = BT_UNKNOWN;
ts->kind = -1;
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 legally be accessed at that point. */
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);
......@@ -2312,12 +2333,15 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
}
else if (ts->kind == -1)
{
if (gfc_find_symbol (name, NULL, 0, &sym))
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;
}
......@@ -2326,8 +2350,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
ts->type = BT_DERIVED;
ts->kind = 0;
gfc_set_sym_referenced (sym);
ts->derived = sym;
return MATCH_YES;
......@@ -2350,6 +2373,12 @@ get_kind:
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. */
......@@ -3673,8 +3702,8 @@ cleanup:
can be matched. Note that if nothing matches, MATCH_YES is
returned (the null string was matched). */
static match
match_prefix (gfc_typespec *ts)
match
gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
......@@ -3720,7 +3749,7 @@ loop:
}
/* Copy attributes matched by match_prefix() to attributes on a symbol. */
/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
static try
copy_prefix (symbol_attribute *dest, locus *where)
......@@ -4245,7 +4274,7 @@ gfc_match_function_decl (void)
old_loc = gfc_current_locus;
m = match_prefix (&current_ts);
m = gfc_match_prefix (&current_ts);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
......@@ -4329,6 +4358,22 @@ gfc_match_function_decl (void)
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;
......@@ -4635,7 +4680,7 @@ gfc_match_subroutine (void)
&& gfc_current_state () != COMP_CONTAINS)
return MATCH_NO;
m = match_prefix (NULL);
m = gfc_match_prefix (NULL);
if (m != MATCH_YES)
return m;
......
......@@ -223,7 +223,7 @@ typedef enum
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
ST_GET_FCN_CHARACTERISTICS, ST_NONE
}
gfc_statement;
......
......@@ -74,8 +74,8 @@ void
gfc_clear_ts (gfc_typespec *ts)
{
ts->type = BT_UNKNOWN;
ts->kind = 0;
ts->derived = NULL;
ts->kind = 0;
ts->cl = NULL;
/* flag that says if the type is C interoperable */
ts->is_c_interop = 0;
......
......@@ -85,6 +85,144 @@ match_word (const char *str, match (*subr) (void), locus *old_locus)
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)
{
......@@ -100,9 +238,15 @@ decode_statement (void)
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
......@@ -113,6 +257,7 @@ decode_statement (void)
|| 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;
......@@ -122,6 +267,8 @@ decode_statement (void)
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. */
......@@ -1870,30 +2017,48 @@ done:
}
/* Recover use associated or imported function characteristics. */
/* Associate function characteristics by going back to the function
declaration and rematching the prefix. */
static try
static match
match_deferred_characteristics (gfc_typespec * ts)
{
locus loc;
match m;
match m = MATCH_ERROR;
char name[GFC_MAX_SYMBOL_LEN + 1];
loc = gfc_current_locus;
if (gfc_current_block ()->ts.type != BT_UNKNOWN)
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)
{
/* Kind expression for an intrinsic type. */
gfc_current_locus = gfc_function_kind_locus;
m = gfc_match_kind_spec (ts, true);
ts->kind = 0;
if (!ts->derived || !ts->derived->components)
m = MATCH_ERROR;
}
else
/* 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)
{
/* A derived type. */
gfc_current_locus = gfc_function_type_locus;
m = gfc_match_type_spec (ts, 0);
gfc_current_block ()->declared_at = gfc_current_locus;
gfc_commit_symbols ();
}
else
gfc_error_check ();
gfc_current_ns->proc_name->result->ts = *ts;
gfc_current_locus =loc;
return m;
}
......@@ -1906,6 +2071,8 @@ static gfc_statement
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)
......@@ -1984,15 +2151,6 @@ 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;
......@@ -2002,21 +2160,37 @@ loop:
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 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 match_deferred_characteristics failed, then there is an error. */
if (bad_characteristic)
{
if (gfc_current_block ()->ts.type != BT_UNKNOWN)
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_function_kind_locus);
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_function_type_locus);
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;
......
......@@ -66,7 +66,6 @@ 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;
extern bool gfc_matching_function;
match gfc_match_prefix (gfc_typespec *);
#endif /* GFC_PARSE_H */
2008-01-17 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.
2008-01-16 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/sizetype.adb: New test.
......@@ -3,10 +3,10 @@
! internal function.
!
character (6) :: c
c = f1 () ! { dg-error "must not be assumed length" }
c = f1 ()
if (c .ne. 'abcdef') call abort
contains
function f1 ()
function f1 () ! { dg-error "must not be assumed length" }
character (*) :: f1
f1 = 'abcdef'
end function f1
......
......@@ -7,10 +7,10 @@
!
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_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" }
......@@ -22,11 +22,11 @@ module mymod
end subroutine bad_foo
end interface
contains
function foo_0 ()
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)
function foo_1 (a) ! { dg-error "must be INTENT" }
integer :: foo_1
integer :: a
foo_1 = 1
......@@ -36,7 +36,7 @@ contains
integer, intent (in) :: a
foo_1_OK = 1
end function foo_1_OK
function foo_2 (a, b)
function foo_2 (a, b) ! { dg-error "cannot be optional" }
integer :: foo_2
integer, intent(in) :: a
integer, intent(in), optional :: b
......@@ -48,7 +48,7 @@ contains
real, intent(in) :: b
foo_2_OK = 2.0 * a + b
end function foo_2_OK
function foo_3 (a, b, c)
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
......
......@@ -8,10 +8,10 @@
MODULE M1
IMPLICIT NONE
CONTAINS
PURE ELEMENTAL SUBROUTINE S1(I,F) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" }
PURE ELEMENTAL SUBROUTINE S1(I,F)
INTEGER, INTENT(IN) :: I
INTERFACE
PURE INTEGER FUNCTION F(I)
PURE INTEGER FUNCTION F(I) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" }
INTEGER, INTENT(IN) :: I
END FUNCTION F
END INTERFACE
......
! { 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" } }
! { 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" } }
! { 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
! { 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" } }
! { 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" } }
......@@ -8,12 +8,12 @@ MODULE M1
INTEGER :: I
END TYPE T1
INTERFACE I
MODULE PROCEDURE F1 ! { dg-error "PUBLIC interface" }
MODULE PROCEDURE F1
END INTERFACE
PRIVATE ! :: T1,F1
PUBLIC :: I
CONTAINS
INTEGER FUNCTION F1(D)
INTEGER FUNCTION F1(D) ! { dg-error "PUBLIC interface" }
TYPE(T1) :: D
F1 = D%I
END FUNCTION
......
......@@ -7,11 +7,11 @@ module m1
end type t1
private :: t1
public :: f1 ! { dg-error "cannot be of PRIVATE type" }
public :: f1
contains
type(t1) function f1()
type(t1) function f1() ! { dg-error "cannot be of PRIVATE type" }
end function
end module
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment