+2005-01-21 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/25124
+ PR fortran/25625
+ * decl.c (get_proc_name): If there is an existing
+ symbol in the encompassing namespace, call errors
+ if it is a procedure of the same name or the kind
+ field is set, indicating a type declaration.
+
+ PR fortran/20881
+ PR fortran/23308
+ PR fortran/25538
+ PR fortran/25710
+ * decl.c (add_global_entry): New function to check
+ for existing global symbol with this name and to
+ create new one if none exists.
+ (gfc_match_entry): Call add_global_entry before
+ matching argument lists for subroutine and function
+ entries.
+ * gfortran.h: Prototype for existing function,
+ global_used.
+ * resolve.c (resolve_global_procedure): New function
+ to check global symbols for procedures.
+ (resolve_call, resolve_function): Calls to this
+ new function for non-contained and non-module
+ procedures.
+ * match.c (match_common): Add check for existing
+ global symbol, creat one if none exists and emit
+ error if there is a clash.
+ * parse.c (global_used): Remove static and use the
+ gsymbol name rather than the new_block name, so that
+ the function can be called from resolve.c.
+ (parse_block_data, parse_module, add_global_procedure):
+ Improve checks for existing gsymbols. Emit error if
+ already defined or if references were to another type.
+ Set defined flag.
+
+ PR fortran/PR24276
+ * trans-expr.c (gfc_conv_aliased_arg): New function called by
+ gfc_conv_function_call that coverts an expression for an aliased
+ component reference to a derived type array into a temporary array
+ of the same type as the component. The temporary is passed as an
+ actual argument for the procedure call and is copied back to the
+ derived type after the call.
+ (is_aliased_array): New function that detects an array reference
+ that is followed by a component reference.
+ (gfc_conv_function_call): Detect an aliased actual argument with
+ is_aliased_array and convert it to a temporary and back again
+ using gfc_conv_aliased_arg.
+
2006-01-19 Tobias Schl\81üter <tobias.schlueter@physik.uni-muenchen.de>
* gfortranspec.c: Update copyright years.
int rc;
if (gfc_current_ns->parent == NULL)
- return gfc_get_symbol (name, NULL, result);
+ rc = gfc_get_symbol (name, NULL, result);
+ else
+ rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
- rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
- if (*result == NULL)
- return rc;
+ sym = *result;
- /* ??? Deal with ENTRY problem */
+ if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
+ {
+ /* Trap another encompassed procedure with the same name. */
+ if (sym->attr.flavor != 0
+ && sym->attr.proc != 0
+ && (sym->attr.subroutine || sym->attr.function))
+ gfc_error_now ("Procedure '%s' at %C is already defined at %L",
+ name, &sym->declared_at);
+
+ /* Trap declarations of attributes in encompassing scope. The
+ signature for this is that ts.kind is set. Legitimate
+ references only set ts.type. */
+ if (sym->ts.kind != 0
+ && sym->attr.proc == 0
+ && gfc_current_ns->parent != NULL
+ && sym->attr.access == 0)
+ gfc_error_now ("Procedure '%s' at %C has an explicit interface"
+ " and must not have attributes declared at %L",
+ name, &sym->declared_at);
+ }
+
+ if (gfc_current_ns->parent == NULL || *result == NULL)
+ return rc;
st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
- sym = *result;
st->n.sym = sym;
sym->refs++;
return m;
}
+/* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
+ name of the entry, rather than the gfc_current_block name, and to return false
+ upon finding an existing global entry. */
+
+static bool
+add_global_entry (const char * name, int sub)
+{
+ gfc_gsymbol *s;
+
+ s = gfc_get_gsymbol(name);
+
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+ global_used(s, NULL);
+ else
+ {
+ s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+ s->where = gfc_current_locus;
+ s->defined = 1;
+ return true;
+ }
+ return false;
+}
/* Match an ENTRY statement. */
if (state == COMP_SUBROUTINE)
{
/* An entry in a subroutine. */
+ if (!add_global_entry (name, 1))
+ return MATCH_ERROR;
+
m = gfc_match_formal_arglist (entry, 0, 1);
if (m != MATCH_YES)
return MATCH_ERROR;
ENTRY f() RESULT (r)
can't be written as
ENTRY f RESULT (r). */
+ if (!add_global_entry (name, 0))
+ return MATCH_ERROR;
+
old_loc = gfc_current_locus;
if (gfc_match_eos () == MATCH_YES)
{
/* parse.c */
try gfc_parse_file (void);
+void global_used (gfc_gsymbol *, locus *);
#endif /* GCC_GFORTRAN_H */
gfc_array_spec *as;
gfc_equiv * e1, * e2;
match m;
+ gfc_gsymbol *gsym;
old_blank_common = gfc_current_ns->blank_common.head;
if (old_blank_common)
if (m == MATCH_ERROR)
goto cleanup;
+ gsym = gfc_get_gsymbol (name);
+ if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
+ {
+ gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
+ sym->name);
+ goto cleanup;
+ }
+
+ if (gsym->type == GSYM_UNKNOWN)
+ {
+ gsym->type = GSYM_COMMON;
+ gsym->where = gfc_current_locus;
+ gsym->defined = 1;
+ }
+
+ gsym->used = 1;
+
if (name[0] == '\0')
{
t = &gfc_current_ns->blank_common;
/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
Inc.
Contributed by Andy Vaught
/* Come here to complain about a global symbol already in use as
something else. */
-static void
+void
global_used (gfc_gsymbol *sym, locus *where)
{
const char *name;
}
gfc_error("Global name '%s' at %L is already being used as a %s at %L",
- gfc_new_block->name, where, name, &sym->where);
+ sym->name, where, name, &sym->where);
}
else
{
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
global_used(s, NULL);
else
{
s->type = GSYM_BLOCK_DATA;
s->where = gfc_current_locus;
+ s->defined = 1;
}
}
gfc_gsymbol *s;
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
global_used(s, NULL);
else
{
s->type = GSYM_MODULE;
s->where = gfc_current_locus;
+ s->defined = 1;
}
st = parse_spec (ST_NONE);
s = gfc_get_gsymbol(gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
global_used(s, NULL);
else
{
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
+ s->defined = 1;
}
}
return;
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
global_used(s, NULL);
else
{
s->type = GSYM_PROGRAM;
s->where = gfc_current_locus;
+ s->defined = 1;
}
}
ap->expr->inline_noncopying_intrinsic = 1;
}
+/* This function does the checking of references to global procedures
+ as defined in sections 18.1 and 14.1, respectively, of the Fortran
+ 77 and 95 standards. It checks for a gsymbol for the name, making
+ one if it does not already exist. If it already exists, then the
+ reference being resolved must correspond to the type of gsymbol.
+ Otherwise, the new symbol is equipped with the attributes of the
+ reference. The corresponding code that is called in creating
+ global entities is parse.c. */
+
+static void
+resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
+{
+ gfc_gsymbol * gsym;
+ uint type;
+
+ type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+
+ gsym = gfc_get_gsymbol (sym->name);
+
+ if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
+ global_used (gsym, where);
+
+ if (gsym->type == GSYM_UNKNOWN)
+ {
+ gsym->type = type;
+ gsym->where = *where;
+ }
+
+ gsym->used = 1;
+}
/************* Function resolution *************/
try t;
int temp;
+ /* If the procedure is not internal or module, it must be external and
+ should be checked for usage. */
+ if (expr->symtree && expr->symtree->n.sym
+ && !expr->symtree->n.sym->attr.dummy
+ && !expr->symtree->n.sym->attr.contained
+ && !expr->symtree->n.sym->attr.use_assoc)
+ resolve_global_procedure (expr->symtree->n.sym, &expr->where, 0);
+
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
{
try t;
+ /* If the procedure is not internal or module, it must be external and
+ should be checked for usage. */
+ if (c->symtree && c->symtree->n.sym
+ && !c->symtree->n.sym->attr.dummy
+ && !c->symtree->n.sym->attr.contained
+ && !c->symtree->n.sym->attr.use_assoc)
+ resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
+
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
}
break;
+ case FL_PROCEDURE:
+ /* An external symbol may not have an intializer because it is taken to be
+ a procedure. */
+ if (sym->attr.external && sym->value)
+ {
+ gfc_error ("External object '%s' at %L may not have an initializer",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
+ break;
+
case FL_DERIVED:
/* Add derived type to the derived type list. */
{
default:
- /* An external symbol falls through to here if it is not referenced. */
- if (sym->attr.external && sym->value)
- {
- gfc_error ("External object '%s' at %L may not have an initializer",
- sym->name, &sym->declared_at);
- return;
- }
-
break;
}
gfc_free_expr (expr);
}
+/* Returns a reference to a temporary array into which a component of
+ an actual argument derived type array is copied and then returned
+ after the function call.
+ TODO Get rid of this kludge, when array descriptors are capable of
+ handling aliased arrays. */
+
+static void
+gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
+{
+ gfc_se lse;
+ gfc_se rse;
+ gfc_ss *lss;
+ gfc_ss *rss;
+ gfc_loopinfo loop;
+ gfc_loopinfo loop2;
+ gfc_ss_info *info;
+ tree offset;
+ tree tmp_index;
+ tree tmp;
+ tree base_type;
+ stmtblock_t body;
+ int n;
+
+ gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the argument expression. */
+ rss = gfc_walk_expr (expr);
+
+ gcc_assert (rss != gfc_ss_terminator);
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, rss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop);
+
+ /* Build an ss for the temporary. */
+ base_type = gfc_typenode_for_spec (&expr->ts);
+ if (GFC_ARRAY_TYPE_P (base_type)
+ || GFC_DESCRIPTOR_TYPE_P (base_type))
+ base_type = gfc_get_element_type (base_type);
+
+ loop.temp_ss = gfc_get_ss ();;
+ loop.temp_ss->type = GFC_SS_TEMP;
+ loop.temp_ss->data.temp.type = base_type;
+
+ if (expr->ts.type == BT_CHARACTER)
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+
+ loop.temp_ss->data.temp.dimen = loop.dimen;
+ loop.temp_ss->next = gfc_ss_terminator;
+
+ /* Associate the SS with the loop. */
+ gfc_add_ss_to_loop (&loop, loop.temp_ss);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop);
+
+ /* Pass the temporary descriptor back to the caller. */
+ info = &loop.temp_ss->data.info;
+ parmse->expr = info->descriptor;
+
+ /* Setup the gfc_se structures. */
+ gfc_copy_loopinfo_to_se (&lse, &loop);
+ gfc_copy_loopinfo_to_se (&rse, &loop);
+
+ rse.ss = rss;
+ lse.ss = loop.temp_ss;
+ gfc_mark_ss_chain_used (rss, 1);
+ gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+ /* Start the scalarized loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+
+ /* Translate the expression. */
+ gfc_conv_expr (&rse, expr);
+
+ gfc_conv_tmp_array_ref (&lse);
+ gfc_advance_se_ss_chain (&lse);
+
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ gfc_add_expr_to_block (&body, tmp);
+
+ gcc_assert (rse.ss == gfc_ss_terminator);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+
+ /* Add the post block after the second loop, so that any
+ freeing of allocated memory is done at the right time. */
+ gfc_add_block_to_block (&parmse->pre, &loop.pre);
+
+ /**********Copy the temporary back again.*********/
+
+ gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+
+ /* Walk the argument expression. */
+ lss = gfc_walk_expr (expr);
+ rse.ss = loop.temp_ss;
+ lse.ss = lss;
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop2);
+ gfc_add_ss_to_loop (&loop2, lss);
+
+ /* Calculate the bounds of the scalarization. */
+ gfc_conv_ss_startstride (&loop2);
+
+ /* Setup the scalarizing loops. */
+ gfc_conv_loop_setup (&loop2);
+
+ gfc_copy_loopinfo_to_se (&lse, &loop2);
+ gfc_copy_loopinfo_to_se (&rse, &loop2);
+
+ gfc_mark_ss_chain_used (lss, 1);
+ gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+ /* Declare the variable to hold the temporary offset and start the
+ scalarized loop body. */
+ offset = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_start_scalarized_body (&loop2, &body);
+
+ /* Build the offsets for the temporary from the loop variables. The
+ temporary array has lbounds of zero and strides of one in all
+ dimensions, so this is very simple. The offset is only computed
+ outside the innermost loop, so the overall transfer could be
+ optimised further. */
+ info = &rse.ss->data.info;
+
+ tmp_index = gfc_index_zero_node;
+ for (n = info->dimen - 1; n > 0; n--)
+ {
+ tree tmp_str;
+ tmp = rse.loop->loopvar[n];
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, rse.loop->from[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, tmp_index);
+
+ tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ rse.loop->to[n-1], rse.loop->from[n-1]);
+ tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp_str, gfc_index_one_node);
+
+ tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, tmp_str);
+ }
+
+ tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp_index, rse.loop->from[0]);
+ gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
+
+ tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ rse.loop->loopvar[0], offset);
+
+ /* Now use the offset for the reference. */
+ tmp = build_fold_indirect_ref (info->data);
+ rse.expr = gfc_build_array_ref (tmp, tmp_index);
+
+ if (expr->ts.type == BT_CHARACTER)
+ rse.string_length = expr->ts.cl->backend_decl;
+
+ gfc_conv_expr (&lse, expr);
+
+ gcc_assert (lse.ss == gfc_ss_terminator);
+
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Generate the copying loops. */
+ gfc_trans_scalarizing_loops (&loop2, &body);
+
+ /* Wrap the whole thing up by adding the second loop to the post-block
+ and following it by the post-block of the fist loop. In this way,
+ if the temporary needs freeing, it is done after use! */
+ gfc_add_block_to_block (&parmse->post, &loop2.pre);
+ gfc_add_block_to_block (&parmse->post, &loop2.post);
+
+ gfc_add_block_to_block (&parmse->post, &loop.post);
+
+ gfc_cleanup_loop (&loop);
+ gfc_cleanup_loop (&loop2);
+
+ /* Pass the string length to the argument expression. */
+ if (expr->ts.type == BT_CHARACTER)
+ parmse->string_length = expr->ts.cl->backend_decl;
+
+ /* We want either the address for the data or the address of the descriptor,
+ depending on the mode of passing array arguments. */
+ if (g77)
+ parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
+ else
+ parmse->expr = build_fold_addr_expr (parmse->expr);
+
+ return;
+}
+
+/* Is true if the last array reference is followed by a component reference. */
+
+static bool
+is_aliased_array (gfc_expr * e)
+{
+ gfc_ref * ref;
+ bool seen_array;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ seen_array = true;
+
+ if (ref->next == NULL && ref->type == REF_COMPONENT)
+ return seen_array;
+ }
+ return false;
+}
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
&& !formal->sym->attr.pointer
&& formal->sym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
- gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ && is_aliased_array (arg->expr))
+ /* The actual argument is a component reference to an
+ array of derived types. In this case, the argument
+ is converted to a temporary, which is passed and then
+ written back after the procedure call. */
+ gfc_conv_aliased_arg (&parmse, arg->expr, f);
+ else
+ gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
}
}
+2005-01-21 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/25124
+ PR fortran/25625
+ * gfortran.dg/internal_references_1.f90: New test.
+ PR fortran/20881
+ PR fortran/23308
+ PR fortran/25538
+ PR fortran/25710
+ * gfortran.dg/global_references_1.f90: New test.
+ * gfortran.dg/g77/19990905-1.f: Restore the error that
+ there is a clash between the common block name and
+ the name of a subroutine reference.
+
+ PR fortran/PR24276
+ * gfortran.dg/aliasing_dummy_1.f90: New test.
+
2006-01-21 Alan Modra <amodra@bigpond.net.au>
* gcc.dg/vmx/1b-01.c: Warning fix.
--- /dev/null
+! { dg-do run }
+! This tests the fix for PR24276, which originated from the Loren P. Meissner example,
+! Array_List. The PR concerns dummy argument aliassing of components of arrays of derived
+! types as arrays of the type of the component. gfortran would compile and run this
+! example but the stride used did not match the actual argument. This test case exercises
+! a procedure call (to foo2, below) that is identical to Array_List's.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+
+program test_lex
+ type :: dtype
+ integer :: n
+ character*5 :: word
+ end type dtype
+
+ type :: list
+ type(dtype), dimension(4) :: list
+ integer :: l = 4
+ end type list
+
+ type(list) :: table
+ type(dtype) :: elist(2,2)
+
+ table%list = (/dtype (1 , "one "), dtype (2 , "two "), dtype (3 , "three"), dtype (4 , "four ")/)
+
+! Test 1D with assumed shape (original bug) and assumed size.
+ call bar (table, 2, 4)
+ if (any (table%list%word.ne.(/"one ","i= 2","three","i= 4"/))) call abort ()
+
+ elist = reshape (table%list, (/2,2/))
+
+! Check 2D is OK with assumed shape and assumed size.
+ call foo3 (elist%word, 1)
+ call foo1 (elist%word, 3)
+ if (any (elist%word.ne.reshape ((/"i= 1","i= 2","i= 3","i= 4"/), (/2,2/)))) call abort ()
+
+contains
+
+ subroutine bar (table, n, m)
+ type(list) :: table
+ integer n, m
+ call foo1 (table%list(:table%l)%word, n)
+ call foo2 (table%list(:table%l)%word, m)
+ end subroutine bar
+
+ subroutine foo1 (slist, i)
+ character(*), dimension(*) :: slist
+ integer i
+ write (slist(i), '(2hi=,i3)') i
+ end subroutine foo1
+
+ subroutine foo2 (slist, i)
+ character(5), dimension(:) :: slist
+ integer i
+ write (slist(i), '(2hi=,i3)') i
+ end subroutine foo2
+
+ subroutine foo3 (slist, i)
+ character(5), dimension(:,:) :: slist
+ integer i
+ write (slist(1,1), '(2hi=,i3)') i
+ end subroutine foo3
+
+end program test_lex
\ No newline at end of file
* =foo7.f in Burley's g77 test suite.
subroutine x
real a(n)
- common /foo/n
+ common /foo/n ! { dg-error "is already being used as a COMMON" }
continue
entry y(a)
- call foo(a(1))
+ call foo(a(1)) ! { dg-error "is already being used as a COMMON" }
end
--- /dev/null
+! { dg-do compile }
+! This program tests the patch for PRs 20881, 23308, 25538 & 25710
+! Assembled from PRs by Paul Thomas <pault@gcc.gnu.org>
+module m
+contains
+ subroutine g(x) ! Local entity
+ REAL :: x
+ x = 1.0
+ end subroutine g
+end module m
+! Error only appears once but testsuite associates with both lines.
+function f(x) ! { dg-error "is already being used as a FUNCTION" }
+ REAL :: f, x
+ f = x
+end function f
+
+function g(x) ! Global entity
+ REAL :: g, x
+ g = x
+
+! PR25710==========================================================
+! Lahey -2607-S: "SOURCE.F90", line 26:
+! Function 'f' cannot be referenced as a subroutine. The previous
+! definition is in 'line 12'.
+
+ call f(g) ! { dg-error "is already being used as a FUNCTION" }
+end function g
+! Error only appears once but testsuite associates with both lines.
+function h(x) ! { dg-error "is already being used as a FUNCTION" }
+ REAL :: h, x
+ h = x
+end function h
+
+SUBROUTINE TT()
+ CHARACTER(LEN=10), EXTERNAL :: j
+ CHARACTER(LEN=10) :: T
+! PR20881===========================================================
+! Error only appears once but testsuite associates with both lines.
+ T = j () ! { dg-error "is already being used as a FUNCTION" }
+ print *, T
+END SUBROUTINE TT
+
+ use m ! Main program
+ real x
+ integer a(10)
+
+! PR23308===========================================================
+! Lahey - 2604-S: "SOURCE.F90", line 52:
+! The name 'foo' cannot be specified as both external procedure name
+! and common block name. The previous appearance is in 'line 68'.
+! Error only appears once but testsuite associates with both lines.
+ common /foo/ a ! { dg-error "is already being used as a COMMON" }
+
+ call f (x) ! OK - reference to local entity
+ call g (x) ! -ditto-
+
+! PR25710===========================================================
+! Lahey - 2607-S: "SOURCE.F90", line 62:
+! Function 'h' cannot be referenced as a subroutine. The previous
+! definition is in 'line 29'.
+
+ call h (x) ! { dg-error "is already being used as a FUNCTION" }
+
+! PR23308===========================================================
+! Lahey - 2521-S: "SOURCE.F90", line 68: Intrinsic procedure name or
+! external procedure name same as common block name 'foo'.
+
+ call foo () ! { dg-error "is already being used as a COMMON" }
+
+contains
+ SUBROUTINE f (x) ! Local entity
+ real x
+ x = 2
+ end SUBROUTINE f
+end
+
+! PR20881===========================================================
+! Lahey - 2636-S: "SOURCE.F90", line 81:
+! Subroutine 'j' is previously referenced as a function in 'line 39'.
+
+SUBROUTINE j (x) ! { dg-error "is already being used as a FUNCTION" }
+ integer a(10)
+ common /bar/ a ! Global entity foo
+ real x
+ x = bar(1.0) ! OK for local procedure to have common block name
+contains
+ function bar (x)
+ real bar, x
+ bar = 2.0*x
+ end function bar
+END SUBROUTINE j
+
+! PR25538===========================================================
+! would ICE with entry and procedure having same names.
+ subroutine link2 (namef) ! { dg-error "is already being used as a SUBROUTINE" }
+ entry link2 (nameg) ! { dg-error "is already being used as a SUBROUTINE" }
+ return
+ end
--- /dev/null
+! { dg-do compile }
+! This tests the patch for PRs 24327, 25024 & 25625, which
+! are all connected with references to internal procedures.
+! This is a composite of the PR testcases; and each is
+! labelled by PR.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+! PR25625 - would neglect to point out that there were 2 subroutines p.
+module m
+ implicit none
+contains
+
+ subroutine p (i) ! { dg-error "is already defined" }
+ integer :: i
+ end subroutine
+
+ subroutine p (i) ! { dg-error "is already defined" }
+ integer :: i
+ end subroutine
+end module
+!
+! PR25124 - would happily ignore the declaration of foo in the main program.
+program test
+real :: foo, x ! { dg-error "explicit interface and must not have attributes declared" }
+x = bar () ! This is OK because it is a regular reference.
+x = foo ()
+contains
+ function foo () ! { dg-error "explicit interface and must not have attributes declared" }
+ foo = 1.0
+ end function foo
+ function bar ()
+ bar = 1.0
+ end function bar
+end program test
+
OSDN Git Service
