mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-04 17:20:23 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/25746 (Elemental assignment gives wrong result)

Browse Source 
2006-05-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25746
	* interface.c (gfc_extend_assign): Use new code EXEC_ASSIGN_CALL.
	* gfortran.h : Put EXEC_ASSIGN_CALL in enum.
	* trans-stmt.c (gfc_conv_elemental_dependencies): New function.
	(gfc_trans_call): Call it.  Add new boolian argument to flag
	need for dependency checking. Assert intent OUT and IN for arg1
	and arg2.
	(gfc_trans_forall_1): Use new code EXEC_ASSIGN_CALL.
	trans-stmt.h : Modify prototype of gfc_trans_call.
	trans.c (gfc_trans_code): Add call for EXEC_ASSIGN_CALL.
	st.c (gfc_free_statement): Free actual for EXEC_ASSIGN_CALL.
	* dependency.c (gfc_check_fncall_dependency): Don't check other
	against itself.

	PR fortran/25090
	* resolve.c : Remove resolving_index_expr.
	(entry_parameter): Remove.
	(gfc_resolve_expr, resolve_charlen, resolve_fl_variable): Remove
	calls to entry_parameter and references to resolving_index_expr.

	PR fortran/27584
	* check.c (gfc_check_associated): Replace NULL assert with an
	error message, since it is possible to generate bad code that
	has us fall through to here..

	PR fortran/19015
	* iresolve.c (maxloc, minloc): If DIM is not present, pass the
	rank of ARRAY as the shape of the result.  Otherwise, pass the
	shape of ARRAY, less the dimension DIM.
	(maxval, minval): The same, when DIM is present, otherwise no
	change.

2006-05-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25746
	* gfortran.dg/elemental_subroutine_3.f90: New test.

	PR fortran/25090
	* gfortran.dg/entry_dummy_ref_1.f90: Remove.

	PR fortran/27584
	* gfortran.dg/associated_target_1.f90: New test.

	PR fortran/19015
	* gfortran.dg/maxloc_shape_1.f90: New test.

From-SVN: r113949
This commit is contained in:
Paul Thomas 2006-05-21 07:35:05 +00:00
parent 80980ba989
commit 476220e7ee
16 changed files with 350 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
gcc/fortran/ChangeLog
View File

@ -1,3 +1,37 @@
2006-05-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25746
* interface.c (gfc_extend_assign): Use new EXEC_ASSIGN_CALL.
* gfortran.h : Put EXEC_ASSIGN_CALL in enum.
* trans-stmt.c (gfc_conv_elemental_dependencies): New function.
(gfc_trans_call): Call it. Add new boolian argument to flag
need for dependency checking. Assert intent OUT and IN for arg1
and arg2.
(gfc_trans_forall_1): Use new code EXEC_ASSIGN_CALL.
trans-stmt.h : Modify prototype of gfc_trans_call.
trans.c (gfc_trans_code): Add call for EXEC_ASSIGN_CALL.
st.c (gfc_free_statement): Free actual for EXEC_ASSIGN_CALL.
* dependency.c (gfc_check_fncall_dependency): Don't check other
against itself.
PR fortran/25090
* resolve.c : Remove resolving_index_expr.
(entry_parameter): Remove.
(gfc_resolve_expr, resolve_charlen, resolve_fl_variable): Lift
calls to entry_parameter and references to resolving_index_expr.
PR fortran/27584
* check.c (gfc_check_associated): Replace NULL assert with an
error message, since it is possible to generate bad code that
has us fall through to here..
PR fortran/19015
* iresolve.c (maxloc, minloc): If DIM is not present, pass the
rank of ARRAY as the shape of the result. Otherwise, pass the
shape of ARRAY, less the dimension DIM.
(maxval, minval): The same, when DIM is present, otherwise no
change.
2006-05-19 H.J. Lu <hongjiu.lu@intel.com>
PR fortran/27662
@ -64,7 +98,7 @@
* resolve.c (resolve_code): Add error condition that the return
expression must be scalar.
PR fortran/24711
PR fortran/27411
* matchexp.c (gfc_get_parentheses): New function.
(match_primary): Remove inline code and call above.
* gfortran.h: Provide prototype for gfc_get_parentheses.
@ -244,7 +278,7 @@
result, is also automatic character length. If so, process
the character length.
PR fortran/18803
PR fortran/18003
PR fortran/25669
PR fortran/26834
* trans_intrinsic.c (gfc_walk_intrinsic_bound): Set

7
gcc/fortran/check.c
View File

@ -532,7 +532,12 @@ gfc_check_associated (gfc_expr * pointer, gfc_expr * target)
else if (target->expr_type == EXPR_FUNCTION)
attr = target->symtree->n.sym->attr;
else
gcc_assert (0); /* Target must be a variable or a function. */
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
"or target VARIABLE or FUNCTION", gfc_current_intrinsic_arg[1],
gfc_current_intrinsic, &target->where);
return FAILURE;
}
if (!attr.pointer && !attr.target)
{

4
gcc/fortran/dependency.c
View File

@ -513,6 +513,10 @@ gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
if (!expr)
continue;
/* Skip other itself. */
if (expr == other)
continue;
/* Skip intent(in) arguments if OTHER itself is intent(in). */
if (formal
&& intent == INTENT_IN

2
gcc/fortran/gfortran.h
View File

@ -1487,7 +1487,7 @@ gfc_forall_iterator;
typedef enum
{
EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN,
EXEC_GOTO, EXEC_CALL, EXEC_RETURN, EXEC_ENTRY,
EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY,
EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,

2
gcc/fortran/interface.c
View File

@ -1827,7 +1827,7 @@ gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
}
/* Replace the assignment with the call. */
c->op = EXEC_CALL;
c->op = EXEC_ASSIGN_CALL;
c->symtree = find_sym_in_symtree (sym);
c->expr = NULL;
c->expr2 = NULL;

62
gcc/fortran/iresolve.c
View File

@ -1081,16 +1081,32 @@ gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
const char *name;
int i, j, idim;
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (dim == NULL)
f->rank = 1;
{
f->rank = 1;
f->shape = gfc_get_shape (1);
mpz_init_set_si (f->shape[0], array->rank);
}
else
{
f->rank = array->rank - 1;
gfc_resolve_dim_arg (dim);
if (array->shape && dim->expr_type == EXPR_CONSTANT)
{
idim = (int) mpz_get_si (dim->value.integer);
f->shape = gfc_get_shape (f->rank);
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
}
if (mask)
@ -1125,6 +1141,7 @@ gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
const char *name;
int i, j, idim;
f->ts = array->ts;
@ -1132,6 +1149,18 @@ gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
{
f->rank = array->rank - 1;
gfc_resolve_dim_arg (dim);
if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
{
idim = (int) mpz_get_si (dim->value.integer);
f->shape = gfc_get_shape (f->rank);
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
}
if (mask)
@ -1188,16 +1217,32 @@ gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
const char *name;
int i, j, idim;
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
if (dim == NULL)
f->rank = 1;
{
f->rank = 1;
f->shape = gfc_get_shape (1);
mpz_init_set_si (f->shape[0], array->rank);
}
else
{
f->rank = array->rank - 1;
gfc_resolve_dim_arg (dim);
if (array->shape && dim->expr_type == EXPR_CONSTANT)
{
idim = (int) mpz_get_si (dim->value.integer);
f->shape = gfc_get_shape (f->rank);
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
}
if (mask)
@ -1232,6 +1277,7 @@ gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
gfc_expr * mask)
{
const char *name;
int i, j, idim;
f->ts = array->ts;
@ -1239,6 +1285,18 @@ gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
{
f->rank = array->rank - 1;
gfc_resolve_dim_arg (dim);
if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT)
{
idim = (int) mpz_get_si (dim->value.integer);
f->shape = gfc_get_shape (f->rank);
for (i = 0, j = 0; i < f->rank; i++, j++)
{
if (i == (idim - 1))
j++;
mpz_init_set (f->shape[i], array->shape[j]);
}
}
}
if (mask)

73
gcc/fortran/resolve.c
View File

@ -60,9 +60,6 @@ static int omp_workshare_flag;
resets the flag each time that it is read. */
static int formal_arg_flag = 0;
/* True if we are resolving a specification expression. */
static int resolving_index_expr = 0;
int
gfc_is_formal_arg (void)
{
@ -2683,43 +2680,6 @@ resolve_variable (gfc_expr * e)
}
/* Emits an error if the expression is a variable that is not a parameter
in all entry formal argument lists for the namespace. */
static void
entry_parameter (gfc_expr *e)
{
gfc_symbol *sym, *esym;
gfc_entry_list *entry;
gfc_formal_arglist *f;
bool p;
sym = e->symtree->n.sym;
if (sym->attr.use_assoc
|| !sym->attr.dummy
|| sym->ns != gfc_current_ns)
return;
entry = sym->ns->entries;
for (; entry; entry = entry->next)
{
esym = entry->sym;
p = false;
for (f = esym->formal; f && !p; f = f->next)
{
if (f->sym && f->sym->name && sym->name == f->sym->name)
p = true;
}
if (!p)
gfc_error ("%s at %L must be a parameter of the entry at %L",
sym->name, &e->where, &esym->declared_at);
}
return;
}
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
@ -2744,10 +2704,6 @@ gfc_resolve_expr (gfc_expr * e)
case EXPR_VARIABLE:
t = resolve_variable (e);
if (gfc_current_ns->entries && resolving_index_expr)
entry_parameter (e);
if (t == SUCCESS)
expression_rank (e);
break;
@ -4699,6 +4655,7 @@ resolve_values (gfc_symbol * sym)
static try
resolve_index_expr (gfc_expr * e)
{
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
@ -4721,12 +4678,9 @@ resolve_charlen (gfc_charlen *cl)
cl->resolved = 1;
resolving_index_expr = 1;
if (resolve_index_expr (cl->length) == FAILURE)
return FAILURE;
resolving_index_expr = 0;
return SUCCESS;
}
@ -4813,29 +4767,20 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
/* Set this flag to check that variables are parameters of all entries.
This check is effected by the call to gfc_resolve_expr through
is_non_contant_shape_array. */
resolving_index_expr = 1;
if (!sym->attr.use_assoc
/* The shape of a main program or module array needs to be constant. */
if (sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)
&& !sym->attr.use_assoc
&& !sym->attr.allocatable
&& !sym->attr.pointer
&& is_non_constant_shape_array (sym))
{
/* The shape of a main program or module array needs to be constant. */
if (sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program))
{
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
return FAILURE;
}
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
return FAILURE;
}
resolving_index_expr = 0;
if (sym->ts.type == BT_CHARACTER)
{
/* Make sure that character string variables with assumed length are

1
gcc/fortran/st.c
View File

@ -112,6 +112,7 @@ gfc_free_statement (gfc_code * p)
break;
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual);
break;

136
gcc/fortran/trans-stmt.c
View File

@ -199,10 +199,121 @@ gfc_trans_entry (gfc_code * code)
}
/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
elemental subroutines. Make temporaries for output arguments if any such
dependencies are found. Output arguments are chosen because internal_unpack
can be used, as is, to copy the result back to the variable. */
static void
gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
gfc_symbol * sym, gfc_actual_arglist * arg)
{
gfc_actual_arglist *arg0;
gfc_expr *e;
gfc_formal_arglist *formal;
gfc_loopinfo tmp_loop;
gfc_se parmse;
gfc_ss *ss;
gfc_ss_info *info;
gfc_symbol *fsym;
int n;
stmtblock_t block;
tree data;
tree offset;
tree size;
tree tmp;
if (loopse->ss == NULL)
return;
ss = loopse->ss;
arg0 = arg;
formal = sym->formal;
/* Loop over all the arguments testing for dependencies. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
if (e == NULL)
continue;
/* Obtain the info structure for the current argument. */
info = NULL;
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
{
if (ss->expr != e)
continue;
info = &ss->data.info;
break;
}
/* If there is a dependency, create a temporary and use it
instead of the variable. */
fsym = formal ? formal->sym : NULL;
if (e->expr_type == EXPR_VARIABLE
&& e->rank && fsym
&& fsym->attr.intent == INTENT_OUT
&& gfc_check_fncall_dependency (e, INTENT_OUT, sym, arg0))
{
/* Make a local loopinfo for the temporary creation, so that
none of the other ss->info's have to be renormalized. */
gfc_init_loopinfo (&tmp_loop);
for (n = 0; n < info->dimen; n++)
{
tmp_loop.to[n] = loopse->loop->to[n];
tmp_loop.from[n] = loopse->loop->from[n];
tmp_loop.order[n] = loopse->loop->order[n];
}
/* Generate the temporary. Merge the block so that the
declarations are put at the right binding level. */
size = gfc_create_var (gfc_array_index_type, NULL);
data = gfc_create_var (pvoid_type_node, NULL);
gfc_start_block (&block);
tmp = gfc_typenode_for_spec (&e->ts);
tmp = gfc_trans_create_temp_array (&se->pre, &se->post,
&tmp_loop, info, tmp,
false, true, false);
gfc_add_modify_expr (&se->pre, size, tmp);
tmp = fold_convert (pvoid_type_node, info->data);
gfc_add_modify_expr (&se->pre, data, tmp);
gfc_merge_block_scope (&block);
/* Obtain the argument descriptor for unpacking. */
gfc_init_se (&parmse, NULL);
parmse.want_pointer = 1;
gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
gfc_add_block_to_block (&se->pre, &parmse.pre);
/* Calculate the offset for the temporary. */
offset = gfc_index_zero_node;
for (n = 0; n < info->dimen; n++)
{
tmp = gfc_conv_descriptor_stride (info->descriptor,
gfc_rank_cst[n]);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
loopse->loop->from[n], tmp);
offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
offset, tmp);
}
info->offset = gfc_create_var (gfc_array_index_type, NULL);
gfc_add_modify_expr (&se->pre, info->offset, offset);
/* Copy the result back using unpack. */
tmp = gfc_chainon_list (NULL_TREE, parmse.expr);
tmp = gfc_chainon_list (tmp, data);
tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&se->post, tmp);
gfc_add_block_to_block (&se->post, &parmse.post);
}
}
}
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree
gfc_trans_call (gfc_code * code)
gfc_trans_call (gfc_code * code, bool dependency_check)
{
gfc_se se;
gfc_ss * ss;
@ -269,11 +380,25 @@ gfc_trans_call (gfc_code * code)
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (ss, 1);
/* Convert the arguments, checking for dependencies. */
gfc_copy_loopinfo_to_se (&loopse, &loop);
loopse.ss = ss;
/* For operator assignment, we need to do dependency checking.
We also check the intent of the parameters. */
if (dependency_check)
{
gfc_symbol *sym;
sym = code->resolved_sym;
gcc_assert (sym->formal->sym->attr.intent = INTENT_OUT);
gcc_assert (sym->formal->next->sym->attr.intent = INTENT_IN);
gfc_conv_elemental_dependencies (&se, &loopse, sym,
code->ext.actual);
}
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
gfc_init_block (&block);
gfc_copy_loopinfo_to_se (&loopse, &loop);
loopse.ss = ss;
/* Add the subroutine call to the block. */
gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual);
@ -287,6 +412,7 @@ gfc_trans_call (gfc_code * code)
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&se.pre, &loop.pre);
gfc_add_block_to_block (&se.pre, &loop.post);
gfc_add_block_to_block (&se.pre, &se.post);
gfc_cleanup_loop (&loop);
}
@ -2539,8 +2665,8 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
/* Explicit subroutine calls are prevented by the frontend but interface
assignments can legitimately produce them. */
case EXEC_CALL:
assign = gfc_trans_call (c);
case EXEC_ASSIGN_CALL:
assign = gfc_trans_call (c, true);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
gfc_add_expr_to_block (&block, tmp);
break;

2
gcc/fortran/trans-stmt.h
View File

@ -38,7 +38,7 @@ tree gfc_trans_goto (gfc_code *);
tree gfc_trans_entry (gfc_code *);
tree gfc_trans_pause (gfc_code *);
tree gfc_trans_stop (gfc_code *);
tree gfc_trans_call (gfc_code *);
tree gfc_trans_call (gfc_code *, bool);
tree gfc_trans_return (gfc_code *);
tree gfc_trans_if (gfc_code *);
tree gfc_trans_arithmetic_if (gfc_code *);

6
gcc/fortran/trans.c
View File

@ -494,7 +494,11 @@ gfc_trans_code (gfc_code * code)
break;
case EXEC_CALL:
res = gfc_trans_call (code);
res = gfc_trans_call (code, false);
break;
case EXEC_ASSIGN_CALL:
res = gfc_trans_call (code, true);
break;
case EXEC_RETURN:

18
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,17 @@
2006-05-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25746
* gfortran.dg/elemental_subroutine_3.f90: New test.
PR fortran/25090
* gfortran.dg/entry_dummy_ref_1.f90: Remove.
PR fortran/27584
* gfortran.dg/associated_target_1.f90: New test.
PR fortran/19015
* gfortran.dg/maxloc_shape_1.f90: New test.
2006-05-20 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/24459
@ -147,7 +161,7 @@
PR fortran/25082
* gfortran.dg/scalar_return_1.f90: New test.
PR fortran/24711
PR fortran/27411
* gfortran.dg/derived_comp_array_ref_1.f90: New test.
2006-05-15 Jakub Jelinek <jakub@redhat.com>
@ -814,7 +828,7 @@
PR fortran/27089
* gfortran.dg/specification_type_resolution_1.f90
PR fortran/18803
PR fortran/18003
PR fortran/25669
PR fortran/26834
* gfortran.dg/bounds_temporaries_1.f90: New test.

12
gcc/testsuite/gfortran.dg/associated_target_1.f90 Normal file
View File

@ -0,0 +1,12 @@
! { dg-do compile }
! This tests the patch for PR27584, where an ICE would ensue if
! a bad argument was fed for the target in ASSOCIATED.
!
! Contributed by Tobias Burnus <tobias.burnus@physik.fu-berlin.de>
!
program test
implicit none
real, pointer :: x
real, target :: y
if(ASSOCIATED(X,(Y))) print *, 'Hello' ! { dg-error "VARIABLE or FUNCTION" }
end program test

53
gcc/testsuite/gfortran.dg/elemental_subroutine_3.f90 Normal file
View File

@ -0,0 +1,53 @@
! { dg-do run }
! Test the fix for PR25746, in which dependency checking was not being
! done for elemental subroutines and therefore for interface assignments.
!
! This test is based on
! http://home.comcast.net/~kmbtib/Fortran_stuff/elem_assign.f90
! as reported by Harald Anlauf <anlauf@gmx.de> in the PR.
!
module elem_assign
implicit none
type mytype
integer x
end type mytype
interface assignment(=)
module procedure myassign
end interface assignment(=)
contains
elemental subroutine myassign(x,y)
type(mytype), intent(out) :: x
type(mytype), intent(in) :: y
! Multiply the components by 2 to verify that this is being called.
x%x = y%x*2
end subroutine myassign
end module elem_assign
program test
use elem_assign
implicit none
type(mytype) :: y(6), x(6) = (/mytype(1),mytype(20),mytype(300),&
mytype(4000),mytype(50000),&
mytype(1000000)/)
type(mytype) :: z(2, 3)
! The original case - dependency between lhs and rhs.
x = x((/2,3,1,4,5,6/))
if (any(x%x .ne. (/40, 600, 2, 8000, 100000, 2000000/))) call abort ()
! Slightly more elborate case with non-trivial array ref on lhs.
x(4:1:-1) = x((/1,3,2,4/))
if (any(x%x .ne. (/16000, 1200, 4, 80, 100000, 2000000/))) call abort ()
! Check that no-dependence case works....
y = x
if (any(y%x .ne. (/32000, 2400, 8, 160, 200000, 4000000/))) call abort ()
! ...and now a case that caused headaches during the preparation of the patch
x(2:5) = x(1:4)
if (any(x%x .ne. (/16000, 32000, 2400, 8, 160, 2000000/))) call abort ()
! Check offsets are done correctly in multi-dimensional cases
z = reshape (x, (/2,3/))
z(:, 3:2:-1) = z(:, 1:2)
y = reshape (z, (/6/))
if (any(y%x .ne. (/ 64000, 128000, 19200, 64, 128000, 256000/))) call abort ()
end program test
! { dg-final { cleanup-modules "elem_assign" } }

13
gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90
View File

@ -1,13 +0,0 @@
! { dg-do compile }
! Tests fix for PR25090 in which references in specification
! expressions to variables that were not entry formal arguments
! would be missed.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
SUBROUTINE S1(I) ! { dg-error "must be a parameter of the entry" }
CHARACTER(LEN=I+J) :: a ! { dg-error "must be a parameter of the entry" }
real :: x(i:j) ! { dg-error "must be a parameter of the entry" }
ENTRY E1(J) ! { dg-error "must be a parameter of the entry" }
END SUBROUTINE S1
END

14
gcc/testsuite/gfortran.dg/maxloc_shape_1.f90 Normal file
View File

@ -0,0 +1,14 @@
! { dg-do compile }
! Tests the implementation of compile-time shape testing, required to fix
! PR19015. The functionality of maxloc and friends is tested by existing
! testcases.
!
! Contributed by Thomas Koeing <Thomas.Koenig@online.de>
!
integer, dimension(0:1,0:1) :: n
integer, dimension(1) :: i
n = reshape((/1, 2, 3, 4/), shape(n))
i = maxloc(n) ! { dg-error "different shape for Array assignment" }
i = maxloc(n,dim=1) ! { dg-error "different shape for Array assignment" }
! print *,i
end program