+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
gfc_symbol *gfc_new_block;
-locus gfc_function_kind_locus;
-locus gfc_function_type_locus;
+bool gfc_matching_function;
/********************* DATA statement subroutines *********************/
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)
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");
}
gfc_free_expr (e);
- ts->kind = -1;
- gfc_function_kind_locus = loc;
gfc_undo_symbols ();
return MATCH_YES;
}
}
msg = gfc_extract_int (e, &ts->kind);
+
if (msg != NULL)
{
gfc_error (msg);
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;
}
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_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';
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);
}
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;
}
&& 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;
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. */
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;
}
-/* 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)
old_loc = gfc_current_locus;
- m = match_prefix (¤t_ts);
+ m = gfc_match_prefix (¤t_ts);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
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_current_state () != COMP_CONTAINS)
return MATCH_NO;
- m = match_prefix (NULL);
+ m = gfc_match_prefix (NULL);
if (m != MATCH_YES)
return m;
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;
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;
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)
{
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
|| 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;
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. */
}
-/* 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;
}
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)
}
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;
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;
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.
! 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
!
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" }
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
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
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
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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
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
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
projects / platform / upstream / linaro-gcc.git / commitdiff