From 5f20c93a30af5976a0d096d7034fb43a0acebf06 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 6 Mar 2006 22:56:39 +0000 Subject: [PATCH] re PR fortran/26107 (ICE after error message on invalid code) 2006-03-06 Paul Thomas 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 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 --- gcc/fortran/ChangeLog | 49 +++++++--- gcc/fortran/resolve.c | 2 +- gcc/fortran/trans-decl.c | 92 ++++++++++++++----- gcc/fortran/trans-expr.c | 48 +++++++--- gcc/fortran/trans-intrinsic.c | 2 +- gcc/fortran/trans-openmp.c | 9 +- gcc/fortran/trans-stmt.c | 2 +- gcc/fortran/trans.h | 2 +- gcc/testsuite/ChangeLog | 29 ++++-- .../gfortran.dg/parent_result_ref_1.f90 | 19 ++++ .../gfortran.dg/parent_result_ref_2.f90 | 35 +++++++ .../gfortran.dg/parent_result_ref_3.f90 | 28 ++++++ .../gfortran.dg/parent_result_ref_4.f90 | 22 +++++ .../gfortran.dg/pure_dummy_length_1.f90 | 29 ++++++ 14 files changed, 303 insertions(+), 65 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/parent_result_ref_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/parent_result_ref_2.f90 create mode 100755 gcc/testsuite/gfortran.dg/parent_result_ref_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/parent_result_ref_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ddb49cc2d77..dcc3c59c00c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,8 +1,29 @@ +2006-03-06 Paul Thomas + + 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 * simplify.c (gfc_simplify_verify): Fix return when SET=''. -2005-03-05 Erik Edelmann +2006-03-05 Erik Edelmann 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 +2006-02-19 Paul Thomas 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 +2006-02-16 Paul Thomas 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 +2006-02-06 Thomas Koenig 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 +2006-01-30 Erik Edelmann 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 +2006-01-27 Paul Thomas 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 +2006-01-27 Erik Edelmann * symbol.c (free_old_symbol): Fix confusing comment, and add code to free old_symbol->formal. -2005-01-26 Paul Thomas +2006-01-26 Paul Thomas 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 +2006-01-25 Erik Edelmann 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 +2006-01-23 Paul Thomas 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 +2006-01-21 Paul Thomas 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 +2006-01-11 Paul Thomas 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 +2006-01-08 Erik Edelmann PR fortran/25093 * resolve.c (resolve_fntype): Check that PUBLIC functions aren't of PRIVATE type. -2005-01-07 Tobias Schl"uter +2006-01-07 Tobias Schl"uter * decl.c (gfc_match_function_decl): Correctly error out in case of omitted function argument list. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4bf394a1ff6..3e7eb9dcea3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 41f5abe831f..daa452e74c1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1fc7f06feb0..4be54594225 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 39ac9396fa1..6ec0a5107be 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 44be1b752de..df8723b29b5 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -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; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 2ec8ba7d181..b3141ca84c7 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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", diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 89f4058a834..e571df9d3a9 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8329ae401b2..b1d03cfa6a3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2006-03-06 Paul Thomas + + 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 * 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 +2006-03-05 Erik Edelmann 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 +2006-02-19 Paul Thomas 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 +2006-02-16 Paul Thomas 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 +2006-02-06 Thomas Koenig 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 +2006-01-30 Erik Edelmann 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 +2006-01-27 Paul Thomas 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 +2006-01-26 Paul Thomas 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 +2006-01-23 Paul Thomas 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 +2006-01-21 Paul Thomas PR fortran/25124 PR fortran/25625 diff --git a/gcc/testsuite/gfortran.dg/parent_result_ref_1.f90 b/gcc/testsuite/gfortran.dg/parent_result_ref_1.f90 new file mode 100644 index 00000000000..c1c7c3d76ec --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parent_result_ref_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/parent_result_ref_2.f90 b/gcc/testsuite/gfortran.dg/parent_result_ref_2.f90 new file mode 100644 index 00000000000..2409cb4685f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parent_result_ref_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/parent_result_ref_3.f90 b/gcc/testsuite/gfortran.dg/parent_result_ref_3.f90 new file mode 100755 index 00000000000..f8e93ff80dc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parent_result_ref_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/parent_result_ref_4.f90 b/gcc/testsuite/gfortran.dg/parent_result_ref_4.f90 new file mode 100644 index 00000000000..d8c84e7cd6b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parent_result_ref_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 new file mode 100644 index 00000000000..4b0b8ae7e17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 @@ -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 -- 2.30.2