+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.
* intrinsic.c (gfc_convert_type_warn): Call
gfc_intrinsic_symbol() on the newly created symbol.
-200
5-02-19 Paul Thomas <pault@gcc.gnu.org>
+200
6-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25054
* resolve.c (is_non_constant_shape_array): New function.
* openmp.c (resolve_omp_clauses): Add a dummy case label to workaround
PR middle-end/26316.
-200
5-02-16 Paul Thomas <pault@gcc.gnu.org>
+200
6-02-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/24557
* trans-expr.c (gfc_add_interface_mapping): Use the actual argument
* 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
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
* gfortran.h: Add prototype for gfc_dep_compare_expr.
* dependency.h: Remove prototype for gfc_dep_compare_expr.
-200
5-01-27 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-27 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* resolve.c (resolve_function): Add GFC_ISYM_LOC to the list of
* 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.
-200
5-01-26 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-26 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* resolve.c (resolve_function): Exclude statement functions from
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.
* resolve.c (gfc_resolve_index): Make sure typespec is
properly initialized.
-200
5-01-23 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25901
* decl.c (get_proc_name): Replace subroutine and function attributes
* gfortranspec.c (lang_specific_driver): Update copyright notice
date.
-200
5-01-21 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25124
PR fortran/25625
* scanner.c (load_line): use maxlen to determine the line-length used
for padding lines in fixed form.
-200
5-01-11 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-11 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25730
* trans-types.c (copy_dt_decls_ifequal): Copy backend decl for
(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.
need_full_assumed_size = temp;
- if (!pure_function (expr, &name))
+ if (!pure_function (expr, &name) && name)
{
if (forall_flag)
{
/* 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;
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;
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. */
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);
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;
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;
}
/* 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. */
&& 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);
}
{
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)
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;
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);
return node;
}
+/* TODO make references to parent function results, as done in
+ gfc_conv_variable. */
+
static tree
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
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;
}
}
&& 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;
}
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",
/* 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);
+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.
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.
PR fortran/26201
* gfortran.dg/convert_1.f90: New.
-200
5-02-19 Paul Thomas <pault@gcc.gnu.org>
+200
6-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25054
* gfortran.dg/namelist_5.f90: New test.
vect-reduc-pattern-1a.c, vect-reduc-pattern-1b.c and
vect-reduc-pattern-1c.c
-200
5-02-16 Paul Thomas <pault@gcc.gnu.org>
+200
6-02-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/24557
* gfortran.dg/assumed_charlen_needed_1.f90: New test.
* 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.
* 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.
* gcc.dg/pragma-re-4.c: New test.
-200
5-01-27 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-27 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* gfortran.dg/assumed_size_refs_3.f90: New test.
* ada/acats/tests/c9/c97305c.ada: Likewise.
* ada/acats/tests/c9/c99004a.ada: Likewise.
-200
5-01-26 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-26 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25964
* gfortran.dg/global_references_2.f90: New test.
* gcc.dg/torture/pr25654.c: New testcase.
* gcc.target/i386/pr25654.c: Likewise.
-200
5-01-23 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25901
* gfortran.dg/internal references_2.f90: New test.
PR c++/25858
* g++.dg/template/crash44.C: New test.
-200
5-01-21 Paul Thomas <pault@gcc.gnu.org>
+200
6-01-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25124
PR fortran/25625
--- /dev/null
+! { dg-do run }\r
+! Tests the fix for PR19546 in which an ICE would result from\r
+! setting the parent result in a contained procedure. \r
+! From the testcase of Francois-Xavier Coudert/Tobias Schlueter\r
+! \r
+function f()\r
+ integer :: f\r
+ f = 42\r
+ call sub ()\r
+ if (f.eq.1) f = f + 1\r
+contains\r
+ subroutine sub\r
+ if (f.eq.42) f = f - 41\r
+ end subroutine sub\r
+end function f\r
+\r
+ integer, external :: f\r
+ if (f ().ne.2) call abort ()\r
+end\r
--- /dev/null
+! { dg-do run }\r
+! Tests the fix for PR19546 in which an ICE would result from\r
+! setting the parent result in a contained procedure. \r
+! This case tests character results.\r
+! \r
+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\r
+ if (f ().ne."wxyz") call abort ()
+ if (g ().ne."WXYZ") call abort ()
+end\r
--- /dev/null
+! { dg-do run }\r
+! Tests the fix for PR19546 in which an ICE would result from\r
+! setting the parent result in a contained procedure. \r
+! Check that parent alternate entry results can be referenced.\r
+! \r
+function f()\r
+ integer :: f, g\r
+ f = 42\r
+ call sub1 ()\r
+ if (f.eq.1) f = 2\r
+ return\r
+entry g()\r
+ g = 99\r
+ call sub2 ()
+ if (g.eq.77) g = 33\r
+contains\r
+ subroutine sub1\r
+ if (f.eq.42) f = 1\r
+ end subroutine sub1\r
+ subroutine sub2\r
+ if (g.eq.99) g = g - 22\r
+ end subroutine sub2\r
+end function f\r
+\r
+ integer, external :: f, g\r
+ if (f ().ne.2) call abort ()
+ if (g ().ne.33) call abort ()\r
+end\r
--- /dev/null
+! { dg-do run }\r
+! Tests the fix for PR19546 in which an ICE would result from\r
+! setting the parent result in a contained procedure. \r
+! Check that parent function results can be referenced in modules.\r
+!
+module m
+contains\r
+ function f()\r
+ integer :: f\r
+ f = 42\r
+ call sub ()\r
+ if (f.eq.1) f = f + 1\r
+ contains\r
+ subroutine sub\r
+ if (f.eq.42) f = f - 41\r
+ end subroutine sub\r
+ end function f
+end module m\r
+\r
+ use m\r
+ if (f ().ne.2) call abort ()\r
+end\r
--- /dev/null
+! { dg-do compile }\r
+! Tests fix for PR26107 in which an ICE would occur after the second\r
+! error message below. This resulted from a spurious attempt to\r
+! produce the third error message, without the name of the function.\r
+!\r
+! This is an expanded version of the testcase in the PR.\r
+!\r
+ pure function equals(self, & ! { dg-error "must be INTENT" }\r
+ string, ignore_case) result(same)\r
+ character(*), intent(in) :: string\r
+ integer(4), intent(in) :: ignore_case\r
+ integer(4) :: same\r
+ if (len (self) < 1) return ! { dg-error "Type of argument" }\r
+ same = 1\r
+ end function\r
+\r
+ function impure(self) result(ival)\r
+ character(*), intent(in) :: self\r
+ ival = 1\r
+ end function\r
+\r
+ pure function purity(self, string, ignore_case) result(same)\r
+ character(*), intent(in) :: self\r
+ character(*), intent(in) :: string\r
+ integer(4), intent(in) :: ignore_case\r
+ integer i\r
+ if (end > impure (self)) & ! { dg-error "non-PURE procedure" }\r
+ return\r
+ end function\r
projects / gcc.git / commitdiff