FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/26107 (ICE after error message on invalid code)

Browse source 
2006-03-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26107
	* resolve.c (resolve_function): Add name after test for pureness.

	PR fortran/19546
	* trans-expr.c (gfc_conv_variable): Detect reference to parent result,
	store current_function_decl, replace with parent, whilst calls are
	made to gfc_get_fake_result_decl, and restore afterwards. Signal this
	to gfc_get_fake_result_decl with a new argument, parent_flag.
	* trans-stmt.c (gfc_trans_return): gfc_get_fake_result_decl 2nd arg
	is set to zero.
	* trans.h: Add parent_flag to gfc_get_fake_result_decl prototype.
	* trans-decl.c (gfc_get_fake_result_decl): On parent_flag, being set,
	add decl to parent function. Replace refs to current_fake_result_decl
	with refs to this_result_decl.
	(gfc_generate_function_code): Null parent_fake_result_decl before the
	translation of code for contained procedures. Set parent_flag to zero
	in call to gfc_get_fake_result_decl.
	* trans-intrinsic.c (gfc_conv_intrinsic_len): The same.

2006-03-06  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26107
	* pure_dummy_length_1.f90: New test.

	PR fortran/19546
	* gfortran.dg/parent_result_ref_1.f90: New test.
	* gfortran.dg/parent_result_ref_2.f90: New test.
	* gfortran.dg/parent_result_ref_3.f90: New test.
	* gfortran.dg/parent_result_ref_4.f90: New test.

From-SVN: r111793
This commit is contained in:
Paul Thomas 2006-03-06 22:56:39 +00:00
parent 9202989a98
commit 5f20c93a30
14 changed files with 303 additions and 65 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
gcc/fortran/ChangeLog
View file

@ -1,8 +1,29 @@
2006-03-06 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26107
* resolve.c (resolve_function): Add name after test for pureness.
PR fortran/19546
* trans-expr.c (gfc_conv_variable): Detect reference to parent result,
store current_function_decl, replace with parent, whilst calls are
made to gfc_get_fake_result_decl, and restore afterwards. Signal this
to gfc_get_fake_result_decl with a new argument, parent_flag.
* trans-stmt.c (gfc_trans_return): gfc_get_fake_result_decl 2nd arg
is set to zero.
* trans.h: Add parent_flag to gfc_get_fake_result_decl prototype.
* trans-decl.c (gfc_get_fake_result_decl): On parent_flag, being set,
add decl to parent function. Replace refs to current_fake_result_decl
with refs to this_result_decl.
(gfc_generate_function_code): Null parent_fake_result_decl before the
translation of code for contained procedures. Set parent_flag to zero
in call to gfc_get_fake_result_decl.
* trans-intrinsic.c (gfc_conv_intrinsic_len): The same.
2006-03-05 Steven G. Kargl <kargls@comcast.net>
* simplify.c (gfc_simplify_verify): Fix return when SET=''.
2005-03-05 Erik Edelmann <eedelman@gcc.gnu.org>
2006-03-05 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/16136
* symbol.c (conf_std): New macro.
@ -180,7 +201,7 @@
* intrinsic.c (gfc_convert_type_warn): Call
gfc_intrinsic_symbol() on the newly created symbol.
2005-02-19 Paul Thomas <pault@gcc.gnu.org>
2006-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25054
* resolve.c (is_non_constant_shape_array): New function.
@ -232,7 +253,7 @@
* openmp.c (resolve_omp_clauses): Add a dummy case label to workaround
PR middle-end/26316.
2005-02-16 Paul Thomas <pault@gcc.gnu.org>
2006-02-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/24557
* trans-expr.c (gfc_add_interface_mapping): Use the actual argument
@ -767,7 +788,7 @@
* trans-decl.c (gfc_generate_function_code): Add new argument,
pedantic, to set_std call.
2005-02-06 Thomas Koenig <Thomas.Koenig@online.de>
2006-02-06 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/23815
* gfortran.texi: Document the GFORTRAN_CONVERT_UNIT environment
@ -929,7 +950,7 @@
for checking arguments array and mask.
(check_reduction): Likewise.
2005-01-30 Erik Edelmann <eedelman@gcc.gnu.org>
2006-01-30 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/24266
* trans-io.c (set_internal_unit): Check the rank of the
@ -958,7 +979,7 @@
* gfortran.h: Add prototype for gfc_dep_compare_expr.
* dependency.h: Remove prototype for gfc_dep_compare_expr.
2005-01-27 Paul Thomas <pault@gcc.gnu.org>
2006-01-27 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* resolve.c (resolve_function): Add GFC_ISYM_LOC to the list of
@ -986,12 +1007,12 @@
* lang-specs.h: Pass -fpreprocessed to f951 if preprocessing
sources.
2005-01-27 Erik Edelmann <eedelman@gcc.gnu.org>
2006-01-27 Erik Edelmann <eedelman@gcc.gnu.org>
* symbol.c (free_old_symbol): Fix confusing comment, and add code
to free old_symbol->formal.
2005-01-26 Paul Thomas <pault@gcc.gnu.org>
2006-01-26 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* resolve.c (resolve_function): Exclude statement functions from
@ -1023,7 +1044,7 @@
temporary from "parm" to "ifm" to avoid clash with temp coming from
trans-array.c.
2005-01-25 Erik Edelmann <eedelman@gcc.gnu.org>
2006-01-25 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25716
* symbol.c (free_old_symbol): New function.
@ -1038,7 +1059,7 @@
* resolve.c (gfc_resolve_index): Make sure typespec is
properly initialized.
2005-01-23 Paul Thomas <pault@gcc.gnu.org>
2006-01-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25901
* decl.c (get_proc_name): Replace subroutine and function attributes
@ -1057,7 +1078,7 @@
* gfortranspec.c (lang_specific_driver): Update copyright notice
date.
2005-01-21 Paul Thomas <pault@gcc.gnu.org>
2006-01-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25124
PR fortran/25625
@ -1210,7 +1231,7 @@
* scanner.c (load_line): use maxlen to determine the line-length used
for padding lines in fixed form.
2005-01-11 Paul Thomas <pault@gcc.gnu.org>
2006-01-11 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25730
* trans-types.c (copy_dt_decls_ifequal): Copy backend decl for
@ -1248,13 +1269,13 @@
(gfc_simplify_ichar): Get the result from unsinged char and in the
range 0 to UCHAR_MAX instead of CHAR_MIN to CHAR_MAX.
2005-01-08 Erik Edelmann <eedelman@gcc.gnu.org>
2006-01-08 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25093
* resolve.c (resolve_fntype): Check that PUBLIC functions
aren't of PRIVATE type.
2005-01-07 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
2006-01-07 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
* decl.c (gfc_match_function_decl): Correctly error out in case of
omitted function argument list.

2
gcc/fortran/resolve.c
View file

@ -1357,7 +1357,7 @@ resolve_function (gfc_expr * expr)
need_full_assumed_size = temp;
if (!pure_function (expr, &name))
if (!pure_function (expr, &name) && name)
{
if (forall_flag)
{

92
gcc/fortran/trans-decl.c
View file

@ -50,6 +50,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
/* Holds the result of the function if no result variable specified. */
static GTY(()) tree current_fake_result_decl;
static GTY(()) tree parent_fake_result_decl;
static GTY(()) tree current_function_return_label;
@ -1733,28 +1734,49 @@ gfc_create_function_decl (gfc_namespace * ns)
create_function_arglist (ns->proc_name);
}
/* Return the decl used to hold the function return value. */
/* Return the decl used to hold the function return value. If
parent_flag is set, the context is the parent_scope*/
tree
gfc_get_fake_result_decl (gfc_symbol * sym)
gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
{
tree decl, length;
tree decl;
tree length;
tree this_fake_result_decl;
tree this_function_decl;
char name[GFC_MAX_SYMBOL_LEN + 10];
if (parent_flag)
{
this_fake_result_decl = parent_fake_result_decl;
this_function_decl = DECL_CONTEXT (current_function_decl);
}
else
{
this_fake_result_decl = current_fake_result_decl;
this_function_decl = current_function_decl;
}
if (sym
&& sym->ns->proc_name->backend_decl == current_function_decl
&& sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master
&& sym != sym->ns->proc_name)
{
tree t = NULL, var;
if (current_fake_result_decl != NULL)
for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
if (this_fake_result_decl != NULL)
for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
break;
if (t)
return TREE_VALUE (t);
decl = gfc_get_fake_result_decl (sym->ns->proc_name);
decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
if (parent_flag)
this_fake_result_decl = parent_fake_result_decl;
else
this_fake_result_decl = current_fake_result_decl;
if (decl && sym->ns->proc_name->attr.mixed_entry_master)
{
tree field;
@ -1769,18 +1791,24 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
NULL_TREE);
}
var = gfc_create_var (TREE_TYPE (decl), sym->name);
GFC_DECL_RESULT (var) = 1;
var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
if (parent_flag)
gfc_add_decl_to_parent_function (var);
else
gfc_add_decl_to_function (var);
SET_DECL_VALUE_EXPR (var, decl);
DECL_HAS_VALUE_EXPR_P (var) = 1;
TREE_CHAIN (current_fake_result_decl)
= tree_cons (get_identifier (sym->name), var,
TREE_CHAIN (current_fake_result_decl));
TREE_CHAIN (this_fake_result_decl)
= tree_cons (get_identifier (sym->name), var,
TREE_CHAIN (this_fake_result_decl));
return var;
}
if (current_fake_result_decl != NULL_TREE)
return TREE_VALUE (current_fake_result_decl);
if (this_fake_result_decl != NULL_TREE)
return TREE_VALUE (this_fake_result_decl);
/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
sym is NULL. */
@ -1800,9 +1828,9 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
if (gfc_return_by_reference (sym))
{
decl = DECL_ARGUMENTS (current_function_decl);
decl = DECL_ARGUMENTS (this_function_decl);
if (sym->ns->proc_name->backend_decl == current_function_decl
if (sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master)
decl = TREE_CHAIN (decl);
@ -1813,10 +1841,10 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
else
{
sprintf (name, "__result_%.20s",
IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
decl = build_decl (VAR_DECL, get_identifier (name),
TREE_TYPE (TREE_TYPE (current_function_decl)));
TREE_TYPE (TREE_TYPE (this_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
DECL_EXTERNAL (decl) = 0;
@ -1826,10 +1854,16 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
layout_decl (decl, 0);
gfc_add_decl_to_function (decl);
if (parent_flag)
gfc_add_decl_to_parent_function (decl);
else
gfc_add_decl_to_function (decl);
}
current_fake_result_decl = build_tree_list (NULL, decl);
if (parent_flag)
parent_fake_result_decl = build_tree_list (NULL, decl);
else
current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
@ -2834,12 +2868,24 @@ gfc_generate_function_code (gfc_namespace * ns)
/* Translate COMMON blocks. */
gfc_trans_common (ns);
/* Null the parent fake result declaration if this namespace is
a module function or an external procedures. */
if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
|| ns->parent == NULL)
parent_fake_result_decl = NULL_TREE;
gfc_generate_contained_functions (ns);
generate_local_vars (ns);
/* Will be created as needed. */
current_fake_result_decl = NULL_TREE;
/* Keep the parent fake result declaration in module functions
or external procedures. */
if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
|| ns->parent == NULL)
current_fake_result_decl = parent_fake_result_decl;
else
current_fake_result_decl = NULL_TREE;
current_function_return_label = NULL;
/* Now generate the code for the body of this function. */
@ -2901,7 +2947,7 @@ gfc_generate_function_code (gfc_namespace * ns)
&& sym->attr.subroutine)
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym);
alternate_return = gfc_get_fake_result_decl (sym, 0);
gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
}

48
gcc/fortran/trans-expr.c
View file

@ -296,6 +296,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
gfc_ref *ref;
gfc_symbol *sym;
tree parent_decl;
int parent_flag;
bool return_value;
bool alternate_entry;
bool entry_master;
sym = expr->symtree->n.sym;
if (se->ss != NULL)
@ -317,32 +322,51 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
se->expr = gfc_get_symbol_decl (sym);
/* Deal with references to a parent results or entries by storing
the current_function_decl and moving to the parent_decl. */
parent_flag = 0;
return_value = sym->attr.function && sym->result == sym;
alternate_entry = sym->attr.function && sym->attr.entry
&& sym->result == sym;
entry_master = sym->attr.result
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name);
parent_decl = DECL_CONTEXT (current_function_decl);
if ((se->expr == parent_decl && return_value)
|| (sym->ns && sym->ns->proc_name
&& sym->ns->proc_name->backend_decl == parent_decl
&& (alternate_entry || entry_master)))
parent_flag = 1;
else
parent_flag = 0;
/* Special case for assigning the return value of a function.
Self recursive functions must have an explicit return value. */
if (se->expr == current_function_decl && sym->attr.function
&& (sym->result == sym))
se_expr = gfc_get_fake_result_decl (sym);
if (sym->attr.function && sym->result == sym
&& (se->expr == current_function_decl || parent_flag))
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
/* Similarly for alternate entry points. */
else if (sym->attr.function && sym->attr.entry
&& (sym->result == sym)
&& sym->ns->proc_name->backend_decl == current_function_decl)
else if (alternate_entry
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag))
{
gfc_entry_list *el = NULL;
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
se_expr = gfc_get_fake_result_decl (sym);
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
break;
}
}
else if (sym->attr.result
&& sym->ns->proc_name->backend_decl == current_function_decl
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name))
se_expr = gfc_get_fake_result_decl (sym);
else if (entry_master
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag))
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
if (se_expr)
se->expr = se_expr;

2
gcc/fortran/trans-intrinsic.c
View file

@ -2269,7 +2269,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
decl = gfc_get_symbol_decl (sym);
if (decl == current_function_decl && sym->attr.function
&& (sym->result == sym))
decl = gfc_get_fake_result_decl (sym);
decl = gfc_get_fake_result_decl (sym, 0);
len = sym->ts.cl->backend_decl;
gcc_assert (len);

9
gcc/fortran/trans-openmp.c
View file

@ -182,6 +182,9 @@ gfc_trans_add_clause (tree node, tree tail)
return node;
}
/* TODO make references to parent function results, as done in
gfc_conv_variable. */
static tree
gfc_trans_omp_variable (gfc_symbol *sym)
{
@ -191,7 +194,7 @@ gfc_trans_omp_variable (gfc_symbol *sym)
Self recursive functions must have an explicit return value. */
if (t == current_function_decl && sym->attr.function
&& (sym->result == sym))
t = gfc_get_fake_result_decl (sym);
t = gfc_get_fake_result_decl (sym, 0);
/* Similarly for alternate entry points. */
else if (sym->attr.function && sym->attr.entry
@ -203,7 +206,7 @@ gfc_trans_omp_variable (gfc_symbol *sym)
for (el = sym->ns->entries; el; el = el->next)
if (sym == el->sym)
{
t = gfc_get_fake_result_decl (sym);
t = gfc_get_fake_result_decl (sym, 0);
break;
}
}
@ -212,7 +215,7 @@ gfc_trans_omp_variable (gfc_symbol *sym)
&& sym->ns->proc_name->backend_decl == current_function_decl
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name))
t = gfc_get_fake_result_decl (sym);
t = gfc_get_fake_result_decl (sym, 0);
return t;
}

2
gcc/fortran/trans-stmt.c
View file

@ -309,7 +309,7 @@ gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
in a subroutine and current_fake_result_decl has already
been generated. */
result = gfc_get_fake_result_decl (NULL);
result = gfc_get_fake_result_decl (NULL, 0);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",

2
gcc/fortran/trans.h
View file

@ -361,7 +361,7 @@ tree gfc_build_label_decl (tree);
/* Return the decl used to hold the function return value.
Do not use if the function has an explicit result variable. */
tree gfc_get_fake_result_decl (gfc_symbol *);
tree gfc_get_fake_result_decl (gfc_symbol *, int);
/* Get the return label for the current function. */
tree gfc_get_return_label (void);

29
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,14 @@
2006-03-06 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26107
* pure_dummy_length_1.f90: New test.
PR fortran/19546
* gfortran.dg/parent_result_ref_1.f90: New test.
* gfortran.dg/parent_result_ref_2.f90: New test.
* gfortran.dg/parent_result_ref_3.f90: New test.
* gfortran.dg/parent_result_ref_4.f90: New test.
2006-03-06 Steven G. Kargl <kargls@comcast.net>
* gfortran.dg/verify_2.f90: New test.
@ -29,7 +40,7 @@
PR c++/15759
* g++.dg/other/default4.C: New test.
2005-03-05 Erik Edelmann <eedelman@gcc.gnu.org>
2006-03-05 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/16136
* allocatable_dummy_1.f90: New.
@ -300,7 +311,7 @@
PR fortran/26201
* gfortran.dg/convert_1.f90: New.
2005-02-19 Paul Thomas <pault@gcc.gnu.org>
2006-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25054
* gfortran.dg/namelist_5.f90: New test.
@ -396,7 +407,7 @@
vect-reduc-pattern-1a.c, vect-reduc-pattern-1b.c and
vect-reduc-pattern-1c.c
2005-02-16 Paul Thomas <pault@gcc.gnu.org>
2006-02-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/24557
* gfortran.dg/assumed_charlen_needed_1.f90: New test.
@ -710,7 +721,7 @@
* g++.old-deja/g++.pt/ttp26.C: Likewise.
* g++.old-deja/g++.pt/ttp36.C: Likewise.
2005-02-06 Thomas Koenig <Thomas.Koenig@online.de>
2006-02-06 Thomas Koenig <Thomas.Koenig@online.de>
PR libfortran/23815
* unf_io_convert_4.f90: New test.
@ -876,7 +887,7 @@
* gcc.target/i386/sselibm-4.c: Likewise.
* gcc.target/i386/sselibm-5.c: Likewise.
2005-01-30 Erik Edelmann <eedelman@gcc.gnu.org>
2006-01-30 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/24266
* gfortran.dg/arrayio_derived_2.f90: New.
@ -971,7 +982,7 @@
* gcc.dg/pragma-re-4.c: New test.
2005-01-27 Paul Thomas <pault@gcc.gnu.org>
2006-01-27 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* gfortran.dg/assumed_size_refs_3.f90: New test.
@ -989,7 +1000,7 @@
* ada/acats/tests/c9/c97305c.ada: Likewise.
* ada/acats/tests/c9/c99004a.ada: Likewise.
2005-01-26 Paul Thomas <pault@gcc.gnu.org>
2006-01-26 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* gfortran.dg/global_references_2.f90: New test.
@ -1112,7 +1123,7 @@
* gcc.dg/torture/pr25654.c: New testcase.
* gcc.target/i386/pr25654.c: Likewise.
2005-01-23 Paul Thomas <pault@gcc.gnu.org>
2006-01-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25901
* gfortran.dg/internal references_2.f90: New test.
@ -1142,7 +1153,7 @@
PR c++/25858
* g++.dg/template/crash44.C: New test.
2005-01-21 Paul Thomas <pault@gcc.gnu.org>
2006-01-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25124
PR fortran/25625

19
gcc/testsuite/gfortran.dg/parent_result_ref_1.f90 Normal file
View file

@ -0,0 +1,19 @@
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! From the testcase of Francois-Xavier Coudert/Tobias Schlueter
!
function f()
integer :: f
f = 42
call sub ()
if (f.eq.1) f = f + 1
contains
subroutine sub
if (f.eq.42) f = f - 41
end subroutine sub
end function f
integer, external :: f
if (f ().ne.2) call abort ()
end

35
gcc/testsuite/gfortran.dg/parent_result_ref_2.f90 Normal file
View file

@ -0,0 +1,35 @@
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! This case tests character results.
!
function f()
character(4) :: f
f = "efgh"
call sub ()
if (f.eq."iklm") f = "abcd"
call sub ()
contains
subroutine sub
f = "wxyz"
if (f.eq."efgh") f = "iklm"
end subroutine sub
end function f
function g() ! { dg-warning "is obsolescent in fortran 95" }
character(*) :: g
g = "efgh"
call sub ()
if (g.eq."iklm") g = "ABCD"
call sub ()
contains
subroutine sub
g = "WXYZ"
if (g.eq."efgh") g = "iklm"
end subroutine sub
end function g
character(4), external :: f, g
if (f ().ne."wxyz") call abort ()
if (g ().ne."WXYZ") call abort ()
end

28
gcc/testsuite/gfortran.dg/parent_result_ref_3.f90 Executable file
View file

@ -0,0 +1,28 @@
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! Check that parent alternate entry results can be referenced.
!
function f()
integer :: f, g
f = 42
call sub1 ()
if (f.eq.1) f = 2
return
entry g()
g = 99
call sub2 ()
if (g.eq.77) g = 33
contains
subroutine sub1
if (f.eq.42) f = 1
end subroutine sub1
subroutine sub2
if (g.eq.99) g = g - 22
end subroutine sub2
end function f
integer, external :: f, g
if (f ().ne.2) call abort ()
if (g ().ne.33) call abort ()
end

22
gcc/testsuite/gfortran.dg/parent_result_ref_4.f90 Normal file
View file

@ -0,0 +1,22 @@
! { dg-do run }
! Tests the fix for PR19546 in which an ICE would result from
! setting the parent result in a contained procedure.
! Check that parent function results can be referenced in modules.
!
module m
contains
function f()
integer :: f
f = 42
call sub ()
if (f.eq.1) f = f + 1
contains
subroutine sub
if (f.eq.42) f = f - 41
end subroutine sub
end function f
end module m
use m
if (f ().ne.2) call abort ()
end

29
gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 Normal file
View file

@ -0,0 +1,29 @@
! { dg-do compile }
! Tests fix for PR26107 in which an ICE would occur after the second
! error message below. This resulted from a spurious attempt to
! produce the third error message, without the name of the function.
!
! This is an expanded version of the testcase in the PR.
!
pure function equals(self, & ! { dg-error "must be INTENT" }
string, ignore_case) result(same)
character(*), intent(in) :: string
integer(4), intent(in) :: ignore_case
integer(4) :: same
if (len (self) < 1) return ! { dg-error "Type of argument" }
same = 1
end function
function impure(self) result(ival)
character(*), intent(in) :: self
ival = 1
end function
pure function purity(self, string, ignore_case) result(same)
character(*), intent(in) :: self
character(*), intent(in) :: string
integer(4), intent(in) :: ignore_case
integer i
if (end > impure (self)) & ! { dg-error "non-PURE procedure" }
return
end function